Compare commits
2 Commits
| Author | SHA1 | Date | |
|---|---|---|---|
|
1436f1124f | ||
|
|
36a17d092b |
@@ -32,8 +32,6 @@ library
|
|||||||
, Core.HindleyMilner
|
, Core.HindleyMilner
|
||||||
, Control.Monad.Errorful
|
, Control.Monad.Errorful
|
||||||
, Rlp.Syntax
|
, Rlp.Syntax
|
||||||
, Rlp.Syntax.Backstage
|
|
||||||
, Rlp.Syntax.Types
|
|
||||||
-- , Rlp.Parse.Decls
|
-- , Rlp.Parse.Decls
|
||||||
, Rlp.Parse
|
, Rlp.Parse
|
||||||
, Rlp.Parse.Associate
|
, Rlp.Parse.Associate
|
||||||
@@ -75,7 +73,6 @@ library
|
|||||||
, effectful-core ^>=2.3.0.0
|
, effectful-core ^>=2.3.0.0
|
||||||
, deriving-compat ^>=0.6.0
|
, deriving-compat ^>=0.6.0
|
||||||
, these >=0.2 && <2.0
|
, these >=0.2 && <2.0
|
||||||
, free >=5.2
|
|
||||||
|
|
||||||
hs-source-dirs: src
|
hs-source-dirs: src
|
||||||
default-language: GHC2021
|
default-language: GHC2021
|
||||||
@@ -119,10 +116,8 @@ test-suite rlp-test
|
|||||||
, QuickCheck
|
, QuickCheck
|
||||||
, hspec ==2.*
|
, hspec ==2.*
|
||||||
, microlens
|
, microlens
|
||||||
, lens >=5.2.3 && <6.0
|
|
||||||
other-modules: Arith
|
other-modules: Arith
|
||||||
, GMSpec
|
, GMSpec
|
||||||
, Core.HindleyMilnerSpec
|
, Core.HindleyMilnerSpec
|
||||||
, Compiler.TypesSpec
|
|
||||||
build-tool-depends: hspec-discover:hspec-discover
|
build-tool-depends: hspec-discover:hspec-discover
|
||||||
|
|
||||||
|
|||||||
@@ -220,9 +220,9 @@ docRlpcErr msg = header
|
|||||||
rule = repeat (ttext . Ansi.blue . Ansi.bold $ "|")
|
rule = repeat (ttext . Ansi.blue . Ansi.bold $ "|")
|
||||||
srclines = ["", "<problematic source code>", ""]
|
srclines = ["", "<problematic source code>", ""]
|
||||||
filename = msgColour "<input>"
|
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 ": "
|
header = ttext $ filename <> msgColour ":" <> pos <> msgColour ": "
|
||||||
<> errorColour "error" <> msgColour ":"
|
<> errorColour "error" <> msgColour ":"
|
||||||
|
|||||||
@@ -1,81 +1,33 @@
|
|||||||
{-# LANGUAGE TemplateHaskell #-}
|
{-# LANGUAGE TemplateHaskell #-}
|
||||||
{-# LANGUAGE FunctionalDependencies #-}
|
|
||||||
{-# LANGUAGE UndecidableInstances, QuantifiedConstraints #-}
|
|
||||||
{-# LANGUAGE PatternSynonyms #-}
|
|
||||||
module Compiler.Types
|
module Compiler.Types
|
||||||
( SrcSpan(..)
|
( SrcSpan(..)
|
||||||
, srcSpanLine, srcSpanColumn, srcSpanAbs, srcSpanLen
|
, srcspanLine, srcspanColumn, srcspanAbs, srcspanLen
|
||||||
, pattern (:<$)
|
|
||||||
, Located(..)
|
, Located(..)
|
||||||
, HasLocation(..)
|
|
||||||
, _Located
|
, _Located
|
||||||
, nolo, nolo'
|
, located
|
||||||
|
, nolo
|
||||||
, (<~>), (~>), (~~>), (<~~)
|
, (<<~), (<~>), (<#>)
|
||||||
|
|
||||||
, comb2, comb3, comb4
|
|
||||||
, lochead
|
|
||||||
|
|
||||||
-- * Re-exports
|
-- * Re-exports
|
||||||
, Comonad(extract)
|
, Comonad
|
||||||
, Apply
|
, Apply
|
||||||
, Bind
|
, Bind
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
import Language.Haskell.TH.Syntax (Lift)
|
|
||||||
|
|
||||||
import Control.Comonad
|
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.Apply
|
||||||
import Data.Functor.Bind
|
import Data.Functor.Bind
|
||||||
import Data.Functor.Compose
|
import Control.Lens hiding ((<<~))
|
||||||
import Data.Functor.Foldable
|
import Language.Haskell.TH.Syntax (Lift)
|
||||||
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)
|
-- | Token wrapped with a span (line, column, absolute, length)
|
||||||
data Located a = Located SrcSpan a
|
data Located a = Located SrcSpan a
|
||||||
deriving (Show, Lift, Functor)
|
deriving (Show, Lift, Functor)
|
||||||
|
|
||||||
data Floc f = Floc SrcSpan (f (Floc f))
|
located :: Lens (Located a) (Located b) a b
|
||||||
|
located = lens extract ($>)
|
||||||
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
|
instance Apply Located where
|
||||||
liftF2 f (Located sa p) (Located sb q)
|
liftF2 f (Located sa p) (Located sb q)
|
||||||
@@ -95,136 +47,53 @@ data SrcSpan = SrcSpan
|
|||||||
!Int -- ^ Column
|
!Int -- ^ Column
|
||||||
!Int -- ^ Absolute
|
!Int -- ^ Absolute
|
||||||
!Int -- ^ Length
|
!Int -- ^ Length
|
||||||
deriving (Show, Eq, Lift)
|
deriving (Show, Lift)
|
||||||
|
|
||||||
tupling :: Iso' SrcSpan (Int, Int, Int, Int)
|
tupling :: Iso' SrcSpan (Int, Int, Int, Int)
|
||||||
tupling = iso (\ (SrcSpan a b c d) -> (a,b,c,d))
|
tupling = iso (\ (SrcSpan a b c d) -> (a,b,c,d))
|
||||||
(\ (a,b,c,d) -> SrcSpan 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
|
-- | debug tool
|
||||||
nolo :: a -> Located a
|
nolo :: a -> Located a
|
||||||
nolo = Located (SrcSpan 0 0 0 0)
|
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
|
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
|
SrcSpan la ca aa sa <> SrcSpan lb cb ab sb = SrcSpan l c a s where
|
||||||
l = min la lb
|
l = min la lb
|
||||||
c = min ca cb
|
c = min ca cb
|
||||||
a = min aa ab
|
a = min aa ab
|
||||||
s = case aa `compare` ab of
|
s = case aa `compare` ab of
|
||||||
EQ -> max sa sb
|
EQ -> max sa sb
|
||||||
LT -> max sa (ab + sb - aa)
|
LT -> max sa (ab + lb - aa)
|
||||||
GT -> max sb (aa + sa - ab)
|
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.
|
||||||
|
|
||||||
data GetOrSet = Get | Set | GetSet
|
(<<~) :: (Comonad w) => (w a -> b) -> w a -> w b
|
||||||
|
(<<~) = (<<=)
|
||||||
|
|
||||||
class CanGet (k :: GetOrSet)
|
infixl 4 <<~
|
||||||
class CanSet (k :: GetOrSet) where
|
|
||||||
|
|
||||||
instance CanGet Get
|
-- | Similar to '(<*>)', but with a cokleisli arrow.
|
||||||
instance CanGet GetSet
|
|
||||||
instance CanSet Set
|
|
||||||
instance CanSet GetSet
|
|
||||||
|
|
||||||
data GetSetLens (k :: GetOrSet) s t a b :: Type where
|
(<~>) :: (Comonad w, Bind w) => w (w a -> b) -> w a -> w b
|
||||||
Getter_ :: (s -> a) -> GetSetLens Get s t a b
|
mc <~> ma = mc >>- \f -> ma =>> f
|
||||||
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
|
|
||||||
|
|
||||||
type GetSetLens' k s a = GetSetLens k s s a a
|
infixl 4 <~>
|
||||||
|
|
||||||
class HasLocation k s | s -> k where
|
-- this is getting silly
|
||||||
-- location :: (Access k f, Functor f) => LensLike' f s SrcSpan
|
|
||||||
getSetLocation :: GetSetLens' k s SrcSpan
|
|
||||||
|
|
||||||
type family Access (k :: GetOrSet) f where
|
(<#>) :: (Functor f) => f (a -> b) -> a -> f b
|
||||||
Access GetSet f = Functor f
|
fab <#> a = fmap ($ a) fab
|
||||||
Access Set f = Settable f
|
|
||||||
Access Get f = (Functor f, Contravariant f)
|
|
||||||
|
|
||||||
instance HasLocation GetSet SrcSpan where
|
infixl 4 <#>
|
||||||
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
|
makePrisms ''Located
|
||||||
|
|
||||||
|
|||||||
@@ -8,7 +8,6 @@ module Rlp.Lex
|
|||||||
, Located(..)
|
, Located(..)
|
||||||
, lexToken
|
, lexToken
|
||||||
, lexStream
|
, lexStream
|
||||||
, lexStream'
|
|
||||||
, lexDebug
|
, lexDebug
|
||||||
, lexCont
|
, lexCont
|
||||||
, popLexState
|
, popLexState
|
||||||
@@ -30,7 +29,6 @@ import Data.Word
|
|||||||
import Data.Default
|
import Data.Default
|
||||||
import Control.Lens
|
import Control.Lens
|
||||||
|
|
||||||
import Compiler.Types
|
|
||||||
import Debug.Trace
|
import Debug.Trace
|
||||||
import Rlp.Parse.Types
|
import Rlp.Parse.Types
|
||||||
}
|
}
|
||||||
@@ -276,12 +274,11 @@ lexCont :: (Located RlpToken -> P a) -> P a
|
|||||||
lexCont = (lexToken >>=)
|
lexCont = (lexToken >>=)
|
||||||
|
|
||||||
lexStream :: P [RlpToken]
|
lexStream :: P [RlpToken]
|
||||||
lexStream = fmap extract <$> lexStream'
|
lexStream = do
|
||||||
|
t <- lexToken
|
||||||
lexStream' :: P [Located RlpToken]
|
case t of
|
||||||
lexStream' = lexToken >>= \case
|
Located _ TokenEOF -> pure [TokenEOF]
|
||||||
t@(Located _ TokenEOF) -> pure [t]
|
Located _ t -> (t:) <$> lexStream
|
||||||
t -> (t:) <$> lexStream'
|
|
||||||
|
|
||||||
lexDebug :: (Located RlpToken -> P a) -> P a
|
lexDebug :: (Located RlpToken -> P a) -> P a
|
||||||
lexDebug k = do
|
lexDebug k = do
|
||||||
|
|||||||
252
src/Rlp/Parse.y
252
src/Rlp/Parse.y
@@ -5,17 +5,15 @@ module Rlp.Parse
|
|||||||
, parseRlpProgR
|
, parseRlpProgR
|
||||||
, parseRlpExpr
|
, parseRlpExpr
|
||||||
, parseRlpExprR
|
, parseRlpExprR
|
||||||
, runP'
|
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
import Compiler.RlpcError
|
import Compiler.RlpcError
|
||||||
import Compiler.RLPC
|
import Compiler.RLPC
|
||||||
import Control.Comonad.Cofree
|
|
||||||
import Rlp.Lex
|
import Rlp.Lex
|
||||||
import Rlp.Syntax
|
import Rlp.Syntax
|
||||||
import Rlp.Parse.Types
|
import Rlp.Parse.Types
|
||||||
import Rlp.Parse.Associate
|
import Rlp.Parse.Associate
|
||||||
import Control.Lens hiding (snoc, (.>), (<.), (<<~), (:<))
|
import Control.Lens hiding (snoc, (.>), (<.), (<<~))
|
||||||
import Data.List.Extra
|
import Data.List.Extra
|
||||||
import Data.Fix
|
import Data.Fix
|
||||||
import Data.Functor.Const
|
import Data.Functor.Const
|
||||||
@@ -73,11 +71,12 @@ import Compiler.Types
|
|||||||
|
|
||||||
%%
|
%%
|
||||||
|
|
||||||
StandaloneProgram :: { Program RlpcPs SrcSpan }
|
StandaloneProgram :: { RlpProgram RlpcPs }
|
||||||
StandaloneProgram : layout0(Decl) {% mkProgram $1 }
|
StandaloneProgram : '{' Decls '}' {% mkProgram $2 }
|
||||||
|
| VL DeclsV VR {% mkProgram $2 }
|
||||||
|
|
||||||
StandaloneExpr :: { Expr' RlpcPs SrcSpan }
|
StandaloneExpr :: { RlpExpr RlpcPs }
|
||||||
: VL Expr VR { $2 }
|
: VL Expr VR { extract $2 }
|
||||||
|
|
||||||
VL :: { () }
|
VL :: { () }
|
||||||
VL : vlbrace { () }
|
VL : vlbrace { () }
|
||||||
@@ -86,105 +85,125 @@ VR :: { () }
|
|||||||
VR : vrbrace { () }
|
VR : vrbrace { () }
|
||||||
| error { () }
|
| error { () }
|
||||||
|
|
||||||
VS :: { () }
|
Decls :: { [Decl' RlpcPs] }
|
||||||
VS : ';' { () }
|
Decls : Decl ';' Decls { $1 : $3 }
|
||||||
| vsemi { () }
|
| Decl ';' { [$1] }
|
||||||
|
| Decl { [$1] }
|
||||||
|
|
||||||
Decl :: { Decl RlpcPs SrcSpan }
|
DeclsV :: { [Decl' RlpcPs] }
|
||||||
|
DeclsV : Decl VS DeclsV { $1 : $3 }
|
||||||
|
| Decl VS { [$1] }
|
||||||
|
| Decl { [$1] }
|
||||||
|
|
||||||
|
VS :: { Located RlpToken }
|
||||||
|
VS : ';' { $1 }
|
||||||
|
| vsemi { $1 }
|
||||||
|
|
||||||
|
Decl :: { Decl' RlpcPs }
|
||||||
: FunDecl { $1 }
|
: FunDecl { $1 }
|
||||||
| TySigDecl { $1 }
|
| TySigDecl { $1 }
|
||||||
| DataDecl { $1 }
|
| DataDecl { $1 }
|
||||||
| InfixDecl { $1 }
|
| InfixDecl { $1 }
|
||||||
|
|
||||||
TySigDecl :: { Decl RlpcPs SrcSpan }
|
TySigDecl :: { Decl' RlpcPs }
|
||||||
: Var '::' Type { TySigD [$1] $3 }
|
: Var '::' Type { (\e -> TySigD [extract e]) <<~ $1 <~> $3 }
|
||||||
|
|
||||||
InfixDecl :: { Decl RlpcPs SrcSpan }
|
InfixDecl :: { Decl' RlpcPs }
|
||||||
: InfixWord litint InfixOp {% mkInfixD $1 ($2 ^. _litint) $3 }
|
: InfixWord litint InfixOp { $1 =>> \w ->
|
||||||
|
InfixD (extract $1) (extractInt $ extract $2)
|
||||||
|
(extract $3) }
|
||||||
|
|
||||||
InfixWord :: { Assoc }
|
InfixWord :: { Located Assoc }
|
||||||
: infixl { InfixL }
|
: infixl { $1 \$> InfixL }
|
||||||
| infixr { InfixR }
|
| infixr { $1 \$> InfixR }
|
||||||
| infix { Infix }
|
| infix { $1 \$> Infix }
|
||||||
|
|
||||||
DataDecl :: { Decl RlpcPs SrcSpan }
|
DataDecl :: { Decl' RlpcPs }
|
||||||
: data Con TyParams '=' DataCons { DataD $2 $3 $5 }
|
: data Con TyParams '=' DataCons { $1 \$> DataD (extract $2) $3 $5 }
|
||||||
|
|
||||||
TyParams :: { [PsName] }
|
TyParams :: { [PsName] }
|
||||||
: {- epsilon -} { [] }
|
: {- epsilon -} { [] }
|
||||||
| TyParams varname { $1 `snoc` extractName $2 }
|
| TyParams varname { $1 `snoc` (extractName . extract $ $2) }
|
||||||
|
|
||||||
DataCons :: { [ConAlt RlpcPs] }
|
DataCons :: { [ConAlt RlpcPs] }
|
||||||
: DataCons '|' DataCon { $1 `snoc` $3 }
|
: DataCons '|' DataCon { $1 `snoc` $3 }
|
||||||
| DataCon { [$1] }
|
| DataCon { [$1] }
|
||||||
|
|
||||||
DataCon :: { ConAlt RlpcPs }
|
DataCon :: { ConAlt RlpcPs }
|
||||||
: Con Type1s { ConAlt $1 $2 }
|
: Con Type1s { ConAlt (extract $1) $2 }
|
||||||
|
|
||||||
Type1s :: { [Ty RlpcPs] }
|
Type1s :: { [RlpType' RlpcPs] }
|
||||||
: {- epsilon -} { [] }
|
: {- epsilon -} { [] }
|
||||||
| Type1s Type1 { $1 `snoc` $2 }
|
| Type1s Type1 { $1 `snoc` $2 }
|
||||||
|
|
||||||
Type1 :: { Ty RlpcPs }
|
Type1 :: { RlpType' RlpcPs }
|
||||||
: '(' Type ')' { $2 }
|
: '(' Type ')' { $2 }
|
||||||
| conname { ConT (extractName $1) }
|
| conname { fmap ConT (mkPsName $1) }
|
||||||
| varname { VarT (extractName $1) }
|
| varname { fmap VarT (mkPsName $1) }
|
||||||
|
|
||||||
Type :: { Ty RlpcPs }
|
Type :: { RlpType' RlpcPs }
|
||||||
: Type '->' Type { FunT $1 $3 }
|
: Type '->' Type { FunT <<~ $1 <~> $3 }
|
||||||
| TypeApp { $1 }
|
| TypeApp { $1 }
|
||||||
|
|
||||||
TypeApp :: { Ty RlpcPs }
|
TypeApp :: { RlpType' RlpcPs }
|
||||||
: Type1 { $1 }
|
: Type1 { $1 }
|
||||||
| TypeApp Type1 { AppT $1 $2 }
|
| TypeApp Type1 { AppT <<~ $1 <~> $2 }
|
||||||
|
|
||||||
FunDecl :: { Decl RlpcPs SrcSpan }
|
FunDecl :: { Decl' RlpcPs }
|
||||||
FunDecl : Var Params '=' Expr { FunD $1 $2 $4 Nothing }
|
FunDecl : Var Params '=' Expr { $4 =>> \e ->
|
||||||
|
FunD (extract $1) $2 e Nothing }
|
||||||
|
|
||||||
Params :: { [Pat RlpcPs] }
|
Params :: { [Pat' RlpcPs] }
|
||||||
Params : {- epsilon -} { [] }
|
Params : {- epsilon -} { [] }
|
||||||
| Params Pat1 { $1 `snoc` $2 }
|
| Params Pat1 { $1 `snoc` $2 }
|
||||||
|
|
||||||
Pat :: { Pat RlpcPs }
|
Pat :: { Pat' RlpcPs }
|
||||||
: Con Pat1s { ConP $1 $2 }
|
: Con Pat1s { $1 =>> \cn ->
|
||||||
|
ConP (extract $1) $2 }
|
||||||
| Pat1 { $1 }
|
| Pat1 { $1 }
|
||||||
|
|
||||||
Pat1s :: { [Pat RlpcPs] }
|
Pat1s :: { [Pat' RlpcPs] }
|
||||||
: Pat1s Pat1 { $1 `snoc` $2 }
|
: Pat1s Pat1 { $1 `snoc` $2 }
|
||||||
| Pat1 { [$1] }
|
| Pat1 { [$1] }
|
||||||
|
|
||||||
Pat1 :: { Pat RlpcPs }
|
Pat1 :: { Pat' RlpcPs }
|
||||||
: Con { ConP $1 [] }
|
: Con { fmap (`ConP` []) $1 }
|
||||||
| Var { VarP $1 }
|
| Var { fmap VarP $1 }
|
||||||
| Lit { LitP $1 }
|
| Lit { LitP <<= $1 }
|
||||||
| '(' Pat ')' { $2 }
|
| '(' Pat ')' { $1 .> $2 <. $3 }
|
||||||
|
|
||||||
Expr :: { Expr' RlpcPs SrcSpan }
|
Expr :: { RlpExpr' RlpcPs }
|
||||||
-- infixities delayed till next release :(
|
-- infixities delayed till next release :(
|
||||||
-- : Expr1 InfixOp Expr { undefined }
|
-- : Expr1 InfixOp Expr { $2 =>> \o ->
|
||||||
: AppExpr { $1 }
|
-- OAppE (extract o) $1 $3 }
|
||||||
| TempInfixExpr { $1 }
|
: TempInfixExpr { $1 }
|
||||||
| LetExpr { $1 }
|
| LetExpr { $1 }
|
||||||
| CaseExpr { $1 }
|
| CaseExpr { $1 }
|
||||||
|
| AppExpr { $1 }
|
||||||
|
|
||||||
TempInfixExpr :: { Expr' RlpcPs SrcSpan }
|
TempInfixExpr :: { RlpExpr' RlpcPs }
|
||||||
TempInfixExpr : Expr1 InfixOp TempInfixExpr {% tempInfixExprErr $1 $3 }
|
TempInfixExpr : Expr1 InfixOp TempInfixExpr {% tempInfixExprErr $1 $3 }
|
||||||
| Expr1 InfixOp Expr1 { nolo' $ InfixEF $2 $1 $3 }
|
| Expr1 InfixOp Expr1 { $2 =>> \o ->
|
||||||
|
OAppE (extract o) $1 $3 }
|
||||||
|
|
||||||
AppExpr :: { Expr' RlpcPs SrcSpan }
|
AppExpr :: { RlpExpr' RlpcPs }
|
||||||
: Expr1 { $1 }
|
: Expr1 { $1 }
|
||||||
| AppExpr Expr1 { comb2 AppEF $1 $2 }
|
| AppExpr Expr1 { AppE <<~ $1 <~> $2 }
|
||||||
|
|
||||||
LetExpr :: { Expr' RlpcPs SrcSpan }
|
LetExpr :: { RlpExpr' RlpcPs }
|
||||||
: let layout1(Binding) in Expr { nolo' $ LetEF NonRec $2 $4 }
|
: let layout1(Binding) in Expr { $1 \$> LetE $2 $4 }
|
||||||
| letrec layout1(Binding) in Expr { nolo' $ LetEF Rec $2 $4 }
|
| letrec layout1(Binding) in Expr { $1 \$> LetrecE $2 $4 }
|
||||||
|
|
||||||
CaseExpr :: { Expr' RlpcPs SrcSpan }
|
CaseExpr :: { RlpExpr' RlpcPs }
|
||||||
: case Expr of layout0(Alt) { nolo' $ CaseEF $2 $4 }
|
: case Expr of layout0(CaseAlt)
|
||||||
|
{ CaseE <<~ $2 <#> $4 }
|
||||||
|
|
||||||
-- TODO: where-binds
|
-- TODO: where-binds
|
||||||
Alt :: { Alt' RlpcPs SrcSpan }
|
CaseAlt :: { (Alt RlpcPs, Where RlpcPs) }
|
||||||
: Pat '->' Expr { AltA $1 (view _unwrap $3) Nothing }
|
: Alt { ($1, []) }
|
||||||
|
|
||||||
|
Alt :: { Alt RlpcPs }
|
||||||
|
: Pat '->' Expr { AltA $1 $3 }
|
||||||
|
|
||||||
-- layout0(p : β) :: [β]
|
-- layout0(p : β) :: [β]
|
||||||
layout0(p) : '{' layout_list0(';',p) '}' { $2 }
|
layout0(p) : '{' layout_list0(';',p) '}' { $2 }
|
||||||
@@ -203,68 +222,38 @@ layout1(p) : '{' layout_list1(';',p) '}' { $2 }
|
|||||||
layout_list1(sep,p) : p { [$1] }
|
layout_list1(sep,p) : p { [$1] }
|
||||||
| layout_list1(sep,p) sep p { $1 `snoc` $3 }
|
| layout_list1(sep,p) sep p { $1 `snoc` $3 }
|
||||||
|
|
||||||
Binding :: { Binding' RlpcPs SrcSpan }
|
Binding :: { Binding' RlpcPs }
|
||||||
: Pat '=' Expr { PatB $1 (view _unwrap $3) }
|
: Pat '=' Expr { PatB <<~ $1 <~> $3 }
|
||||||
|
|
||||||
Expr1 :: { Expr' RlpcPs SrcSpan }
|
Expr1 :: { RlpExpr' RlpcPs }
|
||||||
: '(' Expr ')' { $2 }
|
: '(' Expr ')' { $1 .> $2 <. $3 }
|
||||||
| Lit { nolo' $ LitEF $1 }
|
| Lit { fmap LitE $1 }
|
||||||
| Var { case $1 of Located ss _ -> ss :< VarEF $1 }
|
| Var { fmap VarE $1 }
|
||||||
| Con { case $1 of Located ss _ -> ss :< VarEF $1 }
|
| Con { fmap VarE $1 }
|
||||||
|
|
||||||
InfixOp :: { PsName }
|
InfixOp :: { Located PsName }
|
||||||
: consym { extractName $1 }
|
: consym { mkPsName $1 }
|
||||||
| varsym { extractName $1 }
|
| varsym { mkPsName $1 }
|
||||||
|
|
||||||
-- TODO: microlens-pro save me microlens-pro (rewrite this with prisms)
|
-- TODO: microlens-pro save me microlens-pro (rewrite this with prisms)
|
||||||
Lit :: { Lit RlpcPs }
|
Lit :: { Lit' RlpcPs }
|
||||||
: litint { $1 ^. to extract
|
: litint { $1 <&> (IntL . (\ (TokenLitInt n) -> n)) }
|
||||||
. singular _TokenLitInt
|
|
||||||
. to IntL }
|
|
||||||
|
|
||||||
Var :: { PsName }
|
Var :: { Located PsName }
|
||||||
Var : varname { $1 <&> view (singular _TokenVarName) }
|
Var : varname { mkPsName $1 }
|
||||||
| varsym { $1 <&> view (singular _TokenVarSym) }
|
| varsym { mkPsName $1 }
|
||||||
|
|
||||||
Con :: { PsName }
|
Con :: { Located PsName }
|
||||||
: conname { $1 <&> view (singular _TokenConName) }
|
: conname { mkPsName $1 }
|
||||||
|
|
||||||
{
|
{
|
||||||
|
|
||||||
parseRlpProgR :: (Monad m) => Text -> RLPCT m (Program RlpcPs SrcSpan)
|
parseRlpExprR :: (Monad m) => Text -> RLPCT m (RlpExpr RlpcPs)
|
||||||
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
|
parseRlpExprR s = liftErrorful $ pToErrorful parseRlpExpr st
|
||||||
where
|
where
|
||||||
st = programInitState s
|
st = programInitState s
|
||||||
|
|
||||||
mkInfixD :: Assoc -> Int -> PsName -> P (Decl RlpcPs SrcSpan)
|
parseRlpProgR :: (Monad m) => Text -> RLPCT m (RlpProgram RlpcPs)
|
||||||
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
|
parseRlpProgR s = do
|
||||||
a <- liftErrorful $ pToErrorful parseRlpProg st
|
a <- liftErrorful $ pToErrorful parseRlpProg st
|
||||||
addDebugMsg @_ @String "dump-parsed" $ show a
|
addDebugMsg @_ @String "dump-parsed" $ show a
|
||||||
@@ -287,48 +276,37 @@ extractInt :: RlpToken -> Int
|
|||||||
extractInt (TokenLitInt n) = n
|
extractInt (TokenLitInt n) = n
|
||||||
extractInt _ = error "extractInt: ugh"
|
extractInt _ = error "extractInt: ugh"
|
||||||
|
|
||||||
mkProgram :: [Decl RlpcPs SrcSpan] -> P (Program RlpcPs SrcSpan)
|
mkProgram :: [Decl' RlpcPs] -> P (RlpProgram RlpcPs)
|
||||||
mkProgram ds = do
|
mkProgram ds = do
|
||||||
pt <- use psOpTable
|
pt <- use psOpTable
|
||||||
pure $ Program (associate pt <$> ds)
|
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)
|
||||||
|
|
||||||
intOfToken :: Located RlpToken -> Int
|
intOfToken :: Located RlpToken -> Int
|
||||||
intOfToken (Located _ (TokenLitInt n)) = n
|
intOfToken (Located _ (TokenLitInt n)) = n
|
||||||
|
|
||||||
tempInfixExprErr :: Expr RlpcPs -> Expr RlpcPs -> P a
|
tempInfixExprErr :: RlpExpr' RlpcPs -> RlpExpr' RlpcPs -> P a
|
||||||
tempInfixExprErr (Located a _) (Located b _) =
|
tempInfixExprErr (Located a _) (Located b _) =
|
||||||
addFatal $ errorMsg (a <> b) $ RlpParErrOther
|
addFatal $ errorMsg (a <> b) $ RlpParErrOther
|
||||||
[ "The rl' frontend is currently in beta. Support for infix expressions is minimal, sorry! :("
|
[ "The rl' frontend is currently in beta. Support for infix expressions is minimal, sorry! :("
|
||||||
, "In the mean time, don't mix any infix operators."
|
, "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
|
import Rlp.Syntax
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
|
|
||||||
associate :: OpTable -> Decl RlpcPs a -> Decl RlpcPs a
|
associate :: OpTable -> Decl' RlpcPs -> Decl' RlpcPs
|
||||||
associate _ p = p
|
associate _ p = p
|
||||||
|
|
||||||
{-# WARNING associate "unimplemented" #-}
|
{-# WARNING associate "unimplemented" #-}
|
||||||
|
|||||||
@@ -1,7 +1,6 @@
|
|||||||
{-# LANGUAGE TemplateHaskell #-}
|
{-# LANGUAGE TemplateHaskell #-}
|
||||||
{-# LANGUAGE ImplicitParams, ViewPatterns, PatternSynonyms #-}
|
{-# LANGUAGE ImplicitParams, ViewPatterns, PatternSynonyms #-}
|
||||||
{-# LANGUAGE LambdaCase #-}
|
{-# LANGUAGE LambdaCase #-}
|
||||||
{-# LANGUAGE UndecidableInstances #-}
|
|
||||||
module Rlp.Parse.Types
|
module Rlp.Parse.Types
|
||||||
(
|
(
|
||||||
-- * Trees That Grow
|
-- * Trees That Grow
|
||||||
@@ -18,9 +17,10 @@ module Rlp.Parse.Types
|
|||||||
, RlpToken(..), AlexInput(..), Position(..), spanFromPos, LexerAction
|
, RlpToken(..), AlexInput(..), Position(..), spanFromPos, LexerAction
|
||||||
, Located(..), PsName
|
, Located(..), PsName
|
||||||
-- ** Lenses
|
-- ** Lenses
|
||||||
, _TokenLitInt, _TokenVarName, _TokenConName, _TokenVarSym
|
|
||||||
, aiPrevChar, aiSource, aiBytes, aiPos, posLine, posColumn
|
, aiPrevChar, aiSource, aiBytes, aiPos, posLine, posColumn
|
||||||
|
|
||||||
|
, (<<~), (<~>)
|
||||||
|
|
||||||
-- * Error handling
|
-- * Error handling
|
||||||
, MsgEnvelope(..), RlpcError(..), RlpParseError(..)
|
, MsgEnvelope(..), RlpcError(..), RlpParseError(..)
|
||||||
, addFatal, addWound, addFatalHere, addWoundHere
|
, addFatal, addWound, addFatalHere, addWoundHere
|
||||||
@@ -28,7 +28,6 @@ module Rlp.Parse.Types
|
|||||||
where
|
where
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
import Core.Syntax (Name)
|
import Core.Syntax (Name)
|
||||||
import Text.Show.Deriving
|
|
||||||
import Control.Monad
|
import Control.Monad
|
||||||
import Control.Monad.State.Strict
|
import Control.Monad.State.Strict
|
||||||
import Control.Monad.Errorful
|
import Control.Monad.Errorful
|
||||||
@@ -54,9 +53,34 @@ import Compiler.Types
|
|||||||
|
|
||||||
data RlpcPs
|
data RlpcPs
|
||||||
|
|
||||||
type instance NameP RlpcPs = PsName
|
type instance XRec RlpcPs a = Located a
|
||||||
|
type instance IdP RlpcPs = PsName
|
||||||
|
|
||||||
type PsName = Located Text
|
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
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
|
|
||||||
@@ -94,10 +118,10 @@ data RlpToken
|
|||||||
-- literals
|
-- literals
|
||||||
= TokenLitInt Int
|
= TokenLitInt Int
|
||||||
-- identifiers
|
-- identifiers
|
||||||
| TokenVarName Text
|
| TokenVarName Name
|
||||||
| TokenConName Text
|
| TokenConName Name
|
||||||
| TokenVarSym Text
|
| TokenVarSym Name
|
||||||
| TokenConSym Text
|
| TokenConSym Name
|
||||||
-- reserved words
|
-- reserved words
|
||||||
| TokenData
|
| TokenData
|
||||||
| TokenCase
|
| TokenCase
|
||||||
@@ -128,31 +152,6 @@ data RlpToken
|
|||||||
| TokenEOF
|
| TokenEOF
|
||||||
deriving (Show)
|
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 {
|
newtype P a = P {
|
||||||
runP :: ParseState
|
runP :: ParseState
|
||||||
-> (ParseState, [MsgEnvelope RlpParseError], Maybe a)
|
-> (ParseState, [MsgEnvelope RlpParseError], Maybe a)
|
||||||
@@ -282,14 +281,13 @@ initAlexInput s = AlexInput
|
|||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
|
|
||||||
|
deriving instance Lift (RlpProgram RlpcPs)
|
||||||
-- deriving instance Lift (Program RlpcPs)
|
deriving instance Lift (Decl RlpcPs)
|
||||||
-- deriving instance Lift (Decl RlpcPs)
|
deriving instance Lift (Pat RlpcPs)
|
||||||
-- deriving instance Lift (Pat RlpcPs)
|
deriving instance Lift (Lit RlpcPs)
|
||||||
-- deriving instance Lift (Lit RlpcPs)
|
deriving instance Lift (RlpExpr RlpcPs)
|
||||||
-- deriving instance Lift (Expr RlpcPs)
|
deriving instance Lift (Binding RlpcPs)
|
||||||
-- deriving instance Lift (Binding RlpcPs)
|
deriving instance Lift (RlpType RlpcPs)
|
||||||
-- deriving instance Lift (Ty RlpcPs)
|
deriving instance Lift (Alt RlpcPs)
|
||||||
-- deriving instance Lift (Alt RlpcPs)
|
deriving instance Lift (ConAlt RlpcPs)
|
||||||
-- deriving instance Lift (ConAlt RlpcPs)
|
|
||||||
|
|
||||||
|
|||||||
@@ -1,10 +1,362 @@
|
|||||||
|
-- recursion-schemes
|
||||||
|
{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable
|
||||||
|
, TemplateHaskell, TypeFamilies #-}
|
||||||
|
{-# LANGUAGE OverloadedStrings, PatternSynonyms, ViewPatterns #-}
|
||||||
|
{-# LANGUAGE TypeFamilies, TypeFamilyDependencies #-}
|
||||||
|
{-# LANGUAGE UndecidableInstances, ImpredicativeTypes #-}
|
||||||
module Rlp.Syntax
|
module Rlp.Syntax
|
||||||
( module Rlp.Syntax.Backstage
|
(
|
||||||
, module Rlp.Syntax.Types
|
-- * 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''
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
--------------------------------------------------------------------------------
|
----------------------------------------------------------------------------------
|
||||||
import Rlp.Syntax.Backstage
|
import Data.Text (Text)
|
||||||
import Rlp.Syntax.Types
|
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
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
|
|
||||||
|
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
|
||||||
|
|
||||||
|
|||||||
@@ -1,35 +0,0 @@
|
|||||||
{-# 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
|
|
||||||
|
|
||||||
@@ -1,143 +0,0 @@
|
|||||||
-- 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,12 +17,10 @@ import Rlp.Parse
|
|||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
|
|
||||||
rlpProg :: QuasiQuoter
|
rlpProg :: QuasiQuoter
|
||||||
rlpProg = undefined
|
rlpProg = mkqq parseRlpProgR
|
||||||
-- rlpProg = mkqq parseRlpProgR
|
|
||||||
|
|
||||||
rlpExpr :: QuasiQuoter
|
rlpExpr :: QuasiQuoter
|
||||||
rlpExpr = undefined
|
rlpExpr = mkqq parseRlpExprR
|
||||||
-- rlpExpr = mkqq parseRlpExprR
|
|
||||||
|
|
||||||
mkq :: (Lift a) => (Text -> RLPCIO a) -> String -> Q Exp
|
mkq :: (Lift a) => (Text -> RLPCIO a) -> String -> Q Exp
|
||||||
mkq parse = evalAndParse >=> lift where
|
mkq parse = evalAndParse >=> lift where
|
||||||
|
|||||||
@@ -41,12 +41,6 @@ import Rlp.Syntax as Rlp
|
|||||||
import Rlp.Parse.Types (RlpcPs, PsName)
|
import Rlp.Parse.Types (RlpcPs, PsName)
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
|
|
||||||
desugarRlpProgR = undefined
|
|
||||||
desugarRlpProg = undefined
|
|
||||||
desugarRlpExpr = undefined
|
|
||||||
|
|
||||||
{--
|
|
||||||
|
|
||||||
type Tree a = Either Name (Name, Branch a)
|
type Tree a = Either Name (Name, Branch a)
|
||||||
|
|
||||||
-- | Rose tree branch representing "nested" "patterns" in the Core language. That
|
-- | Rose tree branch representing "nested" "patterns" in the Core language. That
|
||||||
@@ -240,5 +234,3 @@ typeToCore (VarT'' x) = TyVar (dsNameToName x)
|
|||||||
dsNameToName :: IdP RlpcPs -> Name
|
dsNameToName :: IdP RlpcPs -> Name
|
||||||
dsNameToName = id
|
dsNameToName = id
|
||||||
|
|
||||||
-}
|
|
||||||
|
|
||||||
|
|||||||
@@ -1,67 +0,0 @@
|
|||||||
{-# 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