.

diff --git a/datatype/Language/GenDSL.hs b/datatype/Language/GenDSL.hs
index a6e0d35..37643bb 100644 (file)
--- 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 (file)
--- 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 (file)
--- 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)