1 files changed, 23 insertions, 21 deletions

diff --git a/src/lib/AbstractSyntax.hs b/src/lib/AbstractSyntax.hs
index e7a396ce..a169ce4d 100644
--- a/src/lib/AbstractSyntax.hs
+++ b/src/lib/AbstractSyntax.hs
@@ -195,7 +195,7 @@ withTrailingConstraints
   :: GroupW -> (GroupW -> SyntaxM (UAnnBinder VoidS VoidS))
   -> SyntaxM (Nest UAnnBinder VoidS VoidS)
 withTrailingConstraints g cont = case g of
-  WithSrcs _ _ (CBin (WithSrc _ Pipe) lhs c) -> do
+  WithSrcs _ _ (CBin Pipe lhs c) -> do
     Nest (UAnnBinder expl (WithSrcB sid b) ann cs) bs <- withTrailingConstraints lhs cont
     s <- case b of
       UBindSource s -> return s
@@ -253,7 +253,7 @@ explicitBindersOptAnn (WithSrcs _ _ bs) =
 
 -- Binder pattern with an optional type annotation
 patOptAnn :: GroupW -> SyntaxM (UPat VoidS VoidS, Maybe (UType VoidS))
-patOptAnn (WithSrcs _ _ (CBin (WithSrc _ Colon) lhs typeAnn)) = (,) <$> pat lhs <*> (Just <$> expr typeAnn)
+patOptAnn (WithSrcs _ _ (CBin Colon lhs typeAnn)) = (,) <$> pat lhs <*> (Just <$> expr typeAnn)
 patOptAnn (WithSrcs _ _ (CParens [g])) = patOptAnn g
 patOptAnn g = (,Nothing) <$> pat g
 
@@ -267,7 +267,7 @@ uBinder (WithSrcs sid _ b) = case b of
 tyOptPat :: GroupW -> SyntaxM (UAnnBinder VoidS VoidS)
 tyOptPat grpTop@(WithSrcs sid _ grp) = case grp of
   -- Named type
-  CBin (WithSrc _ Colon) lhs typeAnn ->
+  CBin Colon lhs typeAnn ->
     UAnnBinder Explicit <$> uBinder lhs <*> (UAnn <$> expr typeAnn) <*> pure []
   -- Binder in grouping parens.
   CParens [g] -> tyOptPat g
@@ -285,7 +285,7 @@ casePat = \case
 
 pat :: GroupW -> SyntaxM (UPat VoidS VoidS)
 pat (WithSrcs sid _ grp) = WithSrcB sid <$> case grp of
-  CBin (WithSrc _ DepComma) lhs rhs -> do
+  CBin DepComma lhs rhs -> do
     lhs' <- pat lhs
     rhs' <- pat rhs
     return $ UPatDepPair $ PairB lhs' rhs'
@@ -316,8 +316,8 @@ pat (WithSrcs sid _ grp) = WithSrcB sid <$> case grp of
 
 tyOptBinder :: Explicitness -> GroupW -> SyntaxM (UAnnBinder VoidS VoidS)
 tyOptBinder expl (WithSrcs sid sids grp) = case grp of
-  CBin (WithSrc _ Pipe)  _ rhs     -> throw (getSrcId rhs) UnexpectedConstraint
-  CBin (WithSrc _ Colon) name ty -> do
+  CBin Pipe  _ rhs     -> throw (getSrcId rhs) UnexpectedConstraint
+  CBin Colon name ty -> do
     b <- uBinder name
     ann <- UAnn <$> expr ty
     return $ UAnnBinder expl b ann []
@@ -327,7 +327,7 @@ tyOptBinder expl (WithSrcs sid sids grp) = case grp of
 
 binderOptTy :: Explicitness -> GroupW -> SyntaxM (UAnnBinder VoidS VoidS)
 binderOptTy expl = \case
-  WithSrcs _ _ (CBin (WithSrc _ Colon) name ty) -> do
+  WithSrcs _ _ (CBin Colon name ty) -> do
     b <- uBinder name
     ann <- UAnn <$> expr ty
     return $ UAnnBinder expl b ann []
@@ -336,7 +336,7 @@ binderOptTy expl = \case
     return $ UAnnBinder expl b UNoAnn []
 
 binderReqTy :: Explicitness -> GroupW -> SyntaxM (UAnnBinder VoidS VoidS)
-binderReqTy expl (WithSrcs _ _ (CBin (WithSrc _ Colon) name ty)) = do
+binderReqTy expl (WithSrcs _ _ (CBin Colon name ty)) = do
   b <- uBinder name
   ann <- UAnn <$> expr ty
   return $ UAnnBinder expl b ann []
@@ -347,7 +347,7 @@ argList gs = partitionEithers <$> mapM singleArg gs
 
 singleArg :: GroupW -> SyntaxM (Either (UExpr VoidS) (UNamedArg VoidS))
 singleArg = \case
-  WithSrcs _ _ (CBin (WithSrc _ CSEqual) lhs rhs) -> Right <$>
+  WithSrcs _ _ (CBin CSEqual lhs rhs) -> Right <$>
     ((,) <$> withoutSrc <$> identifier "named argument" lhs <*> expr rhs)
   g -> Left <$> expr g
 
@@ -417,7 +417,7 @@ blockDecls (d:ds) = do
 -- === Concrete to abstract syntax of expressions ===
 
 expr :: GroupW -> SyntaxM (UExpr VoidS)
-expr (WithSrcs sid _ grp) = WithSrcE sid <$> case grp of
+expr (WithSrcs sid sids grp) = WithSrcE sid <$> case grp of
   CLeaf x -> leaf sid x
   CPrim prim xs     -> UPrim prim <$> mapM expr xs
   CParens [g] -> do
@@ -449,9 +449,9 @@ expr (WithSrcs sid _ grp) = WithSrcE sid <$> case grp of
           args' <- mapM expr args
           return $ UTabApp f args'
         _ -> error "unexpected postfix group (should be ruled out at grouping stage)"
-  CBin (WithSrc opSid op) lhs rhs -> case op of
-    Dollar             -> extendAppRight <$> expr lhs <*> expr rhs
-    Pipe               -> extendAppLeft  <$> expr lhs <*> expr rhs
+  CBin op lhs rhs -> case op of
+    Dollar -> extendAppRight <$> expr lhs <*> expr rhs
+    Pipe   -> extendAppLeft  <$> expr lhs <*> expr rhs
     Dot -> do
       lhs' <- expr lhs
       WithSrcs rhsSid _ rhs' <- return rhs
@@ -461,13 +461,17 @@ expr (WithSrcs sid _ grp) = WithSrcE sid <$> case grp of
         _ -> throw rhsSid BadField
       return $ UFieldAccess lhs' (WithSrc rhsSid name)
     DoubleColon   -> UTypeAnn <$> (expr lhs) <*> expr rhs
-    EvalBinOp s -> evalOp s
+    EvalBinOp (WithSrc opSid s) -> do
+      let f = WithSrcE opSid (fromSourceNameW (WithSrc opSid s))
+      lhs' <- expr lhs
+      rhs' <- expr rhs
+      return $ explicitApp f [lhs', rhs']
     DepAmpersand  -> do
       lhs' <- tyOptPat lhs
       UDepPairTy . (UDepPairType ExplicitDepPair lhs') <$> expr rhs
     DepComma      -> UDepPair <$> (expr lhs) <*> expr rhs
-    CSEqual       -> throw opSid BadEqualSign
-    Colon         -> throw opSid BadColon
+    CSEqual       -> throw errSid BadEqualSign
+    Colon         -> throw errSid BadColon
     ImplicitArrow -> case lhs of
       WithSrcs _ _ (CParens gs) -> do
         bs <- aPiBinders gs
@@ -478,11 +482,9 @@ expr (WithSrcs sid _ grp) = WithSrcE sid <$> case grp of
       lhs' <- tyOptPat lhs
       UTabPi . (UTabPiExpr lhs') <$> expr rhs
    where
-    evalOp s = do
-      let f = WithSrcE opSid (fromSourceNameW (WithSrc opSid s))
-      lhs' <- expr lhs
-      rhs' <- expr rhs
-      return $ explicitApp f [lhs', rhs']
+     errSid = case sids of
+       [sid'] -> sid'
+       _ -> sid
   CPrefix (WithSrc prefixSid name) g -> do
     case name of
       "+" -> (withoutSrc <$> expr g) <&> \case