datatype/Language/GenDSL.hs

   1 {-# LANGUAGE TemplateHaskell #-}
   2 module Language.GenDSL where
   3
   4 import Language.Haskell.TH.Syntax
   5 import Language.Haskell.TH
   6 import Data.Char
   7 import Control.Monad
   8
   9 className :: Name -> Name
  10 className = mkName . (++"'") . stringName
  11 constructorName :: Name -> Name
  12 constructorName = mkName . map toLower . stringName
  13 selectorName :: Name -> Name
  14 selectorName = mkName . map toLower . (++"'") . stringName
  15 stringName :: Name -> String
  16 stringName (Name occ _) = occString occ
  17
  18 numberedArgs :: [a] -> [String]
  19 numberedArgs = zipWith (\i _->"f" ++ show i) [0 :: Int ..]
  20
  21 mkConsClass :: Name -> DecsQ
  22 mkConsClass typename = reify typename >>= \info->case info of
  23     TyConI dec
  24         -> case dec of
  25         DataD _ _ tyvars _ constructors _
  26             -> sequence
  27                 [ {-mkDerivation tyvars
  28                 ,-}mkConstructorClasses tyvars constructors
  29                 , mkPrinterInstances constructors
  30                 , mkCompilerInstances constructors
  31                 ]
  32         _
  33             -> fail "mkConsClass only supports data types"
  34     _
  35         -> fail "mkConsClass only supports types"
  36   where
  37 --    mkDerivation :: [TyVarBndr] -> DecQ
  38 --    mkDerivation tyvars = let names = (map (VarT . getNameTyVarBndr) tyvars) in pure $
  39 --        InstanceD Nothing
  40 --            [ConT (mkName "Serialise") `AppT` t | t <- names]
  41 --            (ConT (mkName "Serialise") `AppT` foldl AppT (ConT typename) names)
  42 --            []
  43
  44     mkConstructorClasses :: [TyVarBndr] -> [Con] -> DecQ
  45     mkConstructorClasses tyvars constructors = do
  46         cclasses <- mapM mkConstructorClassMember constructors
  47         sclasses <- concat <$> mapM mkSelectorClassMember constructors
  48         pclasses <- mapM mkPredicateClassMember constructors
  49         pure $ ClassD [] (className typename) [PlainTV view] [] (cclasses ++ sclasses ++ pclasses)
  50       where
  51         view = mkName "m"
  52
  53         mkConstructorClassMember :: Con -> DecQ
  54         mkConstructorClassMember (NormalC consname fs)
  55             = mkConstructorClassMemberForName consname [t | (_, t)<-fs]
  56         mkConstructorClassMember (RecC consname fs)
  57             = mkConstructorClassMemberForName consname [t | (_, _, t)<-fs]
  58         mkConstructorClassMember t
  59             = fail $ "mkConsClass not supported for types such as: " ++ show t
  60
  61         mkConstructorClassMemberForName :: Name -> [Type] -> DecQ
  62         mkConstructorClassMemberForName consName fs
  63             = pure $ SigD (constructorName consName)
  64                 $ foldr (AppT . AppT ArrowT) resultT
  65                 $ map (AppT $ VarT view) fs
  66
  67         mkSelectorClassMember :: Con -> DecsQ
  68         mkSelectorClassMember (NormalC consName fs)
  69             = mapM (uncurry mkSelectorClassMemberForField)
  70             $ zipWith (\(_, t) i->(mkName $ map toLower (stringName consName) ++ "f" ++ show i, t)) fs [0 :: Int ..]
  71         mkSelectorClassMember (RecC consName fs)
  72             = (++) <$> mapM (uncurry mkSelectorClassMemberForField) [(n, t)|(n, _, t)<-fs]
  73                 <*> mapM (uncurry mkSelectorClassMemberForField)
  74                     (zipWith (\(_, _, t) i->(mkName $ map toLower (stringName consName) ++ "f" ++ show i, t)) fs [0 :: Int ..])
  75
  76         mkSelectorClassMember t
  77             = fail $ "mkConsClass not supported for types such as: " ++ show t
  78
  79         mkSelectorClassMemberForField :: Name -> Type -> DecQ
  80         mkSelectorClassMemberForField n t = pure
  81             $ SigD (className n)
  82             $ ForallT [] [ConT (mkName "Serialise") `AppT` VarT (getNameTyVarBndr ty) | ty <- tyvars]
  83             $ ArrowT `AppT` resultT `AppT` (VarT view `AppT` t)
  84
  85         mkPredicateClassMember :: Con -> DecQ
  86         mkPredicateClassMember (NormalC consName _)
  87             = mkPredicateClassMemberForName consName
  88         mkPredicateClassMember (RecC consName _)
  89             = mkPredicateClassMemberForName consName
  90         mkPredicateClassMember t
  91             = fail $ "mkConsClass not supported for types such as: " ++ show t
  92
  93         mkPredicateClassMemberForName :: Name -> DecQ
  94         mkPredicateClassMemberForName n = pure
  95             $ SigD (mkName $ "is" ++ stringName n)
  96             $ ForallT [] [ConT (mkName "Serialise") `AppT` VarT (getNameTyVarBndr ty) | ty <- tyvars]
  97             $ ArrowT `AppT` resultT `AppT` (VarT view `AppT` ConT (mkName "Bool"))
  98
  99         resultT = VarT view `AppT` (foldl AppT (ConT typename) $ map (VarT . getNameTyVarBndr) $ tyvars)
 100
 101     mkPrinterInstances :: [Con] -> DecQ
 102     mkPrinterInstances constructors
 103         =   InstanceD Nothing [] (AppT (ConT $ className typename) (ConT $ mkName "Printer")) . concat
 104         <$> ((:) <$> mapM mkPrinterPredicate constructors <*> mapM mkPrinterInstance constructors)
 105       where
 106         mkPrinterInstance :: Con -> DecsQ
 107         mkPrinterInstance (NormalC consName fs)
 108             | null fs = pure [FunD (constructorName consName)
 109                     [Clause [] (NormalB $ VarE (mkName "printLit") `AppE` LitE (StringL $ stringName consName)) [] ]]
 110             | otherwise =
 111                 let args = map mkName $ numberedArgs fs
 112                 in (:) <$> pure (FunD (constructorName consName)
 113                     [Clause
 114                         (map VarP args)
 115                         (NormalB $
 116                             (AppE (VarE (mkName "printCons") `AppE` LitE (StringL $ stringName consName))
 117                                 (foldl (\x y->x `pc` pl " " `pc` y) (pl "") $ map VarE args)
 118                             )
 119                         )
 120                         []
 121                     ])
 122                 <*> mapM mkPrinterSelector
 123                     (zipWith (\_ i->map toLower (stringName consName) ++ "f" ++ show i) fs [0 :: Int ..])
 124         mkPrinterInstance (RecC consName fs)
 125             = let args = map mkName $ numberedArgs fs
 126             in (:) <$> pure (FunD (constructorName consName)
 127                 [Clause
 128                     (map VarP args)
 129                     (NormalB $
 130                         (AppE (VarE (mkName "printRec") `AppE` LitE (StringL $ stringName typename))
 131                             (foldl1 (\x y->x `pc` pl ", " `pc` y)
 132                                 $ zipWith (\x ((Name occ'' _), _, _)->pl (occString occ'') `pc` pl "=" `pc` VarE x) args fs)
 133                         )
 134                     )
 135                     []
 136                 ])
 137             <*> ((++)
 138                 <$> mapM mkPrinterSelector [occString occ | (Name occ _, _, _)<-fs]
 139                 <*> mapM mkPrinterSelector
 140                     (zipWith (\_ i->map toLower (stringName consName) ++ "f" ++ show i) fs [0 :: Int ..])
 141             )
 142         mkPrinterInstance t = fail $ "mkConsClass not supported for types such as: " ++ show t
 143
 144         mkPrinterSelector :: String -> Q Dec
 145         mkPrinterSelector n' = do
 146             body <- [|\d->d >> printLit $(pure $ LitE $ StringL ('.':n'))|]
 147             pure $ FunD (selectorName $ mkName n') [Clause [] (NormalB body) []]
 148
 149         mkPrinterPredicate :: Con -> Q Dec
 150         mkPrinterPredicate (NormalC consName _)
 151             = mkPrinterPredicateForName consName
 152         mkPrinterPredicate (RecC consName _)
 153             = mkPrinterPredicateForName consName
 154         mkPrinterPredicate t = fail $ "mkConsClass not supported for types such as: " ++ show t
 155
 156         mkPrinterPredicateForName :: Name -> Q Dec
 157         mkPrinterPredicateForName consName = do
 158             body <- [| \d->printLit $(pure $ LitE $ StringL $ "is" ++ stringName consName ++ " ") >>> d|]
 159             pure $ FunD (mkName $ "is" ++ stringName consName) [Clause [] (NormalB body) []]
 160
 161     mkCompilerInstances :: [Con] -> DecQ
 162     mkCompilerInstances constructors
 163         =   InstanceD Nothing [] (AppT (ConT $ className typename) (ConT $ mkName "Compiler")) . concat
 164         <$> ((:) <$> mapM (uncurry mkCompilerPredicate) (zip [0..] constructors) <*> mapM (uncurry mkCompilerInstance) (zip constructors [0..]))
 165       where
 166         mkCompilerInstance :: Con -> Int -> DecsQ
 167         mkCompilerInstance (NormalC consName fs) consnum = (:)
 168             <$> mkCompilerInstanceForName consName consnum (numberedArgs fs)
 169             <*> mapM (uncurry mkCompilerSelector) (zip [0..] [map toLower (stringName consName) ++ f | f<-numberedArgs fs])
 170         mkCompilerInstance (RecC consName fs) consnum = (:)
 171             <$> mkCompilerInstanceForName consName consnum [occString occ | (Name occ _, _, _) <- fs]
 172             <*> ((++)
 173                 <$> mapM (uncurry mkCompilerSelector) (zip [0..] [occString occ | (Name occ _, _, _) <- fs])
 174                 <*> mapM (uncurry mkCompilerSelector) (zip [0..] [map toLower (stringName consName) ++ f | f<-numberedArgs fs])
 175             )
 176         mkCompilerInstance t _ = fail $ "mkConsClass not supported for types such as: " ++ show t
 177
 178         mkCompilerInstanceForName :: Name -> Int -> [String] -> DecQ
 179         mkCompilerInstanceForName name consnum fs =
 180             let args = map mkName $ numberedArgs fs
 181             in do
 182                 body <- [|instr [Push $(pure $ LitE $ IntegerL $ toInteger $ consnum)] *> $(mkBody $ map VarE args) <* instr [Sth $ $(pure $ LitE $ IntegerL $ toInteger $ length fs) + 1] |]
 183                 pure $ FunD (constructorName name)
 184                     [Clause (map VarP args) (NormalB body) [] ]
 185           where
 186             mkBody :: [Exp] -> Q Exp
 187             mkBody [] = pure $ VarE (mkName "pure") `AppE` ConE name
 188             mkBody (a:as) = foldM (\x y->pure $ ifx "<*>" x y) (ifx "<$>" (ConE name) a) as
 189
 190         mkCompilerSelector :: Int -> String -> DecQ
 191         mkCompilerSelector idx n' = do
 192             body <- [|\d->d >> instr [Ldh $(pure $ LitE (IntegerL (toInteger idx)))] |]
 193             pure $ FunD (selectorName $ mkName n')
 194                 [Clause [] (NormalB body) [] ]
 195
 196         mkCompilerPredicate :: Int -> Con -> Q Dec
 197         mkCompilerPredicate idx (NormalC consName _)
 198             = mkCompilerPredicateForName idx consName
 199         mkCompilerPredicate idx (RecC consName _)
 200             = mkCompilerPredicateForName idx consName
 201         mkCompilerPredicate _ t = fail $ "mkConsClass not supported for types such as: " ++ show t
 202
 203         mkCompilerPredicateForName :: Int -> Name -> Q Dec
 204         mkCompilerPredicateForName i consName = do
 205             body <- [| \d->d >> instr [Ldh (-1), Push $(pure $ LitE $ IntegerL $ toInteger i), Eq] |]
 206             pure $ FunD (mkName $ "is" ++ stringName consName) [Clause [] (NormalB body) []]
 207
 208 instrE :: Exp -> Exp
 209 instrE e = VarE (mkName "instr") `AppE` ListE [e]
 210
 211 ifx :: String -> Exp -> Exp -> Exp
 212 ifx op a b = InfixE (Just a) (VarE $ mkName op) (Just b)
 213
 214 pc :: Exp -> Exp -> Exp
 215 pc l r = VarE (mkName ">>>") `AppE` l `AppE` r
 216
 217 pl :: String -> Exp
 218 pl s = VarE (mkName "printLit") `AppE` LitE (StringL s)
 219
 220 getNameTyVarBndr :: TyVarBndr -> Name
 221 getNameTyVarBndr (PlainTV name) = name
 222 getNameTyVarBndr (KindedTV name _) = name