Commit e28537b0 authored by Mart Lubbers's avatar Mart Lubbers
Browse files

Initial stab at supporting data types

parent 66e3f085
Pipeline #59041 passed with stage
in 1 minute and 46 seconds
definition module mTask.GenmTask
from Control.Monad.RWST import :: RWST
from Data.Either import :: Either
import StdGeneric
//* Auxiliary type to help with casting values, this is gone at runtime
:: Box b a =: Box b
derive binumap Box
unBox (Box b) :== b
box b :== Box b
reBox x :== box (unBox x)
derive binumap RWST, Either
:: GMTaskState = { types :: [String], constructors :: [String] }
generic gmTaskDcl a *! :: RWST () [String] GMTaskState (Either String) a
derive gmTaskDcl OBJECT of gtd, CONS of gcd, RECORD of grd, FIELD of gfd, PAIR, UNIT
derive gmTaskDcl Int, Bool, Char, Real
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
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.Generics
import Text => qualified join
derive binumap Box, RWST, Either
object x :== OBJECT x
field x :== FIELD x
nl :: [String] -> [String]
nl acc = ["\n":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
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)
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]]]]]
ifNotSeenC :== ifNotSeen (\n s->{s & constructors=n}) (\s->s.constructors)
ifNotSeenT :== ifNotSeen (\n s->{s & types=n}) (\s->s.types)
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
consName :: (a -> String) | genericDescriptorName a
consName = toLowerCase o safe o genericDescriptorName
where
safe s
| s.[0] == '_' = s % (1, size s)
= s
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]
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
deconsName :: (a -> String) | genericDescriptorName a
deconsName = (+++) "un" o genericDescriptorName
fieldSelName :: (a -> String) | genericDescriptorName a
fieldSelName = (+++) "get" o genericDescriptorName
fieldSetName :: (a -> String) | genericDescriptorName a
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]
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
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
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]
)
run :: (RWST () [String] GMTaskState (Either String) a) -> Either String (Box [String] a)
run m = box o snd <$> execRWST m () {types=[], constructors=[]}
tbox :: (Box b1 a) (Box b2 a) -> Box (b1, b2) a
tbox b1 b2 = box (unBox b1, unBox b2)
module GenmTask
import StdEnv
import Control.Monad
import mTask.Show => qualified :: Box
import mTask.GenmTask
//:: 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
:: 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)
//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
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 "}"
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