Non-primitive result type in ExprTypeFunction constructor

2 files changed, 20 insertions, 27 deletions

diff --git a/src/Parser/Core.hs b/src/Parser/Core.hs
index c317067..f2445a2 100644
--- a/src/Parser/Core.hs
+++ b/src/Parser/Core.hs
@@ -106,7 +106,7 @@ lookupVarExpr off sline name = do
     case etype of
         ExprTypePrim (Proxy :: Proxy a) -> return $ SomeExpr $ (Variable sline fqn :: Expr a)
         ExprTypeConstr1 _ -> return $ SomeExpr $ (Undefined "incomplete type" :: Expr DynamicType)
-        ExprTypeFunction args (_ :: Proxy a) -> return $ SomeExpr $ (FunVariable args sline fqn :: Expr (FunctionType a))
+        ExprTypeFunction args (ExprTypePrim (_ :: Proxy a)) -> return $ SomeExpr $ (FunVariable args sline fqn :: Expr (FunctionType a))
         stype -> return $ SomeExpr $ DynVariable stype sline fqn
 
 lookupScalarVarExpr :: Int -> SourceLine -> VarName -> TestParser SomeExpr
@@ -115,7 +115,7 @@ lookupScalarVarExpr off sline name = do
     case etype of
         ExprTypePrim (Proxy :: Proxy a) -> return $ SomeExpr $ (Variable sline fqn :: Expr a)
         ExprTypeConstr1 _ -> return $ SomeExpr $ (Undefined "incomplete type" :: Expr DynamicType)
-        ExprTypeFunction args (pa :: Proxy a) -> do
+        ExprTypeFunction args (ExprTypePrim (pa :: Proxy a)) -> do
             SomeExpr <$> unifyExpr off pa (FunVariable args sline fqn :: Expr (FunctionType a))
         stype -> return $ SomeExpr $ DynVariable stype sline fqn
 
diff --git a/src/Script/Expr.hs b/src/Script/Expr.hs
index 9e4ffa0..3d26157 100644
--- a/src/Script/Expr.hs
+++ b/src/Script/Expr.hs
@@ -276,7 +276,7 @@ data SomeExprType
     = forall a. ExprType a => ExprTypePrim (Proxy a)
     | forall a. ExprTypeConstr1 a => ExprTypeConstr1 (Proxy a)
     | ExprTypeVar TypeVar
-    | forall a. ExprType a => ExprTypeFunction (FunctionArguments SomeArgumentType) (Proxy a)
+    | ExprTypeFunction (FunctionArguments SomeArgumentType) SomeExprType
     | ExprTypeApp SomeExprType [ SomeExprType ]
     | ExprTypeForall TypeVar SomeExprType
 
@@ -288,28 +288,21 @@ someExprType (SomeExpr expr) = go expr
         DynVariable stype _ _ -> stype
         HideType e -> go e
         TypeLambda tvar stype _ -> ExprTypeForall tvar stype
-        (e :: Expr a)
-            | IsFunType <- asFunType e -> ExprTypeFunction (gof e) (proxyOfFunctionType e)
-            | otherwise -> ExprTypePrim (Proxy @a)
-
-    gof :: forall e. ExprType e => Expr (FunctionType e) -> FunctionArguments SomeArgumentType
-    gof = \case
-        Let _ _ _ body -> gof body
-        Variable {} -> error "someExprType: gof: variable"
-        FunVariable params _ _ -> params
-        ArgsReq args body -> fmap snd args <> gof body
-        ArgsApp (FunctionArguments used) body ->
-            let FunctionArguments args = gof body
-             in FunctionArguments $ args `M.difference` used
-        FunctionAbstraction {} -> mempty
-        FunctionEval {} -> error "someExprType: gof: function eval"
-        TypeApp {} -> error "someExprType: gof: type application"
-        Pure {} -> error "someExprType: gof: pure"
-        App {} -> error "someExprType: gof: app"
-        Undefined {} -> error "someExprType: gof: undefined"
-
-    proxyOfFunctionType :: Expr (FunctionType a) -> Proxy a
-    proxyOfFunctionType _ = Proxy
+
+        ArgsReq args inner -> exprTypeFunction (fmap snd args) (go inner)
+        ArgsApp (FunctionArguments used) inner
+            | ExprTypeFunction (FunctionArguments args) x <- go inner
+            -> ExprTypeFunction (FunctionArguments (args `M.difference` used)) x
+        FunctionAbstraction inner -> exprTypeFunction mempty (go inner)
+        FunctionEval _ inner
+            | ExprTypeFunction _ x <- go inner -> x
+
+        (_ :: Expr a) -> ExprTypePrim (Proxy @a)
+
+    exprTypeFunction :: FunctionArguments SomeArgumentType -> SomeExprType -> SomeExprType
+    exprTypeFunction args (ExprTypeFunction args' inner) = ExprTypeFunction (args <> args') inner
+    exprTypeFunction args inner = ExprTypeFunction args inner
+
 
 renameTypeVar :: TypeVar -> TypeVar -> Expr a -> Expr a
 renameTypeVar a b = go
@@ -364,7 +357,7 @@ textSomeExprType = go []
     go (x : _) (ExprTypeConstr1 c) = textExprTypeConstr1 c x
     go [] (ExprTypeConstr1 _) = "<incomplte type>"
     go _ (ExprTypeVar (TypeVar name)) = name
-    go _ (ExprTypeFunction _ r) = "function:" <> textExprType r
+    go _ (ExprTypeFunction _ r) = "function:" <> textSomeExprType r
     go _ (ExprTypeApp c xs) = go (map textSomeExprType xs) c
     go _ (ExprTypeForall (TypeVar name) ctype) = "∀" <> name <> "." <> go [] ctype
 
@@ -425,7 +418,7 @@ textSomeVarValue (SomeVarValue (VarValue _ args value))
 someVarValueType :: SomeVarValue -> SomeExprType
 someVarValueType (SomeVarValue (VarValue _ args _ :: VarValue a))
     | anull args = ExprTypePrim (Proxy @a)
-    | otherwise  = ExprTypeFunction args (Proxy @a)
+    | otherwise  = ExprTypeFunction args (ExprTypePrim (Proxy @a))
 
 
 newtype ArgumentKeyword = ArgumentKeyword Text