From a68927147bb9bec6937fba763049eabc84670651 Mon Sep 17 00:00:00 2001 From: Mart Lubbers Date: Tue, 31 Aug 2021 16:06:02 +0200 Subject: [PATCH] cleanup --- datatype/Language/GenDSL.hs | 301 ++++++++++++++++++------------------ 1 file changed, 151 insertions(+), 150 deletions(-) diff --git a/datatype/Language/GenDSL.hs b/datatype/Language/GenDSL.hs index 673827f..5209e7b 100644 --- a/datatype/Language/GenDSL.hs +++ b/datatype/Language/GenDSL.hs @@ -1,4 +1,5 @@ {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ParallelListComp #-} module Language.GenDSL where import Language.Haskell.TH.Syntax @@ -15,8 +16,18 @@ selectorName = mkName . map toLower . (++"'") . stringName stringName :: Name -> String stringName (Name occ _) = occString occ -numberedArgs :: [a] -> [String] -numberedArgs = zipWith (\i _->"f" ++ show i) [0 :: Int ..] +numberedArgs :: [a] -> [Name] +numberedArgs = zipWith (\i _->mkName $ "f" ++ show i) [0 :: Int ..] + +toNameType :: Con -> Q [(Name, Type)] +toNameType (NormalC consName fs) = pure [(mkName $ map toLower (stringName consName) ++ "f" ++ show i, t) | (_, t)<-fs | i <- [0 :: Int ..]] +toNameType (RecC consName fs) = pure [(n, t) | (n, _, t)<-fs] +toNameType c = fail $ "Unsupported constructor type: " ++ show c + +getConsName :: Con -> Q Name +getConsName (NormalC consName _) = pure consName +getConsName (RecC consName _) = pure consName +getConsName c = fail $ "Unsupported constructor type: " ++ show c mkConsClass :: Name -> DecsQ mkConsClass typename = reify typename >>= \info->case info of @@ -24,8 +35,7 @@ mkConsClass typename = reify typename >>= \info->case info of -> case dec of DataD _ _ tyvars _ constructors _ -> sequence - [ {-mkDerivation tyvars - ,-}mkConstructorClasses tyvars constructors + [ mkConstructorClasses tyvars constructors , mkPrinterInstances constructors , mkCompilerInstances constructors ] @@ -34,176 +44,167 @@ 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) --- [] - - mkConstructorClasses :: [TyVarBndr] -> [Con] -> DecQ - mkConstructorClasses tyvars constructors = do - cclasses <- mapM mkConstructorClassMember constructors - sclasses <- concat <$> mapM mkSelectorClassMember constructors - pclasses <- mapM mkPredicateClassMember constructors - pure $ ClassD [] (className typename) [PlainTV view] [] (cclasses ++ sclasses ++ pclasses) + mkConstructorClasses :: [TyVarBndr] -> [Con] -> Q Dec + mkConstructorClasses tyvars constructors + = ClassD [] (className typename) [PlainTV view] [] + <$> (genClassMembers <$> mapM getConsName constructors <*> mapM toNameType constructors) where + genClassMembers consNames fieldTypes = mkPredicates $ mkSelectors $ mkConstructors + where + mkConstructors = zipWith mkConstructorClassMember consNames fieldTypes + mkSelectors ds = foldl (foldr $ uncurry mkSelectorClassMember) ds fieldTypes + mkPredicates ds = foldr mkPredicateClassMember ds consNames + view = mkName "m" - mkConstructorClassMember :: Con -> DecQ - mkConstructorClassMember (NormalC consname fs) - = mkConstructorClassMemberForName consname [t | (_, t)<-fs] - mkConstructorClassMember (RecC consname fs) - = mkConstructorClassMemberForName consname [t | (_, _, t)<-fs] - mkConstructorClassMember t - = fail $ "mkConsClass not supported for types such as: " ++ show t - - mkConstructorClassMemberForName :: Name -> [Type] -> DecQ - mkConstructorClassMemberForName consName fs - = pure $ SigD (constructorName consName) + mkConstructorClassMember :: Name -> [(Name, Type)] -> Dec + mkConstructorClassMember consName fs + = SigD (constructorName consName) $ foldr (AppT . AppT ArrowT) resultT - $ map (AppT $ VarT view) fs - - mkSelectorClassMember :: Con -> DecsQ - mkSelectorClassMember (NormalC consName fs) - = mapM (uncurry mkSelectorClassMemberForField) - $ zipWith (\(_, t) i->(mkName $ map toLower (stringName consName) ++ "f" ++ show i, t)) fs [0 :: Int ..] - 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 - - mkSelectorClassMemberForField :: Name -> Type -> DecQ - mkSelectorClassMemberForField n t = pure + $ map ((AppT $ VarT view) . snd) fs + + mkSelectorClassMember :: Name -> Type -> [Dec] -> [Dec] + mkSelectorClassMember n t = (:) $ SigD (className n) - $ 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 + mkPredicateClassMember :: Name -> [Dec] -> [Dec] + mkPredicateClassMember n = (:) $ 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 :: [Con] -> DecQ mkPrinterInstances constructors - = InstanceD Nothing [] (AppT (ConT $ className typename) (ConT $ mkName "Printer")) . concat - <$> ((:) <$> mapM mkPrinterPredicate constructors <*> mapM mkPrinterInstance constructors) + = InstanceD Nothing [] (AppT (ConT $ className typename) (ConT $ mkName "Printer")) + <$> (genInstances <$> mapM getConsName constructors <*> mapM toNameType constructors) where - 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) + 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 args) + (map VarP $ numberedArgs fs) (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) + (AppE (VarE (mkName "printCons") `AppE` LitE (StringL $ stringName consName)) + (foldl (\x y->x `pc` pl " " `pc` y) (pl "") $ map VarE $ numberedArgs 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) []] + ] + --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 - <$> ((:) <$> 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) []] + <$> 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] -- 2.20.1