diff --git a/rlp.cabal b/rlp.cabal index 61250c1..6105295 100644 --- a/rlp.cabal +++ b/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 diff --git a/src/Rlp/Parse.y b/src/Rlp/Parse.y index acb7fad..048617d 100644 --- a/src/Rlp/Parse.y +++ b/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 } diff --git a/src/Rlp/Parse/Types.hs b/src/Rlp/Parse/Types.hs index 8fba710..b8af882 100644 --- a/src/Rlp/Parse/Types.hs +++ b/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)