From 953086d75136a422f606eeb02e27f55a00f448ef Mon Sep 17 00:00:00 2001 From: crumbtoo Date: Fri, 16 Feb 2024 16:13:40 -0700 Subject: [PATCH] SrcSpan --- rlp.cabal | 4 ++- src/Compiler/RLPC.hs | 4 +-- src/Compiler/Types.hs | 47 ++++++++------------------- src/Rlp/Parse/Types.hs | 2 -- src/Rlp/Syntax.hs | 13 +++++++- tst/Compiler/TypesSpec.hs | 67 +++++++++++++++++++++++++++++++++++++++ 6 files changed, 98 insertions(+), 39 deletions(-) create mode 100644 tst/Compiler/TypesSpec.hs diff --git a/rlp.cabal b/rlp.cabal index 2a14936..e4d9342 100644 --- a/rlp.cabal +++ b/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 diff --git a/src/Compiler/RLPC.hs b/src/Compiler/RLPC.hs index fb599fc..1ea0ddd 100644 --- a/src/Compiler/RLPC.hs +++ b/src/Compiler/RLPC.hs @@ -220,9 +220,9 @@ docRlpcErr msg = header rule = repeat (ttext . Ansi.blue . Ansi.bold $ "|") srclines = ["", "", ""] filename = msgColour "" - 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 ":" diff --git a/src/Compiler/Types.hs b/src/Compiler/Types.hs index 607a0db..106c5cc 100644 --- a/src/Compiler/Types.hs +++ b/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 diff --git a/src/Rlp/Parse/Types.hs b/src/Rlp/Parse/Types.hs index 4b3cbe1..c449aea 100644 --- a/src/Rlp/Parse/Types.hs +++ b/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 diff --git a/src/Rlp/Syntax.hs b/src/Rlp/Syntax.hs index a22d9b6..fb9f2c0 100644 --- a/src/Rlp/Syntax.hs +++ b/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 diff --git a/tst/Compiler/TypesSpec.hs b/tst/Compiler/TypesSpec.hs new file mode 100644 index 0000000..15e175b --- /dev/null +++ b/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 + ] +