quasiquoting for patterns

[clean-tests.git] / datatype / Language / GenDSL.hs

diff --git a/datatype/MkCons.hs b/datatype/Language/GenDSL.hs
similarity index 65%
rename from datatype/MkCons.hs
rename to datatype/Language/GenDSL.hs
index 57b14c6..374469d 100644 (file)
--- a/datatype/MkCons.hs
+++ b/datatype/Language/GenDSL.hs
@@ -1,5 +1,5 @@
 {-# LANGUAGE TemplateHaskell #-}
-module MkCons where
+module Language.GenDSL where
 
 import Language.Haskell.TH.Syntax
 import Language.Haskell.TH
@@ -26,8 +26,8 @@ mkConsClass typename = reify typename >>= \info->case info of
             -> sequence 
                 [ mkDerivation tyvars
                 , mkConstructorClasses tyvars constructors
-                , mkPrinterInstances tyvars constructors
-                , mkCompilerInstances tyvars constructors
+                , mkPrinterInstances constructors
+                , mkCompilerInstances constructors
                 ]
         _
             -> fail "mkConsClass only supports data types"
@@ -45,7 +45,8 @@ mkConsClass typename = reify typename >>= \info->case info of
     mkConstructorClasses tyvars constructors = do
         cclasses <- mapM mkConstructorClassMember constructors
         sclasses <- concat <$> mapM mkSelectorClassMember constructors
-        pure $ ClassD [] (className typename) [PlainTV view] [] (cclasses ++ sclasses)
+        pclasses <- mapM mkPredicateClassMember constructors
+        pure $ ClassD [] (className typename) [PlainTV view] [] (cclasses ++ sclasses ++ pclasses)
       where
         view = mkName "m"
 
@@ -58,15 +59,15 @@ mkConsClass typename = reify typename >>= \info->case info of
             = fail $ "mkConsClass not supported for types such as: " ++ show t
 
         mkConstructorClassMemberForName :: Name -> [Type] -> DecQ
-        mkConstructorClassMemberForName consname fs
-            = pure $ SigD (constructorName consname)
+        mkConstructorClassMemberForName consName fs
+            = pure $ SigD (constructorName consName)
                 $ foldr (AppT . AppT ArrowT) resultT
                 $ map (AppT $ VarT view) fs
 
         mkSelectorClassMember :: Con -> DecsQ
-        mkSelectorClassMember (NormalC _ fs)
+        mkSelectorClassMember (NormalC consName fs)
             = mapM (uncurry mkSelectorClassMemberForField)
-            $ zipWith (\(_, t) i->(mkName $ map toLower (stringName typename) ++ "f" ++ show i, t)) fs [0 :: Int ..]
+            $ zipWith (\(_, t) i->(mkName $ map toLower (stringName consName) ++ "f" ++ show i, t)) fs [0 :: Int ..]
         mkSelectorClassMember (RecC _ fs)
             = mapM (uncurry mkSelectorClassMemberForField) [(n, t)|(n, _, t)<-fs]
         mkSelectorClassMember t
@@ -78,31 +79,45 @@ mkConsClass typename = reify typename >>= \info->case info of
             $ 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
+            $ 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 :: [TyVarBndr] -> [Con] -> DecQ
-    mkPrinterInstances _ constructors
+    mkPrinterInstances :: [Con] -> DecQ
+    mkPrinterInstances constructors
         =   InstanceD Nothing [] (AppT (ConT $ className typename) (ConT $ mkName "Printer")) . concat
-        <$> mapM mkPrinterInstance constructors
+        <$> ((:) <$> mapM mkPrinterPredicate constructors <*> mapM mkPrinterInstance constructors)
       where
         mkPrinterInstance :: Con -> DecsQ
-        mkPrinterInstance (NormalC name fs)
-            | null fs = pure [FunD (constructorName name)
-                    [Clause [] (NormalB $ VarE (mkName "printLit") `AppE` LitE (StringL $ stringName name)) [] ]]
+        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 name)
+                in (:) <$> pure (FunD (constructorName consName)
                     [Clause
                         (map VarP args)
                         (NormalB $
-                            (AppE (VarE (mkName "printCons") `AppE` LitE (StringL $ stringName name))
+                            (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 typename) ++ "f" ++ show i) fs [0 :: Int ..])
+                    (zipWith (\_ i->map toLower (stringName consName) ++ "f" ++ show i) fs [0 :: Int ..])
         mkPrinterInstance (RecC name fs)
             = let args = map mkName $ numberedArgs fs
             in (:) <$> pure (FunD (constructorName name)
@@ -124,17 +139,29 @@ mkConsClass typename = reify typename >>= \info->case info of
             body <- [|\d->d >> printLit $(pure $ LitE $ StringL ('.':n'))|]
             pure $ FunD (selectorName $ mkName n') [Clause [] (NormalB body) []]
 
-    mkCompilerInstances :: [TyVarBndr] -> [Con] -> DecQ
-    mkCompilerInstances _ constructors
+        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 mkCompilerInstance) (zip constructors [0..])
+        <$> ((:) <$> mapM (uncurry mkCompilerPredicate) (zip [0..] constructors) <*> mapM (uncurry mkCompilerInstance) (zip constructors [0..]))
       where
         mkCompilerInstance :: Con -> Int -> DecsQ
-        mkCompilerInstance (NormalC name fs) consnum = (:)
-            <$> mkCompilerInstanceForName name consnum (numberedArgs fs)
-            <*> mapM (uncurry mkCompilerSelector) (zip [0..] [map toLower (stringName typename) ++ f | f<-numberedArgs fs])
-        mkCompilerInstance (RecC name fs) consnum = (:)
-            <$> mkCompilerInstanceForName name consnum [occString occ | (Name occ _, _, _) <- fs]
+        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])
         mkCompilerInstance t _ = fail $ "mkConsClass not supported for types such as: " ++ show t
 
@@ -156,6 +183,18 @@ mkConsClass typename = reify typename >>= \info->case info of
             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]