Commit 35aa03e8 by Björn Peemöller

### Arity problems (hopefully) solved

parent dbab7444
 ... @@ -99,23 +99,24 @@ by which the variables get renamed. ... @@ -99,23 +99,24 @@ by which the variables get renamed. > modifyRenameEnv :: (RenameEnv -> RenameEnv) -> SCM () > modifyRenameEnv :: (RenameEnv -> RenameEnv) -> SCM () > modifyRenameEnv f = S.modify $\ s -> s { renameEnv = f$ renameEnv s } > modifyRenameEnv f = S.modify $\ s -> s { renameEnv = f$ renameEnv s } > incId :: SCM () > incId = S.modify $\ s -> s { currentId = succ$ currentId s } > getCurrentId :: SCM Integer > getCurrentId = S.gets currentId > newId :: SCM Integer > newId = incId >> getCurrentId > inNestedEnv :: SCM a -> SCM a > inNestedEnv :: SCM a -> SCM a > inNestedEnv act = do > inNestedEnv act = do > oldEnv <- getRenameEnv > oldEnv <- getRenameEnv > modifyRenameEnv nestEnv > modifyRenameEnv nestEnv > S.modify $\ s -> s { currentId = succ$ currentId s } > incId > res <- act > res <- act > modifyRenameEnv $const oldEnv > modifyRenameEnv$ const oldEnv > return res > return res > newId :: SCM Integer > newId = do > S.modify $\ s -> s { currentId = succ$ currentId s } > getCurrentId > getCurrentId :: SCM Integer > getCurrentId = S.gets currentId > report :: Message -> SCM () > report :: Message -> SCM () > report msg = S.modify $\ s -> s { errors = msg : errors s } > report msg = S.modify$ \ s -> s { errors = msg : errors s } ... ...
 ... @@ -27,7 +27,7 @@ type annotation is present. ... @@ -27,7 +27,7 @@ type annotation is present. > import qualified Control.Monad.State as S (State, runState, gets, modify) > import qualified Control.Monad.State as S (State, runState, gets, modify) > import Data.List (nub, partition) > import Data.List (nub, partition) > import qualified Data.Map as Map (Map, empty, insert, lookup) > import qualified Data.Map as Map (Map, empty, insert, lookup) > import Data.Maybe (catMaybes, fromJust, isJust, listToMaybe, maybeToList) > import Data.Maybe (catMaybes, fromJust, fromMaybe, isJust, listToMaybe, maybeToList) > import qualified Data.Set as Set (Set, fromList, member, notMember, unions) > import qualified Data.Set as Set (Set, fromList, member, notMember, unions) > import Text.PrettyPrint > import Text.PrettyPrint ... @@ -436,22 +436,24 @@ signature the declared type must be too general. ... @@ -436,22 +436,24 @@ signature the declared type must be too general. > genDecl :: ModuleIdent -> TCEnv -> SigEnv -> Set.Set Int -> TypeSubst -> Decl > genDecl :: ModuleIdent -> TCEnv -> SigEnv -> Set.Set Int -> TypeSubst -> Decl > -> TCM () > -> TCM () > genDecl m tcEnv sigs lvs theta (FunctionDecl _ f _) = > genDecl m tcEnv sigs lvs theta (FunctionDecl _ f (Equation _ lhs _ : _)) = > modifyValueEnv (genVar True m tcEnv sigs lvs theta f) > modifyValueEnv (genVar True m tcEnv sigs lvs theta arity f) > genDecl m tcEnv sigs lvs theta (PatternDecl _ t _) = > where arity = Just $length$ snd $flatLhs lhs > mapM_ (modifyValueEnv . genVar False m tcEnv sigs lvs theta ) (bv t) > genDecl m tcEnv sigs lvs theta (PatternDecl _ t _) = > mapM_ (modifyValueEnv . genVar False m tcEnv sigs lvs theta Nothing) (bv t) > genDecl _ _ _ _ _ _ = internalError "TypeCheck.genDecl: no pattern match" > genDecl _ _ _ _ _ _ = internalError "TypeCheck.genDecl: no pattern match" > genVar :: Bool -> ModuleIdent -> TCEnv -> SigEnv -> Set.Set Int -> TypeSubst > genVar :: Bool -> ModuleIdent -> TCEnv -> SigEnv -> Set.Set Int -> TypeSubst > -> Ident -> ValueEnv -> ValueEnv > -> Maybe Int -> Ident -> ValueEnv -> ValueEnv > genVar poly m tcEnv sigs lvs theta v tyEnv = case lookupTypeSig v sigs of > genVar poly m tcEnv sigs lvs theta ma v tyEnv = case lookupTypeSig v sigs of > Just sigTy > Just sigTy > | cmpTypes sigma (expandPolyType m tcEnv sigTy) -> tyEnv' > | cmpTypes sigma (expandPolyType m tcEnv sigTy) -> tyEnv' > | otherwise -> errorAt (positionOfIdent v) > | otherwise -> errorAt (positionOfIdent v) > (errTypeSigTooGeneral m what sigTy sigma) > (errTypeSigTooGeneral m what sigTy sigma) > Nothing -> tyEnv' > Nothing -> tyEnv' > where what = text (if poly then "Function:" else "Variable:") <+> ppIdent v > where what = text (if poly then "Function:" else "Variable:") <+> ppIdent v > tyEnv' = rebindFun m v (varArity v tyEnv) sigma tyEnv > tyEnv' = rebindFun m v arity sigma tyEnv > arity = fromMaybe (varArity v tyEnv) ma > sigma = genType poly (subst theta (varType v tyEnv)) > sigma = genType poly (subst theta (varType v tyEnv)) > genType poly' (ForAll n ty) > genType poly' (ForAll n ty) > | n > 0 = internalError$ "TypeCheck.genVar: " ++ showLine (positionOfIdent v) ++ show v ++ " :: " ++ show ty > | n > 0 = internalError $"TypeCheck.genVar: " ++ showLine (positionOfIdent v) ++ show v ++ " :: " ++ show ty ... ...  ... @@ -11,7 +11,8 @@ are considered equal if their original names match. ... @@ -11,7 +11,8 @@ are considered equal if their original names match. \begin{verbatim} \begin{verbatim} > module Env.Value > module Env.Value > ( ValueEnv, ValueInfo (..), bindGlobalInfo, bindFun, rebindFun, bindLabel > ( ValueEnv, ValueInfo (..) > , bindGlobalInfo, bindFun, qualBindFun, rebindFun, unbindFun, bindLabel > , lookupValue, qualLookupValue, qualLookupCons, lookupTuple, tupleDCs > , lookupValue, qualLookupValue, qualLookupCons, lookupTuple, tupleDCs > , initDCEnv, ppTypes ) where > , initDCEnv, ppTypes ) where ... @@ -80,6 +81,11 @@ allow the usage of the qualified list constructor \texttt{(Prelude.:)}. ... @@ -80,6 +81,11 @@ allow the usage of the qualified list constructor \texttt{(Prelude.:)}. > v = Value qf a ty > v = Value qf a ty > fun = "Base.bindFun" > fun = "Base.bindFun" > qualBindFun :: ModuleIdent -> Ident -> Int -> TypeScheme -> ValueEnv -> ValueEnv > qualBindFun m f a ty = qualBindTopEnv "Base.qualBindFun" qf$ > Value qf a ty > where qf = qualifyWith m f > rebindFun :: ModuleIdent -> Ident -> Int -> TypeScheme -> ValueEnv > rebindFun :: ModuleIdent -> Ident -> Int -> TypeScheme -> ValueEnv > -> ValueEnv > -> ValueEnv > rebindFun m f a ty > rebindFun m f a ty ... @@ -88,6 +94,9 @@ allow the usage of the qualified list constructor \texttt{(Prelude.:)}. ... @@ -88,6 +94,9 @@ allow the usage of the qualified list constructor \texttt{(Prelude.:)}. > where qf = qualifyWith m f > where qf = qualifyWith m f > v = Value qf a ty > v = Value qf a ty > unbindFun :: Ident -> ValueEnv -> ValueEnv > unbindFun = unbindTopEnv > bindLabel :: Ident -> QualIdent -> TypeScheme -> ValueEnv -> ValueEnv > bindLabel :: Ident -> QualIdent -> TypeScheme -> ValueEnv -> ValueEnv > bindLabel l r ty tyEnv = bindTopEnv "Base.bindLabel" l v tyEnv > bindLabel l r ty tyEnv = bindTopEnv "Base.bindLabel" l v tyEnv > where v = Label (qualify l) r ty > where v = Label (qualify l) r ty ... ...
 ... @@ -249,25 +249,27 @@ visitFuncDecl (IL.FunctionDecl qident params typeexpr expression) = do ... @@ -249,25 +249,27 @@ visitFuncDecl (IL.FunctionDecl qident params typeexpr expression) = do let argtypes = splitoffArgTypes typeexpr params let argtypes = splitoffArgTypes typeexpr params setFunctionId (qident, argtypes) setFunctionId (qident, argtypes) qname <- visitQualIdent qident qname <- visitQualIdent qident arity <- fromMaybe (length params) liftM lookupIdArity qident whenFlatCurry whenFlatCurry (do is <- mapM newVarIndex params (do is <- mapM newVarIndex params texpr <- visitType typeexpr texpr <- visitType typeexpr expr <- visitExpression expression expr <- visitExpression expression vis <- getVisibility False qident vis <- getVisibility False qident clearVarIndices clearVarIndices return (Func qname (length params) vis texpr (Rule is expr)) return (Func qname arity vis texpr (Rule is expr)) ) ) (do texpr <- visitType typeexpr (do texpr <- visitType typeexpr clearVarIndices clearVarIndices return (Func qname (length params) Public texpr (Rule [] (Var $mkIdx 0))) return (Func qname arity Public texpr (Rule [] (Var$ mkIdx 0))) ) ) visitFuncDecl (IL.ExternalDecl qident _ extname typeexpr) = do visitFuncDecl (IL.ExternalDecl qident _ extname typeexpr) = do setFunctionId (qident, []) setFunctionId (qident, []) texpr <- visitType typeexpr texpr <- visitType typeexpr qname <- visitQualIdent qident qname <- visitQualIdent qident arity <- fromMaybe (typeArity typeexpr) liftM lookupIdArity qident vis <- getVisibility False qident vis <- getVisibility False qident xname <- visitExternalName extname xname <- visitExternalName extname return $Func qname (typeArity typeexpr) vis texpr (External xname) return$ Func qname arity vis texpr (External xname) visitFuncDecl (IL.NewtypeDecl _ _ _) = do visitFuncDecl (IL.NewtypeDecl _ _ _) = do mid <- moduleId mid <- moduleId internalError $"\"" ++ Id.moduleName mid internalError$ "\"" ++ Id.moduleName mid ... ...
 ... @@ -30,7 +30,6 @@ lifted to the top-level. ... @@ -30,7 +30,6 @@ lifted to the top-level. > import Base.Expr > import Base.Expr > import Base.Messages (internalError) > import Base.Messages (internalError) > import Base.SCC > import Base.SCC > import Base.TopEnv > import Base.Types > import Base.Types > import Env.Eval (EvalEnv) > import Env.Eval (EvalEnv) ... @@ -195,15 +194,17 @@ in the type environment. ... @@ -195,15 +194,17 @@ in the type environment. > where tys = map (varType tyEnv) fvs > where tys = map (varType tyEnv) fvs > abstractFunType f tyEnv' = > abstractFunType f tyEnv' = > qualBindFun m (liftIdent pre f) > qualBindFun m (liftIdent pre f) > (foldr TypeArrow (varType tyEnv' f) tys) > (length fvs + varArity tyEnv' f) -- (arrowArity ty) > (polyType ty) > (unbindFun f tyEnv') > (unbindFun f tyEnv') > where ty = foldr TypeArrow (varType tyEnv' f) tys > abstractFunAnnots :: ModuleIdent -> String -> [Ident] -> EvalEnv -> EvalEnv > abstractFunAnnots :: ModuleIdent -> String -> [Ident] -> EvalEnv -> EvalEnv > abstractFunAnnots _ pre fs evEnv = foldr abstractFunAnnot evEnv fs > abstractFunAnnots _ pre fs evEnv = foldr abstractFunAnnot evEnv fs > where abstractFunAnnot f evEnv' = > where > case Map.lookup f evEnv' of > abstractFunAnnot f evEnv' = case Map.lookup f evEnv' of > Just ev -> Map.insert (liftIdent pre f) ev (Map.delete f evEnv') > Just ev -> Map.insert (liftIdent pre f) ev (Map.delete f evEnv') > Nothing -> evEnv' > Nothing -> evEnv' > abstractFunDecl :: String -> [Ident] -> [Ident] > abstractFunDecl :: String -> [Ident] -> [Ident] > -> AbstractEnv -> Decl -> LiftM Decl > -> AbstractEnv -> Decl -> LiftM Decl ... @@ -305,18 +306,15 @@ to the top-level. ... @@ -305,18 +306,15 @@ to the top-level. > apply :: Expression -> [Expression] -> Expression > apply :: Expression -> [Expression] -> Expression > apply = foldl Apply > apply = foldl Apply > qualBindFun :: ModuleIdent -> Ident -> Type -> ValueEnv -> ValueEnv > varArity :: ValueEnv -> Ident -> Int > qualBindFun m f ty = qualBindTopEnv "Lift.qualBindFun" qf $> varArity tyEnv v = case lookupValue v tyEnv of > Value qf (arrowArity ty) (polyType ty) > [Value _ a _] -> a > where qf = qualifyWith m f > _ -> internalError$ "Lift.varArity: " ++ show v > unbindFun :: Ident -> ValueEnv -> ValueEnv > unbindFun = unbindTopEnv > varType :: ValueEnv -> Ident -> Type > varType :: ValueEnv -> Ident -> Type > varType tyEnv v = case lookupValue v tyEnv of > varType tyEnv v = case lookupValue v tyEnv of > [Value _ _ (ForAll _ ty)] -> ty > [Value _ _ (ForAll _ ty)] -> ty > _ -> internalError $"Lift.varType " ++ show v > _ -> internalError$ "Lift.varType: " ++ show v > liftIdent :: String -> Ident -> Ident > liftIdent :: String -> Ident -> Ident > liftIdent prefix x = renameIdent (mkIdent $prefix ++ show x)$ uniqueId x > liftIdent prefix x = renameIdent (mkIdent $prefix ++ show x)$ uniqueId x ... ...
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!