Commit 9764c729 authored by Simon Peyton Jones's avatar Simon Peyton Jones
Browse files

Tests for quasi-quotation

parent 090fb7b3
TOP=../../..
include $(TOP)/mk/boilerplate.mk
include $(TOP)/mk/test.mk
TOP=../../../..
include $(TOP)/mk/boilerplate.mk
include $(TOP)/mk/test.mk
{-# LANGUAGE QuasiQuotes #-}
module Main where
parse = undefined
main :: IO ()
main = print $ [$parse||]
qq001.hs:7:15:
GHC stage restriction: parse
is used in a quasiquote, and must be imported, not defined locally
test('qq001', only_compiler_types(['ghc']),
compile_fail, [''])
TOP=../../../..
include $(TOP)/mk/boilerplate.mk
include $(TOP)/mk/test.mk
{-# LANGUAGE QuasiQuotes #-}
module Main where
parse = undefined
main :: IO ()
main = case () of
[$parse||] -> return ()
_ -> return ()
qq002.hs:8:9:
GHC stage restriction: parse
is used in a quasiquote, and must be imported, not defined locally
test('qq002', only_compiler_types(['ghc']),
compile_fail, [''])
TOP=../../../..
include $(TOP)/mk/boilerplate.mk
include $(TOP)/mk/test.mk
{-# LANGUAGE QuasiQuotes #-}
module Main where
main :: IO ()
main = print $ \parse -> [$parse||]
qq003.hs:5:25:
GHC stage restriction: parse
is used in a quasiquote, and must be imported, not defined locally
test('qq003', only_compiler_types(['ghc']),
compile_fail, [''])
TOP=../../../..
include $(TOP)/mk/boilerplate.mk
include $(TOP)/mk/test.mk
{-# LANGUAGE QuasiQuotes #-}
module Main where
main :: IO ()
main = p undefined
where
p = \parse -> case () of
[$parse||] -> return ()
_ -> return ()
qq004.hs:8:20:
GHC stage restriction: parse
is used in a quasiquote, and must be imported, not defined locally
test('qq004', only_compiler_types(['ghc']),
compile_fail, [''])
{-# 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 parseExprExp 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
{-# LANGUAGE QuasiQuotes #-}
module Main where
import Expr
main :: IO ()
main = do print $ eval [$expr|1 + 3 + 5|]
case [$expr|2|] of
[$expr|$n|] -> print n
_ -> return ()
case [$expr|1 + 2|] of
[$expr|$x + $y|] -> putStrLn $ show x ++ " + " ++ show y
_ -> return ()
TOP=../../../..
include $(TOP)/mk/boilerplate.mk
include $(TOP)/mk/test.mk
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment