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