numberedArgs :: [a] -> Q [Name]
numberedArgs = zipWithM (\i _->newName $ "f" ++ show i) [0 :: Int ..]
-adtFieldName :: Name -> Int -> Name
+adtFieldName :: Name -> Integer -> Name
adtFieldName consName idx = mkName $ map toLower (stringName consName) ++ "f" ++ show idx
-data Field = Field { fname :: Name, ffresh :: Name, ftype :: Type }
+data Field = Field { fcons :: Name, ftotal :: Integer, fnum :: Integer, fname :: Name, ftype :: Type }
-toNameType :: Con -> Q [Field]
-toNameType (NormalC consName fs) = numberedArgs fs
- >>= \nfs->pure [Field (adtFieldName consName i) nf t | (_, t) <- fs | nf <- nfs | i <- [0 :: Int ..]]
-toNameType (RecC _ fs) = numberedArgs fs
- >>= \nfs->pure [Field n nf t | (n, _, t)<-fs | nf <- nfs]
+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 _) = pure consName
+getConsName (NormalC consName _)
+ | head (stringName consName) == ':' = fail "Infix constructors are not supported"
+ | otherwise = pure consName
getConsName (RecC consName _) = pure consName
getConsName c = fail $ "Unsupported constructor type: " ++ show c
-ifx :: String -> Exp -> Exp -> Exp
-ifx op a b = InfixE (Just a) (VarE $ mkName op) (Just b)
+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)
getNameTyVarBndr :: TyVarBndr -> Name
getNameTyVarBndr (PlainTV name) = name
getNameTyVarBndr (KindedTV name _) = name
+fun :: Name -> [PatQ] -> ExpQ -> DecQ
+fun name args body = funD name [clause args (normalB body) []]
+
genDSL :: Name -> DecsQ
genDSL typename = reify typename >>= \info->case info of
TyConI (DataD _ _ tyvars _ constructors _)
- -> mkDSL typename tyvars <$> newName "view" <*> newName "d" <*> mapM getConsName constructors <*> mapM toNameType constructors
+ -> mapM getConsName constructors >>= mkDSL typename tyvars (map toNameType constructors)
t
-> fail $ "mkConsClass only supports datatypes and not: " ++ show t
-mkDSL :: Name -> [TyVarBndr] -> Name -> Name -> [Name] -> [[Field]] -> [Dec]
-mkDSL typeName typeVars viewName argName consNames fields = [ mkClass, mkPrinter, mkCompiler ]
+mkDSL :: Name -> [TyVarBndr] -> [[Field]] -> [Name] -> DecsQ
+mkDSL typeName typeVars fields consNames = sequence [ mkClass, mkPrinter, mkCompiler, mkInterpreter ]
where
- mkDecls mkConstructor mkSelector mkPredicate
- = zipWith3 mkConstructor [0..] consNames fields
- ++ concatMap (zipWith mkSelector [0..]) fields
- ++ zipWith mkPredicate [0..] consNames
-
- mkClass :: Dec
- mkClass = ClassD [] (className typeName) [PlainTV viewName] [] $ mkDecls mkConstructor mkSelector mkPredicate
+ mkClass :: DecQ
+ mkClass = classD (pure []) (className typeName) [PlainTV (mkName "v")] []
+ ( zipWith mkConstructor consNames fields
+ ++ concatMap (map mkSelector) fields
+ ++ map mkPredicate consNames
+ )
where
- view a = VarT viewName `AppT` a
- arrow = AppT . AppT ArrowT
-
- mkConstructor :: Integer -> Name -> [Field] -> Dec
- mkConstructor _ n fs = SigD (constructorName n) $ foldr arrow resultT $ map (view . ftype) fs
+ view a = varT (mkName "v") `appT` a
+ arrow = appT . appT arrowT
- mkSelector :: Integer -> Field -> Dec
- mkSelector _ f = SigD (selectorName (fname f)) $ resultT `arrow` view (ftype f)
+ mkConstructor :: Name -> [Field] -> DecQ
+ mkConstructor n fs = sigD (constructorName n) $ foldr arrow resultT $ map (view . pure . ftype) fs
- mkPredicate :: Integer -> Name -> Dec
- mkPredicate _ n = SigD (predicateName n) $ resultT `arrow` view (ConT (mkName "Bool"))
+ mkSelector :: Field -> DecQ
+ mkSelector f = sigD (selectorName (fname f)) $ resultT `arrow` view (pure $ ftype f)
- resultT = view $ foldl AppT (ConT typeName) $ map (VarT . getNameTyVarBndr) $ typeVars
+ mkPredicate :: Name -> DecQ
+ mkPredicate n = sigD (predicateName n) $ resultT `arrow` view (conT (mkName "Bool"))
- fun name args body = FunD name [Clause args (NormalB body) []]
+ resultT :: TypeQ
+ resultT = view $ foldl appT (conT typeName) $ map (varT . getNameTyVarBndr) $ typeVars
- mkPrinter :: Dec
- mkPrinter = InstanceD Nothing [] (AppT (ConT $ className typeName) (ConT $ mkName "Printer")) $ mkDecls mkConstructor mkSelector mkPredicate
+ mkPrinter :: DecQ
+ mkPrinter = instanceD (pure []) (appT (conT $ className typeName) (conT $ mkName "Printer"))
+ $ zipWith mkConstructor consNames fields
+ ++ concatMap (map mkSelector) fields
+ ++ map mkPredicate consNames
where
- pl s = VarE (mkName "printLit") `AppE` LitE (StringL s)
-
- mkConstructor :: Integer -> Name -> [Field] -> Dec
- mkConstructor _ consName fs = fun (constructorName consName) (map (VarP . ffresh) fs) (pcons `AppE` pargs)
- where pcons = VarE (mkName "printCons") `AppE` LitE (StringL $ stringName consName)
- pargs = foldl (ifx ">->") (pl "") $ map (VarE . ffresh) fs
-
- mkSelector :: Integer -> Field -> Dec
- mkSelector _ Field{fname=n} = fun (selectorName n) [VarP argName] (ifx ">>" (VarE argName) $ pl ('.':stringName n))
-
- mkPredicate :: Integer -> Name -> Dec
- mkPredicate _ n = fun (predicateName n) [VarP argName] (ifx ">->" (pl $ stringName $ predicateName n) $ VarE argName)
-
- mkCompiler :: Dec
- mkCompiler = InstanceD Nothing [] (AppT (ConT $ className typeName) (ConT $ mkName "Compiler")) $ mkDecls mkConstructor mkSelector mkPredicate
+ pl s = varE (mkName "printLit") `appE` string s
+
+ mkConstructor :: Name -> [Field] -> 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)
+ 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))
+
+ mkPredicate :: Name -> DecQ
+ mkPredicate n = do
+ fresh <- newName "f"
+ fun (predicateName n) [varP fresh] (ifx ">->" (pl $ stringName $ predicateName n) $ varE fresh)
+
+ mkCompiler :: DecQ
+ mkCompiler = instanceD (pure []) (appT (conT $ className typeName) (conT $ mkName "Compiler"))
+ $ zipWith3 mkConstructor [0..] consNames fields
+ ++ concat (zipWith (map . mkSelector) [0..] fields)
+ ++ zipWith mkPredicate [0..] consNames
+ where
+ instrE e = varE (mkName "instr") `appE` listE e
+
+ mkConstructor :: Integer -> Name -> [Field] -> 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]
+
+ 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]
+
+ 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")
+ ]
+
+ mkInterpreter :: DecQ
+ mkInterpreter = instanceD (pure []) (appT (conT $ className typeName) (conT $ mkName "Interpreter"))
+ $ zipWith mkConstructor consNames fields
+ ++ concatMap (map mkSelector) fields
+ ++ zipWith mkPredicate consNames fields
where
- instrE e = VarE (mkName "instr") `AppE` ListE e
-
- mkConstructor :: Integer -> Name -> [Field] -> Dec
- mkConstructor consNum consName fs = fun (constructorName consName) (map (VarP . ffresh) fs)
- $ ifx "*>" pushCons $ ifx "<*" (mkBody $ map (VarE . ffresh) fs) storeHeap
- where storeHeap = instrE [ConE (mkName "Sth") `AppE` (ifx "+" (LitE $ IntegerL 1) (LitE $ IntegerL $ toInteger $ length fs))]
- mkBody = foldl (ifx "<*>") (VarE (mkName "pure") `AppE` ConE consName)
- pushCons = instrE [ConE (mkName "Push") `AppE` LitE (IntegerL consNum)]
-
- mkSelector :: Integer -> Field -> Dec
- mkSelector consNum Field{fname=f} = fun (selectorName f) [VarP argName]
- $ ifx ">>" (VarE argName) $ instrE
- [ConE (mkName "Ldh") `AppE` LitE (IntegerL consNum)]
-
- mkPredicate :: Integer -> Name -> Dec
- mkPredicate consNum consName = fun (predicateName consName) [VarP argName]
- $ ifx ">>" (VarE argName) $ instrE
- [ ConE (mkName "Ldh") `AppE` LitE (IntegerL (-1))
- , ConE (mkName "Push") `AppE` LitE (IntegerL $ toInteger consNum)
- , ConE (mkName "Eq")
- ]
+ wildcase e = if length consNames == 1 then [] else
+ [match wildP (normalB e) []]
+
+ mkConstructor :: Name -> [Field] -> 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)
+
+ mkSelector :: Field -> DecQ
+ mkSelector f = do
+ fresh <- newName "f"
+ fun (selectorName $ fname f) [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")
repositories / clean-tests.git / blobdiff