clean up

lib/mTask/mTask/GenmTask.dcl

@@ -27,9 +27,11 @@ derive gmTaskIcl Int, Bool, Char, Real
 class gmTask a | gmTaskIcl{|*|} a & gmTaskDcl{|*|} a
 */
 
-/**
- * @param Module name (and also filename)
- * @param dcl preamble (stuff coming after our imports but before any code)
- * @param icl preamble (stuff coming after our imports but before any code)
- */
-gmTask :: String [String] [String] -> Either String (Box ([String], [String]) a) | gType{|*|} a
+:: GmTaskOptions =
+	{ moduleName  :: String
+	, dclPreamble :: [String]
+	, iclPreamble :: [String]
+	, skipList    :: [String]
+	}
+
+gmTask :: GmTaskOptions -> Either String (Box ([String], [String]) a) | gType{|*|} a

lib/mTask/mTask/GenmTask.icl

@@ -3,42 +3,84 @@ implementation module mTask.GenmTask
 import StdEnv
 import Data.Func
 import Data.Either
-import Data.Generics
 import GenType
+from Data.Generics import
+	class genericDescriptorName(..), class genericDescriptorType(..),
+	instance genericDescriptorName GenericRecordDescriptor,
+	instance genericDescriptorName GenericTypeDefDescriptor,
+	instance genericDescriptorName GenericFieldDescriptor,
+	instance genericDescriptorName GenericConsDescriptor,
+	instance genericDescriptorType GenericRecordDescriptor,
+	instance genericDescriptorType GenericTypeDefDescriptor,
+	instance genericDescriptorType GenericFieldDescriptor,
+	instance genericDescriptorType GenericConsDescriptor
 import Text => qualified join
+import Data.List
 
 (<$$>) infixr 4 :: (a -> b) (Box a c) -> Box b c
 (<$$>) f (Box a) = Box (f a)
-
-gmTask :: String [String] [String] -> Either String (Box ([String], [String]) a) | gType{|*|} a
-gmTask modname dclpre iclpre = Right $ genmTask <$$> gType{|*|}
+:: GmTaskOptions =
+	{ moduleName  :: String
+	, dclPreamble :: [String]
+	, iclPreamble :: [String]
+	, skipList    :: [String]
+	}
+
+gmTask :: GmTaskOptions -> Either String (Box ([String], [String]) a) | gType{|*|} a
+gmTask opts = Right $ genmTask <$$> gType{|*|}
 where
+	inSkipList :: Type -> Bool
+	inSkipList a = isBasic a || isMember (typeName a) ["_Unit", "_Tuple2", "_Tuple3"] || isMember (typeName a) opts.skipList
+
 	genmTask :: GType -> ([String], [String])
 	genmTask gty
-		# gtypes = filter (not o isBasic) $ map gTypeToType $ flatten $ flattenGType gty
+		# gtypes = filter (not o inSkipList) $ map gTypeToType $ flatten $ flattenGType gty
 		= ( preambleDcl $ foldr (flip genDcl) [] gtypes
 		  , preambleIcl $ foldr (flip genIcl) [] gtypes
 		  )
 
-	preambleIcl acc = [ "implementation module ", modname:nl $ nl $ imports $ iclpre ++ nl acc]
-	preambleDcl acc = [ "definition module ", modname:nl $ nl $ imports $ dclpre ++ nl acc]
-
+	preambleIcl acc = [ "implementation module ", opts.moduleName:nl $ nl $ imports $ opts.iclPreamble ++ nl acc]
+	preambleDcl acc =
+		[ "definition module ", opts.moduleName:nl 
+		[ "import mTask.Language":nl
+		[ "import mTask.Interpret":nl
+		[ "import mTask.Show":nl $ opts.dclPreamble ++ nl acc]]]]
 	imports acc =
-		[ "import mTask.Language, mTask.Interpret, mTask.Show":nl
+		[ "import mTask.Interpret":nl
+		[ "import mTask.Interpret.DSL":nl
+		[ "import mTask.Language":nl
+		[ "import mTask.Show => qualified censor":nl $ nl
+		[ "import Control.Applicative":nl
 		[ "import Control.Monad":nl
+		[ "import Control.Monad.State":nl
+		[ "import Control.Monad.Trans":nl
+		[ "import Control.Monad.Writer":nl
 		[ "import Data.Func":nl
-		[ "import StdEnv":nl acc ]]]]
+		[ "import Data.Functor":nl
+		[ "import Data.Functor.Identity":nl
+		[ "import Data.List":nl $ nl
+		[ "import StdEnv":nl acc ]]]]]]]]]]]]]]
 
 	genIcl :: [String] Type -> [String]
-	genIcl acc ty
-		| isMember (typeName ty) ["_Unit", "_Tuple2", "_Tuple3"] = acc
-		= mkInstances ty $ nl $ mkClassDerives ty $ mkDerives ty acc
-	where mkInstances ty = mkByteWidthInstance ty o mkShowInstance ty
+	genIcl acc ty = mkInstances ty $ nl $ mkClassDerives ty $ mkDerives ty $ mkSpecialSelectors ty $ nl acc
+	where mkInstances ty = mkInterpretInstance ty o mkByteWidthInstance ty o mkShowInstance ty
 	
 	genDcl :: [String] Type -> [String]
-	genDcl acc ty
-		| isMember (typeName ty) ["_Unit", "_Tuple2", "_Tuple3"] = acc
-		= mkInstanceDefs ty $ nl $ mkClassDef ty $ nl $ mkClassDerives ty $ mkDerives ty acc
+	genDcl acc ty = mkInstanceDefs ty $ nl $ mkClassDef ty $ nl $ mkClassDerives ty $ mkDerives ty acc
+
+mkSpecialSelectors :: Type [String] -> [String]
+mkSpecialSelectors (TyNewType gtd gcd ty) acc = mkSpecialSelectors (TyObject gtd [(gcd, [ty])]) acc
+mkSpecialSelectors ty=:(TyObject gtd [(gcd, _)]) acc = foldr (fieldmaps gtd) acc $ zip (args ty, fieldTypes gcd.gcd_type)
+where
+	fieldTypes (GenTypeArrow l r) = [l:fieldTypes r]
+	fieldTypes r = [r]
+mkSpecialSelectors ty=:(TyRecord grd fields) acc = foldr (fieldmaps grd) acc [(a, genericDescriptorType gfd)\\(gfd, _)<-fields & a<-args ty]
+mkSpecialSelectors ty acc = abort $ concat3 "mkSpecialSelectors: Unsupported type: " (toString ty) "\n"
+
+fieldmaps :: a (String, GenType) [String] -> [String] | genericDescriptorType a
+fieldmaps otype (name, vtype) acc
+	= [name, " :: ": pGenType (genericDescriptorType otype) [" -> ":pGenType (replaceBuiltins vtype)
+	$ nl [name, " _ = undef":nl acc]]]
 
 mkClassDef :: Type [String] -> [String]
 mkClassDef ty acc = ["class ", className ty, " ", v, " where":nl $ mkConstructorDefs ty acc]
@@ -62,7 +104,7 @@ where
 		where
 			mkCType (GenTypeArrow l r) res acc = ["(", v, " ":pGenType l [") ":mkCType r res acc]]
 			mkCType t res acc = ["-> ", v, " ":res t acc]
-		mType t res acc = [v, " ":pGenType t acc]
+		mType t res acc = [v, " ":res t acc]
 
 	mkFields :: (GenericFieldDescriptor, Type) [String] -> [String]
 	mkFields (gfd, _) acc
@@ -77,8 +119,8 @@ where
 	mkShowFunctions :: Type -> ([String] -> [String])
 	mkShowFunctions (TyNewType gtd gcd ty) = mkShowFunctions $ TyObject gtd [(gcd, [ty])]
 	mkShowFunctions (TyObject gtd [(gcd, [])]) = mkUnitConsDecons gcd
-	mkShowFunctions (TyObject gtd [(gcd, vs)]) = mkConsDecons [tv\\tv<-genTvs` & _<-vs] gcd
-	mkShowFunctions (TyRecord grd fields) = mkConsDecons [gfd.gfd_name\\(gfd, _)<-fields] grd o flip (foldr mkFields) fields
+	mkShowFunctions (TyObject gtd [(gcd, vs)]) = mkConsDecons ty gcd
+	mkShowFunctions (TyRecord grd fields) = mkConsDecons ty grd o flip (foldr mkFields) fields
 	mkShowFunctions ty = abort $ concat3 "mkShowInstance: Unsupported type: " (toString ty) "\n"
 
 	mkUnitConsDecons :: a [String] -> [String] | genericDescriptorName, genericDescriptorType a
@@ -87,17 +129,17 @@ where
 		[ "\t", deconsName gd, " obj fun = par $ show \"", deconsName gd, " \" >>| obj >>| show \" \" >>| fun >>| return undef"
 		:nl acc]]
 
-	mkConsDecons :: [String] a [String] -> [String]| genericDescriptorName, genericDescriptorType a
-	mkConsDecons args gd acc
-		= [ "\t", consName gd, " ", 'Text'.join " " args, " = "
+	mkConsDecons :: Type a [String] -> [String] | genericDescriptorName, genericDescriptorType a
+	mkConsDecons ty gd acc
+		= [ "\t", consName gd, " ":printArgs ty [" = "
 			, "par $ show \"", genericDescriptorName gd, " \" >>| "
-			, 'Text'.join " >>| show \" \" >>| " args
-			, " >>| return undef":nl
+			: isperse " >>| show \" \" >>| " (map printString $ args ty)
+			[ " >>| return undef":nl
 		[ "\t", deconsName gd, " obj fun = "
-			, "par $ show \"", deconsName gd, " \" >>| obj >>| show \" (\\\\", 'Text'.join " " args, "->\" >>| fun "
-			, 'Text'.join " " [concat ["(show \"", a, "\")"]\\a<-args]
-			, " >>| show \")\""
-		:nl acc]]
+			, "par $ show \"", deconsName gd, " \" >>| obj >>| show \" (\\\\":printArgs ty ["->\" >>| fun "
+			: isperse " " [\acc->["(show \"", a, "\")":acc]\\a<-args ty]
+			[ " >>| show \")\""
+		:nl acc]]]]]]
 
 	mkFields :: (GenericFieldDescriptor, Type) [String] -> [String]
 	mkFields (gfd, _) acc =
@@ -119,7 +161,7 @@ where
 	gty (TyNewType gtd gcd ty) = genericDescriptorType gtd
 	gty (TyObject gtd _) = genericDescriptorType gtd
 	gty (TyRecord grd fields) = genericDescriptorType grd
-	gty ty = abort "mkByteWidthDef: unsupported"
+	gty ty = abort $ concat3 "mkByteWidthDef: Unsupported type: " (toString ty) "\n"
 
 mkByteWidthInstance :: Type [String] -> [String]
 mkByteWidthInstance ty acc
@@ -129,33 +171,84 @@ where
 	mkByteWidthFunction :: Type -> ([String] -> [String])
 	mkByteWidthFunction (TyNewType gtd gcd ty) = mkByteWidthFunction $ TyObject gtd [(gcd, [ty])]
 	mkByteWidthFunction (TyObject gtd [(gcd, [])]) = printString "1"
-	mkByteWidthFunction (TyObject gtd [(gcd, vs)])
-		= fieldcalls [tv\\tv <- genTvs` & _<-vs]
-		o printString "\n\twhere"
-		o flip (foldr $ fieldmaps gtd) [(s, v)\\v <- fieldTypes gcd.gcd_type & s<-genTvs`]
-	mkByteWidthFunction (TyRecord grd fields)
-		= fieldcalls [gfd.gfd_name\\(gfd, _)<-fields]
-		o printString "\n\twhere"
-		o flip (foldr $ fieldmaps grd) [(genericDescriptorName gfd, genericDescriptorType gfd)\\(gfd, _)<-fields]
+	mkByteWidthFunction ty=:(TyObject gtd [(gcd, vs)]) = fieldcalls (args ty)
+	mkByteWidthFunction (TyRecord grd fields) = fieldcalls (args ty)
 	mkByteWidthFunction ty = abort $ concat3 "mkByteWidthFunctions: Unsupported type: " (toString ty) "\n"
 
-	fieldTypes (GenTypeArrow l r) = [l:fieldTypes r]
-	fieldTypes r = [r]
-
 	fieldcalls :: [String] [String] -> [String]
 	fieldcalls [v] acc = ["toByteWidth (",v," obj)":acc]
 	fieldcalls [v:vs] acc = fieldcalls [v] [" + ":fieldcalls vs acc]
 
-fieldmaps :: a (String, GenType) [String] -> [String] | genericDescriptorType a
-fieldmaps otype (name, vtype) acc
-	= nl ["\t\t", name, " :: ": pGenType (genericDescriptorType otype) [" -> ":pGenType (replaceBuiltins vtype)
-	$ nl ["\t\t", name, " _ = undef":acc]]]
+constructor :: Type [String] -> [String]
+constructor (TyNewType gtd gcd ty) acc = ["(\\a->", gtd.gtd_name, " a)":acc]
+constructor (TyObject gtd _) acc = printString gtd.gtd_name acc
+constructor ty=:(TyRecord grd fields) acc
+	= ["(\\":printArgs ty ["->{", grd.grd_name, "|":isperse ", " [\acc->[a, "=", a:acc]\\a<-args ty] ["})":acc]]]
+constructor ty acc = abort $ concat3 "constructor: Unsupported type " (toString ty) "\n"
+
+args :: Type -> [String]
+args (TyNewType gtd gcd ty) = ["a"]
+args (TyObject gtd [(gcd, vs)]) = [concat3 (toLowerCase gcd.gcd_name) "f" (toString tv)\\_<-vs & tv<-[0..]]
+args (TyRecord grd fields) = [gfd.gfd_name\\(gfd, _)<-fields]
+args ty = abort $ concat3 "args: Unsupported type " (toString ty) "\n"
+
+printArgs ty :== isperse " " [printString a\\a<-args ty]
+
+isperse :: a [[a] -> [a]] [a] -> [a]
+isperse s m c = foldr id c $ intersperse (\c->[s:c]) m
+
+mkInterpretInstance :: Type [String] -> [String]
+mkInterpretInstance ty acc = mkInterpretDef ty [" where":nl $ mkInterpretFunctions ty acc]
+where
+	mkInterpretFunctions :: Type -> ([String] -> [String])
+	mkInterpretFunctions ty=:(TyNewType gtd gcd _) =  mkConsDecons ty gcd
+	mkInterpretFunctions (TyObject gtd [(gcd, [])]) = mkUnitConsDecons gcd
+	mkInterpretFunctions ty=:(TyObject gtd [(gcd, vs)]) = mkConsDecons ty gcd
+	mkInterpretFunctions ty=:(TyRecord grd fields) = mkConsDecons ty grd o flip (foldr mkFields) fields
+	mkInterpretFunctions ty = abort $ concat3 "mkInterpretInstance: Unsupported type: " (toString ty) "\n"
+
+	mkUnitConsDecons :: a [String] -> [String] | genericDescriptorName, genericDescriptorType a
+	mkUnitConsDecons gd acc =
+		[ "\t", consName gd, " = tell` []":nl
+		[ "\t", deconsName gd, " obj fun = fun"
+		:nl acc]]
+//instance tupl (StateT BCState (WriterT [BCInstr] Identity))
+//where
+//	first t  = censorListen t >>= \(_, is)->tell` if (onlyArg is)
+//		(take (toByteWidth $ fst $ unpack t) is)
+//		(is ++ [ BCPop $ UInt8 (toByteWidth $ snd $ unpack $ t)])
+//	second t = censorListen t >>= \(_, is)->tell` if (onlyArg is)
+//		(drop (toByteWidth $ fst $ unpack t) is)
+//		(is ++ [ BCRot (UInt8 (toByteWidth $ unpack t)) $ UInt8 (toByteWidth $ snd $ unpack t)
+//		       , BCPop $ UInt8 (toByteWidth $ fst $ unpack t)])
+//	tupl a b = liftM2 tuple a b
+
+	mkConsDecons :: Type a [String] -> [String]| genericDescriptorName, genericDescriptorType a
+	mkConsDecons ty gd acc =
+		[ "\t", consName gd, " ":printArgs ty [" = "
+			: constructor ty [" <$> ":isperse " <*> " [printString a\\a<-args ty]
+			$ nl
+		[ "\t", deconsName gd, " obj fun = undef"
+//			, "par $ show \"", deconsName gd, " \" >>| obj >>| show \" (\\\\", 'Text'.join " " args, "->\" >>| fun "
+//			, 'Text'.join " " [concat3 "(show \"" a "\")"\\a<-args]
+//			, " >>| show \")\""
+		:nl acc]]]]
+
+	mkFields :: (GenericFieldDescriptor, Type) [String] -> [String]
+	mkFields (gfd, _) acc =
+		[ "\t", fieldSelName gfd, " d = undef":nl//d >>| show \".", typeName ty, ".", genericDescriptorName gfd, "\"":nl
+		[ "\t", fieldSetName gfd, " d f = undef"//show \"{ ", typeName ty, " | d & ", genericDescriptorName gfd, "=\" >>| f >>| show \"}\""
+		:nl acc]]
 
 mkInstanceDefs :: Type [String] -> [String]
 mkInstanceDefs ty acc
-	= mkByteWidthDef ty $ nl
+	= mkInterpretDef ty $ nl
+	$ mkByteWidthDef ty $ nl
 	$ mkInstanceDef (className ty) (printString "Show") $ nl acc
 
+mkInterpretDef :: Type [String] -> [String]
+mkInterpretDef ty acc = mkInstanceDef (className ty) (printString "(StateT BCState (WriterT [BCInstr] Identity))") acc
+
 mkInstanceDef :: String ([String] -> [String])  [String] -> [String]
 mkInstanceDef a ty acc = ["instance ", a, " ":ty acc]
 
@@ -169,10 +262,10 @@ mkClassDerives a acc
 	| not (isBuiltin a) = foldl (\acc g->["derive class ", g, " ", typeName a:nl acc]) (nl acc) ["iTask"]
 	= acc
 
-nl :: [String] -> [String]
+nl :: ![String] -> [String]
 nl acc = ["\n":acc]
 
-printString :: String [String] -> [String]
+printString :: !String ![String] -> ![String]
 printString a acc = [a:acc]
 
 className :: (Type -> String)

tools/GenmTask.icl

@@ -3,7 +3,6 @@ module GenmTask
 import Data.Either
 import Data.Error
 import Data.Func
-import Data.Generics
 import GenType
 import StdEnv
 import System.File
@@ -30,12 +29,17 @@ Start w = case g of
 where
 	g :: Either String (Box ([String], [String]) (TR Real ()))
 	g = gmTask
-		"DataType"
-		["import Types\n"]
-		["import Types\n"
-		,"Start \n"
-		,"\t=  showIt (unTA ta ta)\n"
-		,"\t++ showIt (t2 (unT2 e \\i _ _->i) (lit ' ') (tupl (lit ()) (lit ())))\n"
-		,"where\n"
-		,"\te = t2 (lit 42.0) (lit ' ') (tupl (lit ()) (lit ()))\n"
-		]
+		{ GmTaskOptions
+		| moduleName  = "DataType"
+		, dclPreamble = ["import Types\n"]
+		, iclPreamble =
+			["import Types\n"
+			,"\n"
+			,"Start \n"
+			,"\t=  showIt (unTA ta ta)\n"
+			,"\t++ showIt (t2 (unT2 e \\i _ _->i) (lit ' ') (tupl (lit ()) (lit ())))\n"
+			,"where\n"
+			,"\te = t2 (lit 42.0) (lit ' ') (tupl (lit ()) (lit ()))\n"
+			]
+		, skipList    = []
+		}