Commit a5780c38 authored by Arjen van Weelden's avatar Arjen van Weelden
Browse files

*** empty log message ***

parent ffcbb6f8
......@@ -20,6 +20,7 @@ import EstherParser, StdMaybe
| CoreCode !Dynamic
| CoreVariable !String
| CoreDynamic
// | CoreEta
class resolveFilename env :: !String !*env -> (!Maybe (Dynamic, GenConsPrio), !*env)
......
......@@ -20,27 +20,40 @@ overloaded3 :: !String !String !String !Dynamic -> Dynamic
overloaded3 c1 c2 c3 ((_, _, _, e) :: (v1, v2, v3, d1 d2 d3 -> t)) = dynamic (\(dict1 &&& dict2 &&& dict3) -> e dict1 dict2 dict3) ||| Class c1 &&& Class c2 &&& Class c3 :: Overloaded (Contexts d1 (Contexts d2 d3)) t (Contexts (Context v1) (Contexts (Context v2) (Context v3)))
abstract :: !String !Core -> Core
abstract v e | freeVar v e = coreK @ e
abstract v e | noVarOf v e = coreK @ e
abstract v (CoreVariable x) = coreI
//abstract v (srcf @ CoreVariable x) | noVarOf v srcf = srcf //dangerous!
/*abstract v (srcf @ CoreVariable x) | noVarOf v srcf = case srcf of
CoreCode (f :: a -> b) -> srcf
_ -> CoreEta @ srcf*/
abstract v (srcf @ srcx @ srcy)
| freeVar v srcf
| freeVar v srcx = coreB` @ srcf @ srcx @ abstract v srcy
| freeVar v srcy = coreC` @ srcf @ abstract v srcx @ srcy
| noVarOf v srcf
| noVarOf v srcx = coreB` @ srcf @ srcx @ abstract v srcy
| noVarOf v srcy = coreC` @ srcf @ abstract v srcx @ srcy
= coreS` @ srcf @ abstract v srcx @ abstract v srcy
abstract v (srcf @ srcx)
| freeVar v srcf = coreB @ srcf @ abstract v srcx
| freeVar v srcx = coreC @ abstract v srcf @ srcx
| noVarOf v srcf = coreB @ srcf @ abstract v srcx
| noVarOf v srcx = coreC @ abstract v srcf @ srcx
= coreS @ abstract v srcf @ abstract v srcx
abstract_ :: !Core -> Core
abstract_ e = coreK @ e
freeVar :: !String !Core -> Bool
freeVar v (f @ x) = freeVar v f && freeVar v x
freeVar v (CoreVariable x) = v <> x
freeVar _ _ = True
noVarOf :: !String !Core -> Bool
noVarOf v (f @ x) = noVarOf v f && noVarOf v x
noVarOf v (CoreVariable x) = v <> x
noVarOf _ _ = True
coreF = dynamic F :: A.a b: (a -> b) a -> b
F f x = f x
generateCode :: !Core !*env -> (!Dynamic, !*env) | resolveFilename env
/*generateCode CoreEta env = (coreF, env)
generateCode (CoreEta @ e) env
# (codef, env) = generateCode e env
= case codef of
(f :: a -> b) -> (dynamic f :: a -> b, env)
_ -> raise (ApplyTypeError codef (dynamic Omega :: A.a b: a -> b))*/
generateCode CoreDynamic env = (dynamic I ||| Class "TC" :: A.z: Overloaded (z -> Dynamic) (z -> Dynamic) (Context z), env)
generateCode (CoreDynamic @ e) env
# (codex, env) = generateCode e env
......@@ -252,9 +265,17 @@ toStringDynamic d = prettyDynamic d
prettyDynamic :: !Dynamic -> ([String], String)
prettyDynamic d = (v, t)
where
v = case d of (x :: a) -> debugShowWithOptions [DebugTerminator "", DebugMaxChars (80 * 22)] x
// v = case d of (x :: a) -> debugShowWithOptions [DebugTerminator "", DebugMaxChars (80 * 22)] x
v = case d of (x :: a) -> debugShowWithOptions [DebugTerminator "", DebugMaxChars 79] x
t = removeForAll (typeCodeOfDynamic d)
where
removeForAll (TypeScheme _ t) = toString t
removeForAll t = toString t
instance toString Core where
toString (CoreApply f x) = toString f +++ " (" +++ toString x +++ ")"
toString (CoreVariable x) = x
toString (CoreCode x) = foldr (+++) "" xs
where
(xs, t) = toStringDynamic x
......@@ -117,43 +117,43 @@ where
patternMatch _ (VariablePattern (NTvariable x _)) then _ = abstract x then
patternMatch _ (AnyPattern _) then _ = abstract_ then
match :: !Dynamic !Int -> Core
match (x :: Real) 1 = ifEqual x
match (x :: Int) 1 = ifEqual x
match (x :: Char) 1 = ifEqual x
match (x :: String) 1 = ifEqual x
match (x :: Bool) 1 = ifEqual x
match constr n = case constructorNode constr of
(arity, x :: a) -> if (n <> arity) (ifMatch x) (raise CaseBadConstructorArity)
where
ifMatch :: !a -> Core | TC a
ifMatch x = CoreCode (dynamic IfConstr :: A.b: (a^ -> b) b a^ -> b)
match :: !Dynamic !Int -> Core
match (x :: Real) 1 = ifEqual x
match (x :: Int) 1 = ifEqual x
match (x :: Char) 1 = ifEqual x
match (x :: String) 1 = ifEqual x
match (x :: Bool) 1 = ifEqual x
match constr n = case constructorNode constr of
(arity, x :: a) -> if (n <> arity) (ifMatch x) (raise CaseBadConstructorArity)
where
IfConstr th el y = if (matchConstructor x y) (th y) el
constructorNode :: !Dynamic -> (!Int, !Dynamic)
constructorNode (f :: a -> b) = (n + 1, d)
ifMatch :: !a -> Core | TC a
ifMatch x = CoreCode (dynamic IfConstr :: A.b: (a^ -> b) b a^ -> b)
where
IfConstr th el y = if (matchConstructor x y) (th y) el
constructorNode :: !Dynamic -> (!Int, !Dynamic)
constructorNode (f :: a -> b) = (n + 1, d)
where
(n, d) = constructorNode (dynamic f (unsafeTypeCast []) :: b)
constructorNode d = (0, d)
ifEqual :: !a -> Core | TC a & == a
ifEqual x = CoreCode (dynamic IfEq :: A.b: (a^ -> b) b a^ -> b)
where
(n, d) = constructorNode (dynamic f (unsafeTypeCast []) :: b)
constructorNode d = (0, d)
IfEq th el y = if (x == y) (th y) el
codeApply :: !Dynamic -> Core
codeApply (_ :: a b c d e f g h i -> j) = raise (NotSupported "constructors with arity above eight")
codeApply (_ :: a b c d e f g h -> i) = CoreCode (dynamic \f n -> f (unsafeSelect1of8 n) (unsafeSelect2of8 n) (unsafeSelect3of8 n) (unsafeSelect4of8 n) (unsafeSelect5of8 n) (unsafeSelect6of8 n) (unsafeSelect7of8 n) (unsafeSelect8of8 n) :: A.j: (a b c d e f g h -> j) i -> j)
codeApply (_ :: a b c d e f g -> h) = CoreCode (dynamic \f n -> f (unsafeSelect1of7 n) (unsafeSelect2of7 n) (unsafeSelect3of7 n) (unsafeSelect4of7 n) (unsafeSelect5of7 n) (unsafeSelect6of7 n) (unsafeSelect7of7 n) :: A.i: (a b c d e f g -> i) h -> i)
codeApply (_ :: a b c d e f -> g) = CoreCode (dynamic \f n -> f (unsafeSelect1of6 n) (unsafeSelect2of6 n) (unsafeSelect3of6 n) (unsafeSelect4of6 n) (unsafeSelect5of6 n) (unsafeSelect6of6 n) :: A.h: (a b c d e f -> h) g -> h)
codeApply (_ :: a b c d e -> f) = CoreCode (dynamic \f n -> f (unsafeSelect1of5 n) (unsafeSelect2of5 n) (unsafeSelect3of5 n) (unsafeSelect4of5 n) (unsafeSelect5of5 n) :: A.g: (a b c d e -> g) f -> g)
codeApply (_ :: a b c d -> e) = CoreCode (dynamic \f n -> f (unsafeSelect1of4 n) (unsafeSelect2of4 n) (unsafeSelect3of4 n) (unsafeSelect4of4 n) :: A.f: (a b c d -> f) e -> f)
codeApply (_ :: a b c -> d) = CoreCode (dynamic \f n -> f (unsafeSelect1of3 n) (unsafeSelect2of3 n) (unsafeSelect3of3 n) :: A.e: (a b c -> e) d -> e)
codeApply (_ :: a b -> c) = CoreCode (dynamic \f n -> f (unsafeSelect1of2 n) (unsafeSelect2of2 n) :: A.d: (a b -> d) c -> d)
codeApply (_ :: a -> b) = CoreCode (dynamic \f n -> f (unsafeSelect1of1 n) :: A.c: (a -> c) b -> c)
codeApply (_ :: a) = CoreCode (dynamic \f n -> f :: A.b: b a -> b)
ifEqual :: !a -> Core | TC a & == a
ifEqual x = CoreCode (dynamic IfEq :: A.b: (a^ -> b) b a^ -> b)
where
IfEq th el y = if (x == y) (th y) el
codeApply :: !Dynamic -> Core
codeApply (_ :: a b c d e f g h i -> j) = raise (NotSupported "constructors with arity above eight")
codeApply (_ :: a b c d e f g h -> i) = CoreCode (dynamic \f n -> f (unsafeSelect1of8 n) (unsafeSelect2of8 n) (unsafeSelect3of8 n) (unsafeSelect4of8 n) (unsafeSelect5of8 n) (unsafeSelect6of8 n) (unsafeSelect7of8 n) (unsafeSelect8of8 n) :: A.j: (a b c d e f g h -> j) i -> j)
codeApply (_ :: a b c d e f g -> h) = CoreCode (dynamic \f n -> f (unsafeSelect1of7 n) (unsafeSelect2of7 n) (unsafeSelect3of7 n) (unsafeSelect4of7 n) (unsafeSelect5of7 n) (unsafeSelect6of7 n) (unsafeSelect7of7 n) :: A.i: (a b c d e f g -> i) h -> i)
codeApply (_ :: a b c d e f -> g) = CoreCode (dynamic \f n -> f (unsafeSelect1of6 n) (unsafeSelect2of6 n) (unsafeSelect3of6 n) (unsafeSelect4of6 n) (unsafeSelect5of6 n) (unsafeSelect6of6 n) :: A.h: (a b c d e f -> h) g -> h)
codeApply (_ :: a b c d e -> f) = CoreCode (dynamic \f n -> f (unsafeSelect1of5 n) (unsafeSelect2of5 n) (unsafeSelect3of5 n) (unsafeSelect4of5 n) (unsafeSelect5of5 n) :: A.g: (a b c d e -> g) f -> g)
codeApply (_ :: a b c d -> e) = CoreCode (dynamic \f n -> f (unsafeSelect1of4 n) (unsafeSelect2of4 n) (unsafeSelect3of4 n) (unsafeSelect4of4 n) :: A.f: (a b c d -> f) e -> f)
codeApply (_ :: a b c -> d) = CoreCode (dynamic \f n -> f (unsafeSelect1of3 n) (unsafeSelect2of3 n) (unsafeSelect3of3 n) :: A.e: (a b c -> e) d -> e)
codeApply (_ :: a b -> c) = CoreCode (dynamic \f n -> f (unsafeSelect1of2 n) (unsafeSelect2of2 n) :: A.d: (a b -> d) c -> d)
codeApply (_ :: a -> b) = CoreCode (dynamic \f n -> f (unsafeSelect1of1 n) :: A.c: (a -> c) b -> c)
codeApply (_ :: a) = CoreCode (dynamic \f n -> f :: A.b: b a -> b)
dynamicTuple :: !Int -> Dynamic
dynamicTuple 2 = dynamicTuple2
dynamicTuple 3 = dynamicTuple3
......
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