Commit 584c191f authored by Mart Lubbers's avatar Mart Lubbers
Browse files

clean up

parent 11ce0c90
Pipeline #59411 passed with stage
in 1 minute and 24 seconds
......@@ -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
......@@ -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)
......
......@@ -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 = []
}
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment