Arity problems (hopefully) solved

src/Checks/SyntaxCheck.lhs

@@ -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 }
 

src/Checks/TypeCheck.lhs

@@ -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

src/Env/Value.lhs

@@ -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

src/Generators/GenFlatCurry.hs

@@ -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

src/Transformations/Lift.lhs

@@ -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