{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE ParallelListComp #-}
module Language.GenDSL where
import Language.Haskell.TH.Syntax
stringName :: Name -> String
stringName (Name occ _) = occString occ
-numberedArgs :: [a] -> [String]
-numberedArgs = zipWith (\i _->"f" ++ show i) [0 :: Int ..]
+numberedArgs :: [a] -> [Name]
+numberedArgs = zipWith (\i _->mkName $ "f" ++ show i) [0 :: Int ..]
+
+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 c = fail $ "Unsupported constructor type: " ++ show c
+
+getConsName :: Con -> Q Name
+getConsName (NormalC consName _) = pure consName
+getConsName (RecC consName _) = pure consName
+getConsName c = fail $ "Unsupported constructor type: " ++ show c
mkConsClass :: Name -> DecsQ
mkConsClass typename = reify typename >>= \info->case info of
-> case dec of
DataD _ _ tyvars _ constructors _
-> sequence
- [ {-mkDerivation tyvars
- ,-}mkConstructorClasses tyvars constructors
+ [ mkConstructorClasses tyvars constructors
, mkPrinterInstances constructors
, mkCompilerInstances constructors
]
_
-> fail "mkConsClass only supports types"
where
--- mkDerivation :: [TyVarBndr] -> DecQ
--- mkDerivation tyvars = let names = (map (VarT . getNameTyVarBndr) tyvars) in pure $
--- InstanceD Nothing
--- [ConT (mkName "Serialise") `AppT` t | t <- names]
--- (ConT (mkName "Serialise") `AppT` foldl AppT (ConT typename) names)
--- []
-
- mkConstructorClasses :: [TyVarBndr] -> [Con] -> DecQ
- mkConstructorClasses tyvars constructors = do
- cclasses <- mapM mkConstructorClassMember constructors
- sclasses <- concat <$> mapM mkSelectorClassMember constructors
- pclasses <- mapM mkPredicateClassMember constructors
- pure $ ClassD [] (className typename) [PlainTV view] [] (cclasses ++ sclasses ++ pclasses)
+ mkConstructorClasses :: [TyVarBndr] -> [Con] -> Q Dec
+ mkConstructorClasses tyvars constructors
+ = ClassD [] (className typename) [PlainTV view] []
+ <$> (genClassMembers <$> mapM getConsName constructors <*> mapM toNameType constructors)
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 :: Con -> DecQ
- mkConstructorClassMember (NormalC consname fs)
- = mkConstructorClassMemberForName consname [t | (_, t)<-fs]
- mkConstructorClassMember (RecC consname fs)
- = mkConstructorClassMemberForName consname [t | (_, _, t)<-fs]
- mkConstructorClassMember t
- = fail $ "mkConsClass not supported for types such as: " ++ show t
-
- mkConstructorClassMemberForName :: Name -> [Type] -> DecQ
- mkConstructorClassMemberForName consName fs
- = pure $ SigD (constructorName consName)
+ mkConstructorClassMember :: Name -> [(Name, Type)] -> Dec
+ mkConstructorClassMember consName fs
+ = SigD (constructorName consName)
$ foldr (AppT . AppT ArrowT) resultT
- $ map (AppT $ VarT view) fs
-
- mkSelectorClassMember :: Con -> DecsQ
- mkSelectorClassMember (NormalC consName fs)
- = mapM (uncurry mkSelectorClassMemberForField)
- $ zipWith (\(_, t) i->(mkName $ map toLower (stringName consName) ++ "f" ++ show i, t)) fs [0 :: Int ..]
- mkSelectorClassMember (RecC consName fs)
- = (++) <$> mapM (uncurry mkSelectorClassMemberForField) [(n, t)|(n, _, t)<-fs]
- <*> mapM (uncurry mkSelectorClassMemberForField)
- (zipWith (\(_, _, t) i->(mkName $ map toLower (stringName consName) ++ "f" ++ show i, t)) fs [0 :: Int ..])
-
- mkSelectorClassMember t
- = fail $ "mkConsClass not supported for types such as: " ++ show t
-
- mkSelectorClassMemberForField :: Name -> Type -> DecQ
- mkSelectorClassMemberForField n t = pure
+ $ map ((AppT $ VarT view) . snd) fs
+
+ mkSelectorClassMember :: Name -> Type -> [Dec] -> [Dec]
+ mkSelectorClassMember n t = (:)
$ SigD (className n)
- $ ForallT [] [ConT (mkName "Serialise") `AppT` VarT (getNameTyVarBndr ty) | ty <- tyvars]
$ ArrowT `AppT` resultT `AppT` (VarT view `AppT` t)
- mkPredicateClassMember :: Con -> DecQ
- mkPredicateClassMember (NormalC consName _)
- = mkPredicateClassMemberForName consName
- mkPredicateClassMember (RecC consName _)
- = mkPredicateClassMemberForName consName
- mkPredicateClassMember t
- = fail $ "mkConsClass not supported for types such as: " ++ show t
-
- mkPredicateClassMemberForName :: Name -> DecQ
- mkPredicateClassMemberForName n = pure
+ mkPredicateClassMember :: Name -> [Dec] -> [Dec]
+ mkPredicateClassMember n = (:)
$ SigD (mkName $ "is" ++ stringName n)
- $ ForallT [] [ConT (mkName "Serialise") `AppT` VarT (getNameTyVarBndr ty) | ty <- tyvars]
$ 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")) . concat
- <$> ((:) <$> mapM mkPrinterPredicate constructors <*> mapM mkPrinterInstance constructors)
+ = InstanceD Nothing [] (AppT (ConT $ className typename) (ConT $ mkName "Printer"))
+ <$> (genInstances <$> mapM getConsName constructors <*> mapM toNameType constructors)
where
- 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)
+ 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 args)
+ (map VarP $ numberedArgs fs)
(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)
+ (AppE (VarE (mkName "printCons") `AppE` LitE (StringL $ stringName consName))
+ (foldl (\x y->x `pc` pl " " `pc` y) (pl "") $ map VarE $ numberedArgs 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) []]
+ ]
+ --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
- <$> ((:) <$> 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) []]
+ <$> 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]
repositories / clean-tests.git / commitdiff