module Checks.PrecCheck (precCheck) where
#if __GLASGOW_HASKELL__ < 710
import Control.Applicative ((<$>), (<*>))
#endif
import Control.Monad (unless, when)
import qualified Control.Monad.State as S (State, runState, gets, modify)
import Data.List (partition)
import Curry.Base.Ident
import Curry.Base.Position
import Curry.Base.Pretty
import Curry.Syntax
import Base.Expr
import Base.Messages (Message, posMessage, internalError)
import Base.Utils (findMultiples)
import Env.OpPrec (OpPrecEnv, OpPrec (..), PrecInfo (..), defaultP, bindP
, mkPrec, qualLookupP)
precCheck :: ModuleIdent -> OpPrecEnv -> [Decl a] -> ([Decl a], OpPrecEnv, [Message])
precCheck m pEnv decls = runPCM (checkDecls decls) initState
where initState = PCState m pEnv []
data PCState = PCState
{ moduleIdent :: ModuleIdent
, precEnv :: OpPrecEnv
, errors :: [Message]
}
type PCM = S.State PCState
runPCM :: PCM a -> PCState -> (a, OpPrecEnv, [Message])
runPCM kcm s = let (a, s') = S.runState kcm s
in (a, precEnv s', reverse $ errors s')
getModuleIdent :: PCM ModuleIdent
getModuleIdent = S.gets moduleIdent
getPrecEnv :: PCM OpPrecEnv
getPrecEnv = S.gets precEnv
modifyPrecEnv :: (OpPrecEnv -> OpPrecEnv) -> PCM ()
modifyPrecEnv f = S.modify $ \ s -> s { precEnv = f $ precEnv s }
withLocalPrecEnv :: PCM a -> PCM a
withLocalPrecEnv act = do
oldEnv <- getPrecEnv
res <- act
modifyPrecEnv $ const oldEnv
return res
report :: Message -> PCM ()
report err = S.modify (\ s -> s { errors = err : errors s })
bindPrecs :: [Decl a] -> PCM ()
bindPrecs ds0 = case findMultiples opFixDecls of
[] -> case filter (`notElem` bvs) opFixDecls of
[] -> do
m <- getModuleIdent
modifyPrecEnv $ \env -> foldr (bindPrec m) env fixDs
ops -> mapM_ (report . errUndefinedOperator) ops
opss -> mapM_ (report . errMultiplePrecedence) opss
where
(fixDs, nonFixDs) = partition isInfixDecl ds0
innerDs = [ d | ClassDecl _ _ _ _ ds <- ds0, d <- ds ]
opFixDecls = [ op | InfixDecl _ _ _ ops <- fixDs, op <- ops ]
bvs = concatMap boundValues nonFixDs ++
map unRenameIdent (concatMap boundValues innerDs)
bindPrec :: ModuleIdent -> Decl a -> OpPrecEnv -> OpPrecEnv
bindPrec m (InfixDecl _ fix mprec ops) pEnv
| p == defaultP = pEnv
| otherwise = foldr (flip (bindP m) p) pEnv ops
where p = OpPrec fix (mkPrec mprec)
bindPrec _ _ pEnv = pEnv
boundValues :: Decl a -> [Ident]
boundValues (DataDecl _ _ _ cs _) = [ v | c <- cs
, v <- constrId c : recordLabels c]
boundValues (NewtypeDecl _ _ _ nc _) = nconstrId nc : nrecordLabels nc
boundValues (TypeSig _ fs _) = fs
boundValues (FunctionDecl _ _ f _) = [f]
boundValues (ExternalDecl _ vs) = bv vs
boundValues (PatternDecl _ t _) = bv t
boundValues (FreeDecl _ vs) = bv vs
boundValues _ = []
checkDecls :: [Decl a] -> PCM [Decl a]
checkDecls decls = bindPrecs decls >> mapM checkDecl decls
checkDecl :: Decl a -> PCM (Decl a)
checkDecl (FunctionDecl p a f eqs) =
FunctionDecl p a f <$> mapM checkEquation eqs
checkDecl (PatternDecl p t rhs) =
PatternDecl p <$> checkPattern t <*> checkRhs rhs
checkDecl (ClassDecl p cx cls tv ds) =
ClassDecl p cx cls tv <$> mapM checkDecl ds
checkDecl (InstanceDecl p cx qcls inst ds) =
InstanceDecl p cx qcls inst <$> mapM checkDecl ds
checkDecl d = return d
checkEquation :: Equation a -> PCM (Equation a)
checkEquation (Equation p lhs rhs) =
Equation p <$> checkLhs lhs <*> checkRhs rhs
checkLhs :: Lhs a -> PCM (Lhs a)
checkLhs (FunLhs f ts) = FunLhs f <$> mapM checkPattern ts
checkLhs (OpLhs t1 op t2) =
flip OpLhs op <$> (checkPattern t1 >>= checkOpL op)
<*> (checkPattern t2 >>= checkOpR op)
checkLhs (ApLhs lhs ts) =
ApLhs <$> checkLhs lhs <*> mapM checkPattern ts
checkPattern :: Pattern a -> PCM (Pattern a)
checkPattern l@(LiteralPattern _ _) = return l
checkPattern n@(NegativePattern _ _) = return n
checkPattern v@(VariablePattern _ _) = return v
checkPattern (ConstructorPattern a c ts) =
ConstructorPattern a c <$> mapM checkPattern ts
checkPattern (InfixPattern a t1 op t2) = do
t1' <- checkPattern t1
t2' <- checkPattern t2
fixPrecT (InfixPattern a) t1' op t2'
checkPattern (ParenPattern t) =
ParenPattern <$> checkPattern t
checkPattern (TuplePattern ts) =
TuplePattern <$> mapM checkPattern ts
checkPattern (ListPattern a ts) =
ListPattern a <$> mapM checkPattern ts
checkPattern (AsPattern v t) =
AsPattern v <$> checkPattern t
checkPattern (LazyPattern t) =
LazyPattern <$> checkPattern t
checkPattern (FunctionPattern a f ts) =
FunctionPattern a f <$> mapM checkPattern ts
checkPattern (InfixFuncPattern a t1 op t2) = do
t1' <- checkPattern t1
t2' <- checkPattern t2
fixPrecT (InfixFuncPattern a) t1' op t2'
checkPattern (RecordPattern a c fs) =
RecordPattern a c <$> mapM (checkField checkPattern) fs
checkRhs :: Rhs a -> PCM (Rhs a)
checkRhs (SimpleRhs p e ds) = withLocalPrecEnv $
flip (SimpleRhs p) <$> checkDecls ds <*> checkExpr e
checkRhs (GuardedRhs es ds) = withLocalPrecEnv $
(flip GuardedRhs) <$> checkDecls ds <*> mapM checkCondExpr es
checkCondExpr :: CondExpr a -> PCM (CondExpr a)
checkCondExpr (CondExpr p g e) = CondExpr p <$> checkExpr g <*> checkExpr e
checkExpr :: Expression a -> PCM (Expression a)
checkExpr l@(Literal _ _) = return l
checkExpr v@(Variable _ _) = return v
checkExpr c@(Constructor _ _) = return c
checkExpr (Paren e) = Paren <$> checkExpr e
checkExpr (Typed e ty) = flip Typed ty <$> checkExpr e
checkExpr (Record a c fs) = Record a c <$> mapM (checkField checkExpr) fs
checkExpr (RecordUpdate e fs) = RecordUpdate <$> (checkExpr e)
<*> mapM (checkField checkExpr) fs
checkExpr (Tuple es) = Tuple <$> mapM checkExpr es
checkExpr (List a es) = List a <$> mapM checkExpr es
checkExpr (ListCompr e qs) = withLocalPrecEnv $
flip ListCompr <$> mapM checkStmt qs <*> checkExpr e
checkExpr (EnumFrom e) = EnumFrom <$> checkExpr e
checkExpr (EnumFromThen e1 e2) =
EnumFromThen <$> checkExpr e1 <*> checkExpr e2
checkExpr (EnumFromTo e1 e2) =
EnumFromTo <$> checkExpr e1 <*> checkExpr e2
checkExpr (EnumFromThenTo e1 e2 e3) =
EnumFromThenTo <$> checkExpr e1 <*> checkExpr e2 <*> checkExpr e3
checkExpr (UnaryMinus e) = UnaryMinus <$> checkExpr e
checkExpr (Apply e1 e2) =
Apply <$> checkExpr e1 <*> checkExpr e2
checkExpr (InfixApply e1 op e2) = do
e1' <- checkExpr e1
e2' <- checkExpr e2
fixPrec e1' op e2'
checkExpr (LeftSection e op) = checkExpr e >>= checkLSection op
checkExpr (RightSection op e) = checkExpr e >>= checkRSection op
checkExpr (Lambda ts e) =
Lambda <$> mapM checkPattern ts <*> checkExpr e
checkExpr (Let ds e) = withLocalPrecEnv $
Let <$> checkDecls ds <*> checkExpr e
checkExpr (Do sts e) = withLocalPrecEnv $
Do <$> mapM checkStmt sts <*> checkExpr e
checkExpr (IfThenElse e1 e2 e3) =
IfThenElse <$> checkExpr e1 <*> checkExpr e2 <*> checkExpr e3
checkExpr (Case ct e alts) =
Case ct <$> checkExpr e <*> mapM checkAlt alts
checkStmt :: Statement a -> PCM (Statement a)
checkStmt (StmtExpr e) = StmtExpr <$> checkExpr e
checkStmt (StmtDecl ds) = StmtDecl <$> checkDecls ds
checkStmt (StmtBind t e) = StmtBind <$> checkPattern t <*> checkExpr e
checkAlt :: Alt a -> PCM (Alt a)
checkAlt (Alt p t rhs) = Alt p <$> checkPattern t <*> checkRhs rhs
checkField :: (a -> PCM a) -> Field a -> PCM (Field a)
checkField check (Field p l x) = Field p l <$> check x
fixPrec :: Expression a -> InfixOp a -> Expression a -> PCM (Expression a)
fixPrec (UnaryMinus e1) op e2 = do
OpPrec fix pr <- getOpPrec op
if pr < 6 || pr == 6 && fix == InfixL
then fixRPrec (UnaryMinus e1) op e2
else if pr > 6
then fixUPrec e1 op e2
else do
report $ errAmbiguousParse "unary" (qualify minusId) (opName op)
return $ InfixApply (UnaryMinus e1) op e2
fixPrec e1 op e2 = fixRPrec e1 op e2
fixUPrec :: Expression a -> InfixOp a -> Expression a
-> PCM (Expression a)
fixUPrec e1 op e2@(UnaryMinus _) = do
report $ errAmbiguousParse "operator" (opName op) (qualify minusId)
return $ UnaryMinus (InfixApply e1 op e2)
fixUPrec e1 op1 e'@(InfixApply e2 op2 e3) = do
OpPrec fix2 pr2 <- getOpPrec op2
if pr2 < 6 || pr2 == 6 && fix2 == InfixL
then do
left <- fixUPrec e1 op1 e2
return $ InfixApply left op2 e3
else if pr2 > 6
then do
op <- fixRPrec e1 op1 $ InfixApply e2 op2 e3
return $ UnaryMinus op
else do
report $ errAmbiguousParse "unary" (qualify minusId) (opName op2)
return $ InfixApply (UnaryMinus e1) op1 e'
fixUPrec e1 op e2 = return $ UnaryMinus (InfixApply e1 op e2)
fixRPrec :: Expression a -> InfixOp a -> Expression a -> PCM (Expression a)
fixRPrec e1 op (UnaryMinus e2) = do
OpPrec _ pr <- getOpPrec op
unless (pr < 6) $ report $ errAmbiguousParse "operator" (opName op) (qualify minusId)
return $ InfixApply e1 op $ UnaryMinus e2
fixRPrec e1 op1 (InfixApply e2 op2 e3) = do
OpPrec fix1 pr1 <- getOpPrec op1
OpPrec fix2 pr2 <- getOpPrec op2
if pr1 < pr2 || pr1 == pr2 && fix1 == InfixR && fix2 == InfixR
then return $ InfixApply e1 op1 $ InfixApply e2 op2 e3
else if pr1 > pr2 || pr1 == pr2 && fix1 == InfixL && fix2 == InfixL
then do
left <- fixPrec e1 op1 e2
return $ InfixApply left op2 e3
else do
report $ errAmbiguousParse "operator" (opName op1) (opName op2)
return $ InfixApply e1 op1 $ InfixApply e2 op2 e3
fixRPrec e1 op e2 = return $ InfixApply e1 op e2
checkLSection :: InfixOp a -> Expression a -> PCM (Expression a)
checkLSection op e@(UnaryMinus _) = do
OpPrec fix pr <- getOpPrec op
unless (pr < 6 || pr == 6 && fix == InfixL) $
report $ errAmbiguousParse "unary" (qualify minusId) (opName op)
return $ LeftSection e op
checkLSection op1 e@(InfixApply _ op2 _) = do
OpPrec fix1 pr1 <- getOpPrec op1
OpPrec fix2 pr2 <- getOpPrec op2
unless (pr1 < pr2 || pr1 == pr2 && fix1 == InfixL && fix2 == InfixL) $
report $ errAmbiguousParse "operator" (opName op1) (opName op2)
return $ LeftSection e op1
checkLSection op e = return $ LeftSection e op
checkRSection :: InfixOp a -> Expression a -> PCM (Expression a)
checkRSection op e@(UnaryMinus _) = do
OpPrec _ pr <- getOpPrec op
unless (pr < 6) $ report $ errAmbiguousParse "unary" (qualify minusId) (opName op)
return $ RightSection op e
checkRSection op1 e@(InfixApply _ op2 _) = do
OpPrec fix1 pr1 <- getOpPrec op1
OpPrec fix2 pr2 <- getOpPrec op2
unless (pr1 < pr2 || pr1 == pr2 && fix1 == InfixR && fix2 == InfixR) $
report $ errAmbiguousParse "operator" (opName op1) (opName op2)
return $ RightSection op1 e
checkRSection op e = return $ RightSection op e
fixPrecT :: (Pattern a -> QualIdent -> Pattern a -> Pattern a)
-> Pattern a -> QualIdent -> Pattern a -> PCM (Pattern a)
fixPrecT infixpatt t1@(NegativePattern _ _) op t2 = do
OpPrec fix pr <- prec op <$> getPrecEnv
unless (pr < 6 || pr == 6 && fix == InfixL) $
report $ errInvalidParse "unary operator" minusId op
fixRPrecT infixpatt t1 op t2
fixPrecT infixpatt t1 op t2 = fixRPrecT infixpatt t1 op t2
fixRPrecT :: (Pattern a -> QualIdent -> Pattern a -> Pattern a)
-> Pattern a -> QualIdent -> Pattern a -> PCM (Pattern a)
fixRPrecT infixpatt t1 op t2@(NegativePattern _ _) = do
OpPrec _ pr <- prec op <$> getPrecEnv
unless (pr < 6) $ report $ errInvalidParse "unary operator" minusId op
return $ infixpatt t1 op t2
fixRPrecT infixpatt t1 op1 (InfixPattern a t2 op2 t3) = do
OpPrec fix1 pr1 <- prec op1 <$> getPrecEnv
OpPrec fix2 pr2 <- prec op2 <$> getPrecEnv
if pr1 < pr2 || pr1 == pr2 && fix1 == InfixR && fix2 == InfixR
then return $ infixpatt t1 op1 (InfixPattern a t2 op2 t3)
else if pr1 > pr2 || pr1 == pr2 && fix1 == InfixL && fix2 == InfixL
then do
left <- fixPrecT infixpatt t1 op1 t2
return $ InfixPattern a left op2 t3
else do
report $ errAmbiguousParse "operator" op1 op2
return $ infixpatt t1 op1 (InfixPattern a t2 op2 t3)
fixRPrecT infixpatt t1 op1 (InfixFuncPattern a t2 op2 t3) = do
OpPrec fix1 pr1 <- prec op1 <$> getPrecEnv
OpPrec fix2 pr2 <- prec op2 <$> getPrecEnv
if pr1 < pr2 || pr1 == pr2 && fix1 == InfixR && fix2 == InfixR
then return $ infixpatt t1 op1 (InfixFuncPattern a t2 op2 t3)
else if pr1 > pr2 || pr1 == pr2 && fix1 == InfixL && fix2 == InfixL
then do
left <- fixPrecT infixpatt t1 op1 t2
return $ InfixFuncPattern a left op2 t3
else do
report $ errAmbiguousParse "operator" op1 op2
return $ infixpatt t1 op1 (InfixFuncPattern a t2 op2 t3)
fixRPrecT infixpatt t1 op t2 = return $ infixpatt t1 op t2
checkOpL :: Ident -> Pattern a -> PCM (Pattern a)
checkOpL op t@(NegativePattern _ _) = do
OpPrec fix pr <- prec (qualify op) <$> getPrecEnv
unless (pr < 6 || pr == 6 && fix == InfixL) $
report $ errInvalidParse "unary operator" minusId (qualify op)
return t
checkOpL op1 t@(InfixPattern _ _ op2 _) = do
OpPrec fix1 pr1 <- prec (qualify op1) <$> getPrecEnv
OpPrec fix2 pr2 <- prec op2 <$> getPrecEnv
unless (pr1 < pr2 || pr1 == pr2 && fix1 == InfixL && fix2 == InfixL) $
report $ errInvalidParse "operator" op1 op2
return t
checkOpL _ t = return t
checkOpR :: Ident -> Pattern a -> PCM (Pattern a)
checkOpR op t@(NegativePattern _ _) = do
OpPrec _ pr <- prec (qualify op) <$> getPrecEnv
when (pr >= 6) $ report $ errInvalidParse "unary operator" minusId (qualify op)
return t
checkOpR op1 t@(InfixPattern _ _ op2 _) = do
OpPrec fix1 pr1 <- prec (qualify op1) <$> getPrecEnv
OpPrec fix2 pr2 <- prec op2 <$> getPrecEnv
unless (pr1 < pr2 || pr1 == pr2 && fix1 == InfixR && fix2 == InfixR) $
report $ errInvalidParse "operator" op1 op2
return t
checkOpR _ t = return t
getOpPrec :: InfixOp a -> PCM OpPrec
getOpPrec op = opPrec op <$> getPrecEnv
opPrec :: InfixOp a -> OpPrecEnv -> OpPrec
opPrec op = prec (opName op)
prec :: QualIdent -> OpPrecEnv -> OpPrec
prec op env = case qualLookupP op env of
[] -> defaultP
PrecInfo _ p : _ -> p
errUndefinedOperator :: Ident -> Message
errUndefinedOperator op = posMessage op $ hsep $ map text
["No definition for", escName op, "in this scope"]
errMultiplePrecedence :: [Ident] -> Message
errMultiplePrecedence [] = internalError
"PrecCheck.errMultiplePrecedence: empty list"
errMultiplePrecedence (op:ops) = posMessage op $
(hsep $ map text ["More than one fixity declaration for", escName op, "at"])
$+$ nest 2 (vcat (map (ppPosition . getPosition) (op:ops)))
errInvalidParse :: String -> Ident -> QualIdent -> Message
errInvalidParse what op1 op2 = posMessage op1 $ hsep $ map text
[ "Invalid use of", what, escName op1, "with", escQualName op2, "in"
, showLine $ qidPosition op2]
errAmbiguousParse :: String -> QualIdent -> QualIdent -> Message
errAmbiguousParse what op1 op2 = posMessage op1 $ hsep $ map text
["Ambiguous use of", what, escQualName op1, "with", escQualName op2, "in"
, showLine $ qidPosition op2]