Compare commits
10 Commits
gm-visuali
...
no-ttg
| Author | SHA1 | Date | |
|---|---|---|---|
|
09f393af89 | ||
|
|
e63e34a3d8 | ||
|
|
13e8701b8a | ||
|
|
66c3d878c2 | ||
|
|
820bd7cdbc | ||
|
|
9297d815d6 | ||
|
|
910cf66468 | ||
|
|
da81a5a98e | ||
|
|
caeec216b5 | ||
|
|
e9cab1ddaf |
@@ -32,6 +32,8 @@ library
|
||||
, Core.HindleyMilner
|
||||
, Control.Monad.Errorful
|
||||
, Rlp.Syntax
|
||||
, Rlp.Syntax.Backstage
|
||||
, Rlp.Syntax.Types
|
||||
-- , Rlp.Parse.Decls
|
||||
, Rlp.Parse
|
||||
, Rlp.Parse.Associate
|
||||
@@ -73,6 +75,7 @@ library
|
||||
, effectful-core ^>=2.3.0.0
|
||||
, deriving-compat ^>=0.6.0
|
||||
, these >=0.2 && <2.0
|
||||
, free >=5.2
|
||||
|
||||
hs-source-dirs: src
|
||||
default-language: GHC2021
|
||||
@@ -116,8 +119,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
|
||||
|
||||
|
||||
@@ -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 ":"
|
||||
|
||||
@@ -1,33 +1,81 @@
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE FunctionalDependencies #-}
|
||||
{-# LANGUAGE UndecidableInstances, QuantifiedConstraints #-}
|
||||
{-# LANGUAGE PatternSynonyms #-}
|
||||
module Compiler.Types
|
||||
( SrcSpan(..)
|
||||
, srcspanLine, srcspanColumn, srcspanAbs, srcspanLen
|
||||
, srcSpanLine, srcSpanColumn, srcSpanAbs, srcSpanLen
|
||||
, pattern (:<$)
|
||||
, Located(..)
|
||||
, HasLocation(..)
|
||||
, _Located
|
||||
, located
|
||||
, nolo
|
||||
, (<<~), (<~>), (<#>)
|
||||
, nolo, nolo'
|
||||
|
||||
, (<~>), (~>), (~~>), (<~~)
|
||||
|
||||
, comb2, comb3, comb4
|
||||
, lochead
|
||||
|
||||
-- * Re-exports
|
||||
, Comonad
|
||||
, Comonad(extract)
|
||||
, Apply
|
||||
, Bind
|
||||
)
|
||||
where
|
||||
--------------------------------------------------------------------------------
|
||||
import Language.Haskell.TH.Syntax (Lift)
|
||||
|
||||
import Control.Comonad
|
||||
import Control.Comonad.Cofree
|
||||
import Control.Comonad.Trans.Cofree qualified as Trans.Cofree
|
||||
import Control.Comonad.Trans.Cofree (CofreeF)
|
||||
import Data.Functor.Apply
|
||||
import Data.Functor.Bind
|
||||
import Control.Lens hiding ((<<~))
|
||||
import Language.Haskell.TH.Syntax (Lift)
|
||||
import Data.Functor.Compose
|
||||
import Data.Functor.Foldable
|
||||
import Data.Semigroup.Foldable
|
||||
import Data.Fix hiding (cata, ana)
|
||||
import Data.Kind
|
||||
import Control.Lens hiding ((<<~), (:<))
|
||||
|
||||
import Data.List.NonEmpty (NonEmpty)
|
||||
import Data.Function (on)
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
-- | Token wrapped with a span (line, column, absolute, length)
|
||||
data Located a = Located SrcSpan a
|
||||
deriving (Show, Lift, Functor)
|
||||
|
||||
located :: Lens (Located a) (Located b) a b
|
||||
located = lens extract ($>)
|
||||
data Floc f = Floc SrcSpan (f (Floc f))
|
||||
|
||||
pattern (:<$) :: a -> f b -> Trans.Cofree.CofreeF f a b
|
||||
pattern a :<$ b = a Trans.Cofree.:< b
|
||||
|
||||
(<~>) :: a -> b -> SrcSpan
|
||||
(<~>) = undefined
|
||||
|
||||
infixl 5 <~>
|
||||
|
||||
-- (~>) :: (CanGet k, CanSet k', HasLocation k a, HasLocation k' b)
|
||||
-- => a -> b -> b
|
||||
-- a ~> b =
|
||||
(~>) = undefined
|
||||
|
||||
infixl 4 ~>
|
||||
|
||||
-- (~~>) :: (CanGet k, HasLocation k a, CanSet k', HasLocation k' b)
|
||||
-- => (a -> b) -> a -> b
|
||||
-- (~~>) :: (f SrcSpan -> b) -> Cofree f SrcSpan -> Cofree f SrcSpan
|
||||
-- f ~~> (ss :< as) = ss :< f as
|
||||
(~~>) = undefined
|
||||
|
||||
infixl 3 ~~>
|
||||
|
||||
-- (<~~) :: (GetLocation a, HasLocation b) => (a -> b) -> a -> b
|
||||
-- a <~~ b = a b & location <>~ srcspan b
|
||||
(<~~) = undefined
|
||||
|
||||
infixr 2 <~~
|
||||
|
||||
instance Apply Located where
|
||||
liftF2 f (Located sa p) (Located sb q)
|
||||
@@ -47,53 +95,136 @@ 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)
|
||||
|
||||
nolo' :: f (Cofree f SrcSpan) -> Cofree f SrcSpan
|
||||
nolo' as = SrcSpan 0 0 0 0 :< as
|
||||
|
||||
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)
|
||||
LT -> max sa (ab + sb - aa)
|
||||
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
|
||||
(<<~) = (<<=)
|
||||
data GetOrSet = Get | Set | GetSet
|
||||
|
||||
infixl 4 <<~
|
||||
class CanGet (k :: GetOrSet)
|
||||
class CanSet (k :: GetOrSet) where
|
||||
|
||||
-- | Similar to '(<*>)', but with a cokleisli arrow.
|
||||
instance CanGet Get
|
||||
instance CanGet GetSet
|
||||
instance CanSet Set
|
||||
instance CanSet GetSet
|
||||
|
||||
(<~>) :: (Comonad w, Bind w) => w (w a -> b) -> w a -> w b
|
||||
mc <~> ma = mc >>- \f -> ma =>> f
|
||||
data GetSetLens (k :: GetOrSet) s t a b :: Type where
|
||||
Getter_ :: (s -> a) -> GetSetLens Get s t a b
|
||||
Setter_ :: ((a -> b) -> s -> t) -> GetSetLens Set s t a b
|
||||
GetterSetter :: (CanGet k', CanSet k')
|
||||
=> (s -> a) -> (s -> b -> t) -> GetSetLens k' s t a b
|
||||
|
||||
infixl 4 <~>
|
||||
type GetSetLens' k s a = GetSetLens k s s a a
|
||||
|
||||
-- this is getting silly
|
||||
class HasLocation k s | s -> k where
|
||||
-- location :: (Access k f, Functor f) => LensLike' f s SrcSpan
|
||||
getSetLocation :: GetSetLens' k s SrcSpan
|
||||
|
||||
(<#>) :: (Functor f) => f (a -> b) -> a -> f b
|
||||
fab <#> a = fmap ($ a) fab
|
||||
type family Access (k :: GetOrSet) f where
|
||||
Access GetSet f = Functor f
|
||||
Access Set f = Settable f
|
||||
Access Get f = (Functor f, Contravariant f)
|
||||
|
||||
infixl 4 <#>
|
||||
instance HasLocation GetSet SrcSpan where
|
||||
getSetLocation = GetterSetter id (flip const)
|
||||
-- location = fromGetSetLens getSetLocation
|
||||
|
||||
instance (CanSet k, HasLocation k a) => HasLocation Set (r -> a) where
|
||||
getSetLocation = Setter_ $ \ss ra r -> ra r & fromSet getSetLocation %~ ss
|
||||
-- location = fromSet getSetLocation
|
||||
|
||||
instance (HasLocation k a) => HasLocation k (Cofree f a) where
|
||||
getSetLocation = case getSetLocation @_ @a of
|
||||
Getter_ sa -> Getter_ $ \ (s :< _) -> sa s
|
||||
Setter_ abst -> Setter_ $ \ss (s :< as) -> abst ss s :< as
|
||||
GetterSetter sa sbt -> GetterSetter sa' sbt' where
|
||||
sa' (s :< _) = sa s
|
||||
sbt' (s :< as) b = sbt s b :< as
|
||||
|
||||
location :: (Access k f, Functor f, HasLocation k s)
|
||||
=> LensLike' f s SrcSpan
|
||||
location = fromGetSetLens getSetLocation
|
||||
|
||||
fromGetSetLens :: (Access k f, Functor f) => GetSetLens' k s a -> LensLike' f s a
|
||||
fromGetSetLens gsl = case gsl of
|
||||
Getter_ sa -> to sa
|
||||
Setter_ abst -> setting abst
|
||||
GetterSetter sa sbt -> lens sa sbt
|
||||
|
||||
fromGet :: (CanGet k) => GetSetLens k s t a b -> Getter s a
|
||||
fromGet (Getter_ sa) = to sa
|
||||
fromGet (GetterSetter sa _) = to sa
|
||||
|
||||
fromSet :: (CanSet k) => GetSetLens k s t a b -> Setter s t a b
|
||||
fromSet (Setter_ abst) = setting abst
|
||||
fromSet (GetterSetter sa sbt) = lens sa sbt
|
||||
|
||||
fromGetSet :: (CanGet k, CanSet k) => GetSetLens k s t a b -> Lens s t a b
|
||||
fromGetSet (GetterSetter sa sbt) = lens sa sbt
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
comb2 :: (Functor f, Semigroup m)
|
||||
=> (Cofree f m -> Cofree f m -> f (Cofree f m))
|
||||
-> Cofree f m -> Cofree f m -> Cofree f m
|
||||
comb2 f a b = ss :< f a b
|
||||
where ss = a `mextract` b
|
||||
|
||||
comb3 :: (Functor f, Semigroup m)
|
||||
=> (Cofree f m -> Cofree f m -> Cofree f m -> f (Cofree f m))
|
||||
-> Cofree f m -> Cofree f m -> Cofree f m -> Cofree f m
|
||||
comb3 f a b c = ss :< f a b c
|
||||
where ss = a `mapply` b `mextract` c
|
||||
|
||||
comb4 :: (Functor f, Semigroup m)
|
||||
=> (Cofree f m -> Cofree f m -> Cofree f m -> Cofree f m
|
||||
-> f (Cofree f m))
|
||||
-> Cofree f m -> Cofree f m -> Cofree f m -> Cofree f m -> Cofree f m
|
||||
comb4 f a b c d = ss :< f a b c d
|
||||
where ss = a `mapply` b `mapply` c `mextract` d
|
||||
|
||||
mextract :: (Comonad w, Semigroup m) => w m -> w m -> m
|
||||
mextract = (<>) `on` extract
|
||||
|
||||
mapply :: (Comonad w, Semigroup m) => w m -> w m -> w m
|
||||
mapply a b = b <&> (<> extract a)
|
||||
|
||||
lochead :: Functor f
|
||||
=> (f SrcSpan -> f SrcSpan) -> Located (f SrcSpan) -> Cofree f SrcSpan
|
||||
lochead afs (Located ss fss) = ss :< unwrap (lochead afs $ Located ss fss)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
makePrisms ''Located
|
||||
|
||||
|
||||
@@ -8,6 +8,7 @@ module Rlp.Lex
|
||||
, Located(..)
|
||||
, lexToken
|
||||
, lexStream
|
||||
, lexStream'
|
||||
, lexDebug
|
||||
, lexCont
|
||||
, popLexState
|
||||
@@ -29,6 +30,7 @@ import Data.Word
|
||||
import Data.Default
|
||||
import Control.Lens
|
||||
|
||||
import Compiler.Types
|
||||
import Debug.Trace
|
||||
import Rlp.Parse.Types
|
||||
}
|
||||
@@ -274,11 +276,12 @@ lexCont :: (Located RlpToken -> P a) -> P a
|
||||
lexCont = (lexToken >>=)
|
||||
|
||||
lexStream :: P [RlpToken]
|
||||
lexStream = do
|
||||
t <- lexToken
|
||||
case t of
|
||||
Located _ TokenEOF -> pure [TokenEOF]
|
||||
Located _ t -> (t:) <$> lexStream
|
||||
lexStream = fmap extract <$> lexStream'
|
||||
|
||||
lexStream' :: P [Located RlpToken]
|
||||
lexStream' = lexToken >>= \case
|
||||
t@(Located _ TokenEOF) -> pure [t]
|
||||
t -> (t:) <$> lexStream'
|
||||
|
||||
lexDebug :: (Located RlpToken -> P a) -> P a
|
||||
lexDebug k = do
|
||||
|
||||
252
src/Rlp/Parse.y
252
src/Rlp/Parse.y
@@ -5,15 +5,17 @@ module Rlp.Parse
|
||||
, parseRlpProgR
|
||||
, parseRlpExpr
|
||||
, parseRlpExprR
|
||||
, runP'
|
||||
)
|
||||
where
|
||||
import Compiler.RlpcError
|
||||
import Compiler.RLPC
|
||||
import Control.Comonad.Cofree
|
||||
import Rlp.Lex
|
||||
import Rlp.Syntax
|
||||
import Rlp.Parse.Types
|
||||
import Rlp.Parse.Associate
|
||||
import Control.Lens hiding (snoc, (.>), (<.), (<<~))
|
||||
import Control.Lens hiding (snoc, (.>), (<.), (<<~), (:<))
|
||||
import Data.List.Extra
|
||||
import Data.Fix
|
||||
import Data.Functor.Const
|
||||
@@ -71,12 +73,11 @@ import Compiler.Types
|
||||
|
||||
%%
|
||||
|
||||
StandaloneProgram :: { RlpProgram RlpcPs }
|
||||
StandaloneProgram : '{' Decls '}' {% mkProgram $2 }
|
||||
| VL DeclsV VR {% mkProgram $2 }
|
||||
StandaloneProgram :: { Program RlpcPs SrcSpan }
|
||||
StandaloneProgram : layout0(Decl) {% mkProgram $1 }
|
||||
|
||||
StandaloneExpr :: { RlpExpr RlpcPs }
|
||||
: VL Expr VR { extract $2 }
|
||||
StandaloneExpr :: { Expr' RlpcPs SrcSpan }
|
||||
: VL Expr VR { $2 }
|
||||
|
||||
VL :: { () }
|
||||
VL : vlbrace { () }
|
||||
@@ -85,125 +86,105 @@ VR :: { () }
|
||||
VR : vrbrace { () }
|
||||
| error { () }
|
||||
|
||||
Decls :: { [Decl' RlpcPs] }
|
||||
Decls : Decl ';' Decls { $1 : $3 }
|
||||
| Decl ';' { [$1] }
|
||||
| Decl { [$1] }
|
||||
VS :: { () }
|
||||
VS : ';' { () }
|
||||
| vsemi { () }
|
||||
|
||||
DeclsV :: { [Decl' RlpcPs] }
|
||||
DeclsV : Decl VS DeclsV { $1 : $3 }
|
||||
| Decl VS { [$1] }
|
||||
| Decl { [$1] }
|
||||
|
||||
VS :: { Located RlpToken }
|
||||
VS : ';' { $1 }
|
||||
| vsemi { $1 }
|
||||
|
||||
Decl :: { Decl' RlpcPs }
|
||||
Decl :: { Decl RlpcPs SrcSpan }
|
||||
: FunDecl { $1 }
|
||||
| TySigDecl { $1 }
|
||||
| DataDecl { $1 }
|
||||
| InfixDecl { $1 }
|
||||
|
||||
TySigDecl :: { Decl' RlpcPs }
|
||||
: Var '::' Type { (\e -> TySigD [extract e]) <<~ $1 <~> $3 }
|
||||
TySigDecl :: { Decl RlpcPs SrcSpan }
|
||||
: Var '::' Type { TySigD [$1] $3 }
|
||||
|
||||
InfixDecl :: { Decl' RlpcPs }
|
||||
: InfixWord litint InfixOp { $1 =>> \w ->
|
||||
InfixD (extract $1) (extractInt $ extract $2)
|
||||
(extract $3) }
|
||||
InfixDecl :: { Decl RlpcPs SrcSpan }
|
||||
: InfixWord litint InfixOp {% mkInfixD $1 ($2 ^. _litint) $3 }
|
||||
|
||||
InfixWord :: { Located Assoc }
|
||||
: infixl { $1 \$> InfixL }
|
||||
| infixr { $1 \$> InfixR }
|
||||
| infix { $1 \$> Infix }
|
||||
InfixWord :: { Assoc }
|
||||
: infixl { InfixL }
|
||||
| infixr { InfixR }
|
||||
| infix { Infix }
|
||||
|
||||
DataDecl :: { Decl' RlpcPs }
|
||||
: data Con TyParams '=' DataCons { $1 \$> DataD (extract $2) $3 $5 }
|
||||
DataDecl :: { Decl RlpcPs SrcSpan }
|
||||
: data Con TyParams '=' DataCons { DataD $2 $3 $5 }
|
||||
|
||||
TyParams :: { [PsName] }
|
||||
: {- epsilon -} { [] }
|
||||
| TyParams varname { $1 `snoc` (extractName . extract $ $2) }
|
||||
| TyParams varname { $1 `snoc` extractName $2 }
|
||||
|
||||
DataCons :: { [ConAlt RlpcPs] }
|
||||
: DataCons '|' DataCon { $1 `snoc` $3 }
|
||||
| DataCon { [$1] }
|
||||
|
||||
DataCon :: { ConAlt RlpcPs }
|
||||
: Con Type1s { ConAlt (extract $1) $2 }
|
||||
: Con Type1s { ConAlt $1 $2 }
|
||||
|
||||
Type1s :: { [RlpType' RlpcPs] }
|
||||
Type1s :: { [Ty RlpcPs] }
|
||||
: {- epsilon -} { [] }
|
||||
| Type1s Type1 { $1 `snoc` $2 }
|
||||
|
||||
Type1 :: { RlpType' RlpcPs }
|
||||
Type1 :: { Ty RlpcPs }
|
||||
: '(' Type ')' { $2 }
|
||||
| conname { fmap ConT (mkPsName $1) }
|
||||
| varname { fmap VarT (mkPsName $1) }
|
||||
| conname { ConT (extractName $1) }
|
||||
| varname { VarT (extractName $1) }
|
||||
|
||||
Type :: { RlpType' RlpcPs }
|
||||
: Type '->' Type { FunT <<~ $1 <~> $3 }
|
||||
Type :: { Ty RlpcPs }
|
||||
: Type '->' Type { FunT $1 $3 }
|
||||
| TypeApp { $1 }
|
||||
|
||||
TypeApp :: { RlpType' RlpcPs }
|
||||
TypeApp :: { Ty RlpcPs }
|
||||
: Type1 { $1 }
|
||||
| TypeApp Type1 { AppT <<~ $1 <~> $2 }
|
||||
| TypeApp Type1 { AppT $1 $2 }
|
||||
|
||||
FunDecl :: { Decl' RlpcPs }
|
||||
FunDecl : Var Params '=' Expr { $4 =>> \e ->
|
||||
FunD (extract $1) $2 e Nothing }
|
||||
FunDecl :: { Decl RlpcPs SrcSpan }
|
||||
FunDecl : Var Params '=' Expr { FunD $1 $2 $4 Nothing }
|
||||
|
||||
Params :: { [Pat' RlpcPs] }
|
||||
Params :: { [Pat RlpcPs] }
|
||||
Params : {- epsilon -} { [] }
|
||||
| Params Pat1 { $1 `snoc` $2 }
|
||||
|
||||
Pat :: { Pat' RlpcPs }
|
||||
: Con Pat1s { $1 =>> \cn ->
|
||||
ConP (extract $1) $2 }
|
||||
Pat :: { Pat RlpcPs }
|
||||
: Con Pat1s { ConP $1 $2 }
|
||||
| Pat1 { $1 }
|
||||
|
||||
Pat1s :: { [Pat' RlpcPs] }
|
||||
Pat1s :: { [Pat RlpcPs] }
|
||||
: Pat1s Pat1 { $1 `snoc` $2 }
|
||||
| Pat1 { [$1] }
|
||||
|
||||
Pat1 :: { Pat' RlpcPs }
|
||||
: Con { fmap (`ConP` []) $1 }
|
||||
| Var { fmap VarP $1 }
|
||||
| Lit { LitP <<= $1 }
|
||||
| '(' Pat ')' { $1 .> $2 <. $3 }
|
||||
Pat1 :: { Pat RlpcPs }
|
||||
: Con { ConP $1 [] }
|
||||
| Var { VarP $1 }
|
||||
| Lit { LitP $1 }
|
||||
| '(' Pat ')' { $2 }
|
||||
|
||||
Expr :: { RlpExpr' RlpcPs }
|
||||
Expr :: { Expr' RlpcPs SrcSpan }
|
||||
-- infixities delayed till next release :(
|
||||
-- : Expr1 InfixOp Expr { $2 =>> \o ->
|
||||
-- OAppE (extract o) $1 $3 }
|
||||
: TempInfixExpr { $1 }
|
||||
-- : Expr1 InfixOp Expr { undefined }
|
||||
: AppExpr { $1 }
|
||||
| TempInfixExpr { $1 }
|
||||
| LetExpr { $1 }
|
||||
| CaseExpr { $1 }
|
||||
| AppExpr { $1 }
|
||||
|
||||
TempInfixExpr :: { RlpExpr' RlpcPs }
|
||||
TempInfixExpr :: { Expr' RlpcPs SrcSpan }
|
||||
TempInfixExpr : Expr1 InfixOp TempInfixExpr {% tempInfixExprErr $1 $3 }
|
||||
| Expr1 InfixOp Expr1 { $2 =>> \o ->
|
||||
OAppE (extract o) $1 $3 }
|
||||
| Expr1 InfixOp Expr1 { nolo' $ InfixEF $2 $1 $3 }
|
||||
|
||||
AppExpr :: { RlpExpr' RlpcPs }
|
||||
AppExpr :: { Expr' RlpcPs SrcSpan }
|
||||
: Expr1 { $1 }
|
||||
| AppExpr Expr1 { AppE <<~ $1 <~> $2 }
|
||||
| AppExpr Expr1 { comb2 AppEF $1 $2 }
|
||||
|
||||
LetExpr :: { RlpExpr' RlpcPs }
|
||||
: let layout1(Binding) in Expr { $1 \$> LetE $2 $4 }
|
||||
| letrec layout1(Binding) in Expr { $1 \$> LetrecE $2 $4 }
|
||||
LetExpr :: { Expr' RlpcPs SrcSpan }
|
||||
: let layout1(Binding) in Expr { nolo' $ LetEF NonRec $2 $4 }
|
||||
| letrec layout1(Binding) in Expr { nolo' $ LetEF Rec $2 $4 }
|
||||
|
||||
CaseExpr :: { RlpExpr' RlpcPs }
|
||||
: case Expr of layout0(CaseAlt)
|
||||
{ CaseE <<~ $2 <#> $4 }
|
||||
CaseExpr :: { Expr' RlpcPs SrcSpan }
|
||||
: case Expr of layout0(Alt) { nolo' $ CaseEF $2 $4 }
|
||||
|
||||
-- TODO: where-binds
|
||||
CaseAlt :: { (Alt RlpcPs, Where RlpcPs) }
|
||||
: Alt { ($1, []) }
|
||||
|
||||
Alt :: { Alt RlpcPs }
|
||||
: Pat '->' Expr { AltA $1 $3 }
|
||||
Alt :: { Alt' RlpcPs SrcSpan }
|
||||
: Pat '->' Expr { AltA $1 (view _unwrap $3) Nothing }
|
||||
|
||||
-- layout0(p : β) :: [β]
|
||||
layout0(p) : '{' layout_list0(';',p) '}' { $2 }
|
||||
@@ -222,38 +203,68 @@ layout1(p) : '{' layout_list1(';',p) '}' { $2 }
|
||||
layout_list1(sep,p) : p { [$1] }
|
||||
| layout_list1(sep,p) sep p { $1 `snoc` $3 }
|
||||
|
||||
Binding :: { Binding' RlpcPs }
|
||||
: Pat '=' Expr { PatB <<~ $1 <~> $3 }
|
||||
Binding :: { Binding' RlpcPs SrcSpan }
|
||||
: Pat '=' Expr { PatB $1 (view _unwrap $3) }
|
||||
|
||||
Expr1 :: { RlpExpr' RlpcPs }
|
||||
: '(' Expr ')' { $1 .> $2 <. $3 }
|
||||
| Lit { fmap LitE $1 }
|
||||
| Var { fmap VarE $1 }
|
||||
| Con { fmap VarE $1 }
|
||||
Expr1 :: { Expr' RlpcPs SrcSpan }
|
||||
: '(' Expr ')' { $2 }
|
||||
| Lit { nolo' $ LitEF $1 }
|
||||
| Var { case $1 of Located ss _ -> ss :< VarEF $1 }
|
||||
| Con { case $1 of Located ss _ -> ss :< VarEF $1 }
|
||||
|
||||
InfixOp :: { Located PsName }
|
||||
: consym { mkPsName $1 }
|
||||
| varsym { mkPsName $1 }
|
||||
InfixOp :: { PsName }
|
||||
: consym { extractName $1 }
|
||||
| varsym { extractName $1 }
|
||||
|
||||
-- TODO: microlens-pro save me microlens-pro (rewrite this with prisms)
|
||||
Lit :: { Lit' RlpcPs }
|
||||
: litint { $1 <&> (IntL . (\ (TokenLitInt n) -> n)) }
|
||||
Lit :: { Lit RlpcPs }
|
||||
: litint { $1 ^. to extract
|
||||
. singular _TokenLitInt
|
||||
. to IntL }
|
||||
|
||||
Var :: { Located PsName }
|
||||
Var : varname { mkPsName $1 }
|
||||
| varsym { mkPsName $1 }
|
||||
Var :: { PsName }
|
||||
Var : varname { $1 <&> view (singular _TokenVarName) }
|
||||
| varsym { $1 <&> view (singular _TokenVarSym) }
|
||||
|
||||
Con :: { Located PsName }
|
||||
: conname { mkPsName $1 }
|
||||
Con :: { PsName }
|
||||
: conname { $1 <&> view (singular _TokenConName) }
|
||||
|
||||
{
|
||||
|
||||
parseRlpExprR :: (Monad m) => Text -> RLPCT m (RlpExpr RlpcPs)
|
||||
parseRlpProgR :: (Monad m) => Text -> RLPCT m (Program RlpcPs SrcSpan)
|
||||
parseRlpProgR s = do
|
||||
a <- liftErrorful $ pToErrorful parseRlpProg st
|
||||
addDebugMsg @_ @String "dump-parsed" $ show a
|
||||
pure a
|
||||
where
|
||||
st = programInitState s
|
||||
|
||||
parseRlpExprR :: (Monad m) => Text -> RLPCT m (Expr' RlpcPs SrcSpan)
|
||||
parseRlpExprR s = liftErrorful $ pToErrorful parseRlpExpr st
|
||||
where
|
||||
st = programInitState s
|
||||
|
||||
parseRlpProgR :: (Monad m) => Text -> RLPCT m (RlpProgram RlpcPs)
|
||||
mkInfixD :: Assoc -> Int -> PsName -> P (Decl RlpcPs SrcSpan)
|
||||
mkInfixD a p ln@(Located ss n) = do
|
||||
let opl :: Lens' ParseState (Maybe OpInfo)
|
||||
opl = psOpTable . at n
|
||||
opl <~ (use opl >>= \case
|
||||
Just o -> addWoundHere l e >> pure (Just o) where
|
||||
e = RlpParErrDuplicateInfixD n
|
||||
l = T.length n
|
||||
Nothing -> pure (Just (a,p))
|
||||
)
|
||||
pos <- use (psInput . aiPos)
|
||||
pure $ InfixD a p ln
|
||||
|
||||
{--
|
||||
|
||||
parseRlpExprR :: (Monad m) => Text -> RLPCT m (Expr RlpcPs)
|
||||
parseRlpExprR s = liftErrorful $ pToErrorful parseRlpExpr st
|
||||
where
|
||||
st = programInitState s
|
||||
|
||||
parseRlpProgR :: (Monad m) => Text -> RLPCT m (Program RlpcPs)
|
||||
parseRlpProgR s = do
|
||||
a <- liftErrorful $ pToErrorful parseRlpProg st
|
||||
addDebugMsg @_ @String "dump-parsed" $ show a
|
||||
@@ -276,37 +287,48 @@ extractInt :: RlpToken -> Int
|
||||
extractInt (TokenLitInt n) = n
|
||||
extractInt _ = error "extractInt: ugh"
|
||||
|
||||
mkProgram :: [Decl' RlpcPs] -> P (RlpProgram RlpcPs)
|
||||
mkProgram :: [Decl RlpcPs SrcSpan] -> P (Program RlpcPs SrcSpan)
|
||||
mkProgram ds = do
|
||||
pt <- use psOpTable
|
||||
pure $ RlpProgram (associate pt <$> ds)
|
||||
|
||||
parseError :: (Located RlpToken, [String]) -> P a
|
||||
parseError ((Located ss t), exp) = addFatal $
|
||||
errorMsg ss (RlpParErrUnexpectedToken t exp)
|
||||
|
||||
mkInfixD :: Assoc -> Int -> PsName -> P (Decl' RlpcPs)
|
||||
mkInfixD a p n = do
|
||||
let opl :: Lens' ParseState (Maybe OpInfo)
|
||||
opl = psOpTable . at n
|
||||
opl <~ (use opl >>= \case
|
||||
Just o -> addWoundHere l e >> pure (Just o) where
|
||||
e = RlpParErrDuplicateInfixD n
|
||||
l = T.length n
|
||||
Nothing -> pure (Just (a,p))
|
||||
)
|
||||
pos <- use (psInput . aiPos)
|
||||
pure $ Located (spanFromPos pos 0) (InfixD a p n)
|
||||
pure $ Program (associate pt <$> ds)
|
||||
|
||||
intOfToken :: Located RlpToken -> Int
|
||||
intOfToken (Located _ (TokenLitInt n)) = n
|
||||
|
||||
tempInfixExprErr :: RlpExpr' RlpcPs -> RlpExpr' RlpcPs -> P a
|
||||
tempInfixExprErr :: Expr RlpcPs -> Expr RlpcPs -> P a
|
||||
tempInfixExprErr (Located a _) (Located b _) =
|
||||
addFatal $ errorMsg (a <> b) $ RlpParErrOther
|
||||
[ "The rl' frontend is currently in beta. Support for infix expressions is minimal, sorry! :("
|
||||
, "In the mean time, don't mix any infix operators."
|
||||
]
|
||||
|
||||
--}
|
||||
|
||||
_litint :: Getter (Located RlpToken) Int
|
||||
_litint = to extract
|
||||
. singular _TokenLitInt
|
||||
|
||||
tempInfixExprErr :: Expr' RlpcPs SrcSpan -> Expr' RlpcPs SrcSpan -> P a
|
||||
tempInfixExprErr (a :< _) (b :< _) =
|
||||
addFatal $ errorMsg (a <> b) $ RlpParErrOther
|
||||
[ "The rl' frontend is currently in beta. Support for infix expressions is minimal, sorry! :("
|
||||
, "In the mean time, don't mix any infix operators."
|
||||
]
|
||||
|
||||
mkProgram :: [Decl RlpcPs SrcSpan] -> P (Program RlpcPs SrcSpan)
|
||||
mkProgram ds = do
|
||||
pt <- use psOpTable
|
||||
pure $ Program (associate pt <$> ds)
|
||||
|
||||
extractName :: Located RlpToken -> PsName
|
||||
extractName (Located ss (TokenVarSym n)) = Located ss n
|
||||
extractName (Located ss (TokenVarName n)) = Located ss n
|
||||
extractName (Located ss (TokenConName n)) = Located ss n
|
||||
extractName (Located ss (TokenConSym n)) = Located ss n
|
||||
|
||||
parseError :: (Located RlpToken, [String]) -> P a
|
||||
parseError ((Located ss t), exp) = addFatal $
|
||||
errorMsg ss (RlpParErrUnexpectedToken t exp)
|
||||
|
||||
}
|
||||
|
||||
|
||||
@@ -16,7 +16,7 @@ import Rlp.Parse.Types
|
||||
import Rlp.Syntax
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
associate :: OpTable -> Decl' RlpcPs -> Decl' RlpcPs
|
||||
associate :: OpTable -> Decl RlpcPs a -> Decl RlpcPs a
|
||||
associate _ p = p
|
||||
|
||||
{-# WARNING associate "unimplemented" #-}
|
||||
|
||||
@@ -1,6 +1,7 @@
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE ImplicitParams, ViewPatterns, PatternSynonyms #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
module Rlp.Parse.Types
|
||||
(
|
||||
-- * Trees That Grow
|
||||
@@ -17,10 +18,9 @@ module Rlp.Parse.Types
|
||||
, RlpToken(..), AlexInput(..), Position(..), spanFromPos, LexerAction
|
||||
, Located(..), PsName
|
||||
-- ** Lenses
|
||||
, _TokenLitInt, _TokenVarName, _TokenConName, _TokenVarSym
|
||||
, aiPrevChar, aiSource, aiBytes, aiPos, posLine, posColumn
|
||||
|
||||
, (<<~), (<~>)
|
||||
|
||||
-- * Error handling
|
||||
, MsgEnvelope(..), RlpcError(..), RlpParseError(..)
|
||||
, addFatal, addWound, addFatalHere, addWoundHere
|
||||
@@ -28,6 +28,7 @@ module Rlp.Parse.Types
|
||||
where
|
||||
--------------------------------------------------------------------------------
|
||||
import Core.Syntax (Name)
|
||||
import Text.Show.Deriving
|
||||
import Control.Monad
|
||||
import Control.Monad.State.Strict
|
||||
import Control.Monad.Errorful
|
||||
@@ -53,34 +54,9 @@ import Compiler.Types
|
||||
|
||||
data RlpcPs
|
||||
|
||||
type instance XRec RlpcPs a = Located a
|
||||
type instance IdP RlpcPs = PsName
|
||||
type instance NameP RlpcPs = PsName
|
||||
|
||||
type instance XFunD RlpcPs = ()
|
||||
type instance XDataD RlpcPs = ()
|
||||
type instance XInfixD RlpcPs = ()
|
||||
type instance XTySigD RlpcPs = ()
|
||||
type instance XXDeclD RlpcPs = ()
|
||||
|
||||
type instance XLetE RlpcPs = ()
|
||||
type instance XLetrecE RlpcPs = ()
|
||||
type instance XVarE RlpcPs = ()
|
||||
type instance XLamE RlpcPs = ()
|
||||
type instance XCaseE RlpcPs = ()
|
||||
type instance XIfE RlpcPs = ()
|
||||
type instance XAppE RlpcPs = ()
|
||||
type instance XLitE RlpcPs = ()
|
||||
type instance XParE RlpcPs = ()
|
||||
type instance XOAppE RlpcPs = ()
|
||||
type instance XXRlpExprE RlpcPs = ()
|
||||
|
||||
type PsName = Text
|
||||
|
||||
instance MapXRec RlpcPs where
|
||||
mapXRec = fmap
|
||||
|
||||
instance UnXRec RlpcPs where
|
||||
unXRec = extract
|
||||
type PsName = Located Text
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
@@ -118,10 +94,10 @@ data RlpToken
|
||||
-- literals
|
||||
= TokenLitInt Int
|
||||
-- identifiers
|
||||
| TokenVarName Name
|
||||
| TokenConName Name
|
||||
| TokenVarSym Name
|
||||
| TokenConSym Name
|
||||
| TokenVarName Text
|
||||
| TokenConName Text
|
||||
| TokenVarSym Text
|
||||
| TokenConSym Text
|
||||
-- reserved words
|
||||
| TokenData
|
||||
| TokenCase
|
||||
@@ -152,6 +128,31 @@ data RlpToken
|
||||
| TokenEOF
|
||||
deriving (Show)
|
||||
|
||||
_TokenLitInt :: Prism' RlpToken Int
|
||||
_TokenLitInt = prism TokenLitInt $ \case
|
||||
TokenLitInt n -> Right n
|
||||
x -> Left x
|
||||
|
||||
_TokenVarName :: Prism' RlpToken Text
|
||||
_TokenVarName = prism TokenVarName $ \case
|
||||
TokenVarName n -> Right n
|
||||
x -> Left x
|
||||
|
||||
_TokenVarSym :: Prism' RlpToken Text
|
||||
_TokenVarSym = prism TokenVarSym $ \case
|
||||
TokenVarSym n -> Right n
|
||||
x -> Left x
|
||||
|
||||
_TokenConName :: Prism' RlpToken Text
|
||||
_TokenConName = prism TokenConName $ \case
|
||||
TokenConName n -> Right n
|
||||
x -> Left x
|
||||
|
||||
_TokenConSym :: Prism' RlpToken Text
|
||||
_TokenConSym = prism TokenConSym $ \case
|
||||
TokenConSym n -> Right n
|
||||
x -> Left x
|
||||
|
||||
newtype P a = P {
|
||||
runP :: ParseState
|
||||
-> (ParseState, [MsgEnvelope RlpParseError], Maybe a)
|
||||
@@ -281,13 +282,14 @@ initAlexInput s = AlexInput
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
deriving instance Lift (RlpProgram RlpcPs)
|
||||
deriving instance Lift (Decl RlpcPs)
|
||||
deriving instance Lift (Pat RlpcPs)
|
||||
deriving instance Lift (Lit RlpcPs)
|
||||
deriving instance Lift (RlpExpr RlpcPs)
|
||||
deriving instance Lift (Binding RlpcPs)
|
||||
deriving instance Lift (RlpType RlpcPs)
|
||||
deriving instance Lift (Alt RlpcPs)
|
||||
deriving instance Lift (ConAlt RlpcPs)
|
||||
|
||||
-- deriving instance Lift (Program RlpcPs)
|
||||
-- deriving instance Lift (Decl RlpcPs)
|
||||
-- deriving instance Lift (Pat RlpcPs)
|
||||
-- deriving instance Lift (Lit RlpcPs)
|
||||
-- deriving instance Lift (Expr RlpcPs)
|
||||
-- deriving instance Lift (Binding RlpcPs)
|
||||
-- deriving instance Lift (Ty RlpcPs)
|
||||
-- deriving instance Lift (Alt RlpcPs)
|
||||
-- deriving instance Lift (ConAlt RlpcPs)
|
||||
|
||||
|
||||
@@ -1,362 +1,10 @@
|
||||
-- recursion-schemes
|
||||
{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable
|
||||
, TemplateHaskell, TypeFamilies #-}
|
||||
{-# LANGUAGE OverloadedStrings, PatternSynonyms, ViewPatterns #-}
|
||||
{-# LANGUAGE TypeFamilies, TypeFamilyDependencies #-}
|
||||
{-# LANGUAGE UndecidableInstances, ImpredicativeTypes #-}
|
||||
module Rlp.Syntax
|
||||
(
|
||||
-- * AST
|
||||
RlpProgram(..)
|
||||
, progDecls
|
||||
, Decl(..), Decl', RlpExpr(..), RlpExpr', RlpExprF(..)
|
||||
, Pat(..), Pat'
|
||||
, Alt(..), Where
|
||||
, Assoc(..)
|
||||
, Lit(..), Lit'
|
||||
, RlpType(..), RlpType'
|
||||
, ConAlt(..)
|
||||
, Binding(..), Binding'
|
||||
|
||||
, _PatB, _FunB
|
||||
, _VarP, _LitP, _ConP
|
||||
|
||||
-- * Trees That Grow boilerplate
|
||||
-- ** Extension points
|
||||
, IdP, IdP', XRec, UnXRec(..), MapXRec(..)
|
||||
-- *** Decl
|
||||
, XFunD, XTySigD, XInfixD, XDataD, XXDeclD
|
||||
-- *** RlpExpr
|
||||
, XLetE, XLetrecE, XVarE, XLamE, XCaseE, XIfE, XAppE, XLitE
|
||||
, XParE, XOAppE, XXRlpExprE
|
||||
-- ** Pattern synonyms
|
||||
-- *** Decl
|
||||
, pattern FunD, pattern TySigD, pattern InfixD, pattern DataD
|
||||
, pattern FunD'', pattern TySigD'', pattern InfixD'', pattern DataD''
|
||||
-- *** RlpExpr
|
||||
, pattern LetE, pattern LetrecE, pattern VarE, pattern LamE, pattern CaseE
|
||||
, pattern IfE , pattern AppE, pattern LitE, pattern ParE, pattern OAppE
|
||||
, pattern XRlpExprE
|
||||
-- *** RlpType
|
||||
, pattern FunConT'', pattern FunT'', pattern AppT'', pattern VarT''
|
||||
, pattern ConT''
|
||||
-- *** Pat
|
||||
, pattern VarP'', pattern LitP'', pattern ConP''
|
||||
-- *** Binding
|
||||
, pattern PatB''
|
||||
( module Rlp.Syntax.Backstage
|
||||
, module Rlp.Syntax.Types
|
||||
)
|
||||
where
|
||||
----------------------------------------------------------------------------------
|
||||
import Data.Text (Text)
|
||||
import Data.Text qualified as T
|
||||
import Data.String (IsString(..))
|
||||
import Data.Functor.Foldable
|
||||
import Data.Functor.Foldable.TH (makeBaseFunctor)
|
||||
import Data.Functor.Classes
|
||||
import Data.Functor.Identity
|
||||
import Data.Kind (Type)
|
||||
import GHC.Generics
|
||||
import Language.Haskell.TH.Syntax (Lift)
|
||||
import Control.Lens
|
||||
import Core.Syntax hiding (Lit, Type, Binding, Binding')
|
||||
import Core (HasRHS(..), HasLHS(..))
|
||||
----------------------------------------------------------------------------------
|
||||
|
||||
data RlpModule p = RlpModule
|
||||
{ _rlpmodName :: Text
|
||||
, _rlpmodProgram :: RlpProgram p
|
||||
}
|
||||
|
||||
-- | dear god.
|
||||
type PhaseShow p =
|
||||
( Show (XRec p (Pat p)), Show (XRec p (RlpExpr p))
|
||||
, Show (XRec p (Lit p)), Show (IdP p)
|
||||
, Show (XRec p (RlpType p))
|
||||
, Show (XRec p (Binding p))
|
||||
)
|
||||
|
||||
newtype RlpProgram p = RlpProgram [Decl' p]
|
||||
|
||||
progDecls :: Lens' (RlpProgram p) [Decl' p]
|
||||
progDecls = lens
|
||||
(\ (RlpProgram ds) -> ds)
|
||||
(const RlpProgram)
|
||||
|
||||
deriving instance (PhaseShow p, Show (XRec p (Decl p))) => Show (RlpProgram p)
|
||||
|
||||
data RlpType p = FunConT
|
||||
| FunT (RlpType' p) (RlpType' p)
|
||||
| AppT (RlpType' p) (RlpType' p)
|
||||
| VarT (IdP p)
|
||||
| ConT (IdP p)
|
||||
|
||||
type RlpType' p = XRec p (RlpType p)
|
||||
|
||||
pattern FunConT'' :: (UnXRec p) => RlpType' p
|
||||
pattern FunT'' :: (UnXRec p) => RlpType' p -> RlpType' p -> RlpType' p
|
||||
pattern AppT'' :: (UnXRec p) => RlpType' p -> RlpType' p -> RlpType' p
|
||||
pattern VarT'' :: (UnXRec p) => IdP p -> RlpType' p
|
||||
pattern ConT'' :: (UnXRec p) => IdP p -> RlpType' p
|
||||
|
||||
pattern FunConT'' <- (unXRec -> FunConT)
|
||||
pattern FunT'' s t <- (unXRec -> FunT s t)
|
||||
pattern AppT'' s t <- (unXRec -> AppT s t)
|
||||
pattern VarT'' n <- (unXRec -> VarT n)
|
||||
pattern ConT'' n <- (unXRec -> ConT n)
|
||||
|
||||
deriving instance (PhaseShow p)
|
||||
=> Show (RlpType p)
|
||||
|
||||
data Decl p = FunD' (XFunD p) (IdP p) [Pat' p] (RlpExpr' p) (Maybe (Where p))
|
||||
| TySigD' (XTySigD p) [IdP p] (RlpType' p)
|
||||
| DataD' (XDataD p) (IdP p) [IdP p] [ConAlt p]
|
||||
| InfixD' (XInfixD p) Assoc Int (IdP p)
|
||||
| XDeclD' !(XXDeclD p)
|
||||
|
||||
deriving instance
|
||||
( Show (XFunD p), Show (XTySigD p)
|
||||
, Show (XDataD p), Show (XInfixD p)
|
||||
, Show (XXDeclD p)
|
||||
, PhaseShow p
|
||||
)
|
||||
=> Show (Decl p)
|
||||
|
||||
type family XFunD p
|
||||
type family XTySigD p
|
||||
type family XDataD p
|
||||
type family XInfixD p
|
||||
type family XXDeclD p
|
||||
|
||||
pattern FunD :: (XFunD p ~ ())
|
||||
=> IdP p -> [Pat' p] -> RlpExpr' p -> Maybe (Where p)
|
||||
-> Decl p
|
||||
pattern TySigD :: (XTySigD p ~ ()) => [IdP p] -> RlpType' p -> Decl p
|
||||
pattern DataD :: (XDataD p ~ ()) => IdP p -> [IdP p] -> [ConAlt p] -> Decl p
|
||||
pattern InfixD :: (XInfixD p ~ ()) => Assoc -> Int -> IdP p -> Decl p
|
||||
pattern XDeclD :: (XXDeclD p ~ ()) => Decl p
|
||||
|
||||
pattern FunD n as e wh = FunD' () n as e wh
|
||||
pattern TySigD ns t = TySigD' () ns t
|
||||
pattern DataD n as cs = DataD' () n as cs
|
||||
pattern InfixD a p n = InfixD' () a p n
|
||||
pattern XDeclD = XDeclD' ()
|
||||
|
||||
pattern FunD'' :: (UnXRec p)
|
||||
=> IdP p -> [Pat' p] -> RlpExpr' p -> Maybe (Where p)
|
||||
-> Decl' p
|
||||
pattern TySigD'' :: (UnXRec p)
|
||||
=> [IdP p] -> RlpType' p -> Decl' p
|
||||
pattern DataD'' :: (UnXRec p)
|
||||
=> IdP p -> [IdP p] -> [ConAlt p] -> Decl' p
|
||||
pattern InfixD'' :: (UnXRec p)
|
||||
=> Assoc -> Int -> IdP p -> Decl' p
|
||||
|
||||
pattern FunD'' n as e wh <- (unXRec -> FunD' _ n as e wh)
|
||||
pattern TySigD'' ns t <- (unXRec -> TySigD' _ ns t)
|
||||
pattern DataD'' n as ds <- (unXRec -> DataD' _ n as ds)
|
||||
pattern InfixD'' a p n <- (unXRec -> InfixD' _ a p n)
|
||||
|
||||
type Decl' p = XRec p (Decl p)
|
||||
|
||||
data Assoc = InfixL
|
||||
| InfixR
|
||||
| Infix
|
||||
deriving (Show, Lift)
|
||||
|
||||
data ConAlt p = ConAlt (IdP p) [RlpType' p]
|
||||
|
||||
deriving instance (Show (IdP p), Show (XRec p (RlpType p))) => Show (ConAlt p)
|
||||
|
||||
data RlpExpr p = LetE' (XLetE p) [Binding' p] (RlpExpr' p)
|
||||
| LetrecE' (XLetrecE p) [Binding' p] (RlpExpr' p)
|
||||
| VarE' (XVarE p) (IdP p)
|
||||
| LamE' (XLamE p) [Pat p] (RlpExpr' p)
|
||||
| CaseE' (XCaseE p) (RlpExpr' p) [(Alt p, Where p)]
|
||||
| IfE' (XIfE p) (RlpExpr' p) (RlpExpr' p) (RlpExpr' p)
|
||||
| AppE' (XAppE p) (RlpExpr' p) (RlpExpr' p)
|
||||
| LitE' (XLitE p) (Lit p)
|
||||
| ParE' (XParE p) (RlpExpr' p)
|
||||
| OAppE' (XOAppE p) (IdP p) (RlpExpr' p) (RlpExpr' p)
|
||||
| XRlpExprE' !(XXRlpExprE p)
|
||||
deriving (Generic)
|
||||
|
||||
type family XLetE p
|
||||
type family XLetrecE p
|
||||
type family XVarE p
|
||||
type family XLamE p
|
||||
type family XCaseE p
|
||||
type family XIfE p
|
||||
type family XAppE p
|
||||
type family XLitE p
|
||||
type family XParE p
|
||||
type family XOAppE p
|
||||
type family XXRlpExprE p
|
||||
|
||||
pattern LetE :: (XLetE p ~ ()) => [Binding' p] -> RlpExpr' p -> RlpExpr p
|
||||
pattern LetrecE :: (XLetrecE p ~ ()) => [Binding' p] -> RlpExpr' p -> RlpExpr p
|
||||
pattern VarE :: (XVarE p ~ ()) => IdP p -> RlpExpr p
|
||||
pattern LamE :: (XLamE p ~ ()) => [Pat p] -> RlpExpr' p -> RlpExpr p
|
||||
pattern CaseE :: (XCaseE p ~ ()) => RlpExpr' p -> [(Alt p, Where p)] -> RlpExpr p
|
||||
pattern IfE :: (XIfE p ~ ()) => RlpExpr' p -> RlpExpr' p -> RlpExpr' p -> RlpExpr p
|
||||
pattern AppE :: (XAppE p ~ ()) => RlpExpr' p -> RlpExpr' p -> RlpExpr p
|
||||
pattern LitE :: (XLitE p ~ ()) => Lit p -> RlpExpr p
|
||||
pattern ParE :: (XParE p ~ ()) => RlpExpr' p -> RlpExpr p
|
||||
pattern OAppE :: (XOAppE p ~ ()) => IdP p -> RlpExpr' p -> RlpExpr' p -> RlpExpr p
|
||||
pattern XRlpExprE :: (XXRlpExprE p ~ ()) => RlpExpr p
|
||||
|
||||
pattern LetE bs e = LetE' () bs e
|
||||
pattern LetrecE bs e = LetrecE' () bs e
|
||||
pattern VarE n = VarE' () n
|
||||
pattern LamE as e = LamE' () as e
|
||||
pattern CaseE e as = CaseE' () e as
|
||||
pattern IfE c a b = IfE' () c a b
|
||||
pattern AppE f x = AppE' () f x
|
||||
pattern LitE l = LitE' () l
|
||||
pattern ParE e = ParE' () e
|
||||
pattern OAppE n a b = OAppE' () n a b
|
||||
pattern XRlpExprE = XRlpExprE' ()
|
||||
|
||||
deriving instance
|
||||
( Show (XLetE p), Show (XLetrecE p), Show (XVarE p)
|
||||
, Show (XLamE p), Show (XCaseE p), Show (XIfE p)
|
||||
, Show (XAppE p), Show (XLitE p), Show (XParE p)
|
||||
, Show (XOAppE p), Show (XXRlpExprE p)
|
||||
, PhaseShow p
|
||||
) => Show (RlpExpr p)
|
||||
|
||||
type RlpExpr' p = XRec p (RlpExpr p)
|
||||
|
||||
class UnXRec p where
|
||||
unXRec :: XRec p a -> a
|
||||
|
||||
class WrapXRec p where
|
||||
wrapXRec :: a -> XRec p a
|
||||
|
||||
class MapXRec p where
|
||||
mapXRec :: (a -> b) -> XRec p a -> XRec p b
|
||||
|
||||
-- old definition:
|
||||
-- type family XRec p (f :: Type -> Type) = (r :: Type) | r -> p f
|
||||
type family XRec p a = (r :: Type) | r -> p a
|
||||
|
||||
type family IdP p
|
||||
|
||||
type IdP' p = XRec p (IdP p)
|
||||
|
||||
type Where p = [Binding p]
|
||||
|
||||
-- do we want guards?
|
||||
data Alt p = AltA (Pat' p) (RlpExpr' p)
|
||||
|
||||
deriving instance (PhaseShow p) => Show (Alt p)
|
||||
|
||||
data Binding p = PatB (Pat' p) (RlpExpr' p)
|
||||
| FunB (IdP p) [Pat' p] (RlpExpr' p)
|
||||
|
||||
type Binding' p = XRec p (Binding p)
|
||||
|
||||
pattern PatB'' :: (UnXRec p) => Pat' p -> RlpExpr' p -> Binding' p
|
||||
pattern PatB'' p e <- (unXRec -> PatB p e)
|
||||
|
||||
deriving instance (Show (XRec p (Pat p)), Show (XRec p (RlpExpr p)), Show (IdP p)
|
||||
) => Show (Binding p)
|
||||
|
||||
data Pat p = VarP (IdP p)
|
||||
| LitP (Lit' p)
|
||||
| ConP (IdP p) [Pat' p]
|
||||
|
||||
pattern VarP'' :: (UnXRec p) => IdP p -> Pat' p
|
||||
pattern LitP'' :: (UnXRec p) => Lit' p -> Pat' p
|
||||
pattern ConP'' :: (UnXRec p) => IdP p -> [Pat' p] -> Pat' p
|
||||
|
||||
pattern VarP'' n <- (unXRec -> VarP n)
|
||||
pattern LitP'' l <- (unXRec -> LitP l)
|
||||
pattern ConP'' c as <- (unXRec -> ConP c as)
|
||||
|
||||
deriving instance (PhaseShow p) => Show (Pat p)
|
||||
|
||||
type Pat' p = XRec p (Pat p)
|
||||
|
||||
data Lit p = IntL Int
|
||||
| CharL Char
|
||||
| ListL [RlpExpr' p]
|
||||
|
||||
deriving instance (PhaseShow p) => Show (Lit p)
|
||||
|
||||
type Lit' p = XRec p (Lit p)
|
||||
|
||||
-- instance HasLHS Alt Alt Pat Pat where
|
||||
-- _lhs = lens
|
||||
-- (\ (AltA p _) -> p)
|
||||
-- (\ (AltA _ e) p' -> AltA p' e)
|
||||
|
||||
-- instance HasRHS Alt Alt RlpExpr RlpExpr where
|
||||
-- _rhs = lens
|
||||
-- (\ (AltA _ e) -> e)
|
||||
-- (\ (AltA p _) e' -> AltA p e')
|
||||
|
||||
-- makeBaseFunctor ''RlpExpr
|
||||
|
||||
-- showsTernaryWith :: (Int -> x -> ShowS)
|
||||
-- -> (Int -> y -> ShowS)
|
||||
-- -> (Int -> z -> ShowS)
|
||||
-- -> String -> Int
|
||||
-- -> x -> y -> z
|
||||
-- -> ShowS
|
||||
-- showsTernaryWith sa sb sc name p a b c = showParen (p > 10)
|
||||
-- $ showString name
|
||||
-- . showChar ' ' . sa 11 a
|
||||
-- . showChar ' ' . sb 11 b
|
||||
-- . showChar ' ' . sc 11 c
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
import Rlp.Syntax.Backstage
|
||||
import Rlp.Syntax.Types
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
makeLenses ''RlpModule
|
||||
makePrisms ''Pat
|
||||
makePrisms ''Binding
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
data RlpExprF p a = LetE'F (XLetE p) [Binding' p] a
|
||||
| LetrecE'F (XLetrecE p) [Binding' p] a
|
||||
| VarE'F (XVarE p) (IdP p)
|
||||
| LamE'F (XLamE p) [Pat p] a
|
||||
| CaseE'F (XCaseE p) a [(Alt p, Where p)]
|
||||
| IfE'F (XIfE p) a a a
|
||||
| AppE'F (XAppE p) a a
|
||||
| LitE'F (XLitE p) (Lit p)
|
||||
| ParE'F (XParE p) a
|
||||
| OAppE'F (XOAppE p) (IdP p) a a
|
||||
| XRlpExprE'F !(XXRlpExprE p)
|
||||
deriving (Functor, Foldable, Traversable, Generic)
|
||||
|
||||
type instance Base (RlpExpr p) = RlpExprF p
|
||||
|
||||
instance (UnXRec p) => Recursive (RlpExpr p) where
|
||||
project = \case
|
||||
LetE' xx bs e -> LetE'F xx bs (unXRec e)
|
||||
LetrecE' xx bs e -> LetrecE'F xx bs (unXRec e)
|
||||
VarE' xx n -> VarE'F xx n
|
||||
LamE' xx ps e -> LamE'F xx ps (unXRec e)
|
||||
CaseE' xx e as -> CaseE'F xx (unXRec e) as
|
||||
IfE' xx a b c -> IfE'F xx (unXRec a) (unXRec b) (unXRec c)
|
||||
AppE' xx f x -> AppE'F xx (unXRec f) (unXRec x)
|
||||
LitE' xx l -> LitE'F xx l
|
||||
ParE' xx e -> ParE'F xx (unXRec e)
|
||||
OAppE' xx f a b -> OAppE'F xx f (unXRec a) (unXRec b)
|
||||
XRlpExprE' xx -> XRlpExprE'F xx
|
||||
|
||||
instance (WrapXRec p) => Corecursive (RlpExpr p) where
|
||||
embed = \case
|
||||
LetE'F xx bs e -> LetE' xx bs (wrapXRec e)
|
||||
LetrecE'F xx bs e -> LetrecE' xx bs (wrapXRec e)
|
||||
VarE'F xx n -> VarE' xx n
|
||||
LamE'F xx ps e -> LamE' xx ps (wrapXRec e)
|
||||
CaseE'F xx e as -> CaseE' xx (wrapXRec e) as
|
||||
IfE'F xx a b c -> IfE' xx (wrapXRec a) (wrapXRec b) (wrapXRec c)
|
||||
AppE'F xx f x -> AppE' xx (wrapXRec f) (wrapXRec x)
|
||||
LitE'F xx l -> LitE' xx l
|
||||
ParE'F xx e -> ParE' xx (wrapXRec e)
|
||||
OAppE'F xx f a b -> OAppE' xx f (wrapXRec a) (wrapXRec b)
|
||||
XRlpExprE'F xx -> XRlpExprE' xx
|
||||
|
||||
|
||||
35
src/Rlp/Syntax/Backstage.hs
Normal file
35
src/Rlp/Syntax/Backstage.hs
Normal file
@@ -0,0 +1,35 @@
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
module Rlp.Syntax.Backstage
|
||||
( strip
|
||||
)
|
||||
where
|
||||
--------------------------------------------------------------------------------
|
||||
import Data.Fix hiding (cata)
|
||||
import Data.Functor.Classes
|
||||
import Data.Functor.Foldable
|
||||
import Rlp.Syntax.Types
|
||||
import Text.Show.Deriving
|
||||
import Language.Haskell.TH.Syntax (Lift)
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
-- oprhan instances because TH
|
||||
|
||||
instance (Show (NameP p)) => Show1 (Alt p) where
|
||||
liftShowsPrec = $(makeLiftShowsPrec ''Alt)
|
||||
|
||||
instance (Show (NameP p)) => Show1 (Binding p) where
|
||||
liftShowsPrec = $(makeLiftShowsPrec ''Binding)
|
||||
|
||||
instance (Show (NameP p)) => Show1 (ExprF p) where
|
||||
liftShowsPrec = $(makeLiftShowsPrec ''ExprF)
|
||||
|
||||
deriving instance (Lift (NameP p), Lift a) => Lift (Expr' p a)
|
||||
deriving instance (Lift (NameP p), Lift a) => Lift (Decl p a)
|
||||
deriving instance (Show (NameP p), Show a) => Show (Decl p a)
|
||||
|
||||
deriving instance (Show (NameP p), Show a) => Show (Program p a)
|
||||
|
||||
strip :: Functor f => Cofree f a -> Fix f
|
||||
strip (_ :< as) = Fix $ strip <$> as
|
||||
|
||||
143
src/Rlp/Syntax/Types.hs
Normal file
143
src/Rlp/Syntax/Types.hs
Normal file
@@ -0,0 +1,143 @@
|
||||
-- recursion-schemes
|
||||
{-# LANGUAGE DeriveTraversable, TemplateHaskell, TypeFamilies #-}
|
||||
{-# LANGUAGE OverloadedStrings, PatternSynonyms, ViewPatterns #-}
|
||||
{-# LANGUAGE UndecidableInstances, ImpredicativeTypes #-}
|
||||
module Rlp.Syntax.Types
|
||||
(
|
||||
NameP
|
||||
, SimpleP
|
||||
, Assoc(..)
|
||||
, ConAlt(..)
|
||||
, Alt(..), Alt'
|
||||
, Ty(..)
|
||||
, Binding(..), Binding'
|
||||
, Expr', ExprF(..)
|
||||
, Rec(..)
|
||||
, Lit(..)
|
||||
, Pat(..)
|
||||
, Decl(..)
|
||||
, Program(..)
|
||||
, Where
|
||||
|
||||
-- * Re-exports
|
||||
, Cofree(..)
|
||||
, Trans.Cofree.CofreeF
|
||||
, SrcSpan(..)
|
||||
)
|
||||
where
|
||||
----------------------------------------------------------------------------------
|
||||
import Data.Text (Text)
|
||||
import Data.Text qualified as T
|
||||
import Data.String (IsString(..))
|
||||
import Data.Functor.Classes
|
||||
import Data.Functor.Identity
|
||||
import Data.Functor.Compose
|
||||
import Data.Fix
|
||||
import Data.Kind (Type)
|
||||
import GHC.Generics
|
||||
import Language.Haskell.TH.Syntax (Lift)
|
||||
import Control.Lens hiding ((:<))
|
||||
|
||||
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(..), Located(..))
|
||||
import Core.Syntax qualified as Core
|
||||
import Core (Rec(..), HasRHS(..), HasLHS(..))
|
||||
----------------------------------------------------------------------------------
|
||||
|
||||
data SimpleP
|
||||
|
||||
type instance NameP SimpleP = String
|
||||
|
||||
type family NameP p
|
||||
|
||||
data ExprF p a = LetEF Rec [Binding p a] a
|
||||
| VarEF (NameP p)
|
||||
| LamEF [Pat p] a
|
||||
| CaseEF a [Alt p a]
|
||||
| IfEF a a a
|
||||
| AppEF a a
|
||||
| LitEF (Lit p)
|
||||
| ParEF a
|
||||
| InfixEF (NameP p) a a
|
||||
deriving (Functor, Foldable, Traversable)
|
||||
|
||||
data ConAlt p = ConAlt (NameP p) [Ty p]
|
||||
|
||||
deriving instance (Lift (NameP p)) => Lift (ConAlt p)
|
||||
deriving instance (Show (NameP p)) => Show (ConAlt p)
|
||||
|
||||
data Ty p = ConT (NameP p)
|
||||
| VarT (NameP p)
|
||||
| FunT (Ty p) (Ty p)
|
||||
| AppT (Ty p) (Ty p)
|
||||
|
||||
deriving instance (Show (NameP p)) => Show (Ty p)
|
||||
deriving instance (Lift (NameP p)) => Lift (Ty p)
|
||||
|
||||
data Pat p = VarP (NameP p)
|
||||
| LitP (Lit p)
|
||||
| ConP (NameP p) [Pat p]
|
||||
|
||||
deriving instance (Lift (NameP p)) => Lift (Pat p)
|
||||
deriving instance (Show (NameP p)) => Show (Pat p)
|
||||
|
||||
data Lit p = IntL Int
|
||||
deriving Show
|
||||
|
||||
deriving instance (Lift (NameP p)) => Lift (Lit p)
|
||||
|
||||
data Assoc = InfixL | InfixR | Infix
|
||||
deriving (Lift, Show)
|
||||
|
||||
deriving instance (Show (NameP p), Show a) => Show (ExprF p a)
|
||||
deriving instance (Lift (NameP p), Lift a) => Lift (ExprF p a)
|
||||
|
||||
data Binding p a = PatB (Pat p) (ExprF p a)
|
||||
deriving (Functor, Foldable, Traversable)
|
||||
|
||||
deriving instance (Lift (NameP p), Lift a) => Lift (Binding p a)
|
||||
deriving instance (Show (NameP p), Show a) => Show (Binding p a)
|
||||
|
||||
type Binding' p a = Binding p (Cofree (ExprF p) a)
|
||||
|
||||
type Where p a = [Binding p a]
|
||||
|
||||
data Alt p a = AltA (Pat p) (ExprF p a) (Maybe (Where p a))
|
||||
deriving (Functor, Foldable, Traversable)
|
||||
|
||||
deriving instance (Show (NameP p), Show a) => Show (Alt p a)
|
||||
deriving instance (Lift (NameP p), Lift a) => Lift (Alt p a)
|
||||
|
||||
type Expr p = Fix (ExprF p)
|
||||
|
||||
type Alt' p a = Alt p (Cofree (ExprF p) a)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
data Program p a = Program
|
||||
{ _programDecls :: [Decl p a]
|
||||
}
|
||||
|
||||
data Decl p a = FunD (NameP p) [Pat p] (Expr' p a) (Maybe (Where p a))
|
||||
| TySigD [NameP p] (Ty p)
|
||||
| DataD (NameP p) [NameP p] [ConAlt p]
|
||||
| InfixD Assoc Int (NameP p)
|
||||
|
||||
type Decl' p a = Decl p (Cofree (ExprF p) a)
|
||||
|
||||
type Expr' p = Cofree (ExprF p)
|
||||
|
||||
makeLenses ''Program
|
||||
|
||||
loccof :: Iso' (Cofree f SrcSpan) (Located (f (Cofree f SrcSpan)))
|
||||
loccof = iso sa bt where
|
||||
sa :: Cofree f SrcSpan -> Located (f (Cofree f SrcSpan))
|
||||
sa (ss :< as) = Located ss as
|
||||
|
||||
bt :: Located (f (Cofree f SrcSpan)) -> Cofree f SrcSpan
|
||||
bt (Located ss as) = ss :< as
|
||||
|
||||
@@ -17,10 +17,12 @@ import Rlp.Parse
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
rlpProg :: QuasiQuoter
|
||||
rlpProg = mkqq parseRlpProgR
|
||||
rlpProg = undefined
|
||||
-- rlpProg = mkqq parseRlpProgR
|
||||
|
||||
rlpExpr :: QuasiQuoter
|
||||
rlpExpr = mkqq parseRlpExprR
|
||||
rlpExpr = undefined
|
||||
-- rlpExpr = mkqq parseRlpExprR
|
||||
|
||||
mkq :: (Lift a) => (Text -> RLPCIO a) -> String -> Q Exp
|
||||
mkq parse = evalAndParse >=> lift where
|
||||
|
||||
@@ -41,6 +41,12 @@ import Rlp.Syntax as Rlp
|
||||
import Rlp.Parse.Types (RlpcPs, PsName)
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
desugarRlpProgR = undefined
|
||||
desugarRlpProg = undefined
|
||||
desugarRlpExpr = undefined
|
||||
|
||||
{--
|
||||
|
||||
type Tree a = Either Name (Name, Branch a)
|
||||
|
||||
-- | Rose tree branch representing "nested" "patterns" in the Core language. That
|
||||
@@ -234,3 +240,5 @@ typeToCore (VarT'' x) = TyVar (dsNameToName x)
|
||||
dsNameToName :: IdP RlpcPs -> Name
|
||||
dsNameToName = id
|
||||
|
||||
-}
|
||||
|
||||
|
||||
67
tst/Compiler/TypesSpec.hs
Normal file
67
tst/Compiler/TypesSpec.hs
Normal file
@@ -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
|
||||
]
|
||||
|
||||
Reference in New Issue
Block a user