Commit 35aa03e8 by Björn Peemöller

### Arity problems (hopefully) solved

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