--- /dev/null
+module deep
+
+import StdEnv
+
+:: DSL
+ = Lit Int
+ | Plus DSL DSL
+ | Div DSL DSL
+
+eval :: DSL -> Int
+eval (Lit i) = i
+eval (Plus x y) = eval x + eval y
+eval (Div x y) = eval x / eval y
+
+//Start = eval (Plus (Lit 41) (Lit 1))
+
+import Control.Applicative
+import Control.Monad
+import Data.Functor
+import Data.Maybe
+
+evalM :: DSL -> Maybe Int
+evalM (Lit i) = pure i
+evalM (Plus x y) = (+) <$> evalM x <*> evalM y
+evalM (Div x y) = evalM x >>= \x->evalM y >>= \y->case y of
+ 0 = Nothing
+ x = Just (x / y)
+
+Start = evalM (Plus (Lit 41) (Lit 1))
--- /dev/null
+module eadt
+
+import StdEnv
+import Control.Monad
+import Control.Applicative
+import Data.Functor
+import Data.Maybe
+
+:: BM a b = { to :: a -> b, fro :: b -> a}
+bm :: BM a a
+bm = {to=id, fro=id}
+
+class eval m where eval :: (m a) -> Maybe a
+class print m where print :: (m a) [String] -> [String]
+class flat m where flat :: (m a) -> DSL a
+:: DSL a
+ = E.e: Lit (BM e a) a & toString e
+ | E.e: Plus (BM e a) (DSL e) (DSL e) & + e
+ | E.m: Ext (m a) & eval, print, flat m
+lit = Lit bm
+(+.) infixl 6
+(+.) = Plus bm
+
+instance eval DSL where
+ eval (Lit _ a) = Just a
+ eval (Plus bm x y) = bm.to <$> ((+) <$> eval x <*> eval y)
+ eval (Ext m) = eval m
+
+instance print DSL where
+ print (Lit bm a) c = [toString (bm.fro a):c]
+ print (Plus _ x y) c = print x ["+":print y c]
+ print (Ext m) c = print m c
+
+instance flat DSL where
+ flat (Ext m) = Ext (flat m)
+ flat a = a
+
+:: Div a = E.e: Div (BM e a) (DSL e) (DSL e) & /, zero, == e
+(/.) infixl 7
+(/.) x y = Ext (Div bm x y)
+
+instance eval Div where
+ eval (Div bm x y) = bm.to <$> (eval x >>= \x->eval y >>= \y->
+ if (y == zero) Nothing (Just (x/y)))
+
+instance print Div where
+ print (Div bm x y) c = print x ["/":print y c]
+
+instance flat Div where
+ flat a = Ext a
+
+:: In a b = In infix 0 a b
+:: Var a = E.b: Var ((DSL b) -> In (DSL b) (DSL a))
+var = Ext o Var
+instance eval Var where
+ eval (Var def) =
+ let (init In body) = def init
+ in eval body
+
+instance print Var where
+ print (Var def) c =
+ let (init In body) = def init
+ in ["let _ = ":print init [" in ":print body c]]
+
+instance flat Var where
+ flat (Var def) =
+ let (init In body) = def init
+ in body
+
+Start = printEval (var \x=lit 41 In x +. lit 1)
+
+printEval :: (DSL a) -> (Maybe a, [String])
+printEval e = (eval e, print e [])
--- /dev/null
+module test
+
+import StdEnv
+import Data.Maybe
+import Data.Functor
+import qualified Data.Map as DM
+import iTasks
+import iTasks.Internal.Serialization
+
+:: Box = E.t: Box t & iTask t
+unBox (Box b) :== b
+
+gEq{|Box|} (Box l) (Box r) = dynamicJSONEncode l == dynamicJSONEncode r
+JSONEncode{|Box|} _ c = [dynamicJSONEncode c]
+JSONDecode{|Box|} _ [c:r] = (dynamicJSONDecode c, r)
+JSONDecode{|Box|} _ r = (Nothing, r)
+gText{|Box|} tv ma = maybe [] (gText{|*|} tv o Just) ma
+gEditor{|Box|} = bijectEditorValue fromBox toBox gEditor{|*|}
+
+fromBox :: Box -> Type
+fromBox (Box t) = fromBoxd (dynamic t)
+
+fromBoxd :: Dynamic -> Type
+fromBoxd (a :: ()) = Unit
+fromBoxd (a :: Int) = Int a
+fromBoxd (a :: Bool) = Bool a
+fromBoxd (a :: Real) = Real a
+fromBoxd (a :: String) = String a
+fromBoxd ((a, b) :: (a, b)) = Tuple (fromBoxd (dynamic a)) (fromBoxd (dynamic b))
+fromBoxd ((a, b, c) :: (a, b, c)) = Tuple3 (fromBoxd (dynamic a)) (fromBoxd (dynamic b)) (fromBoxd (dynamic b))
+fromBoxd (a :: Person) = Person a
+
+toBox :: Type -> Box
+toBox (Int a) = Box a
+toBox (Bool a) = Box a
+toBox (Real a) = Box a
+toBox (String a) = Box a
+toBox Unit = Box ()
+toBox (Tuple l r) = case (toBox l, toBox r) of
+ (Box l, Box r) = Box (l, r)
+toBox (Tuple3 l m r) = case (toBox l, toBox m, toBox r) of
+ (Box l, Box m, Box r) = Box (l, m, r)
+toBox (Person p) = Box p
+ /*
+gEditor{|Box|} =
+ { Editor
+ | genUI = \uia dp em vst->case em of
+ Enter = (Error "enterInformation not possible for existentials (genUI)", vst)
+ (View b=:(Box a)) = case (castEditor a).Editor.genUI uia dp (View a) vst of
+ (Error e, vst) = (Error e, vst)
+ (Ok (ui, es), vst) = (Ok (ui, AnnotatedState (dynamicJSONEncode (View (), uia, b)) es), vst)
+ (Update b=:(Box a)) = case (castEditor a).Editor.genUI uia dp (Update a) vst of
+ (Error e, vst) = (Error e, vst)
+ (Ok (ui, es), vst) = (Ok (ui, AnnotatedState (dynamicJSONEncode (Update (), uia, b)) es), vst)
+ , onEdit = \dp dpn es vst->case es of
+ AnnotatedState ebox es = case dynamicJSONDecode ebox of
+ Just (Enter, _, Box b) = case (castEditor b).Editor.onEdit dp dpn es vst of
+ (Error e, vst) = (Error e, vst)
+ (Ok (ui, es), vst) = (Ok (ui, AnnotatedState ebox es), vst)
+ Just (View (), _, Box b) = case (castEditor b).Editor.onEdit dp dpn es vst of
+ (Error e, vst) = (Error e, vst)
+ (Ok (ui, es), vst) = (Ok (ui, AnnotatedState ebox es), vst)
+ Just (Update (), _, Box b) = case (castEditor b).Editor.onEdit dp dpn es vst of
+ (Error e, vst) = (Error e, vst)
+ (Ok (ui, es), vst) = (Ok (ui, AnnotatedState ebox es), vst)
+ Nothing = (Error "corrupt editor state in Box", vst)
+ _ = (Error "corrupt editor state in Box", vst)
+ , onRefresh = \dp b=:(Box nb) es vst->case es of
+ AnnotatedState box es = case dynamicJSONDecode box of
+ Just (View (), uia, Box _) = case (castEditor nb).Editor.genUI uia dp (View nb) vst of
+ (Ok (ui, es), vst) = (Ok (ReplaceUI ui, AnnotatedState (dynamicJSONEncode (View (), uia, b)) es), vst)
+ (Error e, vst) = (Error e, vst)
+ Just (Update (), uia, Box _) = case (castEditor nb).Editor.genUI uia dp (Update nb) vst of
+ (Ok (ui, es), vst) = (Ok (ReplaceUI ui, AnnotatedState (dynamicJSONEncode (Update (), uia, b)) es), vst)
+ (Error e, vst) = (Error e, vst)
+ Just (Enter, uia, Box _) = case (castEditor nb).Editor.genUI uia dp (Update nb) vst of
+ (Ok (ui, es), vst) = (Ok (ReplaceUI ui, AnnotatedState (dynamicJSONEncode (Update (), uia, b)) es), vst)
+ (Error e, vst) = (Error e, vst)
+ Nothing = (Error "corrupt editor state in Box", vst)
+ _ = (Error "corrupt editor state in Box", vst)
+ , valueFromState = \es->case es of
+ AnnotatedState box es = case dynamicJSONDecode box of
+ Just (_, _, Box a) = case (castEditor a).Editor.valueFromState es of
+ Just a = Just (Box a)
+ Nothing = Nothing
+ Nothing = Nothing
+ }
+where
+ castEditor :: t -> Editor t | gEditor{|*|} t
+ castEditor _ = gEditor{|*|}
+*/
+
+Start w = doTasks t w
+
+//t = updateSharedInformation [] (Box 42)
+t = withShared (Box 42) \bs->
+ updateSharedInformation [] bs
+ -|| updateSharedInformation [] bs
+
+:: Type
+ = Int Int
+ | Bool Bool
+ | String String
+ | Real Real
+ | Unit
+ | List [Type]
+ | Tuple Type Type
+ | Tuple3 Type Type Type
+ | Person Person
+:: Person = {firstName :: String, lastName :: String}
+
+derive class iTask Type, Person
+++ /dev/null
-#include <stdio.h>
-
-extern int fac(int n);
-
-int cmain()
-{
- for(int i = 0; i<10; i++)
- printf("Fac %d: %d\n", i, fac(i));
-}
+++ /dev/null
-module gopt
-
-import StdEnv, StdGeneric
-
-import Data.List
-import Data.Error
-import Data.Func
-import Data.Functor
-import Data.Tuple
-import Data.Maybe
-import Control.Applicative
-import Control.Monad => qualified join
-import System.CommandLine
-import Text
-
-:: Opt a
- = BinaryFlag (a -> a) (a -> a)
- | Flags [(String, ([String] a -> (MaybeError [String] (a, [String]))))]
- | Positionals [(String, String a -> (MaybeError [String] a))]
- | SubParsers [(String, Opt a)]
-
-class bifmap m :: (a -> b) (b -> a) (m b) -> m a
-instance bifmap Opt
-where
- bifmap fr to (BinaryFlag set unset) = BinaryFlag (to o set o fr) (to o unset o fr)
- bifmap fr to (Flags fs) = Flags $ map (appSnd $ (\f s->fm (appFst to) o f s o fr)) fs
- bifmap fr to (Positionals fs) = Positionals $ map (appSnd $ fmap $ \f->fm to o f o fr) fs
- bifmap fr to (SubParsers sp) = SubParsers $ map (appSnd (bifmap fr to)) sp
-
-fm f (Ok a) = Ok (f a)
-fm f (Error e) = Error e
-
-combine sel app p s t = p s (sel t) >>= \l->pure (app (const l) t)
-combine` sel app p s t = p s (sel t) >>= \(l, as)->pure ((app (const l) t), as)
-
-ar0 s f as = Ok o flip tuple as o f
-
-generic gopt a *! :: Opt a
-//generic gopt a :: Opt a
-gopt{|Bool|} = BinaryFlag (const True) (const False)
-gopt{|Int|} = Positionals [("INT", \s _->if (and [isDigit c\\c<-:s]) (Ok $ toInt s) (Error ["Not an integer"]))]
-gopt{|Char|} = Positionals [("CHAR", \s _->if (size s == 1) (Ok s.[0]) (Error ["Not a single character"]))]
-gopt{|String|} = Positionals [("STRING", \s _->Ok s)]
-gopt{|RECORD|} f = bifmap (\(RECORD a)->a) (\x->RECORD x) f
-gopt{|OBJECT|} f = bifmap (\(OBJECT a)->a) (\x->OBJECT x) f
-gopt{|FIELD of {gfd_name}|} f = case f of
- //Child is a boolean
- BinaryFlag set unset = mapF $ Flags [(gfd_name, ar0 gfd_name set), ("no-" +++ gfd_name, ar0 ("no-" +++ gfd_name) unset)]
- //Child is a basic value or a tuple
- Positionals ps = mapF $ Flags [(gfd_name, ptoarg ps)]
- //Child is another record, make the arguments ddstyle TODO
- Flags x = mapF (Flags x)
- //Child is a subparser
- SubParsers ps = mapF (Flags [(gfd_name, pOpts (SubParsers ps))])
- x = abort "Subparsers not supported"
-where
- mapF :: ((m a) -> m (FIELD a)) | bifmap m
- mapF = bifmap (\(FIELD a)->a) (\x->FIELD x)
-
- ptoarg [p] [] i = Error ["Not enough arguments for " +++ gfd_name]
- ptoarg [(_, p):ps] [a:as] i = p a i >>= ptoarg ps as
- ptoarg [] as i = Ok (i, as)
-gopt{|PAIR|} l r = case (l, r) of
- (Positionals pl, Positionals pr)
- = Positionals
- $ map (appSnd $ combine PFst appPFst) pl
- ++ map (appSnd $ combine PSnd appPSnd) pr
- (Flags fl, Flags fr)
- = Flags
- $ map (appSnd $ combine` PFst appPFst) fl
- ++ map (appSnd $ combine` PSnd appPSnd) fr
- (x, y) = abort $ "gopt{|PAIR|}: " +++ consPrint x +++ " " +++ consPrint y
-where
- appPFst f (PAIR x y) = PAIR (f x) y
- appPSnd f (PAIR x y) = PAIR x (f y)
- PFst (PAIR x y) = x
- PSnd (PAIR x y) = y
-gopt{|UNIT|} = Positionals []
-gopt{|CONS of {gcd_name}|} c = bifmap (\(CONS a)->a) CONS $ SubParsers [(gcd_name, c)]
-gopt{|EITHER|} l r = case (l, r) of
- (SubParsers sl, SubParsers sr)
- = SubParsers
- $ map (appSnd $ bifmap (\(LEFT a)->a) LEFT) sl
- ++ map (appSnd $ bifmap (\(RIGHT a)->a) RIGHT) sr
-gopt{|(,)|} l r = case (l, r) of
- (Positionals pl, Positionals pr)
- = Positionals
- $ map (appSnd $ combine fst appFst) pl
- ++ map (appSnd $ combine snd appSnd) pr
-gopt{|(,,)|} f s t = case (f, s, t) of
- (Positionals pf, Positionals ps, Positionals pt)
- = Positionals
- $ map (appSnd $ combine fst3 appFst3) pf
- ++ map (appSnd $ combine snd3 appSnd3) ps
- ++ map (appSnd $ combine thd3 appThd3) pt
-
-consPrint (Positionals x) = "Positionals"
-consPrint (BinaryFlag x _) = "BinaryFlag"
-consPrint (Flags x) = "Flags"
-consPrint (SubParsers x) = "SubParsers"
-
-parseOpts :: [String] a -> MaybeError [String] (a, [String]) | gopt{|*|} a
-parseOpts args a = pOpts gopt{|*|} args a
-
-pOpts :: (Opt a) [String] a -> MaybeError [String] (a, [String])
-pOpts (Positionals [p:ps]) [] a = Error [toString (length [p:ps]) +++ " positional arguments required"]
-pOpts (Positionals [p:ps]) [arg:args] a = (snd p) arg a >>= pOpts (Positionals ps) args
-pOpts (SubParsers ps) [arg:args] a = case find (\(l,p)->l==arg) ps of
- Nothing = Error ["Unrecognized subcommand"]
- Just (l, p) = pOpts p args a
-pOpts (SubParsers ps) [] a = Error ["One of these subcommands required: " +++ join ", " (map fst ps)]
-pOpts (Flags fs) [arg:args] a
- | not (startsWith "--" arg) = Ok (a, [arg:args])
- = case find (\(l,p)->"--" +++ l == arg) fs of
- Nothing = Error ["Unrecognized option: " +++ arg]
- Just (l, p) = p args a >>= \(a, args)->pOpts (Flags fs) args a
-pOpts (BinaryFlag yes no) args a
- = pOpts (Positionals [("BOOL", \s v->
- if (s == "True")
- (Ok (yes v))
- (if (s == "False")
- (Ok (no v))
- (Error ["Not True or False"])
- )
- )]) args a
-pOpts t args a = Ok (a, args)
-
-pHelp :: (Opt a) -> [String]
-pHelp (Positionals []) = []
-pHelp (Positionals [(i, _):ps]) = [i, " ":pHelp $ Positionals ps]
-pHelp (SubParsers ps) =
- flatten
- [[n, " ":pHelp opt] ++ ["\n"]
- \\(n, opt)<-ps
- ]
-pHelp (Flags fs) =
- ["Flags\n"
- :
- flatten
- [["--",f, "\n"]
- \\(f, p)<-fs
- ]
- ]
-
-:: T =
- { field :: (Int,Int)
- , field2 :: String
- , t2 :: C
- }
-:: T2 = {f :: Int, f2 :: Bool}
-:: C = A Int | B | C Bool
-
-:: ADT
- = ADT1
- | ADT2 Int String
-
-derive binumap Opt, [], (,), MaybeError
-derive gopt T, T2, ADT, C
-
-Start w
-# ([argv0:args], w) = getCommandLine w
-//= pHelp opt
-= parseOpts args {field=(0, 0),field2="",t2=A 4}
-
-opt :: Opt T
-opt = gopt{|*|}
--- /dev/null
+module shallow
+
+import StdEnv
+
+:: DSL = DSL a
+
+lit :: a -> DSL a
+lit a = ...
+++ /dev/null
-module struct
-
-import StdEnv
-import StdGeneric
-import StdDebug
-
-import Text
-
-import Data.Functor
-import Control.Applicative
-
-toEnumValue :: GenericConsDescriptor -> String
-toEnumValue gcd = gcd.gcd_type_def.gtd_name +++ "_" +++ gcd.gcd_name
-
-toEnumType :: GenericTypeDefDescriptor -> String
-toEnumType gtd = "enum cleanc_" +++ gtd.gtd_name
-
-class gGenerateC a | gToCType{|*|}, gToCValue{|*|}, gToCEnums{|*|} a
-
-:: CInfo a = {header :: String , toValue :: a -> String}
-
-generateCInfo :: CInfo a | gGenerateC a
-generateCInfo =
- let
- (CEnums enums) = cast res gToCEnums{|*|}
- (SM types) = cast res gToCType{|*|}
- res =
- { header = concat
- [ join "\n" (removeDup (sort enums))
- , "\n\n"
- , concat (types {fresh=0,inRecord=False,indent=0} [])
- , ";"
- ]
- , toValue = \a->concat (gToCValue{|*|} a [])
- }
- in res
-where
- cast :: (v a) -> ((w a) -> w a)
- cast _ = id
-
-generic gToCType a :: Structmaker a
-:: Structmaker a = SM (SData [String] -> [String]) | StructMakerOnzin a
-:: SData = {indent :: Int, fresh :: Int, inRecord :: Bool}
-indent s c = [createArray s.indent '\t':c]
-show str s c = indent s [str:c]
-
-gToCType{|Int|} = SM (show "uint64_t")
-gToCType{|Real|} = SM (show "double")
-gToCType{|Bool|} = SM (show "bool")
-gToCType{|UNIT|} = SM \_->id
-gToCType{|EITHER|} (SM fl) (SM fr) = SM \s->fl s o fr s
-gToCType{|PAIR|} (SM fl) (SM fr)
- = SM \s c
- | s.inRecord = fl s (fr s c)
- = fl s [" f", toString s.fresh, ";\n":fr {s & fresh=s.fresh+1} c]
-gToCType{|OBJECT of gtd|} (SM f)
- //Newtype
- | gtd.gtd_num_conses == 0 = SM f
- = SM \s c
- //Enumeration (no data)
- | and [gcd.gcd_arity == 0\\gcd<-gtd.gtd_conses] = indent s [toEnumType gtd:c]
- //Regular ADTs
- # s` = {s & indent = s.indent + 1}
- = indent s ["struct clean_", gtd.gtd_name, " {\n":
- indent s` [toEnumType gtd, " cons;\n":
- indent s` ["union {\n":
- f {s` & indent=s`.indent+1, inRecord=False} (indent s` ["} data;\n":
- indent s ["}":c]])]]]
-gToCType{|CONS of gcd|} (SM f)
- //No data field
- | gcd.gcd_arity == 0 = SM \_->id
- //Only one data field
- | gcd.gcd_arity == 1 = SM \s c->f s [" ", gcd.gcd_name, ";\n":c]
- = SM \s c->indent s ["struct {\n":f {s & indent=s.indent+1} [" f", toString (gcd.gcd_arity - 1), ";\n":indent s ["} ", gcd.gcd_name, ";\n":c]]]
-gToCType{|RECORD of grd|} (SM f)
- = SM \s c->indent s ["struct clean_", grd.grd_name, " {\n": f {s & indent=s.indent+1, inRecord=True} (indent s ["}":c])]
-gToCType{|FIELD of gfd|} (SM f) = SM \s c->f s [" ", gfd.gfd_name,";\n":c]
-
-:: CEnums a = CEnums [String] | CEnumsOnzin a
-generic gToCEnums a :: CEnums a
-gToCEnums{|a|} = CEnums []
-gToCEnums{|UNIT|} = CEnums []
-gToCEnums{|EITHER|} (CEnums fl) (CEnums fr) = CEnums (fl ++ fr)
-gToCEnums{|PAIR|} (CEnums fl) (CEnums fr) = CEnums (fl ++ fr)
-gToCEnums{|OBJECT of gtd|} (CEnums f) = CEnums [concat [toEnumType gtd, " {", join ", " (map toEnumValue gtd.gtd_conses), "};"]:f]
-gToCEnums{|CONS|} (CEnums f) = CEnums f
-gToCEnums{|RECORD|} (CEnums f) = CEnums f
-gToCEnums{|FIELD|} (CEnums f) = CEnums f
-
-generic gToCValue a :: a [String] -> [String]
-gToCValue{|Int|} i c = [toString i:c]
-gToCValue{|Real|} r c = [toString r:c]
-gToCValue{|Bool|} b c = [if b "true" "false":c]
-gToCValue{|UNIT|} _ _ = []
-gToCValue{|EITHER|} fl _ (LEFT l) c = fl l c
-gToCValue{|EITHER|} _ fr (RIGHT l) c = fr l c
-gToCValue{|PAIR|} fl fr (PAIR l r) c = fl l [", ":fr r c]
-gToCValue{|OBJECT of gtd|} f (OBJECT a) c
- //Newtype
- | gtd.gtd_num_conses == 0 = f a c
- | and [gcd.gcd_arity == 0\\gcd<-gtd.gtd_conses] = f a c
- = ["{":f a ["}":c]]
-gToCValue{|CONS of gcd|} f (CONS a) c
- //No data field
- | gcd.gcd_arity == 0 = [toEnumValue gcd:c]
- | gcd.gcd_arity == 1 = [" .cons=",toEnumValue gcd,", .data.",gcd.gcd_name,"=":f a c]
- = [" .cons=",toEnumValue gcd,", .data.",gcd.gcd_name,"={":f a ["} ":c]]
-gToCValue{|RECORD|} f (RECORD a) c = ["{":f a ["}":c]]
-gToCValue{|FIELD of gfd|} f (FIELD a) c = [" .", gfd.gfd_name, "=": f a c]
-
-:: DHTDetails
- = DHT Int Bool
- | SHT Addr
- | XXX Int Int Int
- | XXY Int Int DHTType
-
-:: Addr =: Addr Int
-
-:: DHTType = DHT11 | DHT12 | DHT22
-
-derive class gGenerateC DHTDetails, DHTType, Addr, Record
-
-Start :: CInfo Record
-Start = generateCInfo
-
-:: Record =
- { field1 :: Int
- , field2 :: Bool
- , field3 :: DHTType
- , field4 :: DHTDetails
- }
module test
-import StdEnv, StdGeneric
-import Data.Array
-
-Start :: [{!Int}]
-Start =
- [ appendArr {!1,2,3} {!4,5,6,7}
- , appendArr {!} {!}
- , appendArr {!} {!1,2,3}
- , appendArr {!1,2,3} {!}
- ]
-/*
-derive bimap Box
-
-:: Box b a =: Box b
-
-unBox (Box b) :== b
-box b :== Box b
-
-generic gPotentialInf a :: [String] -> Box Bool a
-
-gPotentialInf{|World|} _ = box False
-gPotentialInf{|File|} _ = box False
-gPotentialInf{|Bool|} _ = box False
-gPotentialInf{|Char|} _ = box False
-gPotentialInf{|Real|} _ = box False
-gPotentialInf{|Int|} _ = box False
-gPotentialInf{|Dynamic|} _ = box False
-gPotentialInf{|(->)|} _ _ _ = box False
-gPotentialInf{|{}|} a m = box (unBox (a m))
-gPotentialInf{|{!}|} a m = box (unBox (a m))
-gPotentialInf{|{#}|} a m = box (unBox (a m))
-gPotentialInf{|UNIT|} _ = box False
-gPotentialInf{|EITHER|} l r m = box (unBox (l m) || unBox (r m))
-gPotentialInf{|PAIR|} l r m = box (unBox (l m) || unBox (r m))
-gPotentialInf{|CONS|} x m = box (unBox (x m))
-gPotentialInf{|FIELD|} x m = box (unBox (x m))
-gPotentialInf{|RECORD of {grd_name}|} x m
- | isMember grd_name m = box True
- = box (unBox (x [grd_name:m]))
-gPotentialInf{|OBJECT of {gtd_name}|} x m
- | isMember gtd_name m = box True
- = box (unBox (x [gtd_name:m]))
-
-//derive gPotentialInf Int,Bool,Char,Real,String,File,World,Dynamic
-derive gPotentialInf (),(,),(,,),(,,,),(,,,,),(,,,,,),(,,,,,,),(,,,,,,,),(,,,,,,,,),(,,,,,,,,,),(,,,,,,,,,,),(,,,,,,,,,,,),(,,,,,,,,,,,,),(,,,,,,,,,,,,,),(,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,),(,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,)
-derive gPotentialInf {},{#},{!},[],[! ],[ !],[!!],[#],[#!]
-
-Start :: Box Bool *File
-Start = gPotentialInf{|*|} []
-*/
+import StdEnv
+import Data.Maybe
+import Data.Functor
+import Control.Monad
+import Control.Applicative
+
+class expr v where
+ lit :: i -> v i | toString i
+ (+.) infixl 6 :: (v i) (v i) -> v i | + i
+
+instance + (v a) | expr v & + a where
+ + l r = l +. r
+
+eval :: (Maybe a) -> Maybe a
+eval x = x
+instance expr Maybe where
+ lit i = Just i
+ +. x y = (+) <$> x <*> y
+
+:: Print a =: Print String
+print :: (Print a) -> String
+print (Print a) = a
+instance expr Print where
+ lit i = Print (toString i)
+ +. (Print l) (Print r) = Print (l +++ "+" +++ r)
+
+printEval :: (A.v: v a | expr v) -> (Maybe a, String)
+//printEval f = (f, let (Print p) = f in p)
+printEval f = (eval f, print f)
+
+//Mag niet
+//Start :: (Maybe Int, String)
+//Start = printEval (lit 4 + lit 38)
+
+//Mag wel
+Start = let (Print f) = lit 4 + lit 38 in f
repositories / clean-tests.git / commitdiff