rlp.cabal

@@ -70,6 +70,7 @@ library
                     , utf8-string >= 1.0.2 && < 1.1
                     , extra >= 1.7.0 && < 2
                     , semigroupoids
+                    , comonad
 
     hs-source-dirs:   src
     default-language: GHC2021

src/Rlp/Parse.y

@@ -13,6 +13,9 @@ import Lens.Micro.Platform
 import Data.List.Extra
 import Data.Fix
 import Data.Functor.Const
+import Data.Functor.Apply
+import Data.Functor.Bind
+import Control.Comonad
 import Data.Functor
 import Data.Text                    qualified as T
 import Data.Void
@@ -125,14 +128,14 @@ Params      : {- epsilon -}             { [] }
 
 Pat1        :: { Pat' RlpcPs }
             : Var                       { undefined }
-            | Lit                       { LitP <$> $1 }
+            | Lit                       { LitP <<= $1 }
 
 Expr        :: { RlpExpr' RlpcPs }
             : Expr1 varsym Expr         { undefined }
             | Expr1                     { $1 }
 
 Expr1       :: { RlpExpr' RlpcPs }
-            : '(' Expr ')'              { fmap ParE' $2 }
+            : '(' Expr ')'              { $1 .> $2 <. $3 }
             | Lit                       { fmap LitE' $1 }
             | Var                       { fmap VarE' $1 }
 

src/Rlp/Parse/Types.hs

@@ -27,6 +27,7 @@ import Core.Syntax                  (Name)
 import Control.Monad
 import Control.Monad.State.Strict
 import Control.Monad.Errorful
+import Control.Comonad
 import Compiler.RlpcError
 import Data.Text                    (Text)
 import Data.Maybe
@@ -35,6 +36,7 @@ import Data.Functor.Foldable
 import Data.Functor.Const
 import Data.Functor.Classes
 import Data.Functor.Apply
+import Data.Functor.Bind
 import Data.HashMap.Strict          qualified as H
 import Data.Void
 import Data.Word                    (Word8)
@@ -177,6 +179,28 @@ instance Apply Located where
                 LT -> max sa (ab + sb)
                 GT -> max sb (aa + sa)
 
+instance Bind Located where
+    Located sa a >>- k = Located (sa `spanAcross` sb) b
+        where
+            Located sb b = k a
+
+spanAcross :: (Int, Int, Int, Int)
+           -> (Int, Int, Int, Int)
+           -> (Int, Int, Int, Int)
+spanAcross (la,ca,aa,sa) (lb,cb,ab,sb) = (l,c,a,s)
+        where
+            l = min la lb
+            c = min ca cb
+            a = min aa ab
+            s = case aa `compare` ab of
+                EQ -> max sa sb
+                LT -> max sa (ab + sb)
+                GT -> max sb (aa + sa)
+
+instance Comonad Located where
+    extract (Located _ a) = a
+    extend ck w@(Located p _) = Located p (ck w)
+
 spanFromPos :: Position -> Int -> (Int, Int, Int, Int)
 spanFromPos (l,c,a) s = (l,c,a,s)