blob: d628e8d52f721cad673c1bc6085296e217648d63 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
|
{-# LANGUAGE DeriveDataTypeable #-}
module Expr where
import Data.Generics
import Language.Haskell.TH as TH
import Language.Haskell.TH.Quote
import Text.ParserCombinators.Parsec
import Text.ParserCombinators.Parsec.Char
data Expr = IntExpr Integer
| AntiIntExpr String
| BinopExpr BinOp Expr Expr
| AntiExpr String
deriving(Typeable, Data)
data BinOp = AddOp
| SubOp
| MulOp
| DivOp
deriving(Typeable, Data)
eval :: Expr -> Integer
eval (IntExpr n) = n
eval (BinopExpr op x y) = (opToFun op) (eval x) (eval y)
where
opToFun AddOp = (+)
opToFun SubOp = (-)
opToFun MulOp = (*)
opToFun DivOp = (div)
small = lower <|> char '_'
large = upper
idchar = small <|> large <|> digit <|> char '\''
lexeme p = do{ x <- p; spaces; return x }
symbol name = lexeme (string name)
parens p = between (symbol "(") (symbol ")") p
_expr :: CharParser st Expr
_expr = term `chainl1` mulop
term :: CharParser st Expr
term = factor `chainl1` addop
factor :: CharParser st Expr
factor = parens _expr <|> integer <|> anti
mulop = do{ symbol "*"; return $ BinopExpr MulOp }
<|> do{ symbol "/"; return $ BinopExpr DivOp }
addop = do{ symbol "+"; return $ BinopExpr AddOp }
<|> do{ symbol "-"; return $ BinopExpr SubOp }
integer :: CharParser st Expr
integer = lexeme $ do{ ds <- many1 digit ; return $ IntExpr (read ds) }
anti = lexeme $
do symbol "$"
c <- small
cs <- many idchar
return $ AntiIntExpr (c : cs)
parseExpr :: Monad m => TH.Loc -> String -> m Expr
parseExpr (Loc {loc_filename = file, loc_start = (line,col)}) s =
case runParser p () "" s of
Left err -> fail $ show err
Right e -> return e
where
p = do pos <- getPosition
setPosition $ setSourceName (setSourceLine (setSourceColumn pos col) line) file
spaces
e <- _expr
eof
return e
expr = QuasiQuoter { quoteExp = parseExprExp, quotePat = parseExprPat }
parseExprExp :: String -> Q Exp
parseExprExp s = do loc <- location
expr <- parseExpr loc s
dataToExpQ (const Nothing `extQ` antiExprExp) expr
antiExprExp :: Expr -> Maybe (Q Exp)
antiExprExp (AntiIntExpr v) = Just $ appE (conE (mkName "IntExpr"))
(varE (mkName v))
antiExprExp (AntiExpr v) = Just $ varE (mkName v)
antiExprExp _ = Nothing
parseExprPat :: String -> Q Pat
parseExprPat s = do loc <- location
expr <- parseExpr loc s
dataToPatQ (const Nothing `extQ` antiExprPat) expr
antiExprPat :: Expr -> Maybe (Q Pat)
antiExprPat (AntiIntExpr v) = Just $ conP (mkName "IntExpr")
[varP (mkName v)]
antiExprPat (AntiExpr v) = Just $ varP (mkName v)
antiExprPat _ = Nothing
|
