- genInstances consNames fieldTypes = mkConstructors
- where
- mkConstructors = zipWith mkPrinterConstructor consNames fieldTypes
- --concat <$> ( (:) <$> mapM mkPrinterPredicate constructors <*> mapM mkPrinterInstance constructors)
-
- mkPrinterConstructor :: Name -> [(Name, Type)] -> Dec
- mkPrinterConstructor consName fs
- = FunD (constructorName consName)
- [Clause
- (map VarP $ numberedArgs fs)
- (NormalB $
- (AppE (VarE (mkName "printCons") `AppE` LitE (StringL $ stringName consName))
- (foldl (\x y->x `pc` pl " " `pc` y) (pl "") $ map VarE $ numberedArgs fs)
- )
- )
- []
- ]
- --mkConstructorClassMember :: Name -> [(Name, Type)] -> Dec
- --mkConstructorClassMember consName fs
- -- = SigD (constructorName consName)
- -- $ foldr (AppT . AppT ArrowT) resultT
- -- $ map ((AppT $ VarT view) . snd) fs
-
-
--- mkPrinterInstance :: Con -> DecsQ
--- 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 consName)
--- [Clause
--- (map VarP args)
--- (NormalB $
--- (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 consName) ++ "f" ++ show i) fs [0 :: Int ..])
--- mkPrinterInstance (RecC consName fs)
--- = let args = map mkName $ numberedArgs fs
--- in (:) <$> pure (FunD (constructorName consName)
--- [Clause
--- (map VarP args)
--- (NormalB $
--- (AppE (VarE (mkName "printRec") `AppE` LitE (StringL $ stringName typename))
--- (foldl1 (\x y->x `pc` pl ", " `pc` y)
--- $ zipWith (\x ((Name occ'' _), _, _)->pl (occString occ'') `pc` pl "=" `pc` VarE x) args 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
--- mkPrinterSelector n' = do
--- body <- [|\d->d >> printLit $(pure $ LitE $ StringL ('.':n'))|]
--- pure $ FunD (selectorName $ mkName n') [Clause [] (NormalB body) []]
---
--- 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
- <$> pure []--((:) <$> mapM (uncurry mkCompilerPredicate) (zip [0..] constructors) <*> mapM (uncurry mkCompilerInstance) (zip constructors [0..]))
--- where
--- mkCompilerInstance :: Con -> Int -> DecsQ
--- 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])
--- <*> 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
--- mkCompilerInstanceForName name consnum fs =
--- let args = map mkName $ numberedArgs fs
--- in do
--- body <- [|instr [Push $(pure $ LitE $ IntegerL $ toInteger $ consnum)] *> $(mkBody $ map VarE args) <* instr [Sth $ $(pure $ LitE $ IntegerL $ toInteger $ length fs) + 1] |]
--- pure $ FunD (constructorName name)
--- [Clause (map VarP args) (NormalB body) [] ]
--- where
--- mkBody :: [Exp] -> Q Exp
--- mkBody [] = pure $ VarE (mkName "pure") `AppE` ConE name
--- mkBody (a:as) = foldM (\x y->pure $ ifx "<*>" x y) (ifx "<$>" (ConE name) a) as
---
--- mkCompilerSelector :: Int -> String -> DecQ
--- mkCompilerSelector idx n' = do
--- body <- [|\d->d >> instr [Ldh $(pure $ LitE (IntegerL (toInteger idx)))] |]
--- 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]