Commit c70b59da authored by Unknown's avatar Unknown

Fix compilation errors resulting from identifier changes

parent cfa7f534
......@@ -452,7 +452,7 @@ errMultiple _ [] = internalError $
errMultiple what (i:is) = posMessage i $
text "Multiple exports of" <+> text what <+> text (escName i) <+> text "at:"
$+$ nest 2 (vcat (map showPos (i:is)))
where showPos = text . showLine . idPosition
where showPos = text . showLine . getPosition
errNonDataTypeOrTypeClass :: QualIdent -> Message
errNonDataTypeOrTypeClass tc = posMessage tc $ hsep $ map text
......
......@@ -280,8 +280,8 @@ checkValueInfo what check p x = do
where p' = getPosition p
checkImported :: (ModuleIdent -> Ident -> IC ()) -> QualIdent -> IC ()
checkImported _ (QualIdent Nothing _) = ok
checkImported f (QualIdent (Just m) x) = f m x
checkImported _ (QualIdent _ Nothing _) = ok
checkImported f (QualIdent _ (Just m) x) = f m x
-- ---------------------------------------------------------------------------
-- Error messages
......
......@@ -724,7 +724,7 @@ errRecursiveTypes (tc:tcs) = posMessage tc $
types del [tc'] = del <> space <> text "and" <+> typePos tc'
types _ (tc':tcs') = comma <+> typePos tc' <> types comma tcs'
typePos tc' =
text (idName tc') <+> parens (text $ showLine $ idPosition tc')
text (idName tc') <+> parens (text $ showLine $ getPosition tc')
errRecursiveClasses :: [Ident] -> Message
errRecursiveClasses [] = internalError
......@@ -739,7 +739,7 @@ errRecursiveClasses (cls:clss) = posMessage cls $
classes del [cls'] = del <> space <> text "and" <+> classPos cls'
classes _ (cls':clss') = comma <+> classPos cls' <> classes comma clss'
classPos cls' =
text (idName cls') <+> parens (text $ showLine $ idPosition cls')
text (idName cls') <+> parens (text $ showLine $ getPosition cls')
errNonArrowKind :: HasPosition p => p -> String -> Doc -> Kind -> Message
errNonArrowKind p what doc k = posMessage p $ vcat
......
......@@ -32,6 +32,7 @@ import Data.List (partition)
import Curry.Base.Ident
import Curry.Base.Position
import Curry.Base.SpanInfo
import Curry.Base.Span
import Curry.Base.Pretty
import Curry.Syntax
......@@ -159,10 +160,12 @@ checkPattern n@(NegativePattern _ _ _) = return n
checkPattern v@(VariablePattern _ _ _) = return v
checkPattern (ConstructorPattern spi a c ts) =
ConstructorPattern spi a c <$> mapM checkPattern ts
checkPattern (InfixPattern spi a t1 op t2) = do
checkPattern (InfixPattern _ a t1 op t2) = do
t1' <- checkPattern t1
t2' <- checkPattern t2
fixPrecT (InfixPattern spi a) t1' op t2'
fixPrecT mkInfixPattern t1' op t2'
where mkInfixPattern t1'' op'' t2'' =
InfixPattern (t1'' @+@ t2'') a t1'' op'' t2''
checkPattern (ParenPattern spi t) =
ParenPattern spi <$> checkPattern t
checkPattern (TuplePattern spi ts) =
......@@ -175,10 +178,12 @@ checkPattern (LazyPattern spi t) =
LazyPattern spi <$> checkPattern t
checkPattern (FunctionPattern spi a f ts) =
FunctionPattern spi a f <$> mapM checkPattern ts
checkPattern (InfixFuncPattern spi a t1 op t2) = do
checkPattern (InfixFuncPattern _ a t1 op t2) = do
t1' <- checkPattern t1
t2' <- checkPattern t2
fixPrecT (InfixFuncPattern spi a) t1' op t2'
fixPrecT mkInfixFuncPattern t1' op t2'
where mkInfixFuncPattern t1'' op'' t2'' =
InfixFuncPattern (t1'' @+@ t2'') a t1'' op'' t2''
checkPattern (RecordPattern spi a c fs) =
RecordPattern spi a c <$> mapM (checkField checkPattern) fs
......@@ -266,47 +271,49 @@ fixPrec spi (UnaryMinus spi' e1) op e2 = do
if pr < 6 || pr == 6 && fix == InfixL
then fixRPrec spi (UnaryMinus spi' e1) op e2
else if pr > 6
then fixUPrec spi e1 op e2
then fixUPrec spi' e1 op e2
else do
report $ errAmbiguousParse "unary" (qualify minusId) (opName op)
return $ InfixApply spi (UnaryMinus spi' e1) op e2 -- TODO updateEndPos?
return $ InfixApply spi (UnaryMinus spi' e1) op e2
fixPrec spi e1 op e2 = fixRPrec spi e1 op e2
fixUPrec :: SpanInfo -> Expression a -> InfixOp a -> Expression a
-> PCM (Expression a)
fixUPrec spi e1 op e2@(UnaryMinus spi' _) = do
report $ errAmbiguousParse "operator" (opName op) (qualify minusId)
return $ UnaryMinus spi' (InfixApply spi e1 op e2) -- TODO updateEndPos?
return $ UnaryMinus spi' (InfixApply spi e1 op e2)
fixUPrec spi e1 op1 e'@(InfixApply spi' e2 op2 e3) = do
OpPrec fix2 pr2 <- getOpPrec op2
if pr2 < 6 || pr2 == 6 && fix2 == InfixL
then do
left <- fixUPrec spi e1 op1 e2
return $ InfixApply spi' left op2 e3 -- TODO updateEndPos?
return $ InfixApply (left @+@ e3) left op2 e3
else if pr2 > 6
then do
op <- fixRPrec spi e1 op1 $ InfixApply spi' e2 op2 e3
return $ UnaryMinus spi op
return $ updateEndPos $ UnaryMinus spi' op
else do
report $ errAmbiguousParse "unary" (qualify minusId) (opName op2)
return $ InfixApply spi' (UnaryMinus spi e1) op1 e' -- TODO updateEndPos?
fixUPrec spi e1 op e2 = return $ UnaryMinus spi (InfixApply spi e1 op e2) -- TODO updateEndPos?
let left = updateEndPos (UnaryMinus spi' e1)
return $ InfixApply (left @+@ e') left op1 e'
fixUPrec spi e1 op e2 = return $ updateEndPos $ UnaryMinus spi
(InfixApply (e1 @+@ e2) e1 op e2)
fixRPrec :: SpanInfo -> Expression a -> InfixOp a -> Expression a
-> PCM (Expression a)
fixRPrec spi e1 op (UnaryMinus spi' e2) = do
OpPrec _ pr <- getOpPrec op
unless (pr < 6) $ report $ errAmbiguousParse "operator" (opName op) (qualify minusId)
return $ InfixApply spi e1 op $ UnaryMinus spi' e2 -- TODO updateEndPos?
return $ InfixApply spi e1 op $ UnaryMinus spi' e2
fixRPrec spi e1 op1 (InfixApply spi' 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 spi e1 op1 $ InfixApply spi' e2 op2 e3 -- TODO updateEndPos?
then return $ InfixApply spi e1 op1 $ InfixApply spi' e2 op2 e3
else if pr1 > pr2 || pr1 == pr2 && fix1 == InfixL && fix2 == InfixL
then do
left <- fixPrec spi e1 op1 e2
return $ InfixApply spi' left op2 e3
left <- fixPrec (e1 @+@ e2) e1 op1 e2
return $ InfixApply (left @+@ e3) left op2 e3
else do
report $ errAmbiguousParse "operator" (opName op1) (opName op2)
return $ InfixApply spi e1 op1 $ InfixApply spi' e2 op2 e3
......@@ -380,7 +387,7 @@ fixRPrecT infixpatt t1 op1 (InfixPattern spi a t2 op2 t3) = do
else if pr1 > pr2 || pr1 == pr2 && fix1 == InfixL && fix2 == InfixL
then do
left <- fixPrecT infixpatt t1 op1 t2
return $ InfixPattern spi a left op2 t3
return $ InfixPattern (left @+@ t3) a left op2 t3
else do
report $ errAmbiguousParse "operator" op1 op2
return $ infixpatt t1 op1 (InfixPattern spi a t2 op2 t3)
......@@ -392,7 +399,7 @@ fixRPrecT infixpatt t1 op1 (InfixFuncPattern spi a t2 op2 t3) = do
else if pr1 > pr2 || pr1 == pr2 && fix1 == InfixL && fix2 == InfixL
then do
left <- fixPrecT infixpatt t1 op1 t2
return $ InfixFuncPattern spi a left op2 t3
return $ InfixFuncPattern (left @+@ t3) a left op2 t3
else do
report $ errAmbiguousParse "operator" op1 op2
return $ infixpatt t1 op1 (InfixFuncPattern spi a t2 op2 t3)
......@@ -471,6 +478,11 @@ prec op env = case qualLookupP op env of
[] -> defaultP
PrecInfo _ p : _ -> p
-- Combine two entities with SpanInfo to a new SpanInfo (discarding info points)
(@+@) :: (HasSpanInfo a, HasSpanInfo b) => a -> b -> SpanInfo
a @+@ b = fromSrcSpan (combineSpans (getSrcSpan a) (getSrcSpan b))
-- ---------------------------------------------------------------------------
-- Error messages
-- ---------------------------------------------------------------------------
......@@ -489,11 +501,12 @@ errMultiplePrecedence (op:ops) = posMessage op $
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]
, showLine $ getPosition op2]
-- FIXME: Messages may have missing positions for minus operators
-- TODO: Is this still true after span update for parser?
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]
, showLine $ getPosition op2]
......@@ -704,7 +704,7 @@ checkLhs p (FunLhs spi f ts) = FunLhs spi f <$> mapM (checkPattern p) ts
checkLhs p (OpLhs spi t1 op t2) = do
let wrongCalls = concatMap (checkParenPattern (Just $ qualify op)) [t1,t2]
unless (null wrongCalls) $ report $ errInfixWithoutParens
(idPosition op) wrongCalls
(getPosition op) wrongCalls
flip (OpLhs spi) op <$> checkPattern p t1 <*> checkPattern p t2
checkLhs p (ApLhs spi lhs ts) =
ApLhs spi <$> checkLhs p lhs <*> mapM (checkPattern p) ts
......@@ -935,7 +935,7 @@ checkVariable :: SpanInfo -> a -> QualIdent -> SCM (Expression a)
checkVariable spi a v
-- anonymous free variable
| isAnonId (unqualify v) = do
checkAnonFreeVarsExtension $ qidPosition v
checkAnonFreeVarsExtension $ getPosition v
(\n -> Variable spi a $ updQualIdent id (flip renameIdent n) v) <$> newId
-- return $ Variable v
-- normal variable
......@@ -975,7 +975,7 @@ checkRecordExpr _ spi c [] = do
else do report $ errAmbiguousData rs c
return $ Record spi () c []
checkRecordExpr p spi c fs =
checkExpr p (RecordUpdate spi (Constructor (fromSrcSpan (qIdent2Span c)) () c)
checkExpr p (RecordUpdate spi (Constructor (getSpanInfo c) () c)
fs)
checkRecordUpdExpr :: SpanInfo -> SpanInfo -> Expression ()
......@@ -1406,4 +1406,4 @@ errInfixWithoutParens p calls = posMessage p $
where
showCall (q1, q2) = showWithPos q1 <+> text "calls" <+> showWithPos q2
showWithPos q = text (qualName q)
<+> parens (text $ showLine $ qidPosition q)
<+> parens (text $ showLine $ getPosition q)
......@@ -419,7 +419,7 @@ checkTypeLhs = checkTypeVars "left hand side of type declaration"
checkExistVars :: [Ident] -> TSCM ()
checkExistVars evs = do
unless (null evs) $ checkUsedExtension (idPosition $ head evs)
unless (null evs) $ checkUsedExtension (getPosition $ head evs)
"Existentially quantified types" ExistentialQuantification
checkTypeVars "list of existentially quantified type variables" evs
......@@ -633,7 +633,7 @@ errMultipleDeclarations is = posMessage i $
text "Multiple declarations of" <+> text (escName i) <+> text "at:" $+$
nest 2 (vcat $ map showPos is)
where i = head is
showPos = text . showLine . idPosition
showPos = text . showLine . getPosition
errMissingLanguageExtension :: Position -> String -> KnownExtension -> Message
errMissingLanguageExtension p what ext = posMessage p $
......
......@@ -537,8 +537,8 @@ warnAliasNameClash [] = internalError
"WarnCheck.warnAliasNameClash: empty list"
warnAliasNameClash mids = posMessage (head mids) $ text
"Overlapping module aliases" $+$ nest 2 (vcat (map myppAlias mids))
where myppAlias mid@(ModuleIdent pos _) =
ppLine pos <> text ":" <+> text (escModuleName mid)
where myppAlias mid =
ppLine (getPosition mid) <> text ":" <+> text (escModuleName mid)
-- -----------------------------------------------------------------------------
-- Check for overlapping/unreachable and non-exhaustive case alternatives
......
......@@ -225,12 +225,12 @@ showsPair sa sb (a,b)
= showsString "(" . sa a . showsString "," . sb b . showsString ")"
showsIdent :: Ident -> ShowS
showsIdent (Ident p x n)
= showsString "(Ident " . showsPosition p . space
showsIdent (Ident spi x n)
= showsString "(Ident " . showsPosition (getPosition spi) . space
. shows x . space . shows n . showsString ")"
showsQualIdent :: QualIdent -> ShowS
showsQualIdent (QualIdent mident ident)
showsQualIdent (QualIdent _ mident ident)
= showsString "(QualIdent "
. showsMaybe showsModuleIdent mident
. space
......@@ -238,9 +238,9 @@ showsQualIdent (QualIdent mident ident)
. showsString ")"
showsModuleIdent :: ModuleIdent -> ShowS
showsModuleIdent (ModuleIdent pos ss)
showsModuleIdent (ModuleIdent spi ss)
= showsString "(ModuleIdent "
. showsPosition pos . space
. showsPosition (getPosition spi) . space
. showsList (showsQuotes showsString) ss
. showsString ")"
......
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