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 _ fs)
  72             = mapM (uncurry mkSelectorClassMemberForField) [(n, t)|(n, _, t)<-fs]
  73         mkSelectorClassMember t
  74             = fail $ "mkConsClass not supported for types such as: " ++ show t
  75
  76         mkSelectorClassMemberForField :: Name -> Type -> DecQ
  77         mkSelectorClassMemberForField n t = pure
  78             $ SigD (className n)
  79             $ ForallT [] [ConT (mkName "Serialise") `AppT` VarT (getNameTyVarBndr ty) | ty <- tyvars]
  80             $ ArrowT `AppT` resultT `AppT` (VarT view `AppT` t)
  81
  82         mkPredicateClassMember :: Con -> DecQ
  83         mkPredicateClassMember (NormalC consName _)
  84             = mkPredicateClassMemberForName consName
  85         mkPredicateClassMember (RecC consName _)
  86             = mkPredicateClassMemberForName consName
  87         mkPredicateClassMember t
  88             = fail $ "mkConsClass not supported for types such as: " ++ show t
  89
  90         mkPredicateClassMemberForName :: Name -> DecQ
  91         mkPredicateClassMemberForName n = pure
  92             $ SigD (mkName $ "is" ++ stringName n)
  93             $ ForallT [] [ConT (mkName "Serialise") `AppT` VarT (getNameTyVarBndr ty) | ty <- tyvars]
  94             $ ArrowT `AppT` resultT `AppT` (VarT view `AppT` ConT (mkName "Bool"))
  95
  96         resultT = VarT view `AppT` (foldl AppT (ConT typename) $ map (VarT . getNameTyVarBndr) $ tyvars)
  97
  98     mkPrinterInstances :: [Con] -> DecQ
  99     mkPrinterInstances constructors
 100         =   InstanceD Nothing [] (AppT (ConT $ className typename) (ConT $ mkName "Printer")) . concat
 101         <$> ((:) <$> mapM mkPrinterPredicate constructors <*> mapM mkPrinterInstance constructors)
 102       where
 103         mkPrinterInstance :: Con -> DecsQ
 104         mkPrinterInstance (NormalC consName fs)
 105             | null fs = pure [FunD (constructorName consName)
 106                     [Clause [] (NormalB $ VarE (mkName "printLit") `AppE` LitE (StringL $ stringName consName)) [] ]]
 107             | otherwise =
 108                 let args = map mkName $ numberedArgs fs
 109                 in (:) <$> pure (FunD (constructorName consName)
 110                     [Clause
 111                         (map VarP args)
 112                         (NormalB $
 113                             (AppE (VarE (mkName "printCons") `AppE` LitE (StringL $ stringName consName))
 114                                 (foldl (\x y->x `pc` pl " " `pc` y) (pl "") $ map VarE args)
 115                             )
 116                         )
 117                         []
 118                     ])
 119                 <*> mapM mkPrinterSelector
 120                     (zipWith (\_ i->map toLower (stringName consName) ++ "f" ++ show i) fs [0 :: Int ..])
 121         mkPrinterInstance (RecC name fs)
 122             = let args = map mkName $ numberedArgs fs
 123             in (:) <$> pure (FunD (constructorName name)
 124                 [Clause
 125                     (map VarP args)
 126                     (NormalB $
 127                         (AppE (VarE (mkName "printRec") `AppE` LitE (StringL $ stringName typename))
 128                             (foldl1 (\x y->x `pc` pl ", " `pc` y)
 129                                 $ zipWith (\x ((Name occ'' _), _, _)->pl (occString occ'') `pc` pl "=" `pc` VarE x) args fs)
 130                         )
 131                     )
 132                     []
 133                 ])
 134             <*> mapM mkPrinterSelector [occString occ | (Name occ _, _, _)<-fs]
 135         mkPrinterInstance t = fail $ "mkConsClass not supported for types such as: " ++ show t
 136
 137         mkPrinterSelector :: String -> Q Dec
 138         mkPrinterSelector n' = do
 139             body <- [|\d->d >> printLit $(pure $ LitE $ StringL ('.':n'))|]
 140             pure $ FunD (selectorName $ mkName n') [Clause [] (NormalB body) []]
 141
 142         mkPrinterPredicate :: Con -> Q Dec
 143         mkPrinterPredicate (NormalC consName _)
 144             = mkPrinterPredicateForName consName
 145         mkPrinterPredicate (RecC consName _)
 146             = mkPrinterPredicateForName consName
 147         mkPrinterPredicate t = fail $ "mkConsClass not supported for types such as: " ++ show t
 148
 149         mkPrinterPredicateForName :: Name -> Q Dec
 150         mkPrinterPredicateForName consName = do
 151             body <- [| \d->printLit $(pure $ LitE $ StringL $ "is" ++ stringName consName ++ " ") >>> d|]
 152             pure $ FunD (mkName $ "is" ++ stringName consName) [Clause [] (NormalB body) []]
 153
 154     mkCompilerInstances :: [Con] -> DecQ
 155     mkCompilerInstances constructors
 156         =   InstanceD Nothing [] (AppT (ConT $ className typename) (ConT $ mkName "Compiler")) . concat
 157         <$> ((:) <$> mapM (uncurry mkCompilerPredicate) (zip [0..] constructors) <*> mapM (uncurry mkCompilerInstance) (zip constructors [0..]))
 158       where
 159         mkCompilerInstance :: Con -> Int -> DecsQ
 160         mkCompilerInstance (NormalC consName fs) consnum = (:)
 161             <$> mkCompilerInstanceForName consName consnum (numberedArgs fs)
 162             <*> mapM (uncurry mkCompilerSelector) (zip [0..] [map toLower (stringName consName) ++ f | f<-numberedArgs fs])
 163         mkCompilerInstance (RecC consName fs) consnum = (:)
 164             <$> mkCompilerInstanceForName consName consnum [occString occ | (Name occ _, _, _) <- fs]
 165             <*> mapM (uncurry mkCompilerSelector) (zip [0..] [occString occ | (Name occ _, _, _) <- fs])
 166         mkCompilerInstance t _ = fail $ "mkConsClass not supported for types such as: " ++ show t
 167
 168         mkCompilerInstanceForName :: Name -> Int -> [String] -> DecQ
 169         mkCompilerInstanceForName name consnum fs =
 170             let args = map mkName $ numberedArgs fs
 171             in do
 172                 body <- [|instr [Push $(pure $ LitE $ IntegerL $ toInteger $ consnum)] *> $(mkBody $ map VarE args) <* instr [Sth $ $(pure $ LitE $ IntegerL $ toInteger $ length fs) + 1] |]
 173                 pure $ FunD (constructorName name)
 174                     [Clause (map VarP args) (NormalB body) [] ]
 175           where
 176             mkBody :: [Exp] -> Q Exp
 177             mkBody [] = pure $ VarE (mkName "pure") `AppE` ConE name
 178             mkBody (a:as) = foldM (\x y->pure $ ifx "<*>" x y) (ifx "<$>" (ConE name) a) as
 179
 180         mkCompilerSelector :: Int -> String -> DecQ
 181         mkCompilerSelector idx n' = do
 182             body <- [|\d->d >> instr [Ldh $(pure $ LitE (IntegerL (toInteger idx)))] |]
 183             pure $ FunD (selectorName $ mkName n')
 184                 [Clause [] (NormalB body) [] ]
 185
 186         mkCompilerPredicate :: Int -> Con -> Q Dec
 187         mkCompilerPredicate idx (NormalC consName _)
 188             = mkCompilerPredicateForName idx consName
 189         mkCompilerPredicate idx (RecC consName _)
 190             = mkCompilerPredicateForName idx consName
 191         mkCompilerPredicate _ t = fail $ "mkConsClass not supported for types such as: " ++ show t
 192
 193         mkCompilerPredicateForName :: Int -> Name -> Q Dec
 194         mkCompilerPredicateForName i consName = do
 195             body <- [| \d->d >> instr [Ldh (-1), Push $(pure $ LitE $ IntegerL $ toInteger i), Eq] |]
 196             pure $ FunD (mkName $ "is" ++ stringName consName) [Clause [] (NormalB body) []]
 197
 198 instrE :: Exp -> Exp
 199 instrE e = VarE (mkName "instr") `AppE` ListE [e]
 200
 201 ifx :: String -> Exp -> Exp -> Exp
 202 ifx op a b = InfixE (Just a) (VarE $ mkName op) (Just b)
 203
 204 pc :: Exp -> Exp -> Exp
 205 pc l r = VarE (mkName ">>>") `AppE` l `AppE` r
 206
 207 pl :: String -> Exp
 208 pl s = VarE (mkName "printLit") `AppE` LitE (StringL s)
 209
 210 getNameTyVarBndr :: TyVarBndr -> Name
 211 getNameTyVarBndr (PlainTV name) = name
 212 getNameTyVarBndr (KindedTV name _) = name