SrcSpan

rlp.cabal

@@ -73,7 +73,7 @@ library
                     , effectful-core ^>=2.3.0.0
                     , deriving-compat ^>=0.6.0
                     , these >=0.2 && <2.0
-                    , free
+                    , free >=5.2
 
     hs-source-dirs:   src
     default-language: GHC2021
@@ -117,8 +117,10 @@ test-suite rlp-test
                  , QuickCheck
                  , hspec            ==2.*
                  , microlens
+                 , lens >=5.2.3 && <6.0
     other-modules: Arith
                  , GMSpec
                  , Core.HindleyMilnerSpec
+                 , Compiler.TypesSpec
     build-tool-depends: hspec-discover:hspec-discover
 

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
@@ -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, srcSpanColumn, srcSpanAbs, srcSpanLen :: Lens' SrcSpan Int
-srcspanLine = tupling . _1
+srcSpanLine = tupling . _1
-srcspanColumn = tupling . _2
+srcSpanColumn = tupling . _2
-srcspanAbs = tupling . _3
+srcSpanAbs = tupling . _3
-srcspanLen = tupling . _4
+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)
+            LT -> max sa (ab + sb - aa)
-            GT -> max sb (aa + la - ab)
+            GT -> max sb (aa + sa - 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 <#>
 
 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

tst/Compiler/TypesSpec.hs

@@ -0,0 +1,67 @@
+{-# LANGUAGE ParallelListComp #-}
+module Compiler.TypesSpec
+    ( spec
+    )
+    where
+--------------------------------------------------------------------------------
+import Control.Lens.Combinators
+import Data.Function            ((&))
+
+import Test.QuickCheck
+import Test.Hspec
+
+import Compiler.Types           (SrcSpan(..), srcSpanAbs, srcSpanLen)
+--------------------------------------------------------------------------------
+
+spec :: Spec
+spec = do
+    describe "SrcSpan" $ do
+        -- it "associates under closure"
+        --     prop_SrcSpan_mul_associative
+        it "commutes under closure"
+            prop_SrcSpan_mul_commutative
+        it "equals itself when squared"
+            prop_SrcSpan_mul_square_eq
+
+prop_SrcSpan_mul_associative :: Property
+prop_SrcSpan_mul_associative = property $ \a b c ->
+    -- very crudely approximate when overflow will occur; bail we think it
+    -- will
+    (([a,b,c] :: [SrcSpan]) & allOf (each . (srcSpanAbs <> srcSpanLen))
+                                    (< (maxBound @Int `div` 3)))
+    ==> (a <> b) <> c === a <> (b <> c :: SrcSpan)
+
+prop_SrcSpan_mul_commutative :: Property
+prop_SrcSpan_mul_commutative = property $ \a b ->
+    a <> b === (b <> a :: SrcSpan)
+
+prop_SrcSpan_mul_square_eq :: Property
+prop_SrcSpan_mul_square_eq = property $ \a ->
+    a <> a === (a :: SrcSpan)
+
+instance Arbitrary SrcSpan where
+    arbitrary = do
+        l <- chooseInt (1, maxBound)
+        c <- chooseInt (1, maxBound)
+        a <- chooseInt (0, maxBound)
+            `suchThat` (\n -> n >= pred l + pred c)
+        s <- chooseInt (0, maxBound)
+        pure $ SrcSpan l c a s
+
+    shrink (SrcSpan l c a s) =
+        [ SrcSpan l' c' a' s'
+        | (l',c',a',s') <- shrinkParts
+        , l' >= 1
+        , c' >= 1
+        , a' >= pred l' + pred c'
+        ]
+      where
+        -- shfl as = unsafePerformIO (generate $ shuffle as)
+        shrinkParts = 
+            [ (l',c',a',s')
+            | l' <- shrinkIntegral l
+            | c' <- shrinkIntegral c
+            | a' <- shrinkIntegral a
+            | s' <- shrinkIntegral s
+            ]
+