organisation and cleaning

organisation and tidying

rlp.cabal

@@ -37,6 +37,7 @@ library
                     , Rlp.Parse.Associate
                     , Rlp.Lex
                     , Rlp.Parse.Types
+                    , Compiler.Types
 
     other-modules:    Data.Heap
                     , Data.Pretty

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)

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 <~>
+

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
 }

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 $
+parseError (Located ss t) = addFatal $
-    errorMsg (SrcSpan l c a s) RlpParErrUnexpectedToken
+    errorMsg ss RlpParErrUnexpectedToken
 
 mkInfixD :: Assoc -> Int -> PsName -> P (Decl' RlpcPs)
 mkInfixD a p n = do

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)