1 {-# LANGUAGE TemplateHaskell #-}
2 {-# LANGUAGE ParallelListComp #-}
3 module Language.GenDSL where
5 import Language.Haskell.TH.Syntax
6 import Language.Haskell.TH
10 className :: Name -> Name
11 className = mkName . (++"'") . stringName
12 constructorName :: Name -> Name
13 constructorName = mkName . map toLower . stringName
14 selectorName :: Name -> Name
15 selectorName = mkName . map toLower . (++"'") . stringName
16 stringName :: Name -> String
17 stringName (Name occ _) = occString occ
19 numberedArgs :: [a] -> [Name]
20 numberedArgs = zipWith (\i _->mkName $ "f" ++ show i) [0 :: Int ..]
22 toNameType :: Con -> Q [(Name, Type)]
23 toNameType (NormalC consName fs) = pure [(mkName $ map toLower (stringName consName) ++ "f" ++ show i, t) | (_, t)<-fs | i <- [0 :: Int ..]]
24 toNameType (RecC consName fs) = pure [(n, t) | (n, _, t)<-fs]
25 toNameType c = fail $ "Unsupported constructor type: " ++ show c
27 getConsName :: Con -> Q Name
28 getConsName (NormalC consName _) = pure consName
29 getConsName (RecC consName _) = pure consName
30 getConsName c = fail $ "Unsupported constructor type: " ++ show c
32 mkConsClass :: Name -> DecsQ
33 mkConsClass typename = reify typename >>= \info->case info of
36 DataD _ _ tyvars _ constructors _
38 [ mkConstructorClasses tyvars constructors
39 , mkPrinterInstances constructors
40 , mkCompilerInstances constructors
43 -> fail "mkConsClass only supports data types"
45 -> fail "mkConsClass only supports types"
47 mkConstructorClasses :: [TyVarBndr] -> [Con] -> Q Dec
48 mkConstructorClasses tyvars constructors
49 = ClassD [] (className typename) [PlainTV view] []
50 <$> (genClassMembers <$> mapM getConsName constructors <*> mapM toNameType constructors)
52 genClassMembers consNames fieldTypes = mkPredicates $ mkSelectors $ mkConstructors
54 mkConstructors = zipWith mkConstructorClassMember consNames fieldTypes
55 mkSelectors ds = foldl (foldr $ uncurry mkSelectorClassMember) ds fieldTypes
56 mkPredicates ds = foldr mkPredicateClassMember ds consNames
60 mkConstructorClassMember :: Name -> [(Name, Type)] -> Dec
61 mkConstructorClassMember consName fs
62 = SigD (constructorName consName)
63 $ foldr (AppT . AppT ArrowT) resultT
64 $ map ((AppT $ VarT view) . snd) fs
66 mkSelectorClassMember :: Name -> Type -> [Dec] -> [Dec]
67 mkSelectorClassMember n t = (:)
69 $ ArrowT `AppT` resultT `AppT` (VarT view `AppT` t)
71 mkPredicateClassMember :: Name -> [Dec] -> [Dec]
72 mkPredicateClassMember n = (:)
73 $ SigD (mkName $ "is" ++ stringName n)
74 $ ArrowT `AppT` resultT `AppT` (VarT view `AppT` ConT (mkName "Bool"))
76 resultT = VarT view `AppT` (foldl AppT (ConT typename) $ map (VarT . getNameTyVarBndr) $ tyvars)
78 mkPrinterInstances :: [Con] -> DecQ
79 mkPrinterInstances constructors
80 = InstanceD Nothing [] (AppT (ConT $ className typename) (ConT $ mkName "Printer"))
81 <$> (genInstances <$> mapM getConsName constructors <*> mapM toNameType constructors)
83 genInstances consNames fieldTypes = mkConstructors
85 mkConstructors = zipWith mkPrinterConstructor consNames fieldTypes
86 --concat <$> ( (:) <$> mapM mkPrinterPredicate constructors <*> mapM mkPrinterInstance constructors)
88 mkPrinterConstructor :: Name -> [(Name, Type)] -> Dec
89 mkPrinterConstructor consName fs
90 = FunD (constructorName consName)
92 (map VarP $ numberedArgs fs)
94 (AppE (VarE (mkName "printCons") `AppE` LitE (StringL $ stringName consName))
95 (foldl (\x y->x `pc` pl " " `pc` y) (pl "") $ map VarE $ numberedArgs fs)
100 --mkConstructorClassMember :: Name -> [(Name, Type)] -> Dec
101 --mkConstructorClassMember consName fs
102 -- = SigD (constructorName consName)
103 -- $ foldr (AppT . AppT ArrowT) resultT
104 -- $ map ((AppT $ VarT view) . snd) fs
107 -- mkPrinterInstance :: Con -> DecsQ
108 -- mkPrinterInstance (NormalC consName fs)
109 -- | null fs = pure [FunD (constructorName consName)
110 -- [Clause [] (NormalB $ VarE (mkName "printLit") `AppE` LitE (StringL $ stringName consName)) [] ]]
112 -- let args = map mkName $ numberedArgs fs
113 -- in (:) <$> pure (FunD (constructorName consName)
117 -- (AppE (VarE (mkName "printCons") `AppE` LitE (StringL $ stringName consName))
118 -- (foldl (\x y->x `pc` pl " " `pc` y) (pl "") $ map VarE args)
123 -- <*> mapM mkPrinterSelector
124 -- (zipWith (\_ i->map toLower (stringName consName) ++ "f" ++ show i) fs [0 :: Int ..])
125 -- mkPrinterInstance (RecC consName fs)
126 -- = let args = map mkName $ numberedArgs fs
127 -- in (:) <$> pure (FunD (constructorName consName)
131 -- (AppE (VarE (mkName "printRec") `AppE` LitE (StringL $ stringName typename))
132 -- (foldl1 (\x y->x `pc` pl ", " `pc` y)
133 -- $ zipWith (\x ((Name occ'' _), _, _)->pl (occString occ'') `pc` pl "=" `pc` VarE x) args fs)
139 -- <$> mapM mkPrinterSelector [occString occ | (Name occ _, _, _)<-fs]
140 -- <*> mapM mkPrinterSelector
141 -- (zipWith (\_ i->map toLower (stringName consName) ++ "f" ++ show i) fs [0 :: Int ..])
143 -- mkPrinterInstance t = fail $ "mkConsClass not supported for types such as: " ++ show t
145 -- mkPrinterSelector :: String -> Q Dec
146 -- mkPrinterSelector n' = do
147 -- body <- [|\d->d >> printLit $(pure $ LitE $ StringL ('.':n'))|]
148 -- pure $ FunD (selectorName $ mkName n') [Clause [] (NormalB body) []]
150 -- mkPrinterPredicate :: Con -> Q Dec
151 -- mkPrinterPredicate (NormalC consName _)
152 -- = mkPrinterPredicateForName consName
153 -- mkPrinterPredicate (RecC consName _)
154 -- = mkPrinterPredicateForName consName
155 -- mkPrinterPredicate t = fail $ "mkConsClass not supported for types such as: " ++ show t
157 -- mkPrinterPredicateForName :: Name -> Q Dec
158 -- mkPrinterPredicateForName consName = do
159 -- body <- [| \d->printLit $(pure $ LitE $ StringL $ "is" ++ stringName consName ++ " ") >>> d|]
160 -- pure $ FunD (mkName $ "is" ++ stringName consName) [Clause [] (NormalB body) []]
162 mkCompilerInstances :: [Con] -> DecQ
163 mkCompilerInstances constructors
164 = InstanceD Nothing [] (AppT (ConT $ className typename) (ConT $ mkName "Compiler")) . concat
165 <$> pure []--((:) <$> mapM (uncurry mkCompilerPredicate) (zip [0..] constructors) <*> mapM (uncurry mkCompilerInstance) (zip constructors [0..]))
167 -- mkCompilerInstance :: Con -> Int -> DecsQ
168 -- mkCompilerInstance (NormalC consName fs) consnum = (:)
169 -- <$> mkCompilerInstanceForName consName consnum (numberedArgs fs)
170 -- <*> mapM (uncurry mkCompilerSelector) (zip [0..] [map toLower (stringName consName) ++ f | f<-numberedArgs fs])
171 -- mkCompilerInstance (RecC consName fs) consnum = (:)
172 -- <$> mkCompilerInstanceForName consName consnum [occString occ | (Name occ _, _, _) <- fs]
174 -- <$> mapM (uncurry mkCompilerSelector) (zip [0..] [occString occ | (Name occ _, _, _) <- fs])
175 -- <*> mapM (uncurry mkCompilerSelector) (zip [0..] [map toLower (stringName consName) ++ f | f<-numberedArgs fs])
177 -- mkCompilerInstance t _ = fail $ "mkConsClass not supported for types such as: " ++ show t
179 -- mkCompilerInstanceForName :: Name -> Int -> [String] -> DecQ
180 -- mkCompilerInstanceForName name consnum fs =
181 -- let args = map mkName $ numberedArgs fs
183 -- body <- [|instr [Push $(pure $ LitE $ IntegerL $ toInteger $ consnum)] *> $(mkBody $ map VarE args) <* instr [Sth $ $(pure $ LitE $ IntegerL $ toInteger $ length fs) + 1] |]
184 -- pure $ FunD (constructorName name)
185 -- [Clause (map VarP args) (NormalB body) [] ]
187 -- mkBody :: [Exp] -> Q Exp
188 -- mkBody [] = pure $ VarE (mkName "pure") `AppE` ConE name
189 -- mkBody (a:as) = foldM (\x y->pure $ ifx "<*>" x y) (ifx "<$>" (ConE name) a) as
191 -- mkCompilerSelector :: Int -> String -> DecQ
192 -- mkCompilerSelector idx n' = do
193 -- body <- [|\d->d >> instr [Ldh $(pure $ LitE (IntegerL (toInteger idx)))] |]
194 -- pure $ FunD (selectorName $ mkName n')
195 -- [Clause [] (NormalB body) [] ]
197 -- mkCompilerPredicate :: Int -> Con -> Q Dec
198 -- mkCompilerPredicate idx (NormalC consName _)
199 -- = mkCompilerPredicateForName idx consName
200 -- mkCompilerPredicate idx (RecC consName _)
201 -- = mkCompilerPredicateForName idx consName
202 -- mkCompilerPredicate _ t = fail $ "mkConsClass not supported for types such as: " ++ show t
204 -- mkCompilerPredicateForName :: Int -> Name -> Q Dec
205 -- mkCompilerPredicateForName i consName = do
206 -- body <- [| \d->d >> instr [Ldh (-1), Push $(pure $ LitE $ IntegerL $ toInteger i), Eq] |]
207 -- pure $ FunD (mkName $ "is" ++ stringName consName) [Clause [] (NormalB body) []]
210 instrE e = VarE (mkName "instr") `AppE` ListE [e]
212 ifx :: String -> Exp -> Exp -> Exp
213 ifx op a b = InfixE (Just a) (VarE $ mkName op) (Just b)
215 pc :: Exp -> Exp -> Exp
216 pc l r = VarE (mkName ">>>") `AppE` l `AppE` r
219 pl s = VarE (mkName "printLit") `AppE` LitE (StringL s)
221 getNameTyVarBndr :: TyVarBndr -> Name
222 getNameTyVarBndr (PlainTV name) = name
223 getNameTyVarBndr (KindedTV name _) = name