datatype/Language/Quote.hs

   1 {-# LANGUAGE TemplateHaskell #-}
   2 {-# LANGUAGE QuasiQuotes #-}
   3 {-# LANGUAGE TupleSections #-}
   4 {-# LANGUAGE ParallelListComp #-}
   5 module Language.Quote (dsl) where
   6
   7 import Data.Char
   8 import Data.Functor.Identity
   9 import Control.Monad
  10
  11 import Language.Haskell.TH
  12 import Language.Haskell.TH.Syntax
  13 import Language.Haskell.TH.Quote
  14
  15 import Text.Parsec
  16 import Text.Parsec.String
  17 import Text.Parsec.Expr as E
  18 import qualified Text.Parsec.Token as P
  19 import Text.Parsec.Language (haskell)
  20 --
  21 import Language.GenDSL as L
  22
  23 dsl :: QuasiQuoter
  24 dsl = QuasiQuoter
  25     { quoteExp = \s->location >>= parseExpr s
  26     , quotePat = undefined
  27     , quoteType = undefined
  28     , quoteDec = undefined
  29     }
  30   where
  31     parseExpr :: String -> Loc -> ExpQ
  32     parseExpr s loc = either (fail . show) id $ runParser p () file s
  33       where
  34         file = loc_filename loc
  35         (line, col) = loc_start loc
  36         p = getPosition >>= setPosition . mPos >> whiteSpace *> expr <* eof
  37         mPos p = setSourceName (setSourceLine (setSourceColumn p col) line) file
  38
  39 -- Lexer
  40 identifier,operator :: Parser String
  41 identifier = P.identifier haskell
  42 operator = P.operator haskell
  43
  44 parens,braces,lexeme :: Parser a -> Parser a
  45 braces = P.braces haskell
  46 parens = P.parens haskell
  47 lexeme = P.lexeme haskell
  48
  49 commaSep :: Parser a -> Parser [a]
  50 commaSep = P.commaSep haskell
  51
  52 symbol :: String -> Parser String
  53 symbol = P.symbol haskell
  54
  55 reserved,reservedOp :: String -> Parser ()
  56 reserved = P.reserved haskell
  57 reservedOp = P.reservedOp haskell
  58
  59 whiteSpace :: Parser ()
  60 whiteSpace = P.whiteSpace haskell
  61
  62 -- Parser
  63 expr :: Parser ExpQ
  64 expr = buildExpressionParser
  65     --Postfix record selectors
  66     [ [E.Postfix (fmap (\s e->varE (selectorName (mkName s)) `appE` e) $ P.lexeme haskell $ char '.' *> identifier)]
  67     , [bin "^" AssocRight]
  68     , [bin "*" AssocLeft, bin "/" AssocLeft]
  69     , [bin "+" AssocLeft, bin "-" AssocLeft]
  70     , [bin o AssocNone | o <- ["==", "/=", "<", ">", "<=", ">="]]
  71     , [bin "&&" AssocRight]
  72     , [bin "||" AssocRight]
  73     -- Infix usage of prefix functions
  74     , [E.Infix (fmap ifx $ lexeme $ char '`' *> identifier <* char '`') AssocRight]
  75     ] basic
  76   where
  77     bin :: String -> Assoc -> Operator String () Identity ExpQ
  78     bin str = E.Infix $ ifx (str++".") <$ sat operator (str==)
  79         (("Expected operator " ++ str ++ " but got ")++)
  80
  81     basic :: Parser ExpQ
  82     basic
  83         =   try (appE . varE <$> var <*> (tupE <$> parens (commaSep expr)))
  84         <|> varE <$> var
  85         <|> mkCase <$ reserved "case" <*> expr <* reserved "of" <*> many1 ((,) <$> pat <*> body)
  86         <|> (\i t e->[|if' $i $t $e|]) <$ reserved "if" <*> expr <* reserved "then" <*> expr <* reserved "else" <*> expr
  87         <|> parens expr
  88         <|> mkLit . litE <$> lite
  89         <|> [|lit True|] <$ sat identifier ("True"==) ("Expected True but got: "++)
  90         <|> [|lit False|] <$  sat identifier ("False"==) ("Expected False but got: "++)
  91
  92     match :: Parser (PatQ, BodyQ)
  93     match = (,) <$> pat <*> body
  94
  95     body :: Parser BodyQ
  96     body =  guardedB <$> many1 (liftM2 (,) <$> guarded <* reservedOp "->" <*> expr)
  97         <|> normalB <$ reservedOp "->" <*> expr
  98       where
  99         guarded :: Parser GuardQ
 100         guarded = normalG <$ reservedOp "|" <*> expr
 101
 102 pat :: Parser PatQ
 103 pat
 104     =   try (recP <$> con <*> braces (commaSep fieldpat))
 105     <|> conP <$> con <*> many pat
 106     <|> try (asP <$> var <* reservedOp "@" <*> pat)
 107     <|> varP <$> var
 108     <|> wildP <$ symbol "_"
 109     <|> litP <$> lite
 110     <|> parens pat
 111   where fieldpat = liftM2 (,) . pure <$> var <* reservedOp "=" <*> pat
 112
 113 lite :: Parser Lit
 114 lite
 115     =   charL <$> P.charLiteral haskell
 116     <|> integerL <$> P.natural haskell
 117
 118 sat :: Parser a -> (a -> Bool) -> (a -> String) -> Parser a
 119 sat p f msg = try (p >>= \a->if f a then pure a else fail (msg a))
 120
 121 mkLit :: ExpQ -> ExpQ
 122 mkLit x = [|lit $x|]
 123
 124 con,var :: Parser Name
 125 con = mkName <$> sat identifier (isUpper . head) ("Not a data constructor: "++)
 126 var = mkName <$> sat identifier (isLower . head) ("Not a variable identifier: "++)
 127
 128 -- Convert case to if statements
 129 mkCase :: ExpQ -> [(PatQ, BodyQ)] -> ExpQ
 130 mkCase name cases = foldr (uncurry mkCaseMatch) [|bottom "Exhausted case"|] cases
 131   where
 132     mkCaseMatch :: PatQ -> BodyQ -> ExpQ -> ExpQ
 133     mkCaseMatch qa qb rest = qb >>= \b->case b of
 134         NormalB e -> qa >>= \a->case mkCasePred name a of
 135             [] -> ex a e
 136             ps -> [|if' $(foldl1 (ifx "&.") ps) $(ex a e) $rest|]
 137         GuardedB _ -> fail "Guarded bodies not yet supported"
 138       where ex a e = mkCaseLets (mkCaseBinding name a) $ pure e
 139
 140     mkCaseLets :: [DecQ] -> ExpQ -> ExpQ
 141     mkCaseLets [] e = e
 142     mkCaseLets defs e = letE defs e
 143
 144     conPtoRecP :: Name -> [Pat] -> Pat
 145     conPtoRecP consName = RecP consName . zip (map (adtFieldName consName) [0..])
 146
 147     mkCasePred :: ExpQ -> Pat -> [ExpQ]
 148     mkCasePred e (LitP l) = [[|lit $(litE l) ==. $e|]]
 149     mkCasePred _ (VarP _) = []
 150     mkCasePred e (ConP cons fs) = mkCasePred e $ conPtoRecP cons fs
 151     mkCasePred e (InfixP l cons r) = mkCasePred e (ConP cons [l,r])
 152     mkCasePred e (UInfixP l cons r) = mkCasePred e (ConP cons [l,r])
 153     mkCasePred e (ParensP p) = mkCasePred e p
 154     mkCasePred e (TildeP p) = mkCasePred e p
 155     mkCasePred e (BangP p) = mkCasePred e p
 156     mkCasePred e (AsP _ p) = mkCasePred e p
 157     mkCasePred _  WildP = []
 158     mkCasePred e (RecP cons fs) = varE (predicateName cons) `appE` e
 159         : concatMap (\(n, p)->mkCasePred (varE (selectorName n) `appE` e) p) fs
 160     mkCasePred _  p = error $ "Unsupported pat: " ++ show p
 161
 162     mkCaseBinding :: ExpQ -> Pat -> [DecQ]
 163     mkCaseBinding _ (LitP _) = []
 164     mkCaseBinding e (VarP v) = [funD v [clause [] (normalB e) []]]
 165     mkCaseBinding e (ConP cons fs) = mkCaseBinding e $ conPtoRecP cons fs
 166     mkCaseBinding e (InfixP l cons r) = mkCaseBinding e (ConP cons [l,r])
 167     mkCaseBinding e (UInfixP l cons r) = mkCaseBinding e (ConP cons [l,r])
 168     mkCaseBinding e (ParensP p) = mkCaseBinding e p
 169     mkCaseBinding e (TildeP p) = mkCaseBinding e p
 170     mkCaseBinding e (BangP p) = mkCaseBinding e p
 171     mkCaseBinding e (AsP n p) = funD n [clause [] (normalB e) []]:mkCaseBinding e p
 172     mkCaseBinding _  WildP = []
 173     mkCaseBinding e (RecP _ fs) = concatMap (\(n, p)->mkCaseBinding (varE (selectorName n) `appE` e) p) fs
 174     mkCaseBinding _  p = error $ "Unsupported pat: " ++ show p