datatype/Language/GenDSL.hs

   1 {-# LANGUAGE TemplateHaskell #-}
   2 {-# LANGUAGE ParallelListComp #-}
   3 module Language.GenDSL where
   4
   5 import Language.Haskell.TH.Syntax
   6 import Language.Haskell.TH
   7 import Data.Char
   8 import Control.Monad
   9
  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
  18
  19 numberedArgs :: [a] -> [Name]
  20 numberedArgs = zipWith (\i _->mkName $ "f" ++ show i) [0 :: Int ..]
  21
  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
  26
  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
  31
  32 mkConsClass :: Name -> DecsQ
  33 mkConsClass typename = reify typename >>= \info->case info of
  34     TyConI dec
  35         -> case dec of
  36         DataD _ _ tyvars _ constructors _
  37             -> sequence
  38                 [ mkConstructorClasses tyvars constructors
  39                 , mkPrinterInstances constructors
  40                 , mkCompilerInstances constructors
  41                 ]
  42         _
  43             -> fail "mkConsClass only supports data types"
  44     _
  45         -> fail "mkConsClass only supports types"
  46   where
  47     mkConstructorClasses :: [TyVarBndr] -> [Con] -> Q Dec
  48     mkConstructorClasses tyvars constructors
  49         =   ClassD [] (className typename) [PlainTV view] []
  50         <$> (genClassMembers <$> mapM getConsName constructors <*> mapM toNameType constructors)
  51       where
  52         genClassMembers consNames fieldTypes = mkPredicates $ mkSelectors $ mkConstructors
  53             where
  54                 mkConstructors = zipWith mkConstructorClassMember consNames fieldTypes
  55                 mkSelectors ds = foldl (foldr $ uncurry mkSelectorClassMember) ds fieldTypes
  56                 mkPredicates ds = foldr mkPredicateClassMember ds consNames
  57
  58         view = mkName "m"
  59
  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
  65
  66         mkSelectorClassMember :: Name -> Type -> [Dec] -> [Dec]
  67         mkSelectorClassMember n t = (:)
  68             $ SigD (className n)
  69             $ ArrowT `AppT` resultT `AppT` (VarT view `AppT` t)
  70
  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"))
  75
  76         resultT = VarT view `AppT` (foldl AppT (ConT typename) $ map (VarT . getNameTyVarBndr) $ tyvars)
  77
  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)
  82       where
  83         genInstances consNames fieldTypes = mkConstructors
  84           where
  85             mkConstructors = zipWith mkPrinterConstructor consNames fieldTypes
  86         --concat <$> ( (:) <$> mapM mkPrinterPredicate constructors <*> mapM mkPrinterInstance constructors)
  87
  88         mkPrinterConstructor :: Name -> [(Name, Type)] -> Dec
  89         mkPrinterConstructor consName fs
  90             = FunD (constructorName consName)
  91                 [Clause
  92                     (map VarP $ numberedArgs fs)
  93                     (NormalB $
  94                         (AppE (VarE (mkName "printCons") `AppE` LitE (StringL $ stringName consName))
  95                             (foldl (\x y->x `pc` pl " " `pc` y) (pl "") $ map VarE $ numberedArgs fs)
  96                         )
  97                     )
  98                     []
  99                 ]
 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
 105
 106
 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)) [] ]]
 111 --            | otherwise =
 112 --                let args = map mkName $ numberedArgs fs
 113 --                in (:) <$> pure (FunD (constructorName consName)
 114 --                    [Clause
 115 --                        (map VarP args)
 116 --                        (NormalB $
 117 --                            (AppE (VarE (mkName "printCons") `AppE` LitE (StringL $ stringName consName))
 118 --                                (foldl (\x y->x `pc` pl " " `pc` y) (pl "") $ map VarE args)
 119 --                            )
 120 --                        )
 121 --                        []
 122 --                    ])
 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)
 128 --                [Clause
 129 --                    (map VarP args)
 130 --                    (NormalB $
 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)
 134 --                        )
 135 --                    )
 136 --                    []
 137 --                ])
 138 --            <*> ((++)
 139 --                <$> mapM mkPrinterSelector [occString occ | (Name occ _, _, _)<-fs]
 140 --                <*> mapM mkPrinterSelector
 141 --                    (zipWith (\_ i->map toLower (stringName consName) ++ "f" ++ show i) fs [0 :: Int ..])
 142 --            )
 143 --        mkPrinterInstance t = fail $ "mkConsClass not supported for types such as: " ++ show t
 144 --
 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) []]
 149 --
 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
 156 --
 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) []]
 161
 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..]))
 166 --      where
 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]
 173 --            <*> ((++)
 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])
 176 --            )
 177 --        mkCompilerInstance t _ = fail $ "mkConsClass not supported for types such as: " ++ show t
 178 --
 179 --        mkCompilerInstanceForName :: Name -> Int -> [String] -> DecQ
 180 --        mkCompilerInstanceForName name consnum fs =
 181 --            let args = map mkName $ numberedArgs fs
 182 --            in do
 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) [] ]
 186 --          where
 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
 190 --
 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) [] ]
 196 --
 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
 203 --
 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) []]
 208
 209 instrE :: Exp -> Exp
 210 instrE e = VarE (mkName "instr") `AppE` ListE [e]
 211
 212 ifx :: String -> Exp -> Exp -> Exp
 213 ifx op a b = InfixE (Just a) (VarE $ mkName op) (Just b)
 214
 215 pc :: Exp -> Exp -> Exp
 216 pc l r = VarE (mkName ">>>") `AppE` l `AppE` r
 217
 218 pl :: String -> Exp
 219 pl s = VarE (mkName "printLit") `AppE` LitE (StringL s)
 220
 221 getNameTyVarBndr :: TyVarBndr -> Name
 222 getNameTyVarBndr (PlainTV name) = name
 223 getNameTyVarBndr (KindedTV name _) = name