import Data.Char
import Control.Monad
+import Printer
+import Compiler
+import Interpreter
+
className,constructorName,selectorName,predicateName :: Name -> Name
className = mkName . (++"'") . stringName
constructorName = mkName . map toLower . stringName
stringName :: Name -> String
stringName (Name occ _) = occString occ
-numberedArgs :: [a] -> Q [Name]
-numberedArgs = zipWithM (\i _->newName $ "f" ++ show i) [0 :: Int ..]
-
adtFieldName :: Name -> Integer -> Name
adtFieldName consName idx = mkName $ map toLower (stringName consName) ++ "f" ++ show idx
-data Field = Field { fcons :: Name, ftotal :: Integer, fnum :: Integer, fname :: Name, ftype :: Type }
-
-toNameType :: Con -> [Field]
-toNameType (NormalC consName fs) = [Field {fcons=consName, ftotal=toInteger $ length fs, fnum=i, fname=adtFieldName consName i, ftype=t} | (_, t) <- fs | i <- [0..]]
-toNameType (RecC consName fs) = [Field consName (toInteger $ length fs) i n t | (n, _, t)<-fs | i <- [0..]]
-toNameType c = fail $ "Unsupported constructor type: " ++ show c
-
-getConsName :: Con -> Q Name
-getConsName (NormalC consName _)
+getConsName :: Con -> Q (Name, [(Name, TypeQ)])
+getConsName (NormalC consName fs)
| head (stringName consName) == ':' = fail "Infix constructors are not supported"
- | otherwise = pure consName
-getConsName (RecC consName _) = pure consName
+ | otherwise = pure (consName, [(adtFieldName consName i, pure t)|(_, t)<-fs | i<-[0..]])
+getConsName (RecC consName fs) = pure (consName, [(n, pure t) | (n, _, t)<-fs])
getConsName c = fail $ "Unsupported constructor type: " ++ show c
-int :: Integral a => a -> ExpQ
-int = litE . integerL . toInteger
-
-string :: String -> ExpQ
-string = litE . stringL
-
ifx :: String -> ExpQ -> ExpQ -> ExpQ
ifx op a b = infixE (Just a) (varE $ mkName op) (Just b)
genDSL :: Name -> DecsQ
genDSL typename = reify typename >>= \info->case info of
TyConI (DataD _ _ tyvars _ constructors _)
- -> mapM getConsName constructors >>= mkDSL typename tyvars (map toNameType constructors)
+ -> mapM getConsName constructors >>= mkDSL typename tyvars
t
- -> fail $ "mkConsClass only supports datatypes and not: " ++ show t
+ -> fail $ "mkConsClass only supports simple datatypes and not: " ++ show t
-mkDSL :: Name -> [TyVarBndr] -> [[Field]] -> [Name] -> DecsQ
-mkDSL typeName typeVars fields consNames = sequence [ mkClass, mkPrinter, mkCompiler, mkInterpreter ]
+mkDSL :: Name -> [TyVarBndr] -> [(Name, [(Name, TypeQ)])] -> DecsQ
+mkDSL typeName typeVars constructors = sequence [ mkClass, mkPrinter, mkCompiler, mkInterpreter ]
where
+ (consNames, fields) = unzip constructors
+
mkClass :: DecQ
mkClass = classD (pure []) (className typeName) [PlainTV (mkName "v")] []
- ( zipWith mkConstructor consNames fields
+ ( map (uncurry mkConstructor) constructors
++ concatMap (map mkSelector) fields
++ map mkPredicate consNames
)
where
- view a = varT (mkName "v") `appT` a
- arrow = appT . appT arrowT
+ v = varT $ mkName "v"
+ arrow x y = [t|$x-> $y|]
- mkConstructor :: Name -> [Field] -> DecQ
- mkConstructor n fs = sigD (constructorName n) $ foldr arrow resultT $ map (view . pure . ftype) fs
+ mkConstructor :: Name -> [(Name, TypeQ)] -> DecQ
+ mkConstructor n fs = sigD (constructorName n) $ foldr arrow resultT $ map (appT v . snd) fs
- mkSelector :: Field -> DecQ
- mkSelector f = sigD (selectorName (fname f)) $ resultT `arrow` view (pure $ ftype f)
+ mkSelector :: (Name, TypeQ) -> DecQ
+ mkSelector (n, t) = sigD (selectorName n) [t|$resultT -> $v $t|]
mkPredicate :: Name -> DecQ
- mkPredicate n = sigD (predicateName n) $ resultT `arrow` view (conT (mkName "Bool"))
+ mkPredicate n = sigD (predicateName n) [t|$resultT -> $v Bool|]
resultT :: TypeQ
- resultT = view $ foldl appT (conT typeName) $ map (varT . getNameTyVarBndr) $ typeVars
+ resultT = appT v $ foldl appT (conT typeName) $ map (varT . getNameTyVarBndr) $ typeVars
mkPrinter :: DecQ
- mkPrinter = instanceD (pure []) (appT (conT $ className typeName) (conT $ mkName "Printer"))
- $ zipWith mkConstructor consNames fields
- ++ concatMap (map mkSelector) fields
+ mkPrinter = instanceD (pure []) [t|$(conT $ className typeName) Printer|]
+ $ map (uncurry mkConstructor) constructors
+ ++ concatMap (map (mkSelector . fst)) fields
++ map mkPredicate consNames
where
- pl s = varE (mkName "printLit") `appE` string s
+ pl s = [|printLit $(lift s)|]
- mkConstructor :: Name -> [Field] -> DecQ
+ mkConstructor :: Name -> [(Name, TypeQ)] -> DecQ
mkConstructor consName fs = do
fresh <- sequence [newName "f" | _<- fs]
fun (constructorName consName) (map varP fresh) (pcons `appE` pargs fresh)
- where pcons = varE (mkName "printCons") `appE` string (stringName consName)
+ where pcons = [|printCons $(lift $ stringName consName)|]
pargs fresh = foldl (ifx ">->") (pl "") $ map varE fresh
- mkSelector :: Field -> DecQ
- mkSelector Field{fname=n} = do
- fresh <- newName "f"
- fun (selectorName n) [varP fresh] (ifx ">>" (varE fresh) $ pl ('.':stringName n))
+ mkSelector :: Name -> DecQ
+ mkSelector n = fun (selectorName n) [] [|\x->x >> $(pl ('.':stringName n))|]
mkPredicate :: Name -> DecQ
- mkPredicate n = do
- fresh <- newName "f"
- fun (predicateName n) [varP fresh] (ifx ">->" (pl $ stringName $ predicateName n) $ varE fresh)
+ mkPredicate n = fun (predicateName n) []
+ [|\x-> $(pl $ stringName $ predicateName n) >-> x|]
mkCompiler :: DecQ
- mkCompiler = instanceD (pure []) (appT (conT $ className typeName) (conT $ mkName "Compiler"))
- $ zipWith3 mkConstructor [0..] consNames fields
- ++ concat (zipWith (map . mkSelector) [0..] fields)
+ mkCompiler = instanceD (pure []) [t|$(conT $ className typeName) Compiler|]
+ $ zipWith (uncurry . mkConstructor) [0..] constructors
+ ++ concatMap (zipWith mkSelector [0..] . map fst) fields
++ zipWith mkPredicate [0..] consNames
where
- instrE e = varE (mkName "instr") `appE` listE e
-
- mkConstructor :: Integer -> Name -> [Field] -> DecQ
+ mkConstructor :: Integer -> Name -> [(Name, TypeQ)] -> DecQ
mkConstructor consNum consName fs = do
fresh <- sequence [newName "f" | _<-fs]
fun (constructorName consName) (map varP fresh)
$ ifx "*>" pushCons $ ifx "<*" (mkBody $ map varE fresh) storeHeap
- where storeHeap = instrE [conE (mkName "Sth") `appE` (ifx "+" (int 1) (int $ length fs))]
- mkBody = foldl (ifx "<*>") (varE (mkName "pure") `appE` conE consName)
- pushCons = instrE [conE (mkName "Push") `appE` int consNum]
+ where storeHeap = [|instr [Sth $ 1 + $(lift $ length fs)]|]
+ mkBody = foldl (ifx "<*>") [|pure $(conE consName)|]
+ pushCons = [|instr [Push $(lift consNum)]|]
- mkSelector :: Integer -> Field -> DecQ
- mkSelector consNum Field{fname=f} = do
- fresh <- newName "f"
- fun (selectorName f) [varP fresh]
- $ ifx ">>" (varE fresh) $ instrE [conE (mkName "Ldh") `appE` int consNum]
+ mkSelector :: Integer -> Name -> DecQ
+ mkSelector fn n = fun (selectorName n) [] [|\x->x >> instr [Ldh $(lift fn)]|]
mkPredicate :: Integer -> Name -> DecQ
- mkPredicate consNum consName = do
- fresh <- newName "f"
- fun (predicateName consName) [varP fresh]
- $ ifx ">>" (varE fresh) $ instrE
- [ conE (mkName "Ldh") `appE` int (-1)
- , conE (mkName "Push") `appE` int consNum
- , conE (mkName "Eq")
- ]
+ mkPredicate consNum consName = fun (predicateName consName) []
+ [|\x->x >> instr [Ldh (-1), Push $(lift consNum), Eq]|]
mkInterpreter :: DecQ
- mkInterpreter = instanceD (pure []) (appT (conT $ className typeName) (conT $ mkName "Interpreter"))
- $ zipWith mkConstructor consNames fields
- ++ concatMap (map mkSelector) fields
- ++ zipWith mkPredicate consNames fields
+ mkInterpreter = instanceD (pure []) [t|$(conT $ className typeName) Interpreter|]
+ $ map (uncurry mkConstructor) constructors
+ ++ concatMap (\(cn, fs)->zipWith (mkSelector cn (length fs)) [0..] (map fst fs)) constructors
+ ++ map (uncurry mkPredicate) constructors
where
- wildcase e = if length consNames == 1 then [] else
- [match wildP (normalB e) []]
-
- mkConstructor :: Name -> [Field] -> DecQ
+ mkConstructor :: Name -> [(Name, TypeQ)] -> DecQ
mkConstructor consName fs = do
fresh <- sequence [newName "f" | _<-fs]
fun (constructorName consName) (map varP fresh)
- $ foldl (ifx "<*>") (varE (mkName "pure") `appE` conE consName) (map varE fresh)
+ $ foldl (ifx "<*>") [|pure $(conE consName)|] (map varE fresh)
- mkSelector :: Field -> DecQ
- mkSelector f = do
+ mkSelector :: Name -> Int -> Int -> Name -> DecQ
+ mkSelector consName ftotal fnum n = do
fresh <- newName "f"
- fun (selectorName $ fname f) [varP fresh] $
- ifx ">>=" (varE fresh) $ lamCaseE $ mkMatch : wilds
+ fun (selectorName n) [varP fresh] $
+ ifx ">>=" (varE fresh) $ lamCaseE (mkMatch:wilds)
where
mkMatch = do
fresh <- newName "e"
- match (conP (fcons f) [if fnum f == i then (varP fresh) else wildP | i<-[0..ftotal f-1]])
- (normalB $ varE (mkName "pure") `appE` varE fresh) []
- wilds = wildcase (varE (mkName "fail") `appE` string "Exhausted case")
-
- mkPredicate :: Name -> [Field] -> DecQ
- mkPredicate n fs = do
- fresh <- newName "f"
- fun (predicateName n) [varP fresh] $ ifx "<$>" (lamCaseE (mkMatch:wilds)) (varE fresh)
- where mkMatch = match (conP n [wildP | _<-fs]) (normalB $ conE (mkName "True")) []
- wilds = wildcase (conE $ mkName "False")
+ match (conP consName [if fnum == i then varP fresh else wildP | i<-[0..ftotal-1]])
+ (normalB [|pure $(varE fresh)|]) []
+ wilds = if length consNames == 1 then [] else
+ [match wildP (normalB [|fail "Exhausted case"|]) []]
+
+ mkPredicate :: Name -> [(Name, TypeQ)] -> DecQ
+ mkPredicate n fs = fun (predicateName n) []
+ $ if length consNames == 1 then [|\_->true|] else
+ [|\x->x >>= \p->case p of $(conP n [wildP | _<-fs]) -> true; _ -> false|]
import Data.Char
import Data.Functor.Identity
+import Control.Monad
+import Language.Haskell.TH
import Language.Haskell.TH.Syntax
import Language.Haskell.TH.Quote
import qualified Text.Parsec.Token as P
import Text.Parsec.Language (haskell)
--
-import Language.GenDSL
+import Language.GenDSL as L
dsl :: QuasiQuoter
dsl = QuasiQuoter
, quoteDec = undefined
}
where
- parseExpr :: MonadFail m => String -> Loc -> m Exp
- parseExpr s loc =
- case runParser p () "" s of
- Left err -> fail $ show err
- Right e -> return e
+ parseExpr :: String -> Loc -> ExpQ
+ parseExpr s loc = either (fail . show) id $ runParser p () file s
where
file = loc_filename loc
(line, col) = loc_start loc
- p = getPosition >>= setPosition . mPos >> whiteSpace *> funOrExpr <* eof
- mPos = (flip setSourceName) file .
- (flip setSourceLine) line .
- (flip setSourceColumn) col
+ p = getPosition >>= setPosition . mPos >> whiteSpace *> expr <* eof
+ mPos p = setSourceName (setSourceLine (setSourceColumn p col) line) file
-- Lexer
identifier,operator :: Parser String
whiteSpace = P.whiteSpace haskell
-- Parser
-funOrExpr :: Parser Exp
-funOrExpr = expr
-
-func :: Parser Exp
-func = many1 ((,) <$> many1 pat <* reservedOp "=" <*> expr) >>= mkFun
- where
- mkFun :: MonadFail m => [([Pat], Exp)] -> m Exp
- mkFun es
- | all ((==1) . length . fst) es = pure $ LamE [VarP (mkName "x")] $ mkCase (VarE (mkName "x")) [(p, e)|([p], e)<-es]
- mkFun _ = fail "Multiple patterns/entries not supported yet"
-
-expr :: Parser Exp
+expr :: Parser ExpQ
expr = buildExpressionParser
--Postfix record selectors
- [ [E.Postfix (fmap (\s e->VarE (selectorName (mkName s)) `AppE` e) $ P.lexeme haskell $ char '.' *> identifier)]
+ [ [E.Postfix (fmap (\s e->varE (selectorName (mkName s)) `appE` e) $ P.lexeme haskell $ char '.' *> identifier)]
, [bin "^" AssocRight]
, [bin "*" AssocLeft, bin "/" AssocLeft]
, [bin "+" AssocLeft, bin "-" AssocLeft]
, [E.Infix (fmap ifx $ lexeme $ char '`' *> identifier <* char '`') AssocRight]
] basic
where
- bin :: String -> Assoc -> Operator String () Identity Exp
+ bin :: String -> Assoc -> Operator String () Identity ExpQ
bin str = E.Infix $ ifx (str++".") <$ sat operator (str==)
(("Expected operator " ++ str ++ " but got ")++)
- basic :: Parser Exp
+ basic :: Parser ExpQ
basic
- = try (AppE . VarE <$> var <*> (TupE <$> parens (commaSep expr)))
- <|> VarE <$> var
- <|> mkCase <$ reserved "case" <*> expr <* reserved "of" <*> many1 ((,) <$> pat <* reservedOp "->" <*> expr)
- <|> (\i t e->VarE (mkName "if'") `AppE` i `AppE` t `AppE` e) <$ reserved "if" <*> expr <* reserved "then" <*> expr <* reserved "else" <*> expr
+ = try (appE . varE <$> var <*> (tupE <$> parens (commaSep expr)))
+ <|> varE <$> var
+ <|> mkCase <$ reserved "case" <*> expr <* reserved "of" <*> many1 ((,) <$> pat <*> body)
+ <|> (\i t e->[|if' $i $t $e|]) <$ reserved "if" <*> expr <* reserved "then" <*> expr <* reserved "else" <*> expr
<|> parens expr
- <|> mkLit . LitE <$> lit
- <|> mkLit . ConE . mkName <$> sat identifier ("True"==) ("Expected True but got: "++)
- <|> mkLit . ConE . mkName <$> sat identifier ("False"==) ("Expected False but got: "++)
+ <|> mkLit . litE <$> lite
+ <|> [|lit True|] <$ sat identifier ("True"==) ("Expected True but got: "++)
+ <|> [|lit False|] <$ sat identifier ("False"==) ("Expected False but got: "++)
+
+ match :: Parser (PatQ, BodyQ)
+ match = (,) <$> pat <*> body
-pat :: Parser Pat
+ body :: Parser BodyQ
+ body = guardedB <$> many1 (liftM2 (,) <$> guarded <* reservedOp "->" <*> expr)
+ <|> normalB <$ reservedOp "->" <*> expr
+ where
+ guarded :: Parser GuardQ
+ guarded = normalG <$ reservedOp "|" <*> expr
+
+pat :: Parser PatQ
pat
- = try (RecP <$> con <*> braces (commaSep $ (,) <$> var <* reservedOp "=" <*> pat))
- <|> ConP <$> con <*> many pat
- <|> try (AsP <$> var <* reservedOp "@" <*> pat)
- <|> VarP <$> var
- <|> WildP <$ symbol "_"
- <|> LitP <$> lit
+ = try (recP <$> con <*> braces (commaSep fieldpat))
+ <|> conP <$> con <*> many pat
+ <|> try (asP <$> var <* reservedOp "@" <*> pat)
+ <|> varP <$> var
+ <|> wildP <$ symbol "_"
+ <|> litP <$> lite
<|> parens pat
+ where fieldpat = liftM2 (,) . pure <$> var <* reservedOp "=" <*> pat
-lit :: Parser Lit
-lit
- = CharL <$> P.charLiteral haskell
- <|> IntegerL <$> P.natural haskell
+lite :: Parser Lit
+lite
+ = charL <$> P.charLiteral haskell
+ <|> integerL <$> P.natural haskell
sat :: Parser a -> (a -> Bool) -> (a -> String) -> Parser a
sat p f msg = try (p >>= \a->if f a then pure a else fail (msg a))
-mkLit :: Exp -> Exp
-mkLit = AppE $ VarE $ mkName "lit"
+mkLit :: ExpQ -> ExpQ
+mkLit x = [|lit $x|]
con,var :: Parser Name
con = mkName <$> sat identifier (isUpper . head) ("Not a data constructor: "++)
var = mkName <$> sat identifier (isLower . head) ("Not a variable identifier: "++)
-- Convert case to if statements
-mkCase :: Exp -> [(Pat, Exp)] -> Exp
-mkCase name cases = foldr (uncurry mkCaseMatch) (VarE (mkName "bottom") `AppE` LitE (StringL "Exhausted case")) cases
+mkCase :: ExpQ -> [(PatQ, BodyQ)] -> ExpQ
+mkCase name cases = foldr (uncurry mkCaseMatch) [|bottom "Exhausted case"|] cases
where
- mkCaseMatch :: Pat -> Exp -> Exp -> Exp
- mkCaseMatch a e rest = case mkCasePred name a of
- [] -> mkCaseLets (mkCaseBinding name a) e
- ps -> VarE (mkName "if'") `AppE` foldl1 (ifx "&.") ps `AppE` (mkCaseLets (mkCaseBinding name a) e) `AppE` rest
-
- mkCaseLets :: [Dec] -> Exp -> Exp
+ mkCaseMatch :: PatQ -> BodyQ -> ExpQ -> ExpQ
+ mkCaseMatch qa qb rest = qb >>= \b->case b of
+ NormalB e -> qa >>= \a->case mkCasePred name a of
+ [] -> ex a e
+ ps -> [|if' $(foldl1 (ifx "&.") ps) $(ex a e) $rest|]
+ GuardedB _ -> fail "Guarded bodies not yet supported"
+ where ex a e = mkCaseLets (mkCaseBinding name a) $ pure e
+
+ mkCaseLets :: [DecQ] -> ExpQ -> ExpQ
mkCaseLets [] e = e
- mkCaseLets defs e = LetE defs e
+ mkCaseLets defs e = letE defs e
conPtoRecP :: Name -> [Pat] -> Pat
conPtoRecP consName = RecP consName . zip (map (adtFieldName consName) [0..])
- mkCasePred :: Exp -> Pat -> [Exp]
- mkCasePred e (LitP l) = [ifx "==." (VarE (mkName "lit") `AppE` LitE l) e]
+ mkCasePred :: ExpQ -> Pat -> [ExpQ]
+ mkCasePred e (LitP l) = [[|lit $(litE l) ==. $e|]]
mkCasePred _ (VarP _) = []
mkCasePred e (ConP cons fs) = mkCasePred e $ conPtoRecP cons fs
mkCasePred e (InfixP l cons r) = mkCasePred e (ConP cons [l,r])
mkCasePred e (BangP p) = mkCasePred e p
mkCasePred e (AsP _ p) = mkCasePred e p
mkCasePred _ WildP = []
- mkCasePred e (RecP cons fs) = VarE (predicateName cons) `AppE` e
- : concatMap (\(n, p)->mkCasePred (VarE (selectorName n) `AppE` e) p) fs
+ mkCasePred e (RecP cons fs) = varE (predicateName cons) `appE` e
+ : concatMap (\(n, p)->mkCasePred (varE (selectorName n) `appE` e) p) fs
mkCasePred _ p = error $ "Unsupported pat: " ++ show p
- mkCaseBinding :: Exp -> Pat -> [Dec]
+ mkCaseBinding :: ExpQ -> Pat -> [DecQ]
mkCaseBinding _ (LitP _) = []
- mkCaseBinding e (VarP v) = [FunD v [Clause [] (NormalB $ e) []]]
+ mkCaseBinding e (VarP v) = [funD v [clause [] (normalB e) []]]
mkCaseBinding e (ConP cons fs) = mkCaseBinding e $ conPtoRecP cons fs
mkCaseBinding e (InfixP l cons r) = mkCaseBinding e (ConP cons [l,r])
mkCaseBinding e (UInfixP l cons r) = mkCaseBinding e (ConP cons [l,r])
mkCaseBinding e (ParensP p) = mkCaseBinding e p
mkCaseBinding e (TildeP p) = mkCaseBinding e p
mkCaseBinding e (BangP p) = mkCaseBinding e p
- mkCaseBinding e (AsP n p) = FunD n [Clause [] (NormalB $ e) []]:mkCaseBinding e p
+ mkCaseBinding e (AsP n p) = funD n [clause [] (normalB e) []]:mkCaseBinding e p
mkCaseBinding _ WildP = []
- mkCaseBinding e (RecP _ fs) = concatMap (\(n, p)->mkCaseBinding (VarE (selectorName n) `AppE` e) p) fs
+ mkCaseBinding e (RecP _ fs) = concatMap (\(n, p)->mkCaseBinding (varE (selectorName n) `appE` e) p) fs
mkCaseBinding _ p = error $ "Unsupported pat: " ++ show p
repositories / clean-tests.git / commitdiff