diff --git a/rlp.cabal b/rlp.cabal index b44fe23..d2b278b 100644 --- a/rlp.cabal +++ b/rlp.cabal @@ -37,6 +37,7 @@ library , Rlp.Parse.Associate , Rlp.Lex , Rlp.Parse.Types + , Compiler.Types other-modules: Data.Heap , Data.Pretty diff --git a/src/Compiler/RlpcError.hs b/src/Compiler/RlpcError.hs index 37edb40..9530b2e 100644 --- a/src/Compiler/RlpcError.hs +++ b/src/Compiler/RlpcError.hs @@ -5,12 +5,14 @@ module Compiler.RlpcError , MsgEnvelope(..) , Severity(..) , RlpcError(..) - , SrcSpan(..) , msgSpan , msgDiagnostic , msgSeverity , liftRlpcErrors , errorMsg + -- * Located Comonad + , Located(..) + , SrcSpan(..) ) where ---------------------------------------------------------------------------------- @@ -20,6 +22,7 @@ import Data.Text qualified as T import GHC.Exts (IsString(..)) import Lens.Micro.Platform import Lens.Micro.Platform.Internal +import Compiler.Types ---------------------------------------------------------------------------------- data MsgEnvelope e = MsgEnvelope @@ -45,13 +48,6 @@ data Severity = SevWarning | SevError deriving Show -data SrcSpan = SrcSpan - !Int -- ^ Line - !Int -- ^ Column - !Int -- ^ Absolute - !Int -- ^ Length - deriving Show - makeLenses ''MsgEnvelope liftRlpcErrors :: (Functor m, IsRlpcError e) diff --git a/src/Compiler/Types.hs b/src/Compiler/Types.hs new file mode 100644 index 0000000..3a94275 --- /dev/null +++ b/src/Compiler/Types.hs @@ -0,0 +1,66 @@ +module Compiler.Types + ( SrcSpan(..) + , Located(..) + , (<<~), (<~>) + + -- * Re-exports + , Comonad + , Apply + , Bind + ) + where +-------------------------------------------------------------------------------- +import Control.Comonad +import Data.Functor.Apply +import Data.Functor.Bind +-------------------------------------------------------------------------------- + +-- | Token wrapped with a span (line, column, absolute, length) +data Located a = Located SrcSpan a + deriving (Show, Functor) + +instance Apply Located where + liftF2 f (Located sa p) (Located sb q) + = Located (sa <> sb) (p `f` q) + +instance Bind Located where + Located sa a >>- k = Located (sa <> sb) b + where + Located sb b = k a + +instance Comonad Located where + extract (Located _ a) = a + extend ck w@(Located p _) = Located p (ck w) + +data SrcSpan = SrcSpan + !Int -- ^ Line + !Int -- ^ Column + !Int -- ^ Absolute + !Int -- ^ Length + deriving Show + +instance Semigroup SrcSpan where + SrcSpan la ca aa sa <> SrcSpan lb cb ab sb = SrcSpan 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 + lb - aa) + GT -> max sb (aa + la - ab) + +-- | A synonym for '(<<=)' with a tighter precedence and left-associativity for +-- use with '(<~>)' in a sort of, comonadic pseudo-applicative style. + +(<<~) :: (Comonad w) => (w a -> b) -> w a -> w b +(<<~) = (<<=) + +infixl 4 <<~ + +-- | Similar to '(<*>)', but with a cokleisli arrow. + +(<~>) :: (Comonad w, Bind w) => w (w a -> b) -> w a -> w b +mc <~> ma = mc >>- \f -> ma =>> f + +infixl 4 <~> + diff --git a/src/Core/Lex.x b/src/Core/Lex.x index ba62996..99a67b1 100644 --- a/src/Core/Lex.x +++ b/src/Core/Lex.x @@ -22,7 +22,8 @@ import Data.Text qualified as T import Data.String (IsString(..)) import Core.Syntax import Compiler.RLPC -import Compiler.RlpcError +-- TODO: unify Located definitions +import Compiler.RlpcError hiding (Located(..)) import Lens.Micro import Lens.Micro.TH } diff --git a/src/Rlp/Parse.y b/src/Rlp/Parse.y index b3999f8..789c517 100644 --- a/src/Rlp/Parse.y +++ b/src/Rlp/Parse.y @@ -208,8 +208,8 @@ mkProgram ds = do pure $ RlpProgram (associate pt <$> ds) parseError :: Located RlpToken -> P a -parseError (Located (l,c,a,s) t) = addFatal $ - errorMsg (SrcSpan l c a s) RlpParErrUnexpectedToken +parseError (Located ss t) = addFatal $ + errorMsg ss RlpParErrUnexpectedToken mkInfixD :: Assoc -> Int -> PsName -> P (Decl' RlpcPs) mkInfixD a p n = do diff --git a/src/Rlp/Parse/Types.hs b/src/Rlp/Parse/Types.hs index 95d01e2..903c574 100644 --- a/src/Rlp/Parse/Types.hs +++ b/src/Rlp/Parse/Types.hs @@ -29,7 +29,6 @@ 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 @@ -37,14 +36,13 @@ import Data.Fix 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) import Lens.Micro.TH import Lens.Micro import Rlp.Syntax +import Compiler.Types -------------------------------------------------------------------------------- -- | Phantom type identifying rlpc's parser phase @@ -74,6 +72,11 @@ type PsName = Text -------------------------------------------------------------------------------- +spanFromPos :: Position -> Int -> SrcSpan +spanFromPos (l,c,a) s = SrcSpan l c a s + +{-# INLINE spanFromPos #-} + type LexerAction a = AlexInput -> Int -> P a data AlexInput = AlexInput @@ -177,71 +180,6 @@ data Layout = Explicit | Implicit Int deriving (Show, Eq) --- | Token wrapped with a span (line, column, absolute, length) -data Located a = Located !(Int, Int, Int, Int) a - deriving (Show, Functor) - -instance Apply Located where - liftF2 f (Located (la,ca,aa,sa) p) (Located (lb,cb,ab,sb) q) - = Located (l,c,a,s) (p `f` q) - 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 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) - --- | A synonym for '(<<=)' with a different precedence for use with '(<~>)' in a --- sort of, comonadic pseudo-applicative style. - -(<<~) :: (Comonad w) => (w a -> b) -> w a -> w b -(<<~) = (<<=) - -infixl 4 <<~ - --- | Similar to '(<*>)', but with a cokleisli arrow. - -(<~>) :: (Comonad w, Bind w) => w (w a -> b) -> w a -> w b -mc <~> ma = mc >>- \f -> ma =>> f - -infixl 4 <~> - --- f :: (w a -> w b -> c) --- a :: w a --- b :: w b - --- result :: w c --- result = f >~~ a <~> b - -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) - -{-# INLINE spanFromPos #-} - type OpTable = H.HashMap Name OpInfo type OpInfo = (Assoc, Int)