Commit 11ce0c90 authored by Mart Lubbers's avatar Mart Lubbers
Browse files

clean up, generate more instances

parent e28537b0
Pipeline #59264 passed with stage
in 1 minute and 23 seconds
Subproject commit b801ec9582f222f212de31cb22ae8d1a7005f6e2
Subproject commit 3a66021bd7402a9f0dbee1ebe60cc52908bf89d8
definition module mTask.GenmTask
from Control.Monad.RWST import :: RWST
from Data.Either import :: Either
from GenType import generic gType, :: Box, :: GType
/*
from Control.Monad.RWST import :: RWST
import StdGeneric
//* Auxiliary type to help with casting values, this is gone at runtime
......@@ -23,5 +25,11 @@ generic gmTaskIcl a *! :: RWST () [String] GMTaskState (Either String) a
derive gmTaskIcl OBJECT of gtd, CONS of gcd, RECORD of grd, FIELD of gfd, PAIR, UNIT
derive gmTaskIcl Int, Bool, Char, Real
class gmTask a | gmTaskIcl{|*|} a & gmTaskDcl{|*|} a
*/
gmTask :: Either String (Box ([String], [String]) a) | gmTask 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
implementation module mTask.GenmTask
import StdGeneric
import StdEnv
import Control.Applicative
import Control.Monad
import Control.Monad.RWST
import Data.Functor
import Data.Maybe
import Data.List
import Data.Either
import Data.Func
import Data.Either
import Data.Generics
import GenType
import Text => qualified join
derive binumap Box, RWST, Either
(<$$>) infixr 4 :: (a -> b) (Box a c) -> Box b c
(<$$>) f (Box a) = Box (f a)
object x :== OBJECT x
field x :== FIELD x
gmTask :: String [String] [String] -> Either String (Box ([String], [String]) a) | gType{|*|} a
gmTask modname dclpre iclpre = Right $ genmTask <$$> gType{|*|}
where
genmTask :: GType -> ([String], [String])
genmTask gty
# gtypes = filter (not o isBasic) $ 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]
imports acc =
[ "import mTask.Language, mTask.Interpret, mTask.Show":nl
[ "import Control.Monad":nl
[ "import Data.Func":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
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
mkClassDef :: Type [String] -> [String]
mkClassDef ty acc = ["class ", className ty, " ", v, " where":nl $ mkConstructorDefs ty acc]
where
mkConstructorDefs :: Type -> ([String] -> [String])
mkConstructorDefs (TyNewType gtd gcd ty) = mkConstructorDefs $ TyObject gtd [(gcd, [ty])]
mkConstructorDefs (TyObject gtd [(gcd, _)]) = mkConsDecons gcd gcd.gcd_type
mkConstructorDefs (TyRecord grd fields) = mkConsDecons grd grd.grd_type o flip (foldr mkFields) fields
mkConstructorDefs ty = abort $ concat3 "mkClassDef: Unsupported type: " (toString ty) "\n"
mkConsDecons :: a GenType [String] -> [String] | genericDescriptorName, genericDescriptorType a
mkConsDecons gd ty acc
# ty = replaceBuiltins ty
= [ "\t", consName gd , " :: ": mType ty pGenType $ nl
[ "\t", deconsName gd, " :: (v ": pGenType (resType ty) [") (":mType ty (\_->printString "res") [") -> v res"
//[ "\t", deconsName gd, " :: (":mType ty (\_ acc->["res":acc]) [") (v ":pGenType (resType ty) [") -> v res"
:nl acc]]]]
where
mType :: GenType (GenType -> ([String] -> [String])) [String] -> [String]
mType t=:(GenTypeArrow _ _) res acc = mkCType t res acc
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]
mkFields :: (GenericFieldDescriptor, Type) [String] -> [String]
mkFields (gfd, _) acc
# ty = replaceBuiltins (genericDescriptorType gfd)
# rtype = genericDescriptorType gfd.gfd_cons
= [ "\t", fieldSelName gfd, " :: (", v, " ":pGenType rtype [") -> ", v, " ":pGenType ty $ nl
[ "\t", fieldSetName gfd, " :: (", v, " ":pGenType rtype [") ", "(v ":pGenType ty [") -> ", v, " ":pGenType rtype $ nl acc]]]]]
mkShowInstance :: Type [String] -> [String]
mkShowInstance ty acc = mkInstanceDef (className ty) (printString "Show") [" where":nl $ mkShowFunctions ty acc]
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 ty = abort $ concat3 "mkShowInstance: Unsupported type: " (toString ty) "\n"
mkUnitConsDecons :: a [String] -> [String] | genericDescriptorName, genericDescriptorType a
mkUnitConsDecons gd acc =
[ "\t", consName gd, " = show \"", genericDescriptorName gd, "\"":nl
[ "\t", deconsName gd, " obj fun = par $ show \"", deconsName gd, " \" >>| obj >>| show \" \" >>| fun >>| return undef"
:nl acc]]
nl :: [String] -> [String]
nl acc = ["\n":acc]
mkConsDecons :: [String] a [String] -> [String]| genericDescriptorName, genericDescriptorType a
mkConsDecons args gd acc
= [ "\t", consName gd, " ", 'Text'.join " " args, " = "
, "par $ show \"", genericDescriptorName gd, " \" >>| "
, 'Text'.join " >>| show \" \" >>| " args
, " >>| 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]]
mkFields :: (GenericFieldDescriptor, Type) [String] -> [String]
mkFields (gfd, _) acc =
[ "\t", fieldSelName gfd, " d = d >>| show \".", typeName ty, ".", genericDescriptorName gfd, "\"":nl
[ "\t", fieldSetName gfd, " d f = show \"{ ", typeName ty, " | d & ", genericDescriptorName gfd, "=\" >>| f >>| show \"}\""
:nl acc]]
gmTaskDcl{|Int|} = pure 0
gmTaskDcl{|Char|} = pure '\0'
gmTaskDcl{|Real|} = pure 0.0
gmTaskDcl{|Bool|} = pure True
gmTaskDcl{|PAIR|} fl fr = PAIR <$> fl <*> fr
gmTaskDcl{|UNIT|} = pure UNIT
mkDefs a = mkInstanceDefs a o mkClassDerives a o mkDerives a o mkClass a
gmTaskDcl{|OBJECT of gtd|} f
| gtd.gtd_num_conses == 0
= ifNotSeenT gtd (mkDefs gtd [])
>>| ifNotSeenC gcd (mkConstructorDefs gcd (translateBuiltins gcd.gcd_type) [])
>>| object <$> f
with gcd = hd gtd.gtd_conses
= ifNotSeenT gtd (mkInstanceDefs gtd $ mkClass gtd [])
>>| object <$> f
gmTaskDcl{|RECORD of grd|} f
= ifNotSeenT grd ( mkDefs grd $ mkConstructorDefs grd (translateBuiltins grd.grd_type) [])
>>| RECORD <$> f
gmTaskDcl{|CONS of gcd|} f
= ifNotSeenC gcd (mkConstructorDefs gcd (translateBuiltins gcd.gcd_type) [])
>>| CONS <$> f
gmTaskDcl{|FIELD of gfd|} f
= ifNotSeenC gfd (mkFieldSelector gfd ftype [])
>>| field <$> f
mkByteWidthDef :: Type [String] -> [String]
mkByteWidthDef ty acc
= mkInstanceDef "toByteWidth" (pGenType gdt)
$ classConstraints gdt acc
where
rtype = translateBuiltins (gfd.gfd_cons.grd_type)
ftype = getRType rtype gfd.gfd_index
classConstraints (GenTypeCons _) acc = acc
classConstraints (GenTypeApp (GenTypeCons _) (GenTypeVar a)) acc = [" | toByteWidth ", genTvs` !! a:acc]
classConstraints (GenTypeApp l (GenTypeVar a)) acc = classConstraints l [" & toByteWidth ", genTvs` !! a:acc]
getRType :: GenType Int -> GenType
getRType (GenTypeArrow l r) 0 = l
getRType (GenTypeArrow l r) idx = getRType r (dec idx)
gdt = gty ty
mkFieldSelector :: a GenType [String] -> [String] | genericDescriptorName a
mkFieldSelector name ty acc =
[ "\t", fieldSelName name, " :: (", v, " ":pGenType (resType rtype) [") -> ", v, " ":pGenType ty $ nl
[ "\t", fieldSetName name, " :: (", v, " ":pGenType (resType rtype) [") ", "(v ":pGenType ty [") -> ", v, " ":pGenType (resType rtype) $ nl acc]]]]]
gty (TyNewType gtd gcd ty) = genericDescriptorType gtd
gty (TyObject gtd _) = genericDescriptorType gtd
gty (TyRecord grd fields) = genericDescriptorType grd
gty ty = abort "mkByteWidthDef: unsupported"
ifNotSeenC :== ifNotSeen (\n s->{s & constructors=n}) (\s->s.constructors)
ifNotSeenT :== ifNotSeen (\n s->{s & types=n}) (\s->s.types)
mkByteWidthInstance :: Type [String] -> [String]
mkByteWidthInstance ty acc
= mkByteWidthDef ty [" where":nl
$ ["\ttoByteWidth obj = ":mkByteWidthFunction ty $ nl acc]]
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 = 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]]]
mkInstanceDefs :: Type [String] -> [String]
mkInstanceDefs ty acc
= mkByteWidthDef ty $ nl
$ mkInstanceDef (className ty) (printString "Show") $ nl acc
mkInstanceDef :: String ([String] -> [String]) [String] -> [String]
mkInstanceDef a ty acc = ["instance ", a, " ":ty acc]
mkDerives :: Type [String] -> [String]
mkDerives a acc
| not (isBuiltin a) = foldl (\acc g->["derive ", g, " ", typeName a:nl acc]) (nl acc) ["toByteCode", "fromByteCode"]
= acc
mkClassDerives :: Type [String] -> [String]
mkClassDerives a acc
| not (isBuiltin a) = foldl (\acc g->["derive class ", g, " ", typeName a:nl acc]) (nl acc) ["iTask"]
= acc
ifNotSeen :: ([String] GMTaskState -> GMTaskState) (GMTaskState -> [String]) a [String] -> RWST b [String] GMTaskState (Either String) () | genericDescriptorName a
ifNotSeen put get n s = gets get >>= \seen
| isMember (genericDescriptorName n) seen = pure ()
= tell s >>| modify (\s->put [genericDescriptorName n:get s] s)
resType :: GenType -> GenType
resType (GenTypeArrow l r) = resType r
resType t = t
nl :: [String] -> [String]
nl acc = ["\n":acc]
consName :: (a -> String) | genericDescriptorName a
consName = toLowerCase o safe o genericDescriptorName
where
safe s
| s.[0] == '_' = s % (1, size s)
= s
printString :: String [String] -> [String]
printString a acc = [a:acc]
printGenType :: ![String] !GenType ![String] -> [String]
printGenType tvs (GenTypeCons a) acc = [a:acc]
printGenType tvs (GenTypeVar i) acc = [tvs !! i:acc]
printGenType tvs x=:(GenTypeApp _ _) acc = ["(":printapps x [")":acc]]
where
printapps :: !GenType ![String] -> [String]
printapps (GenTypeApp l r) acc = printapps l [" ":printGenType tvs r acc]
printapps t acc = printGenType tvs t acc
printGenType tvs (GenTypeArrow l r) acc = printGenType tvs l ["->":printGenType tvs r acc]
className :: (Type -> String)
className = (+++) "mTask" o typeName
translateBuiltins :: GenType -> GenType
translateBuiltins (GenTypeCons s) = GenTypeCons $ fromMaybe s $ lookup s table
where
table =
[("_Unit", "()")
,("_List", "[]") ,("_!List", "[!]") ,("_List!", "[ !]") ,("_!List!", "[!!]")
,("_#List", "[#]") ,("_#List!", "[#!]")
,("_Maybe", "?^") ,("_!Maybe", "?") ,("_#Maybe", "?#")
,("_Array", "{}") ,("_!Array", "{!}") ,("_#Array", "{#}") ,("_32#Array", "{32#}")
:[("_Tuple" +++ toString i, "(" +++ createArray (i-1) ',' +++")")\\i<-[2..32]]]
translateBuiltins (GenTypeVar i) = GenTypeVar i
translateBuiltins (GenTypeApp l r) = GenTypeApp (translateBuiltins l) (translateBuiltins r)
translateBuiltins (GenTypeArrow l r) = GenTypeArrow (translateBuiltins l) (translateBuiltins r)
className :: (a -> String) | genericDescriptorName a
className = (+++) "mTask" o genericDescriptorName
consName :: (a -> String) | genericDescriptorName a
consName = toLowerCase o safe o genericDescriptorName
where safe s = if (s.[0] == '_') (s % (1, size s)) s
deconsName :: (a -> String) | genericDescriptorName a
deconsName = (+++) "un" o genericDescriptorName
......@@ -116,125 +194,25 @@ fieldSetName = (+++) "set" o genericDescriptorName
v :: String
v = "v"
pGenType :== printGenType genTvs`
genTvs` = genTvs [toString c \\ c<-:"abcdefghijklmnopqrstuwxyz"]
genTvs :: ![String] -> [String]
genTvs tvs = let gt s = s ++ gt [c +++ s \\ c <- tvs, s <- s] in gt tvs
printString :: String [String] -> [String]
printString a acc = [a:acc]
mkClass :: a [String] -> [String] | genericDescriptorName a
mkClass a acc = ["class ", className a, " ", v, " where":nl acc]
mkDerives :: a [String] -> [String] | genericDescriptorName a
mkDerives a acc = foldl (\acc g->["derive ", g, " ", genericDescriptorName a:nl acc]) acc ["toByteCode", "fromByteCode"]
mkClassDerives :: a [String] -> [String] | genericDescriptorName a
mkClassDerives a acc = foldl (\acc g->["derive class ", g, " ", genericDescriptorName a:nl acc]) acc ["iTask"]
mkInstanceDefs :: a [String] -> [String] | genericDescriptorName a
mkInstanceDefs a acc = foldl (flip (mkInstanceDef a) o nl) acc ["Show", "toByteWidth"]
mkInstanceDef :: a String [String] -> [String] | genericDescriptorName a
mkInstanceDef a ty acc = ["instance ", className a, " ", ty:acc]
mkConstructorDefs :: a GenType [String] -> [String] | genericDescriptorName a
mkConstructorDefs name ty acc =
[ "\t", consName name, " :: ": mType ty pGenType $ nl
[ "\t", deconsName name, " :: (v ": pGenType (resType ty) [") (":mType ty (\_->printString "res") [") -> v res"
// , "\t", deconsName name, " :: (":mType ty (\_->printString "res") [") (v ":pGenType (resType ty) [") -> v res"
:nl acc]]]]
where
mType t=:(GenTypeArrow _ _) res acc = mkCType t res acc
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]
mkInstanceInst :: String a [String] -> [String] | genericDescriptorName a
mkInstanceInst clss a acc = mkInstanceDef a clss [" where":nl acc]
mkShowInstance :: a [String] -> [String] | genericDescriptorName a
mkShowInstance a acc = mkInstanceDef a "Show" [" where":nl acc]
resType :: GenType -> GenType
resType (GenTypeArrow l r) = resType r
resType t = t
mkShowConstructorInst :: GenType a [String] -> [String] | genericDescriptorName a
mkShowConstructorInst ty name acc
| args =: [] =
[ "\t", consName name, " = show \"", genericDescriptorName name, "\"":nl
[ "\t", deconsName name, " obj fun = show \"", deconsName name, "\" >>| obj >>| show \" \" >>| fun"
:nl acc]]
=
[ "\t", consName name, " ", 'Text'.join " " args, " = "
, "show \"", genericDescriptorName name, "\" >>| "
, 'Text'.join " >>| " args
, " >>| return undef":nl
[ "\t", deconsName name, " obj fun = "
, "show \"", deconsName name, "\" >>| obj >>| show \"(\\", 'Text'.join " " args, "->\" >>| fun "
, 'Text'.join " " [concat ["(show \"", a, "\")"]\\a<-args]
, " >>| show \")\""
:nl acc]]
where
args = gargs genTvs` ty
gargs [t:tvs] (GenTypeArrow _ r) = [t:gargs tvs r]
gargs _ _ = []
gmTaskIcl{|Int|} = pure 0
gmTaskIcl{|Char|} = pure '\0'
gmTaskIcl{|Real|} = pure 0.0
gmTaskIcl{|Bool|} = pure True
gmTaskIcl{|OBJECT of gtd|} f
| gtd.gtd_num_conses == 0
= ifNotSeenT gtd (mkInstanceInst "Show" gtd [])
>>| ifNotSeenC gcd []
>>| object <$> f
with gcd = hd gtd.gtd_conses
= ifNotSeenT gtd (mkInstanceInst "Show" gtd [])
>>| object <$> f
gmTaskIcl{|RECORD of grd|} f
= ifNotSeenT grd
( mkDerives grd
$ mkClassDerives grd
$ mkInstanceInst "Show" grd
$ mkShowConstructorInst (translateBuiltins grd.grd_type) grd [])
>>| RECORD <$> f
gmTaskIcl{|CONS of gcd|} f
= ifNotSeenC gcd (mkShowConstructorInst (translateBuiltins gcd.gcd_type) gcd [])
>>| CONS <$> f
gmTaskIcl{|FIELD of gfd|} f
= ifNotSeenC gfd (mkShowFieldSelector gfd ftype [])
>>| field <$> f
printGenType :: ![String] !GenType ![String] -> [String]
printGenType tvs (GenTypeCons a) acc = [a:acc]
printGenType tvs (GenTypeVar i) acc = [tvs !! i:acc]
printGenType tvs x=:(GenTypeApp _ _) acc = ["(":printapps x [")":acc]]
where
rtype = translateBuiltins (gfd.gfd_cons.grd_type)
ftype = getRType rtype gfd.gfd_index
getRType :: GenType Int -> GenType
getRType (GenTypeArrow l r) 0 = l
getRType (GenTypeArrow l r) idx = getRType r (dec idx)
mkShowFieldSelector :: a GenType [String] -> [String] | genericDescriptorName a
mkShowFieldSelector name ty acc =
[ "\t", fieldSelName name, " d = d >>| show \".", gfd.gfd_cons.grd_name, ".", genericDescriptorName name, "\"":nl
[ "\t", fieldSetName name, " d f = show \"{ ", gfd.gfd_cons.grd_name, " | d & ", genericDescriptorName name, "=\" >>| f >>| show \"}\""
:nl acc]]
gmTaskIcl{|PAIR|} fl fr = PAIR <$> fl <*> fr
gmTaskIcl{|UNIT|} = pure UNIT
printapps :: !GenType ![String] -> [String]
printapps (GenTypeApp l r) acc = printapps l [" ":printGenType tvs r acc]
printapps t acc = printGenType tvs t acc
printGenType tvs (GenTypeArrow l r) acc = printGenType tvs l ["->":printGenType tvs r acc]
gmTask :: Either String (Box ([String], [String]) a) | gmTask a
gmTask = fmap preambles $ tbox <$> run gmTaskDcl{|*|} <*> run gmTaskIcl{|*|}
where
preambles :: (Box ([String], [String]) a) -> Box ([String], [String]) a
preambles (Box (dcl, icl)) = Box
( ["/* DCL */":nl dcl]
, ["/* ICL */":nl icl]
)
pGenType :: (GenType [String] -> [String])
pGenType = printGenType genTvs`
run :: (RWST () [String] GMTaskState (Either String) a) -> Either String (Box [String] a)
run m = box o snd <$> execRWST m () {types=[], constructors=[]}
genTvs` :: [String]
genTvs` =: genTvs [toString c \\ c<-:"abcdefghijklmnopqrstuwxyz"]
tbox :: (Box b1 a) (Box b2 a) -> Box (b1, b2) a
tbox b1 b2 = box (unBox b1, unBox b2)
genTvs :: ![String] -> [String]
genTvs tvs = let gt s = s ++ gt [c +++ s \\ c <- tvs, s <- s] in gt tvs
......@@ -13,7 +13,7 @@ from Data.Either import :: Either
from iTasks.WF.Definition import :: Task
from mTask.Interpret.ByteCodeEncoding import
generic toByteCode, generic fromByteCode, class toByteWidth,
generic toByteCode, generic fromByteCode, class toByteWidth(..),
instance toByteWidth (a,b),
instance toByteWidth (a,b,c),
instance toByteWidth (TaskValue a),
......
......@@ -21,7 +21,9 @@ import iTasks.SDS.Definition
return :== pure
instance expr Show where
lit t = show (toString t) // /*show "lit" >>>| */ show2String t
lit t = case dynamic t of
(c :: Char) = show "'" >>| show (toString c) >>| show "'"
_ = show (toString t)
(+.) x y = binop x "+" y
(-.) x y = binop x "-" y
(*.) x y = binop x "*" y
......
module GenmTask
import Data.Either
import Data.Error
import Data.Func
import Data.Generics
import GenType
import StdEnv
import Control.Monad
import mTask.Show => qualified :: Box
import System.File
import mTask.GenmTask
import mTask.Show => qualified :: Box
import Text => qualified join
//:: T :== Int
:: T1 a = T1 Int Bool T2 a T3 TR
:: T2 = T2 Real Char
:: T3 =: T3 T2
:: TR = {i :: Int, b :: Bool, m :: (Char, ())}
:: M a = M a
derive class gmTask T1, T2, T3, TR, S2, (), (,), (,,), (,,,), (,,,,), (,,,,,), M
import Types
:: S2 a b c d e f g h i j k l m n o p q r s t u v w x y z aa ab = S2 a b c d e f g h i j k l m n o p q r s t u v w x y z (aa ab)
derive gType T1, T2, T3, TR, S2, M, TA
//Start :: Either String (Box ([String], [String]) (S2 (T1 Int) T2 T3 TR () ((), ()) () () () () () () () () () () () () () () () () () () () () M Int))
Start :: Either String (Box ([String], [String]) TR)
//Start :: Box ([String], [String]) (T1 Int)
Start = gmTask
import StdDebug
class mTaskTR v where
tr :: (v Int) (v Bool) -> v TR
unTR :: (v TR) ((v Int) (v Bool) -> v res) -> v res
geti :: (v TR) -> v Int
seti :: (v TR) (v Int) -> v TR
getb :: (v TR) -> v Bool
setb :: (v TR) (v Bool) -> v TR
instance mTaskTR Show where
tr a b = show "TR" >>| a >>| b>>| return undef
unTR obj fun = show "unTR (\a b->" >>| fun (show "a") (show "b")>>| show ")"
geti d = d >>| show ".TR.i"
seti d f = show "{ TR | d & i=" >>| f >>| show "}"
getb d = d >>| show ".TR.b"
setb d f = show "{ TR | d & b=" >>| f >>| show "}"
Start w = case g of
Left err = snd (fclose (stderr <<< err <<< "\n") w)
Right (Box (dcl, icl))