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
  10 import Language.Haskell.TH.Syntax
  11 import Language.Haskell.TH.Quote
  12
  13 import Text.Parsec
  14 import Text.Parsec.String
  15 import Text.Parsec.Expr as E
  16 import qualified Text.Parsec.Token as P
  17 import Text.Parsec.Language (haskell)
  18 --
  19 import Language.GenDSL
  20
  21 dsl :: QuasiQuoter
  22 dsl = QuasiQuoter
  23     { quoteExp = \s->location >>= parseExpr s
  24     , quotePat = undefined
  25     , quoteType = undefined
  26     , quoteDec = undefined
  27     }
  28   where
  29     parseExpr :: MonadFail m => String -> Loc -> m Exp
  30     parseExpr s loc =
  31         case runParser p () "" s of
  32           Left err -> fail $ show err
  33           Right e  -> return e
  34       where
  35         file = loc_filename loc
  36         (line, col) = loc_start loc
  37         p = getPosition >>= setPosition . mPos >> whiteSpace *> funOrExpr <* eof
  38         mPos = (flip setSourceName) file .
  39             (flip setSourceLine) line .
  40             (flip setSourceColumn) col
  41
  42 -- Lexer
  43 identifier,operator :: Parser String
  44 identifier = P.identifier haskell
  45 operator = P.operator haskell
  46
  47 parens,braces,lexeme :: Parser a -> Parser a
  48 braces = P.braces haskell
  49 parens = P.parens haskell
  50 lexeme = P.lexeme haskell
  51
  52 commaSep :: Parser a -> Parser [a]
  53 commaSep = P.commaSep haskell
  54
  55 symbol :: String -> Parser String
  56 symbol = P.symbol haskell
  57
  58 reserved,reservedOp :: String -> Parser ()
  59 reserved = P.reserved haskell
  60 reservedOp = P.reservedOp haskell
  61
  62 whiteSpace :: Parser ()
  63 whiteSpace = P.whiteSpace haskell
  64
  65 -- Parser
  66 funOrExpr :: Parser Exp
  67 funOrExpr = expr
  68
  69 func :: Parser Exp
  70 func = many1 ((,) <$> many1 pat <* reservedOp "=" <*> expr) >>= mkFun
  71   where
  72     mkFun :: MonadFail m => [([Pat], Exp)] -> m Exp
  73     mkFun es
  74         | all ((==1) . length . fst) es = pure $ LamE [VarP (mkName "x")] $ mkCase (VarE (mkName "x")) [(p, e)|([p], e)<-es]
  75     mkFun _ = fail "Multiple patterns/entries not supported yet"
  76
  77 expr :: Parser Exp
  78 expr = buildExpressionParser
  79     --Postfix record selectors
  80     [ [E.Postfix (fmap (\s e->VarE (selectorName (mkName s)) `AppE` e) $ P.lexeme haskell $ char '.' *> identifier)]
  81     , [bin "^" AssocRight]
  82     , [bin "*" AssocLeft, bin "/" AssocLeft]
  83     , [bin "+" AssocLeft, bin "-" AssocLeft]
  84     , [bin o AssocNone | o <- ["==", "/=", "<", ">", "<=", ">="]]
  85     , [bin "&&" AssocRight]
  86     , [bin "||" AssocRight]
  87     -- Infix usage of prefix functions
  88     , [E.Infix (fmap ifx $ lexeme $ char '`' *> identifier <* char '`') AssocRight]
  89     ] basic
  90   where
  91     bin :: String -> Assoc -> Operator String () Identity Exp
  92     bin str = E.Infix $ ifx (str++".") <$ sat operator (str==)
  93         (("Expected operator " ++ str ++ " but got ")++)
  94
  95     basic :: Parser Exp
  96     basic
  97         =   try (AppE . VarE <$> var <*> (TupE <$> parens (commaSep expr)))
  98         <|> VarE <$> var
  99         <|> mkCase <$ reserved "case" <*> expr <* reserved "of" <*> many1 ((,) <$> pat <* reservedOp "->" <*> expr)
 100         <|> (\i t e->VarE (mkName "if'") `AppE` i `AppE` t `AppE` e) <$ reserved "if" <*> expr <* reserved "then" <*> expr <* reserved "else" <*> expr
 101         <|> parens expr
 102         <|> mkLit . LitE <$> lit
 103         <|> mkLit . ConE . mkName <$> sat identifier ("True"==) ("Expected True but got: "++)
 104         <|> mkLit . ConE . mkName <$> sat identifier ("False"==) ("Expected False but got: "++)
 105
 106 pat :: Parser Pat
 107 pat
 108     =   try (RecP <$> con <*> braces (commaSep $ (,) <$> var <* reservedOp "=" <*> pat))
 109     <|> ConP <$> con <*> many pat
 110     <|> try (AsP <$> var <* reservedOp "@" <*> pat)
 111     <|> VarP <$> var
 112     <|> WildP <$ symbol "_"
 113     <|> LitP <$> lit
 114     <|> parens pat
 115
 116 lit :: Parser Lit
 117 lit
 118     =   CharL <$> P.charLiteral haskell
 119     <|> IntegerL <$> P.natural haskell
 120
 121 sat :: Parser a -> (a -> Bool) -> (a -> String) -> Parser a
 122 sat p f msg = try (p >>= \a->if f a then pure a else fail (msg a))
 123
 124 mkLit :: Exp -> Exp
 125 mkLit = AppE $ VarE $ mkName "lit"
 126
 127 con,var :: Parser Name
 128 con = mkName <$> sat identifier (isUpper . head) ("Not a data constructor: "++)
 129 var = mkName <$> sat identifier (isLower . head) ("Not a variable identifier: "++)
 130
 131 -- Convert case to if statements
 132 mkCase :: Exp -> [(Pat, Exp)] -> Exp
 133 mkCase name cases = foldr (uncurry mkCaseMatch) (VarE (mkName "bottom") `AppE` LitE (StringL "Exhausted case")) cases
 134   where
 135     mkCaseMatch :: Pat -> Exp -> Exp -> Exp
 136     mkCaseMatch a e rest = case mkCasePred name a of
 137         [] -> mkCaseLets (mkCaseBinding name a) e
 138         ps -> VarE (mkName "if'") `AppE` foldl1 (ifx "&.") ps `AppE` (mkCaseLets (mkCaseBinding name a) e) `AppE` rest
 139
 140     mkCaseLets :: [Dec] -> Exp -> Exp
 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 :: Exp -> Pat -> [Exp]
 148     mkCasePred e (LitP l) = [ifx "==." (VarE (mkName "lit") `AppE` 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 :: Exp -> Pat -> [Dec]
 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