From: Mart Lubbers Date: Mon, 13 Sep 2021 15:12:12 +0000 (+0200) Subject: . X-Git-Url: https://git.martlubbers.net/?a=commitdiff_plain;ds=inline;p=clean-tests.git . --- diff --git a/datatype/Language/GenDSL.hs b/datatype/Language/GenDSL.hs index a6e0d35..37643bb 100644 --- a/datatype/Language/GenDSL.hs +++ b/datatype/Language/GenDSL.hs @@ -1,21 +1,25 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE ParallelListComp #-} +{-# LANGUAGE KindSignatures #-} module Language.GenDSL where import Language.Haskell.TH.Syntax import Language.Haskell.TH import Data.Char +import qualified Data.Set as DS import Control.Monad +import Debug.Trace import Printer import Compiler import Interpreter className,constructorName,selectorName,predicateName :: Name -> Name -className = mkName . (++"'") . stringName -constructorName = mkName . map toLower . stringName -selectorName = mkName . map toLower . (++"'") . stringName +className = mkName . (++"DSL") . stringName +constructorName = mkName . (\(c:cs)->toLower c:cs) . stringName +selectorName = mkName . ("get"++) . stringName predicateName = mkName . ("is"++) . stringName +setterName = mkName . ("set"++) . stringName stringName :: Name -> String stringName (Name occ _) = occString occ @@ -23,13 +27,6 @@ stringName (Name occ _) = occString occ adtFieldName :: Name -> Integer -> Name adtFieldName consName idx = mkName $ map toLower (stringName consName) ++ "f" ++ show idx -getConsName :: Con -> Q (Name, [(Name, TypeQ)]) -getConsName (NormalC consName fs) - | head (stringName consName) == ':' = fail "Infix constructors are not supported" - | otherwise = pure (consName, [(adtFieldName consName i, pure t)|(_, t)<-fs | i<-[0..]]) -getConsName (RecC consName fs) = pure (consName, [(n, pure t) | (n, _, t)<-fs]) -getConsName c = fail $ "Unsupported constructor type: " ++ show c - ifx :: String -> ExpQ -> ExpQ -> ExpQ ifx op a b = infixE (Just a) (varE $ mkName op) (Just b) @@ -38,51 +35,82 @@ fun name args body = funD name [clause args (normalB body) []] class GenDSL a where genDSL :: a -> DecsQ instance GenDSL a => GenDSL [a] where genDSL = fmap concat . mapM genDSL +instance GenDSL Dec where + genDSL (DataD _ typeName tyVars _ constructors _) + = mapM getConsName constructors >>= mkDSL typeName . concat + where + getConsName :: Con -> Q [(Name, [(Name, Type)], Type)] + getConsName (RecGadtC consNames fs ty) + = pure [(consName, [(n, t) | (n, _, t)<-fs], ty) | consName<-consNames] + --Invent names for non record types + getConsName (GadtC consNames fs ty) + | all (not . (':'==) . head . stringName) consNames + = concat <$> mapM getConsName [RecGadtC [consName] [(adtFieldName consName i, b, t) | (b, t)<-fs | i<-[0..]] ty | consName <- consNames] + getConsName (NormalC consName fs) = getConsName $ RecC consName [(adtFieldName consName i, b, t) | (b, t)<-fs | i<-[0..]] + getConsName (RecC consName fs) = getConsName $ RecGadtC [consName] fs + $ foldl AppT (ConT typeName) $ map getName tyVars + where getName (PlainTV name) = VarT name + getName (KindedTV name _) = VarT name + getConsName (ForallC _ [] ty) = getConsName ty + getConsName c = fail $ "Unsupported constructor type: " ++ show c + genDSL (NewtypeD cxt name tvs mk con ds) = genDSL (DataD cxt name tvs mk [con] ds) + genDSL t = fail $ "mkConsClass only supports simple datatypes and not on: " ++ show t instance GenDSL Name where - genDSL typename = reify typename >>= \info->case info of - TyConI (DataD _ _ tyvars _ constructors _) - -> mapM getConsName constructors >>= mkDSL typename tyvars - t - -> fail $ "mkConsClass only supports simple datatypes and not: " ++ show t - -mkDSL :: Name -> [TyVarBndr] -> [(Name, [(Name, TypeQ)])] -> DecsQ -mkDSL typeName typeVars constructors = sequence [ mkClass, mkPrinter, mkCompiler, mkInterpreter ] + genDSL typeName = reify typeName >>= \info->case info of + TyConI dec -> genDSL dec + DataConI _ _ parent -> genDSL parent + t -> fail $ "mkConsClass only works on types and not on: " ++ show t + +uncurry3 f (x, y, z) = f x y z + +posSelector :: Type -> Type -> Bool +posSelector field res = vars field DS.empty `DS.isSubsetOf` vars res DS.empty where - (consNames, fields) = unzip constructors + vars :: Type -> DS.Set String -> DS.Set String + vars (AppT l r) = vars l . vars r + vars (VarT n) = DS.insert (stringName n) + vars (InfixT l _ r) = vars l . vars r + vars (UInfixT l _ r) = vars l . vars r + vars (ParensT t) = vars t + vars (ImplicitParamT _ t) = vars t + vars _ = id + +mkDSL :: Name -> [(Name, [(Name, Type)], Type)] -> DecsQ +mkDSL typeName constructors = sequence [ mkClass, mkPrinter, mkCompiler, mkInterpreter ] + where + (consNames, fields, types) = unzip3 constructors + selectors = [(n, [f | f@(_, ft)<-fs, posSelector ft ty], ty) | (n, fs, ty)<-constructors] + (_, sfields, stypes) = unzip3 selectors mkClass :: DecQ mkClass = classD (pure []) (className typeName) [PlainTV (mkName "v")] [] - ( map (uncurry mkConstructor) constructors - ++ concatMap (map mkSelector) fields - ++ map mkPredicate consNames + ( map (uncurry3 mkConstructor) constructors + ++ concat (zipWith (\ct fs->map (uncurry $ mkSelector ct) fs) types sfields) + ++ zipWith mkPredicate types consNames ) where v = varT $ mkName "v" - arrow x y = [t|$x-> $y|] - mkConstructor :: Name -> [(Name, TypeQ)] -> DecQ - mkConstructor n fs = sigD (constructorName n) $ foldr arrow resultT $ map (appT v . snd) fs + mkConstructor :: Name -> [(Name, Type)] -> Type -> DecQ + mkConstructor n fs res = sigD (constructorName n) + $ foldr (\x y->[t|$x -> $y|]) [t|$v $(pure res)|] + $ map (appT v . pure .snd) fs - mkSelector :: (Name, TypeQ) -> DecQ - mkSelector (n, t) = sigD (selectorName n) [t|$resultT -> $v $t|] - - mkPredicate :: Name -> DecQ - mkPredicate n = sigD (predicateName n) [t|$resultT -> $v Bool|] + mkSelector :: Type -> Name -> Type -> DecQ + mkSelector res n t = sigD (selectorName n) [t|$v $(pure res) -> $v $(pure t)|] - resultT :: TypeQ - resultT = appT v $ foldl appT (conT typeName) $ map (varT . getName) $ typeVars - where getName (PlainTV name) = name - getName (KindedTV name _) = name + mkPredicate :: Type -> Name -> DecQ + mkPredicate res n = sigD (predicateName n) [t|$v $(pure res) -> $v Bool|] mkPrinter :: DecQ mkPrinter = instanceD (pure []) [t|$(conT $ className typeName) Printer|] - $ map (uncurry mkConstructor) constructors - ++ concatMap (map (mkSelector . fst)) fields + $ zipWith mkConstructor consNames fields + ++ concatMap (map (mkSelector . fst)) sfields ++ map mkPredicate consNames where pl s = [|printLit $(lift s)|] - mkConstructor :: Name -> [(Name, TypeQ)] -> DecQ + mkConstructor :: Name -> [(Name, Type)] -> DecQ mkConstructor consName fs = do fresh <- sequence [newName "f" | _<- fs] fun (constructorName consName) (map varP fresh) (pcons `appE` pargs fresh) @@ -98,11 +126,11 @@ mkDSL typeName typeVars constructors = sequence [ mkClass, mkPrinter, mkCompiler mkCompiler :: DecQ mkCompiler = instanceD (pure []) [t|$(conT $ className typeName) Compiler|] - $ zipWith (uncurry . mkConstructor) [0..] constructors - ++ concatMap (zipWith mkSelector [0..] . map fst) fields + $ zipWith3 mkConstructor [0..] consNames fields + ++ concatMap (zipWith mkSelector [0..]. map fst) sfields ++ zipWith mkPredicate [0..] consNames where - mkConstructor :: Integer -> Name -> [(Name, TypeQ)] -> DecQ + mkConstructor :: Integer -> Name -> [(Name, Type)] -> DecQ mkConstructor consNum consName fs = do fresh <- sequence [newName "f" | _<-fs] fun (constructorName consName) (map varP fresh) @@ -120,11 +148,11 @@ mkDSL typeName typeVars constructors = sequence [ mkClass, mkPrinter, mkCompiler mkInterpreter :: DecQ mkInterpreter = instanceD (pure []) [t|$(conT $ className typeName) Interpreter|] - $ map (uncurry mkConstructor) constructors - ++ concatMap (\(cn, fs)->zipWith (mkSelector cn (length fs)) [0..] (map fst fs)) constructors - ++ map (uncurry mkPredicate) constructors + $ zipWith mkConstructor consNames fields + ++ concatMap (\(cn, fs, _)->zipWith (mkSelector cn (length fs)) [0..] (map fst fs)) selectors + ++ zipWith mkPredicate consNames fields where - mkConstructor :: Name -> [(Name, TypeQ)] -> DecQ + mkConstructor :: Name -> [(Name, Type)] -> DecQ mkConstructor consName fs = do fresh <- sequence [newName "f" | _<-fs] fun (constructorName consName) (map varP fresh) @@ -143,7 +171,7 @@ mkDSL typeName typeVars constructors = sequence [ mkClass, mkPrinter, mkCompiler wilds = if length consNames == 1 then [] else [match wildP (normalB [|fail "Exhausted case"|]) []] - mkPredicate :: Name -> [(Name, TypeQ)] -> DecQ + mkPredicate :: Name -> [(Name, Type)] -> DecQ mkPredicate n fs = fun (predicateName n) [] $ if length consNames == 1 then [|\_->true|] else [|\x->x >>= \p->case p of $(conP n [wildP | _<-fs]) -> true; _ -> false|] diff --git a/datatype/Main.hs b/datatype/Main.hs index e794d9b..bc53f7b 100644 --- a/datatype/Main.hs +++ b/datatype/Main.hs @@ -47,19 +47,19 @@ main e0 :: Expression v => v Int e0 = lit 2 -. lit 8 -e1 :: (Expression v, Tuple' v) => v (Tuple Char Int) +e1 :: (Expression v, TupleDSL v) => v (Tuple Char Int) e1 = tuple (lit 'c') (lit 42) -e1' :: (Expression v, Tuple' v) => v Char +e1' :: (Expression v, TupleDSL v) => v Char e1' = tuplef0' e1 -e1'' :: (Expression v, Tuple' v) => v Int +e1'' :: (Expression v, TupleDSL v) => v Int e1'' = tuplef1' e1 -e2 :: (Expression v, TupleR' v) => v (TupleR Char Bool) +e2 :: (Expression v, TupleRDSL v) => v (TupleR Char Bool) e2 = tupler (lit 'c') (lit True) -e3 :: (Expression v, Tuple' v, TupleR' v) => v (TupleR Char (Tuple Int Bool)) +e3 :: (Expression v, TupleDSL v, TupleRDSL v) => v (TupleR Char (Tuple Int Bool)) e3 = tupler (lit 'c') (tuple (lit 42) (lit True)) f0 :: (Expression v, Function () v) => Main (v Int) @@ -81,7 +81,7 @@ f2 :- Main {unmain=sub (lit 2, lit 8)} ) -f3 :: (Expression v, Tuple' v, Function (v Int) v) => Main (v (Tuple Int Int)) +f3 :: (Expression v, TupleDSL v, Function (v Int) v) => Main (v (Tuple Int Int)) f3 = fun ( \idfun->(\x->x) :- Main {unmain=tuple (idfun (lit 42)) (idfun (lit 4)) } @@ -93,7 +93,7 @@ f4 :- Main {unmain=fac (lit 10)} ) -f5 :: (List' v, Expression v, Function (v (List Int)) v) => Main (v Int) +f5 :: (ListDSL v, Expression v, Function (v (List Int)) v) => Main (v Int) f5 = fun ( \sumf->(\l->[dsl|case l of Nil -> 0 @@ -103,7 +103,7 @@ f5 :- Main {unmain=[dsl|sumf (1 `cons` (2 `cons` (3 `cons` nil)))|]} ) -f6 :: (TupleR' v, Expression v, Function (v (TupleR Int Char)) v) => Main (v Int) +f6 :: (TupleRDSL v, Expression v, Function (v (TupleR Int Char)) v) => Main (v Int) f6 = fun ( \firstfun->(\l->[dsl|case l of TupleR {first=f} -> f @@ -122,7 +122,7 @@ f7 :- Main {unmain=ffac (lit 10)} ) -f7' :: (DSL v, List' v, Function (v (List Int)) v) => Main (v Int) +f7' :: (DSL v, ListDSL v, Function (v (List Int)) v) => Main (v Int) f7' = fun ( \fromto->( \(from, to)->[dsl|if from > to then nil else from `cons` fromto (from + 1, to)|] diff --git a/datatype/Tuple.hs b/datatype/Tuple.hs index 8b76339..8442be1 100644 --- a/datatype/Tuple.hs +++ b/datatype/Tuple.hs @@ -1,15 +1,14 @@ {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE DeriveGeneric #-} module Tuple where import Printer -import Compiler -import Interpreter import Language.GenDSL import Language data Tuple a b = Tuple a b -$(genDSL ''Tuple) +$(genDSL 'Tuple) data Tuple3 a c = Tuple3 a Int c $(genDSL ''Tuple3) @@ -19,3 +18,9 @@ $(genDSL ''TupleR) data List a = Nil | Cons a (List a) $(genDSL ''List) + +data Expr a where + Lift :: a -> Expr a + Plus :: Expr a -> Expr a -> Expr a + Equal :: Expr a -> Expr a -> Expr Bool +$(genDSL ''Expr)