Commit bdee80a4 authored by Kai-Oliver Prott's avatar Kai-Oliver Prott

Fix compilation errors resulting from AST changes

parent 65bfd25c
......@@ -103,8 +103,8 @@ syntaxCheck _ (env, mdl)
-- precedences
-- * Environment: The operator precedence environment is updated
precCheck :: Monad m => Check m (Module a)
precCheck _ (env, Module ps m es is ds)
| null msgs = ok (env { opPrecEnv = pEnv' }, Module ps m es is ds')
precCheck _ (env, Module spi ps m es is ds)
| null msgs = ok (env { opPrecEnv = pEnv' }, Module spi ps m es is ds')
| otherwise = failMessages msgs
where (ds', pEnv', msgs) = PC.precCheck (moduleIdent env) (opPrecEnv env) ds
......@@ -122,8 +122,8 @@ deriveCheck _ (env, mdl) = case DC.deriveCheck (tyConsEnv env) mdl of
-- * Declarations: remain unchanged
-- * Environment: The instance environment is updated
instanceCheck :: Monad m => Check m (Module a)
instanceCheck _ (env, Module ps m es is ds)
| null msgs = ok (env { instEnv = inEnv' }, Module ps m es is ds)
instanceCheck _ (env, Module spi ps m es is ds)
| null msgs = ok (env { instEnv = inEnv' }, Module spi ps m es is ds)
| otherwise = failMessages msgs
where (inEnv', msgs) = INC.instanceCheck (moduleIdent env) (tyConsEnv env)
(classEnv env) (instEnv env) ds
......@@ -134,8 +134,8 @@ instanceCheck _ (env, Module ps m es is ds)
-- * Environment: The value environment is updated.
typeCheck :: Monad m => Options -> CompEnv (Module a)
-> CYT m (CompEnv (Module PredType))
typeCheck _ (env, Module ps m es is ds)
| null msgs = ok (env { valueEnv = vEnv' }, Module ps m es is ds')
typeCheck _ (env, Module spi ps m es is ds)
| null msgs = ok (env { valueEnv = vEnv' }, Module spi ps m es is ds')
| otherwise = failMessages msgs
where (ds', vEnv', msgs) = TC.typeCheck (moduleIdent env) (tyConsEnv env)
(valueEnv env) (classEnv env)
......@@ -143,7 +143,7 @@ typeCheck _ (env, Module ps m es is ds)
-- |Check the export specification
exportCheck :: Monad m => Check m (Module a)
exportCheck _ (env, mdl@(Module _ _ es _ _))
exportCheck _ (env, mdl@(Module _ _ _ es _ _))
| null msgs = ok (env, mdl)
| otherwise = failMessages msgs
where msgs = EC.exportCheck (moduleIdent env) (aliasEnv env)
......@@ -151,8 +151,8 @@ exportCheck _ (env, mdl@(Module _ _ es _ _))
-- |Check the export specification
expandExports :: Monad m => Options -> CompEnv (Module a) -> m (CompEnv (Module a))
expandExports _ (env, Module ps m es is ds)
= return (env, Module ps m (Just es') is ds)
expandExports _ (env, Module spi ps m es is ds)
= return (env, Module spi ps m (Just es') is ds)
where es' = EC.expandExports (moduleIdent env) (aliasEnv env)
(tyConsEnv env) (valueEnv env) es
......
......@@ -24,7 +24,7 @@ import Base.Messages (Message, posMessage)
import Env.TypeConstructor
deriveCheck :: TCEnv -> Module a -> [Message]
deriveCheck tcEnv (Module _ m _ _ ds) = concatMap (checkDecl m tcEnv) ds
deriveCheck tcEnv (Module _ _ m _ _ ds) = concatMap (checkDecl m tcEnv) ds
-- No instances can be derived for abstract data types as well as for
-- existential data types.
......
......@@ -53,7 +53,7 @@ ok = return ()
-- if an extension is unkown.
checkModule :: Module a -> EXCM ()
checkModule (Module ps _ _ _ _) = mapM_ checkPragma ps
checkModule (Module _ ps _ _ _ _) = mapM_ checkPragma ps
checkPragma :: ModulePragma -> EXCM ()
checkPragma (LanguagePragma _ exts) = mapM_ checkExtension exts
......
......@@ -28,6 +28,7 @@ import qualified Data.Set.Extra as Set
import Curry.Base.Ident
import Curry.Base.Position
import Curry.Base.Pretty
import Curry.Base.SpanInfo
import Curry.Syntax hiding (impls)
import Curry.Syntax.Pretty
......@@ -149,15 +150,16 @@ declDeriveInfo tcEnv clsEnv (NewtypeDecl p tc tvs nc clss) =
declDeriveInfo _ _ _ =
internalError "InstanceCheck.declDeriveInfo: no data or newtype declaration"
mkDeriveInfo :: TCEnv -> ClassEnv -> Position -> Ident -> [Ident] -> Context
mkDeriveInfo :: TCEnv -> ClassEnv -> SpanInfo -> Ident -> [Ident] -> Context
-> [TypeExpr] -> [QualIdent] -> INCM DeriveInfo
mkDeriveInfo tcEnv clsEnv p tc tvs cx tys clss = do
mkDeriveInfo tcEnv clsEnv spi tc tvs cx tys clss = do
m <- getModuleIdent
let otc = qualifyWith m tc
oclss = map (flip (getOrigName m) tcEnv) clss
PredType ps ty = expandConstrType m tcEnv clsEnv otc tvs cx tys
(tys', ty') = arrowUnapply ty
return $ DeriveInfo p otc (PredType ps ty') tys' $ sortClasses clsEnv oclss
where p = spanInfo2Pos spi
sortClasses :: ClassEnv -> [QualIdent] -> [QualIdent]
sortClasses clsEnv clss = map fst $ sortBy compareDepth $ map adjoinDepth clss
......@@ -248,7 +250,7 @@ reportUndecidable p what doc predicate@(Pred _ ty) = do
-- satisfied by cx.
checkInstance :: TCEnv -> ClassEnv -> Decl a -> INCM ()
checkInstance tcEnv clsEnv (InstanceDecl p cx cls inst _) = do
checkInstance tcEnv clsEnv (InstanceDecl spi cx cls inst _) = do
m <- getModuleIdent
let PredType ps ty = expandPolyType m tcEnv clsEnv $ QualTypeExpr cx inst
ocls = getOrigName m cls tcEnv
......@@ -258,6 +260,7 @@ checkInstance tcEnv clsEnv (InstanceDecl p cx cls inst _) = do
ps'' <- reducePredSet p what doc clsEnv ps'
Set.mapM_ (report . errMissingInstance m p what doc) $
ps'' `Set.difference` (maxPredSet clsEnv ps)
where p = spanInfo2Pos spi
checkInstance _ _ _ = ok
-- All types specified in the optional default declaration of a module
......@@ -267,7 +270,7 @@ checkInstance _ _ _ = ok
checkDefault :: TCEnv -> ClassEnv -> Decl a -> INCM ()
checkDefault tcEnv clsEnv (DefaultDecl p tys) =
mapM_ (checkDefaultType p tcEnv clsEnv) tys
mapM_ (checkDefaultType (spanInfo2Pos p) tcEnv clsEnv) tys
checkDefault _ _ _ = ok
checkDefaultType :: Position -> TCEnv -> ClassEnv -> TypeExpr -> INCM ()
......
......@@ -26,6 +26,7 @@ import Data.List (partition, nub)
import Curry.Base.Ident
import Curry.Base.Position
import Curry.Base.SpanInfo ()
import Curry.Base.Pretty
import Curry.Syntax
import Curry.Syntax.Pretty
......@@ -53,7 +54,7 @@ import Env.TypeConstructor
-- synonyms into the type constructor environment.
kindCheck :: TCEnv -> ClassEnv -> Module a -> ((TCEnv, ClassEnv), [Message])
kindCheck tcEnv clsEnv (Module _ m _ _ ds) = runKCM check initState
kindCheck tcEnv clsEnv (Module _ _ m _ _ ds) = runKCM check initState
where
check = do
checkNonRecursiveTypes tds &&> checkAcyclicSuperClasses cds
......@@ -510,7 +511,7 @@ kcRhs tcEnv (GuardedRhs es ds) = do
kcCondExpr :: TCEnv -> CondExpr a -> KCM ()
kcCondExpr tcEnv (CondExpr p g e) = kcExpr tcEnv p g >> kcExpr tcEnv p e
kcExpr :: TCEnv -> Position -> Expression a -> KCM ()
kcExpr :: HasPosition p => TCEnv -> p -> Expression a -> KCM ()
kcExpr _ _ (Literal _ _) = ok
kcExpr _ _ (Variable _ _) = ok
kcExpr _ _ (Constructor _ _) = ok
......@@ -562,7 +563,7 @@ kcExpr tcEnv p (Case _ e alts) = do
kcExpr tcEnv p e
mapM_ (kcAlt tcEnv) alts
kcStmt :: TCEnv -> Position -> Statement a -> KCM ()
kcStmt :: HasPosition p => TCEnv -> p -> Statement a -> KCM ()
kcStmt tcEnv p (StmtExpr e) = kcExpr tcEnv p e
kcStmt tcEnv _ (StmtDecl ds) = mapM_ (kcDecl tcEnv) ds
kcStmt tcEnv p (StmtBind _ e) = kcExpr tcEnv p e
......@@ -570,20 +571,20 @@ kcStmt tcEnv p (StmtBind _ e) = kcExpr tcEnv p e
kcAlt :: TCEnv -> Alt a -> KCM ()
kcAlt tcEnv (Alt _ _ rhs) = kcRhs tcEnv rhs
kcField :: TCEnv -> Position -> Field (Expression a) -> KCM ()
kcField :: HasPosition p => TCEnv -> p -> Field (Expression a) -> KCM ()
kcField tcEnv p (Field _ _ e) = kcExpr tcEnv p e
kcContext :: TCEnv -> Position -> Context -> KCM ()
kcContext :: HasPosition p => TCEnv -> p -> Context -> KCM ()
kcContext tcEnv p = mapM_ (kcConstraint tcEnv p)
kcConstraint :: TCEnv -> Position -> Constraint -> KCM ()
kcConstraint :: HasPosition p => TCEnv -> p -> Constraint -> KCM ()
kcConstraint tcEnv p sc@(Constraint qcls ty) = do
m <- getModuleIdent
kcType tcEnv p "class constraint" doc (clsKind m qcls tcEnv) ty
where
doc = ppConstraint sc
kcTypeSig :: TCEnv -> Position -> QualTypeExpr -> KCM ()
kcTypeSig :: HasPosition p => TCEnv -> p -> QualTypeExpr -> KCM ()
kcTypeSig tcEnv p (QualTypeExpr cx ty) = do
tcEnv' <- foldM bindFreshKind tcEnv free
kcContext tcEnv' p cx
......@@ -592,17 +593,17 @@ kcTypeSig tcEnv p (QualTypeExpr cx ty) = do
free = filter (null . flip lookupTypeInfo tcEnv) $ nub $ fv ty
doc = ppTypeExpr 0 ty
kcValueType :: TCEnv -> Position -> String -> Doc -> TypeExpr -> KCM ()
kcValueType :: HasPosition p => TCEnv -> p -> String -> Doc -> TypeExpr -> KCM ()
kcValueType tcEnv p what doc = kcType tcEnv p what doc KindStar
kcType :: TCEnv -> Position -> String -> Doc -> Kind -> TypeExpr -> KCM ()
kcType :: HasPosition p => TCEnv -> p -> String -> Doc -> Kind -> TypeExpr -> KCM ()
kcType tcEnv p what doc k ty = do
k' <- kcTypeExpr tcEnv p "type expression" doc' 0 ty
unify p what (doc $-$ text "Type:" <+> doc') k k'
where
doc' = ppTypeExpr 0 ty
kcTypeExpr :: TCEnv -> Position -> String -> Doc -> Int -> TypeExpr -> KCM Kind
kcTypeExpr :: HasPosition p => TCEnv -> p -> String -> Doc -> Int -> TypeExpr -> KCM Kind
kcTypeExpr tcEnv p _ _ n (ConstructorType tc) = do
m <- getModuleIdent
case qualLookupTypeInfo tc tcEnv of
......@@ -634,7 +635,7 @@ kcTypeExpr tcEnv p what doc n (ForallType vs ty) = do
tcEnv' <- foldM bindFreshKind tcEnv $ vs
kcTypeExpr tcEnv' p what doc n ty
kcArrow :: Position -> String -> Doc -> Kind -> KCM (Kind, Kind)
kcArrow :: HasPosition p => p -> String -> Doc -> Kind -> KCM (Kind, Kind)
kcArrow p what doc k = do
theta <- getKindSubst
case subst theta k of
......@@ -653,7 +654,7 @@ kcArrow p what doc k = do
-- ---------------------------------------------------------------------------
-- The unification uses Robinson's algorithm.
unify :: Position -> String -> Doc -> Kind -> Kind -> KCM ()
unify :: HasPosition p => p -> String -> Doc -> Kind -> Kind -> KCM ()
unify p what doc k1 k2 = do
theta <- getKindSubst
let k1' = subst theta k1
......@@ -740,14 +741,14 @@ errRecursiveClasses (cls:clss) = posMessage cls $
classPos cls' =
text (idName cls') <+> parens (text $ showLine $ idPosition cls')
errNonArrowKind :: Position -> String -> Doc -> Kind -> Message
errNonArrowKind :: HasPosition p => p -> String -> Doc -> Kind -> Message
errNonArrowKind p what doc k = posMessage p $ vcat
[ text "Kind error in" <+> text what, doc
, text "Kind:" <+> ppKind k
, text "Cannot be applied"
]
errPartialAlias :: Position -> QualIdent -> Int -> Int -> Message
errPartialAlias :: HasPosition p => p -> QualIdent -> Int -> Int -> Message
errPartialAlias p tc arity argc = posMessage p $ hsep
[ text "Type synonym", ppQIdent tc
, text "requires at least"
......@@ -757,7 +758,7 @@ errPartialAlias p tc arity argc = posMessage p $ hsep
where
plural n x = if n == 1 then x else x ++ "s"
errKindMismatch :: Position -> String -> Doc -> Kind -> Kind -> Message
errKindMismatch :: HasPosition p => p -> String -> Doc -> Kind -> Kind -> Message
errKindMismatch p what doc k1 k2 = posMessage p $ vcat
[ text "Kind error in" <+> text what, doc
, text "Inferred kind:" <+> ppKind k2
......
......@@ -44,6 +44,8 @@ import qualified Data.Set as Set ( Set, empty, insert, member
import Curry.Base.Ident
import Curry.Base.Position
import Curry.Base.Pretty
import Curry.Base.Span
import Curry.Base.SpanInfo
import Curry.Syntax
import Curry.Syntax.Pretty (ppPattern)
......@@ -69,7 +71,7 @@ import Env.Value (ValueEnv, ValueInfo (..))
syntaxCheck :: [KnownExtension] -> TCEnv -> ValueEnv -> Module ()
-> ((Module (), [KnownExtension]), [Message])
syntaxCheck exts tcEnv vEnv mdl@(Module _ m _ _ ds) =
syntaxCheck exts tcEnv vEnv mdl@(Module _ _ m _ _ ds) =
case findMultiples $ concatMap constrs tds of
[] -> case findMultiples (ls ++ fs ++ cs) of
[] -> runSC (checkModule mdl) state
......@@ -438,7 +440,7 @@ qualLookupListCons v env
-- declaration are allowed to be declared).
checkModule :: Module () -> SCM (Module (), [KnownExtension])
checkModule (Module ps m es is ds) = do
checkModule (Module spi ps m es is ds) = do
mapM_ bindTypeDecl tds
mapM_ bindClassDecl cds
ds' <- checkTopDecls ds
......@@ -447,7 +449,7 @@ checkModule (Module ps m es is ds) = do
let ds'' = updateClassAndInstanceDecls cds' ids' ds'
checkFuncPatDeps
exts <- getExtensions
return (Module ps m es is ds'', exts)
return (Module spi ps m es is ds'', exts)
where tds = filter isTypeDecl ds
cds = filter isClassDecl ds
ids = filter isInstanceDecl ds
......@@ -542,10 +544,11 @@ checkDeclLhs (FreeDecl p vs) =
FreeDecl p <$> mapM (checkVar' "free variables declaration") vs
checkDeclLhs d = return d
checkPrecedence :: Position -> Maybe Precedence -> SCM (Maybe Precedence)
checkPrecedence :: SpanInfo -> Maybe Precedence -> SCM (Maybe Precedence)
checkPrecedence _ Nothing = return Nothing
checkPrecedence p (Just i) = do
unless (0 <= i && i <= 9) $ report $ errPrecedenceOutOfRange p i
unless (0 <= i && i <= 9) $ report
$ errPrecedenceOutOfRange (spanInfo2Pos p) i
return $ Just i
checkVar' :: String -> Var a -> SCM (Var a)
......@@ -560,7 +563,7 @@ checkVar _what v = do
renameVar :: Ident -> SCM Ident
renameVar v = renameIdent v <$> getScopeId
checkEquationsLhs :: Position -> [Equation ()] -> SCM (Decl ())
checkEquationsLhs :: SpanInfo -> [Equation ()] -> SCM (Decl ())
checkEquationsLhs p [Equation p' lhs rhs] = do
lhs' <- checkEqLhs p' lhs
case lhs' of
......@@ -569,12 +572,13 @@ checkEquationsLhs p [Equation p' lhs rhs] = do
where funDecl' (f, lhs') = FunctionDecl p () f [Equation p' lhs' rhs]
patDecl' t = do
k <- getScopeId
when (k == globalScopeId) $ report $ errToplevelPattern p
when (k == globalScopeId) $ report
$ errToplevelPattern (spanInfo2Pos p)
return $ PatternDecl p' t rhs
checkEquationsLhs _ _ = internalError "SyntaxCheck.checkEquationsLhs"
checkEqLhs :: Position -> Lhs () -> SCM (Either (Ident, Lhs ()) (Pattern ()))
checkEqLhs p toplhs = do
checkEqLhs :: SpanInfo -> Lhs () -> SCM (Either (Ident, Lhs ()) (Pattern ()))
checkEqLhs spi toplhs = do
m <- getModuleIdent
k <- getScopeId
env <- getRenameEnv
......@@ -603,12 +607,13 @@ checkEqLhs p toplhs = do
InfixPattern a' t1' op1 (infixPattern t2' op2 t3)
infixPattern t1' op1 t2' = InfixPattern () t1' op1 t2'
ApLhs lhs ts -> do
checked <- checkEqLhs p lhs
checked <- checkEqLhs spi lhs
case checked of
Left (f', lhs') -> return $ Left (f', ApLhs lhs' ts)
r -> do report $ errNonVariable "curried definition" f
return $ r
where (f, _) = flatLhs lhs
where p = spanInfo2Pos spi
checkOpLhs :: Integer -> RenameEnv -> (Pattern a -> Pattern a)
-> Pattern a -> Either (Ident, Lhs a) (Pattern a)
......@@ -686,7 +691,7 @@ checkEquation (Equation p lhs rhs) = inNestedScope $ do
rhs' <- checkRhs rhs
return $ Equation p lhs' rhs'
checkLhs :: Position -> Lhs () -> SCM (Lhs ())
checkLhs :: SpanInfo -> Lhs () -> SCM (Lhs ())
checkLhs p (FunLhs f ts) = FunLhs f <$> mapM (checkPattern p) ts
checkLhs p (OpLhs t1 op t2) = do
let wrongCalls = concatMap (checkParenPattern (Just $ qualify op)) [t1,t2]
......@@ -701,7 +706,7 @@ checkLhs p (ApLhs lhs ts) =
-- @param Pattern
-- @return Liste mit fehlerhaften Funktionsaufrufen
checkParenPattern :: (Maybe QualIdent) -> Pattern a -> [(QualIdent, QualIdent)]
checkParenPattern :: Maybe QualIdent -> Pattern a -> [(QualIdent, QualIdent)]
checkParenPattern _ (LiteralPattern _ _) = []
checkParenPattern _ (NegativePattern _ _) = []
checkParenPattern _ (VariablePattern _ _) = []
......@@ -728,7 +733,7 @@ checkParenPattern o (InfixFuncPattern _ t1 op t2) =
maybe [] (\c -> [(c, op)]) o
++ checkParenPattern Nothing t1 ++ checkParenPattern Nothing t2
checkPattern :: Position -> Pattern () -> SCM (Pattern ())
checkPattern :: SpanInfo -> Pattern () -> SCM (Pattern ())
checkPattern _ (LiteralPattern a l) =
return $ LiteralPattern a l
checkPattern _ (NegativePattern a l) =
......@@ -759,7 +764,7 @@ checkPattern _ (FunctionPattern _ _ _) = internalError $
checkPattern _ (InfixFuncPattern _ _ _ _) = internalError $
"SyntaxCheck.checkPattern: infix function pattern not defined"
checkConstructorPattern :: Position -> QualIdent -> [Pattern ()]
checkConstructorPattern :: SpanInfo -> QualIdent -> [Pattern ()]
-> SCM (Pattern ())
checkConstructorPattern p c ts = do
env <- getRenameEnv
......@@ -791,7 +796,7 @@ checkConstructorPattern p c ts = do
= return $ VariablePattern () $ renameIdent (unqualify c) k -- (varIdent r) k
| otherwise = do
let n = arity r
checkFuncPatsExtension p
checkFuncPatsExtension (spanInfo2Pos p)
checkFuncPatCall r c
ts' <- mapM (checkPattern p) ts
mapM_ (checkFPTerm p) ts'
......@@ -801,7 +806,7 @@ checkConstructorPattern p c ts = do
(FunctionPattern () (qualVarIdent r) ts1) ts2
else FunctionPattern () (qualVarIdent r) ts'
checkInfixPattern :: Position -> Pattern () -> QualIdent -> Pattern ()
checkInfixPattern :: SpanInfo -> Pattern () -> QualIdent -> Pattern ()
-> SCM (Pattern ())
checkInfixPattern p t1 op t2 = do
m <- getModuleIdent
......@@ -822,13 +827,13 @@ checkInfixPattern p t1 op t2 = do
when (n /= 2) $ report $ errWrongArity op n 2
flip (InfixPattern ()) qop <$> checkPattern p t1 <*> checkPattern p t2
funcPattern r qop = do
checkFuncPatsExtension p
checkFuncPatsExtension (spanInfo2Pos p)
checkFuncPatCall r qop
ts'@[t1',t2'] <- mapM (checkPattern p) [t1,t2]
mapM_ (checkFPTerm p) ts'
return $ InfixFuncPattern () t1' qop t2'
checkRecordPattern :: Position -> QualIdent -> [Field (Pattern ())]
checkRecordPattern :: SpanInfo -> QualIdent -> [Field (Pattern ())]
-> SCM (Pattern ())
checkRecordPattern p c fs = do
env <- getRenameEnv
......@@ -858,14 +863,16 @@ checkFuncPatCall r f = case r of
-- Note: process decls first
checkRhs :: Rhs () -> SCM (Rhs ())
checkRhs (SimpleRhs p e ds) = inNestedScope $
flip (SimpleRhs p) <$> checkDeclGroup bindVarDecl ds <*> checkExpr p e
flip (SimpleRhs p) <$> checkDeclGroup bindVarDecl ds <*> checkExpr sp e
where sp = SpanInfo (Span "" p p) [] -- TODO
checkRhs (GuardedRhs es ds) = inNestedScope $
flip GuardedRhs <$> checkDeclGroup bindVarDecl ds <*> mapM checkCondExpr es
checkCondExpr :: CondExpr () -> SCM (CondExpr ())
checkCondExpr (CondExpr p g e) = CondExpr p <$> checkExpr p g <*> checkExpr p e
checkCondExpr (CondExpr p g e) = CondExpr p <$> checkExpr sp g <*> checkExpr sp e
where sp = SpanInfo (Span "" p p) [] -- TODO
checkExpr :: Position -> Expression () -> SCM (Expression ())
checkExpr :: SpanInfo -> Expression () -> SCM (Expression ())
checkExpr _ (Literal a l) = return $ Literal a l
checkExpr _ (Variable a v) = checkVariable a v
checkExpr _ (Constructor a c) = checkVariable a c
......@@ -904,7 +911,7 @@ checkExpr p (IfThenElse e1 e2 e3) =
checkExpr p (Case ct e alts) =
Case ct <$> checkExpr p e <*> mapM checkAlt alts
checkLambda :: Position -> [Pattern ()] -> Expression () -> SCM (Expression ())
checkLambda :: SpanInfo -> [Pattern ()] -> Expression () -> SCM (Expression ())
checkLambda p ts e = case findMultiples (bvNoAnon ts) of
[] -> do
ts' <- mapM (bindPattern "lambda expression" p) ts
......@@ -946,7 +953,7 @@ checkVariable a v
rs' -> do report $ errAmbiguousIdent rs' v
return $ Variable a v
checkRecordExpr :: Position -> QualIdent -> [Field (Expression ())]
checkRecordExpr :: SpanInfo -> QualIdent -> [Field (Expression ())]
-> SCM (Expression ())
checkRecordExpr _ c [] = do
m <- getModuleIdent
......@@ -962,7 +969,7 @@ checkRecordExpr _ c [] = do
return $ Record () c []
checkRecordExpr p c fs = checkExpr p (RecordUpdate (Constructor () c) fs)
checkRecordUpdExpr :: Position -> Expression () -> [Field (Expression ())]
checkRecordUpdExpr :: SpanInfo -> Expression () -> [Field (Expression ())]
-> SCM (Expression ())
checkRecordUpdExpr p e fs = do
e' <- checkExpr p e
......@@ -977,20 +984,20 @@ checkRecordUpdExpr p e fs = do
-- scope has to be nested one level.
-- * Because statements are processed list-wise, inNestedEnv can not be
-- used as this nesting must be visible to following statements.
checkStatement :: String -> Position -> Statement () -> SCM (Statement ())
checkStatement :: String -> SpanInfo -> Statement () -> SCM (Statement ())
checkStatement _ p (StmtExpr e) = StmtExpr <$> checkExpr p e
checkStatement s p (StmtBind t e) =
flip StmtBind <$> checkExpr p e <*> (incNesting >> bindPattern s p t)
checkStatement _ _ (StmtDecl ds) =
StmtDecl <$> (incNesting >> checkDeclGroup bindVarDecl ds)
bindPattern :: String -> Position -> Pattern () -> SCM (Pattern ())
bindPattern :: String -> SpanInfo -> Pattern () -> SCM (Pattern ())
bindPattern s p t = do
t' <- checkPattern p t
banFPTerm s p t'
addBoundVariables True t'
banFPTerm :: String -> Position -> Pattern a -> SCM ()
banFPTerm :: String -> SpanInfo -> Pattern a -> SCM ()
banFPTerm _ _ (LiteralPattern _ _) = ok
banFPTerm _ _ (NegativePattern _ _) = ok
banFPTerm _ _ (VariablePattern _ _) = ok
......@@ -1004,9 +1011,9 @@ banFPTerm s p (ListPattern _ ts) = mapM_ (banFPTerm s p) ts
banFPTerm s p (AsPattern _ t) = banFPTerm s p t
banFPTerm s p (LazyPattern t) = banFPTerm s p t
banFPTerm s p pat@(FunctionPattern _ _ _)
= report $ errUnsupportedFuncPattern s p pat
= report $ errUnsupportedFuncPattern s (spanInfo2Pos p) pat
banFPTerm s p pat@(InfixFuncPattern _ _ _ _)
= report $ errUnsupportedFuncPattern s p pat
= report $ errUnsupportedFuncPattern s (spanInfo2Pos p) pat
checkOp :: InfixOp a -> SCM (InfixOp a)
checkOp op = do
......@@ -1029,7 +1036,8 @@ checkOp op = do
checkAlt :: Alt () -> SCM (Alt ())
checkAlt (Alt p t rhs) = inNestedScope $
Alt p <$> bindPattern "case expression" p t <*> checkRhs rhs
Alt p <$> bindPattern "case expression" sp t <*> checkRhs rhs
where sp = SpanInfo (Span "" p p) [] -- TODO
addBoundVariables :: (QuantExpr t) => Bool -> t -> SCM t
addBoundVariables checkDuplicates ts = do
......@@ -1048,7 +1056,7 @@ addBoundVariables checkDuplicates ts = do
-- shadowed by local variables (cf.\ Sect.~3.15.1 of the revised
-- Haskell'98 report~\cite{PeytonJones03:Haskell}).
checkFieldLabels :: String -> Position -> Maybe QualIdent -> [Field a] -> SCM ()
checkFieldLabels :: String -> SpanInfo -> Maybe QualIdent -> [Field a] -> SCM ()
checkFieldLabels what p c fs = do
mapM checkFieldLabel ls' >>= checkLabels p c ls'
onJust (report . errDuplicateLabel what) (findDouble ls)
......@@ -1075,7 +1083,7 @@ checkFieldLabel l = do
when (null cs') $ report $ errUndefinedLabel l
return cs'
checkLabels :: Position -> Maybe QualIdent -> [QualIdent] -> [[QualIdent]]
checkLabels :: SpanInfo -> Maybe QualIdent -> [QualIdent] -> [[QualIdent]]
-> SCM ()
checkLabels _ (Just c) ls css = do
env <- getRenameEnv
......@@ -1085,7 +1093,8 @@ checkLabels _ (Just c) ls css = do
_ -> internalError $
"Checks.SyntaxCheck.checkLabels: " ++ show c
checkLabels p Nothing ls css =
when (null (foldr1 intersect css)) $ report $ errNoCommonCons p ls
when (null (foldr1 intersect css))
$ report $ errNoCommonCons (spanInfo2Pos p) ls
checkField :: (a -> SCM a) -> Field a -> SCM (Field a)
checkField check (Field p l x) = Field p l <$> check x
......@@ -1190,7 +1199,7 @@ genFuncPattAppl term [] = term
genFuncPattAppl term (t:ts)
= FunctionPattern () qApplyId [genFuncPattAppl term ts, t]
checkFPTerm :: Position -> Pattern a -> SCM ()
checkFPTerm :: SpanInfo -> Pattern a -> SCM ()
checkFPTerm _ (LiteralPattern _ _) = ok
checkFPTerm _ (NegativePattern _ _) = ok
checkFPTerm _ (VariablePattern _ _) = ok
......@@ -1200,7 +1209,8 @@ checkFPTerm p (ParenPattern t) = checkFPTerm p t
checkFPTerm p (TuplePattern ts) = mapM_ (checkFPTerm p) ts
checkFPTerm p (ListPattern _ ts) = mapM_ (checkFPTerm p) ts
checkFPTerm p (AsPattern _ t) = checkFPTerm p t
checkFPTerm p t@(LazyPattern _) = report $ errUnsupportedFPTerm "Lazy" p t
checkFPTerm p t@(LazyPattern _) =
report $ errUnsupportedFPTerm "Lazy" (spanInfo2Pos p) t
checkFPTerm p (RecordPattern _ _ fs) = mapM_ (checkFPTerm p)
[ t | Field _ _ t <- fs ]
checkFPTerm _ (FunctionPattern _ _ _) = ok -- do not check again
......
......@@ -55,6 +55,7 @@ import qualified Data.Set.Extra as Set ( Set, concatMap, deleteMin, empty
import Curry.Base.Ident
import Curry.Base.Position
import Curry.Base.Pretty
import Curry.Base.SpanInfo
import Curry.Syntax
import Curry.Syntax.Pretty
......@@ -295,8 +296,8 @@ checkFieldLabel (NewtypeDecl _ _ tvs (NewRecordDecl p _ (l, ty)) _) = do
ok
checkFieldLabel _ = ok
tcFieldLabel :: [Ident] -> (Ident, Position, TypeExpr)
-> TCM (Ident, Position, Type)
tcFieldLabel :: HasPosition p => [Ident] -> (Ident, p, TypeExpr)
-> TCM (Ident, p, Type)
tcFieldLabel tvs (l, p, ty) = do
m <- getModuleIdent
tcEnv <- getTyConsEnv
......@@ -310,7 +311,7 @@ groupLabels ((x, y, z):xyzs) =
(x, y, z : map thd3 xyzs') : groupLabels xyzs''
where (xyzs', xyzs'') = partition ((x ==) . fst3) xyzs
tcFieldLabels :: (Ident, Position, [Type]) -> TCM ()
tcFieldLabels :: HasPosition p => (Ident, p, [Type]) -> TCM ()
tcFieldLabels (_, _, []) = return ()
tcFieldLabels (l, p, ty:tys) = unless (null (filter (ty /=) tys)) $ do
m <- getModuleIdent
......@@ -525,7 +526,7 @@ tcPDecl _ _ = internalError "TypeCheck.tcPDecl"
-- signature. This prevents missing instance errors when the inferred type
-- of a function is less general than the declared type.
tcFunctionPDecl :: Int -> PredSet -> TypeScheme -> Position -> Ident
tcFunctionPDecl :: Int -> PredSet -> TypeScheme -> SpanInfo -> Ident
-> [Equation a] -> TCM (PredSet, (Type, PDecl PredType))
tcFunctionPDecl i ps tySc@(ForAll _ pty) p f eqs = do
(_, ty) <- inst tySc
......@@ -538,7 +539,7 @@ tcEquation :: Set.Set Int -> Type -> PredSet -> Equation a
tcEquation fs ty ps eqn@(Equation p lhs rhs) =
tcEqn fs p lhs rhs >>- unifyDecl p "equation" (ppEquation eqn) ps ty
tcEqn :: Set.Set Int -> Position -> Lhs a -> Rhs a
tcEqn :: Set.Set Int -> SpanInfo -> Lhs a -> Rhs a
-> TCM (PredSet, Type, Equation PredType)
tcEqn fs p lhs rhs = do
(ps, tys, lhs', ps', ty, rhs') <- withLocalValueEnv $ do
......@@ -561,7 +562,7 @@ lambdaVar v = do
ty <- freshTypeVar
return (v, 0, monoType ty)
unifyDecl :: Position -> String -> Doc -> PredSet -> Type -> PredSet -> Type
unifyDecl :: HasPosition p => p -> String -> Doc -> PredSet -> Type -> PredSet -> Type
-> TCM PredSet
unifyDecl p what doc psLhs tyLhs psRhs tyRhs = do
ps <- unify p what doc psLhs tyLhs psRhs tyRhs
......@@ -584,7 +585,7 @@ defaultPDecl fvs ps ty (_, PatternDecl p t _) = case t of
_ -> return ps
defaultPDecl _ _ _ _ = internalError "TypeCheck.defaultPDecl"