Fix compilation errors resulting from identifier changes

src/Checks/ExportCheck.hs

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

src/Checks/InterfaceCheck.hs

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

src/Checks/KindCheck.hs

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

src/Checks/PrecCheck.hs

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

src/Checks/SyntaxCheck.hs

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

src/Checks/TypeSyntaxCheck.hs

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

src/Checks/WarnCheck.hs

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

src/IL/ShowModule.hs

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