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