Commit 35aa03e8 authored by Björn Peemöller 's avatar Björn Peemöller
Browse files

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!
Please register or to comment