support all other patterns and nested patterns

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

diff --git a/datatype/Language/GenDSL.hs b/datatype/Language/GenDSL.hs
index 374469d..673827f 100644 (file)
--- a/datatype/Language/GenDSL.hs
+++ b/datatype/Language/GenDSL.hs
@@ -24,8 +24,8 @@ mkConsClass typename = reify typename >>= \info->case info of
         -> case dec of
         DataD _ _ tyvars _ constructors _
             -> sequence 
-                [ mkDerivation tyvars
-                , mkConstructorClasses tyvars constructors
+                [ {-mkDerivation tyvars
+                ,-}mkConstructorClasses tyvars constructors
                 , mkPrinterInstances constructors
                 , mkCompilerInstances constructors
                 ]
@@ -34,12 +34,12 @@ mkConsClass typename = reify typename >>= \info->case info of
     _
         -> fail "mkConsClass only supports types"
   where
-    mkDerivation :: [TyVarBndr] -> DecQ
-    mkDerivation tyvars = let names = (map (VarT . getNameTyVarBndr) tyvars) in pure $
-        InstanceD Nothing
-            [ConT (mkName "Serialise") `AppT` t | t <- names]
-            (ConT (mkName "Serialise") `AppT` foldl AppT (ConT typename) names)
-            []
+--    mkDerivation :: [TyVarBndr] -> DecQ
+--    mkDerivation tyvars = let names = (map (VarT . getNameTyVarBndr) tyvars) in pure $
+--        InstanceD Nothing
+--            [ConT (mkName "Serialise") `AppT` t | t <- names]
+--            (ConT (mkName "Serialise") `AppT` foldl AppT (ConT typename) names)
+--            []
 
     mkConstructorClasses :: [TyVarBndr] -> [Con] -> DecQ
     mkConstructorClasses tyvars constructors = do
@@ -68,8 +68,11 @@ mkConsClass typename = reify typename >>= \info->case info of
         mkSelectorClassMember (NormalC consName fs)
             = mapM (uncurry mkSelectorClassMemberForField)
             $ 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 (RecC consName fs)
+            = (++) <$> mapM (uncurry mkSelectorClassMemberForField) [(n, t)|(n, _, t)<-fs]
+                <*> mapM (uncurry mkSelectorClassMemberForField) 
+                    (zipWith (\(_, _, t) i->(mkName $ map toLower (stringName consName) ++ "f" ++ show i, t)) fs [0 :: Int ..])
+
         mkSelectorClassMember t
             = fail $ "mkConsClass not supported for types such as: " ++ show t
 
@@ -118,9 +121,9 @@ mkConsClass typename = reify typename >>= \info->case info of
                     ])
                 <*> mapM mkPrinterSelector
                     (zipWith (\_ i->map toLower (stringName consName) ++ "f" ++ show i) fs [0 :: Int ..])
-        mkPrinterInstance (RecC name fs)
+        mkPrinterInstance (RecC consName fs)
             = let args = map mkName $ numberedArgs fs
-            in (:) <$> pure (FunD (constructorName name)
+            in (:) <$> pure (FunD (constructorName consName)
                 [Clause
                     (map VarP args)
                     (NormalB $
@@ -131,7 +134,11 @@ mkConsClass typename = reify typename >>= \info->case info of
                     )
                     []
                 ])
-            <*> mapM mkPrinterSelector [occString occ | (Name occ _, _, _)<-fs]
+            <*> ((++)
+                <$> mapM mkPrinterSelector [occString occ | (Name occ _, _, _)<-fs]
+                <*> mapM mkPrinterSelector
+                    (zipWith (\_ i->map toLower (stringName consName) ++ "f" ++ show i) fs [0 :: Int ..])
+            )
         mkPrinterInstance t = fail $ "mkConsClass not supported for types such as: " ++ show t
 
         mkPrinterSelector :: String -> Q Dec
@@ -162,7 +169,10 @@ mkConsClass typename = reify typename >>= \info->case info of
             <*> 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])
+            <*> ((++)
+                <$> mapM (uncurry mkCompilerSelector) (zip [0..] [occString occ | (Name occ _, _, _) <- fs])
+                <*> mapM (uncurry mkCompilerSelector) (zip [0..] [map toLower (stringName consName) ++ f | f<-numberedArgs fs])
+            )
         mkCompilerInstance t _ = fail $ "mkConsClass not supported for types such as: " ++ show t
 
         mkCompilerInstanceForName :: Name -> Int -> [String] -> DecQ