SrcSpan

src/Compiler/RLPC.hs

@@ -220,9 +220,9 @@ docRlpcErr msg = header
                 rule = repeat (ttext . Ansi.blue . Ansi.bold $ "|")
                 srclines = ["", "<problematic source code>", ""]
         filename = msgColour "<input>"
-        pos = msgColour $ tshow (msg ^. msgSpan . srcspanLine)
+        pos = msgColour $ tshow (msg ^. msgSpan . srcSpanLine)
                        <> ":"
-                       <> tshow (msg ^. msgSpan . srcspanColumn)
+                       <> tshow (msg ^. msgSpan . srcSpanColumn)
 
         header = ttext $ filename <> msgColour ":" <> pos <> msgColour ": "
                         <> errorColour "error" <> msgColour ":"

src/Compiler/Types.hs

@@ -1,12 +1,11 @@
 {-# LANGUAGE TemplateHaskell #-}
 module Compiler.Types
     ( SrcSpan(..)
-    , srcspanLine, srcspanColumn, srcspanAbs, srcspanLen
+    , srcSpanLine, srcSpanColumn, srcSpanAbs, srcSpanLen
     , Located(..)
     , _Located
     , located
     , nolo
-    , (<<~), (<~>), (<#>)
 
     -- * Re-exports
     , Comonad
@@ -18,7 +17,7 @@ module Compiler.Types
 import Control.Comonad
 import Data.Functor.Apply
 import Data.Functor.Bind
-import Control.Lens             hiding ((<<~))
+import Control.Lens                 hiding ((<<~))
 import Language.Haskell.TH.Syntax   (Lift)
 --------------------------------------------------------------------------------
 
@@ -47,53 +46,35 @@ data SrcSpan = SrcSpan
     !Int -- ^ Column
     !Int -- ^ Absolute
     !Int -- ^ Length
-    deriving (Show, Lift)
+    deriving (Show, Eq, Lift)
 
 tupling :: Iso' SrcSpan (Int, Int, Int, Int)
 tupling = iso (\ (SrcSpan a b c d) -> (a,b,c,d))
               (\ (a,b,c,d) -> SrcSpan a b c d)
 
-srcspanLine, srcspanColumn, srcspanAbs, srcspanLen :: Lens' SrcSpan Int
-srcspanLine = tupling . _1
-srcspanColumn = tupling . _2
-srcspanAbs = tupling . _3
-srcspanLen = tupling . _4
+srcSpanLine, srcSpanColumn, srcSpanAbs, srcSpanLen :: Lens' SrcSpan Int
+srcSpanLine = tupling . _1
+srcSpanColumn = tupling . _2
+srcSpanAbs = tupling . _3
+srcSpanLen = tupling . _4
 
 -- | debug tool
 nolo :: a -> Located a
 nolo = Located (SrcSpan 0 0 0 0)
 
 instance Semigroup SrcSpan where
+    -- multiple identities? what are the consequences of this...?
+    SrcSpan _ _ _ 0 <> SrcSpan l c a s = SrcSpan l c a s
+    SrcSpan l c a s <> SrcSpan _ _ _ 0 = SrcSpan l c a s
+
     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 <~>
-
--- this is getting silly
-
-(<#>) :: (Functor f) => f (a -> b) -> a -> f b
-fab <#> a = fmap ($ a) fab
-
-infixl 4 <#>
+            LT -> max sa (ab + sb - aa)
+            GT -> max sb (aa + sa - ab)
 
 makePrisms ''Located
 

src/Rlp/Parse/Types.hs

@@ -19,8 +19,6 @@ module Rlp.Parse.Types
     -- ** Lenses
     , aiPrevChar, aiSource, aiBytes, aiPos, posLine, posColumn
 
-    , (<<~), (<~>)
-
     -- * Error handling
     , MsgEnvelope(..), RlpcError(..), RlpParseError(..)
     , addFatal, addWound, addFatalHere, addWoundHere

src/Rlp/Syntax.hs

@@ -10,12 +10,18 @@ module Rlp.Syntax
     , Alt(..)
     , Ty(..)
     , Binding(..)
-    , Expr(..)
+    , Expr(..), Expr', ExprF(..)
     , Lit(..)
     , Pat(..)
     , Decl(..)
     , Program(..)
     , Where
+
+    -- * Re-exports
+    , Cofree(..)
+    , Trans.Cofree.CofreeF
+    , pattern (:<$)
+    , SrcSpan(..)
     )
     where
 ----------------------------------------------------------------------------------
@@ -29,10 +35,12 @@ import GHC.Generics
 import Language.Haskell.TH.Syntax   (Lift)
 import Control.Lens
 
+import Control.Comonad.Trans.Cofree qualified as Trans.Cofree
 import Control.Comonad.Cofree
 import Data.Functor.Foldable
 import Data.Functor.Foldable.TH     (makeBaseFunctor)
 
+import Compiler.Types               (SrcSpan(..))
 import Core.Syntax                  qualified as Core
 import Core                         (Rec(..), HasRHS(..), HasLHS(..))
 ----------------------------------------------------------------------------------
@@ -105,6 +113,9 @@ type Where p = [Binding p]
 data Assoc = InfixL | InfixR | Infix
     deriving (Lift, Show)
 
+pattern (:<$) :: a -> f b -> Trans.Cofree.CofreeF f a b
+pattern a :<$ b = a Trans.Cofree.:< b
+
 --------------------------------------------------------------------------------
 
 makeBaseFunctor ''Expr