import Data.Char
import Control.Monad
-className :: Name -> Name
+className,constructorName,selectorName,predicateName :: Name -> Name
className = mkName . (++"'") . stringName
-constructorName :: Name -> Name
constructorName = mkName . map toLower . stringName
-selectorName :: Name -> Name
selectorName = mkName . map toLower . (++"'") . stringName
+predicateName = mkName . ("is"++) . stringName
+
stringName :: Name -> String
stringName (Name occ _) = occString occ
-numberedArgs :: [a] -> [Name]
-numberedArgs = zipWith (\i _->mkName $ "f" ++ show i) [0 :: Int ..]
+numberedArgs :: [a] -> Q [Name]
+numberedArgs = zipWithM (\i _->newName $ "f" ++ show i) [0 :: Int ..]
+
+data Field = Field { fname :: Name, ffresh :: Name, ftype :: Type }
-toNameType :: Con -> Q [(Name, Type)]
-toNameType (NormalC consName fs) = pure [(mkName $ map toLower (stringName consName) ++ "f" ++ show i, t) | (_, t)<-fs | i <- [0 :: Int ..]]
-toNameType (RecC consName fs) = pure [(n, t) | (n, _, t)<-fs]
+toNameType :: Con -> Q [Field]
+toNameType (NormalC consName fs) = numberedArgs fs
+ >>= \nfs->pure [Field (mkName $ map toLower (stringName consName) ++ "f" ++ show 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 c = fail $ "Unsupported constructor type: " ++ show c
getConsName :: Con -> Q Name
getConsName (RecC consName _) = pure consName
getConsName c = fail $ "Unsupported constructor type: " ++ show c
-mkConsClass :: Name -> DecsQ
-mkConsClass typename = reify typename >>= \info->case info of
- TyConI dec
- -> case dec of
- DataD _ _ tyvars _ constructors _
- -> sequence
- [ mkConstructorClasses tyvars constructors
- , mkPrinterInstances constructors
- , mkCompilerInstances constructors
- ]
- _
- -> fail "mkConsClass only supports data types"
- _
- -> fail "mkConsClass only supports types"
+ifx :: String -> Exp -> Exp -> Exp
+ifx op a b = InfixE (Just a) (VarE $ mkName op) (Just b)
+
+getNameTyVarBndr :: TyVarBndr -> Name
+getNameTyVarBndr (PlainTV name) = name
+getNameTyVarBndr (KindedTV name _) = name
+
+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
+ 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 ]
where
- mkConstructorClasses :: [TyVarBndr] -> [Con] -> Q Dec
- mkConstructorClasses tyvars constructors
- = ClassD [] (className typename) [PlainTV view] []
- <$> (genClassMembers <$> mapM getConsName constructors <*> mapM toNameType constructors)
+ 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
where
- genClassMembers consNames fieldTypes = mkPredicates $ mkSelectors $ mkConstructors
- where
- mkConstructors = zipWith mkConstructorClassMember consNames fieldTypes
- mkSelectors ds = foldl (foldr $ uncurry mkSelectorClassMember) ds fieldTypes
- mkPredicates ds = foldr mkPredicateClassMember ds consNames
-
- view = mkName "m"
-
- mkConstructorClassMember :: Name -> [(Name, Type)] -> Dec
- mkConstructorClassMember consName fs
- = SigD (constructorName consName)
- $ foldr (AppT . AppT ArrowT) resultT
- $ map ((AppT $ VarT view) . snd) fs
-
- mkSelectorClassMember :: Name -> Type -> [Dec] -> [Dec]
- mkSelectorClassMember n t = (:)
- $ SigD (className n)
- $ ArrowT `AppT` resultT `AppT` (VarT view `AppT` t)
-
- mkPredicateClassMember :: Name -> [Dec] -> [Dec]
- mkPredicateClassMember n = (:)
- $ SigD (mkName $ "is" ++ stringName n)
- $ ArrowT `AppT` resultT `AppT` (VarT view `AppT` ConT (mkName "Bool"))
-
- resultT = VarT view `AppT` (foldl AppT (ConT typename) $ map (VarT . getNameTyVarBndr) $ tyvars)
-
- mkPrinterInstances :: [Con] -> DecQ
- mkPrinterInstances constructors
- = InstanceD Nothing [] (AppT (ConT $ className typename) (ConT $ mkName "Printer"))
- <$> (genInstances <$> mapM getConsName constructors <*> mapM toNameType constructors)
+ 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
+
+ mkSelector :: Integer -> Field -> Dec
+ mkSelector _ f = SigD (selectorName (fname f)) $ resultT `arrow` view (ftype f)
+
+ mkPredicate :: Integer -> Name -> Dec
+ mkPredicate _ n = SigD (predicateName n) $ resultT `arrow` view (ConT (mkName "Bool"))
+
+ resultT = view $ foldl AppT (ConT typeName) $ map (VarT . getNameTyVarBndr) $ typeVars
+
+ fun name args body = FunD name [Clause args (NormalB body) []]
+
+ mkPrinter :: Dec
+ mkPrinter = InstanceD Nothing [] (AppT (ConT $ className typeName) (ConT $ mkName "Printer")) $ mkDecls mkConstructor mkSelector mkPredicate
where
- genInstances consNames fieldTypes = mkConstructors
- where
- mkConstructors = zipWith mkPrinterConstructor consNames fieldTypes
- --concat <$> ( (:) <$> mapM mkPrinterPredicate constructors <*> mapM mkPrinterInstance constructors)
-
- mkPrinterConstructor :: Name -> [(Name, Type)] -> Dec
- mkPrinterConstructor consName fs
- = FunD (constructorName consName)
- [Clause
- (map VarP $ numberedArgs fs)
- (NormalB $
- (AppE (VarE (mkName "printCons") `AppE` LitE (StringL $ stringName consName))
- (foldl (\x y->x `pc` pl " " `pc` y) (pl "") $ map VarE $ numberedArgs fs)
- )
- )
- []
- ]
- --mkConstructorClassMember :: Name -> [(Name, Type)] -> Dec
- --mkConstructorClassMember consName fs
- -- = SigD (constructorName consName)
- -- $ foldr (AppT . AppT ArrowT) resultT
- -- $ map ((AppT $ VarT view) . snd) fs
-
-
--- mkPrinterInstance :: Con -> DecsQ
--- mkPrinterInstance (NormalC consName fs)
--- | null fs = pure [FunD (constructorName consName)
--- [Clause [] (NormalB $ VarE (mkName "printLit") `AppE` LitE (StringL $ stringName consName)) [] ]]
--- | otherwise =
--- let args = map mkName $ numberedArgs fs
--- in (:) <$> pure (FunD (constructorName consName)
--- [Clause
--- (map VarP args)
--- (NormalB $
--- (AppE (VarE (mkName "printCons") `AppE` LitE (StringL $ stringName consName))
--- (foldl (\x y->x `pc` pl " " `pc` y) (pl "") $ map VarE args)
--- )
--- )
--- []
--- ])
--- <*> mapM mkPrinterSelector
--- (zipWith (\_ i->map toLower (stringName consName) ++ "f" ++ show i) fs [0 :: Int ..])
--- mkPrinterInstance (RecC consName fs)
--- = let args = map mkName $ numberedArgs fs
--- in (:) <$> pure (FunD (constructorName consName)
--- [Clause
--- (map VarP args)
--- (NormalB $
--- (AppE (VarE (mkName "printRec") `AppE` LitE (StringL $ stringName typename))
--- (foldl1 (\x y->x `pc` pl ", " `pc` y)
--- $ zipWith (\x ((Name occ'' _), _, _)->pl (occString occ'') `pc` pl "=" `pc` VarE x) args fs)
--- )
--- )
--- []
--- ])
--- <*> ((++)
--- <$> mapM mkPrinterSelector [occString occ | (Name occ _, _, _)<-fs]
--- <*> mapM mkPrinterSelector
--- (zipWith (\_ i->map toLower (stringName consName) ++ "f" ++ show i) fs [0 :: Int ..])
--- )
--- mkPrinterInstance t = fail $ "mkConsClass not supported for types such as: " ++ show t
---
--- mkPrinterSelector :: String -> Q Dec
--- mkPrinterSelector n' = do
--- body <- [|\d->d >> printLit $(pure $ LitE $ StringL ('.':n'))|]
--- pure $ FunD (selectorName $ mkName n') [Clause [] (NormalB body) []]
---
--- mkPrinterPredicate :: Con -> Q Dec
--- mkPrinterPredicate (NormalC consName _)
--- = mkPrinterPredicateForName consName
--- mkPrinterPredicate (RecC consName _)
--- = mkPrinterPredicateForName consName
--- mkPrinterPredicate t = fail $ "mkConsClass not supported for types such as: " ++ show t
---
--- mkPrinterPredicateForName :: Name -> Q Dec
--- mkPrinterPredicateForName consName = do
--- body <- [| \d->printLit $(pure $ LitE $ StringL $ "is" ++ stringName consName ++ " ") >>> d|]
--- pure $ FunD (mkName $ "is" ++ stringName consName) [Clause [] (NormalB body) []]
-
- mkCompilerInstances :: [Con] -> DecQ
- mkCompilerInstances constructors
- = InstanceD Nothing [] (AppT (ConT $ className typename) (ConT $ mkName "Compiler")) . concat
- <$> pure []--((:) <$> mapM (uncurry mkCompilerPredicate) (zip [0..] constructors) <*> mapM (uncurry mkCompilerInstance) (zip constructors [0..]))
--- where
--- mkCompilerInstance :: Con -> Int -> DecsQ
--- mkCompilerInstance (NormalC consName fs) consnum = (:)
--- <$> mkCompilerInstanceForName consName consnum (numberedArgs fs)
--- <*> mapM (uncurry mkCompilerSelector) (zip [0..] [map toLower (stringName consName) ++ f | f<-numberedArgs fs])
--- mkCompilerInstance (RecC consName fs) consnum = (:)
--- <$> mkCompilerInstanceForName consName consnum [occString occ | (Name occ _, _, _) <- fs]
--- <*> ((++)
--- <$> mapM (uncurry mkCompilerSelector) (zip [0..] [occString occ | (Name occ _, _, _) <- fs])
--- <*> mapM (uncurry mkCompilerSelector) (zip [0..] [map toLower (stringName consName) ++ f | f<-numberedArgs fs])
--- )
--- mkCompilerInstance t _ = fail $ "mkConsClass not supported for types such as: " ++ show t
---
--- mkCompilerInstanceForName :: Name -> Int -> [String] -> DecQ
--- mkCompilerInstanceForName name consnum fs =
--- let args = map mkName $ numberedArgs fs
--- in do
--- body <- [|instr [Push $(pure $ LitE $ IntegerL $ toInteger $ consnum)] *> $(mkBody $ map VarE args) <* instr [Sth $ $(pure $ LitE $ IntegerL $ toInteger $ length fs) + 1] |]
--- pure $ FunD (constructorName name)
--- [Clause (map VarP args) (NormalB body) [] ]
--- where
--- mkBody :: [Exp] -> Q Exp
--- mkBody [] = pure $ VarE (mkName "pure") `AppE` ConE name
--- mkBody (a:as) = foldM (\x y->pure $ ifx "<*>" x y) (ifx "<$>" (ConE name) a) as
---
--- mkCompilerSelector :: Int -> String -> DecQ
--- mkCompilerSelector idx n' = do
--- body <- [|\d->d >> instr [Ldh $(pure $ LitE (IntegerL (toInteger idx)))] |]
--- pure $ FunD (selectorName $ mkName n')
--- [Clause [] (NormalB body) [] ]
---
--- mkCompilerPredicate :: Int -> Con -> Q Dec
--- mkCompilerPredicate idx (NormalC consName _)
--- = mkCompilerPredicateForName idx consName
--- mkCompilerPredicate idx (RecC consName _)
--- = mkCompilerPredicateForName idx consName
--- mkCompilerPredicate _ t = fail $ "mkConsClass not supported for types such as: " ++ show t
---
--- mkCompilerPredicateForName :: Int -> Name -> Q Dec
--- mkCompilerPredicateForName i consName = do
--- body <- [| \d->d >> instr [Ldh (-1), Push $(pure $ LitE $ IntegerL $ toInteger i), Eq] |]
--- pure $ FunD (mkName $ "is" ++ stringName consName) [Clause [] (NormalB body) []]
-
-instrE :: Exp -> Exp
-instrE e = VarE (mkName "instr") `AppE` ListE [e]
+ pl s = VarE (mkName "printLit") `AppE` LitE (StringL s)
-ifx :: String -> Exp -> Exp -> Exp
-ifx op a b = InfixE (Just a) (VarE $ mkName op) (Just b)
+ 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
-pc :: Exp -> Exp -> Exp
-pc l r = VarE (mkName ">>>") `AppE` l `AppE` r
+ mkSelector :: Integer -> Field -> Dec
+ mkSelector _ Field{fname=n} = fun (selectorName n) [VarP argName] (ifx ">>" (VarE argName) $ pl ('.':stringName n))
-pl :: String -> Exp
-pl s = VarE (mkName "printLit") `AppE` LitE (StringL s)
+ mkPredicate :: Integer -> Name -> Dec
+ mkPredicate _ n = fun (predicateName n) [VarP argName] (ifx ">->" (pl $ stringName $ predicateName n) $ VarE argName)
-getNameTyVarBndr :: TyVarBndr -> Name
-getNameTyVarBndr (PlainTV name) = name
-getNameTyVarBndr (KindedTV name _) = name
+ mkCompiler :: Dec
+ mkCompiler = InstanceD Nothing [] (AppT (ConT $ className typeName) (ConT $ mkName "Compiler")) $ mkDecls mkConstructor mkSelector mkPredicate
+ 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")
+ ]
repositories / clean-tests.git / blobdiff