ghc-exactprint-0.2: tests/examples/Expr.hs

{-# 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,Show)

data BinOp  =  AddOp
            |  SubOp
            |  MulOp
            |  DivOp
    deriving(Typeable, Data,Show)

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    = undefined -- 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   =  undefined
{-
           do{ symbol "*"; return $ BinopExpr MulOp }
        <|> do{ symbol "/"; return $ BinopExpr DivOp }
-}
addop   = undefined
{-
  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   = undefined
{-
  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 $ "baz"
      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

-- keep parser happy
runParser = undefined
getPosition = undefined
setPosition = undefined
setSourceName = undefined
setSourceLine = undefined
setSourceColumn = undefined
spaces = undefined
eof = undefined
many = undefined
digit = undefined
many1 = undefined
data CharParser a b = F a b
(<|>) = undefined
chainl1 = undefined
string = undefined
char = undefined
lower = undefined
upper = undefined
between = undefined
instance Monad (CharParser a) where
instance Applicative (CharParser a) where
instance Functor (CharParser a) where