msyds/rlp
1
0
Fork 0
Code Issues 4 Pull Requests Actions Packages Projects Releases 2 Wiki Activity

show

Browse Source
This commit is contained in:
crumbtoo
2024-01-28 16:24:08 -07:00
parent c74c192645
commit 83dda869f8
5 changed files with 91 additions and 17 deletions
Download Patch File Download Diff File Expand all files Collapse all files

4
rlp.cabal
View File

@@ -48,7 +48,7 @@ library
build-tool-depends: happy:happy, alex:alex
-- other-extensions:
build-depends: base ^>=4.18.0.0
build-depends: base >=4.17 && <4.20
-- required for happy
, array >= 0.5.5 && < 0.6
, containers >= 0.6.7 && < 0.7
@@ -85,7 +85,7 @@ executable rlpc
main-is: Main.hs
-- other-modules:
-- other-extensions:
build-depends: base ^>=4.18.0.0
build-depends: base >=4.17.0.0 && <4.20.0.0
, rlp
, optparse-applicative >= 0.18.1 && < 0.19
, microlens >= 0.4.13 && < 0.5

11
src/Rlp/Parse.y
View File

@@ -1,5 +1,5 @@
{
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE LambdaCase, ViewPatterns #-}
module Rlp.Parse
( parseRlpProg
)
@@ -86,7 +86,7 @@ Decl :: { Decl' RlpcPs }
| InfixDecl { $1 }
InfixDecl :: { Decl' RlpcPs }
: InfixWord litint InfixOp {% mkInfixD $1 $2 $3 }
: InfixWord litint InfixOp {% mkInfixD $1 (intOfToken $2) $3 }
InfixWord :: { Assoc }
: infixl { InfixL }
@@ -94,11 +94,11 @@ InfixWord :: { Assoc }
| infix { Infix }
DataDecl :: { Decl' RlpcPs }
: data Con TyParams '=' DataCons { DataD $2 $3 $5 }
: data Con TyParams '=' DataCons { $1 =>> \_ -> DataD' (extract $2) $3 $5 }
TyParams :: { [PsName] }
: {- epsilon -} { [] }
| TyParams varname { $1 `snoc` $2 }
| TyParams varname { $1 `snoc` extract (mkPsName $2) }
DataCons :: { [ConAlt RlpcPs] }
: DataCons '|' DataCon { $1 `snoc` $3 }
@@ -193,4 +193,7 @@ mkInfixD a p n = do
pos <- use (psInput . aiPos)
pure $ Located (spanFromPos pos 0) (InfixD' a p n)
intOfToken :: Located RlpToken -> Int
intOfToken (Located _ (TokenLitInt n)) = n
}

2
src/Rlp/Parse/Associate.hs
View File

@@ -14,6 +14,6 @@ import Rlp.Parse.Types
import Rlp.Syntax
--------------------------------------------------------------------------------
associate = undefined
associate x y = y
{-# WARNING associate "temporarily undefined" #-}

39
src/Rlp/Parse/Types.hs
View File

@@ -53,9 +53,22 @@ type instance XRec RlpcPs f = Located (f RlpcPs)
type instance IdP RlpcPs = PsName
type instance XInfixD RlpcPs = ()
type instance XVarE RlpcPs = ()
type instance XLitE RlpcPs = ()
type instance XFunD RlpcPs = ()
type instance XDataD RlpcPs = ()
type instance XTySigD RlpcPs = ()
type instance XXDecl RlpcPs = ()
type instance XLetE 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 XXRlpExpr RlpcPs = ()
type instance XLitE RlpcPs = ()
type PsName = Text
@@ -198,6 +211,28 @@ spanAcross (la,ca,aa,sa) (lb,cb,ab,sb) = (l,c,a,s)
LT -> max sa (ab + sb)
GT -> max sb (aa + sa)
-- | A synonym for '(<<=)' with a different precedence for use with '(<~>)' in a
-- sort of, comonadic pseudo-applicative style.
(<<~) :: (Comonad w) => (w a -> b) -> w a -> w b
(<<~) = (<<=)
infixl 4 <<~
-- | Similar to '(<*>)', but with a cokleisli arrow.
(<~>) :: (Comonad w, Bind w) => w (w a -> b) -> w a -> w b
mc <~> ma = mc >>- \f -> ma =>> f
infixl 4 <~>
-- f :: (w a -> w b -> c)
-- a :: w a
-- b :: w b
-- result :: w c
-- result = f >~~ a <~> b
instance Comonad Located where
extract (Located _ a) = a
extend ck w@(Located p _) = Located p (ck w)

50
src/Rlp/Syntax.hs
View File

@@ -3,6 +3,7 @@
, TemplateHaskell, TypeFamilies #-}
{-# LANGUAGE OverloadedStrings, PatternSynonyms #-}
{-# LANGUAGE TypeFamilies, TypeFamilyDependencies #-}
{-# LANGUAGE UndecidableInstances, ImpredicativeTypes #-}
module Rlp.Syntax
(
-- * AST
@@ -17,14 +18,15 @@ module Rlp.Syntax
-- * Pattern synonyms for unused extensions
-- ** Decl
, pattern InfixD', pattern FunD'
, pattern InfixD', pattern FunD', pattern DataD'
-- ** RlpExpr
, pattern ParE', pattern VarE', pattern LitE'
-- * Trees That Grow extensions
, UnXRec(..), MapXRec(..), XRec, IdP
-- ** RlpExpr
, XLetE, XVarE, XConE, XLamE, XCaseE, XIfE, XAppE, XLitE, XXRlpExpr
, XLetE, XVarE, XConE, XLamE, XCaseE, XIfE, XAppE, XLitE, XParE, XOAppE
, XXRlpExpr
-- ** Decl
, XFunD, XTySigD, XDataD, XInfixD, XXDecl
)
@@ -37,7 +39,7 @@ import Data.Functor.Foldable.TH (makeBaseFunctor)
import Data.Functor.Classes
import Lens.Micro
import Lens.Micro.TH
import Core.Syntax hiding (Lit)
import Core.Syntax hiding (Lit, Binding)
import Core (HasRHS(..), HasLHS(..))
----------------------------------------------------------------------------------
@@ -46,7 +48,15 @@ data RlpModule p = RlpModule
, _rlpmodProgram :: RlpProgram p
}
newtype RlpProgram p = RlpProgram [Decl p]
-- | dear god.
type PhaseShow p =
( Show (XRec p Pat), Show (XRec p RlpExpr)
, Show (XRec p Lit), Show (IdP p)
)
newtype RlpProgram p = RlpProgram [Decl' p]
deriving instance (PhaseShow p, Show (XRec p Decl)) => Show (RlpProgram p)
data Decl p = FunD (XFunD p) (IdP p) [Pat' p] (RlpExpr' p) (Maybe (Where p))
| TySigD (XTySigD p) [IdP p] Type
@@ -54,6 +64,12 @@ data Decl p = FunD (XFunD p) (IdP p) [Pat' p] (RlpExpr' p) (Maybe (Where p))
| InfixD (XInfixD p) Assoc Int (IdP p)
| XDecl !(XXDecl p)
deriving instance ( Show (XFunD p), Show (XTySigD p)
, Show (XDataD p), Show (XInfixD p)
, Show (XXDecl p), Show (IdP p)
, PhaseShow p
) => Show (Decl p)
type family XFunD p
type family XTySigD p
type family XDataD p
@@ -68,6 +84,9 @@ pattern FunD' n as e wh = FunD () n as e wh
pattern InfixD' :: (XInfixD p ~ ()) => Assoc -> Int -> (IdP p) -> Decl p
pattern InfixD' a p n = InfixD () a p n
pattern DataD' :: (XDataD p ~ ()) => IdP p -> [IdP p] -> [ConAlt p] -> Decl p
pattern DataD' n as ds = DataD () n as ds
type Decl' p = XRec p Decl
data Assoc = InfixL
@@ -77,7 +96,9 @@ data Assoc = InfixL
data ConAlt p = ConAlt (IdP p) [Type]
data RlpExpr p = LetE (XLetE p) [Bind p] (RlpExpr' p)
deriving instance (Show (IdP p)) => Show (ConAlt p)
data RlpExpr p = LetE (XLetE 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)]
@@ -88,6 +109,12 @@ data RlpExpr p = LetE (XLetE p) [Bind p] (RlpExpr' p)
| OAppE (XOAppE p) (IdP p) (RlpExpr' p) (RlpExpr' p)
| XRlpExpr !(XXRlpExpr p)
deriving instance
( Show (XLetE 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 (XXRlpExpr p), PhaseShow p)
=> Show (RlpExpr p)
type RlpExpr' p = XRec p RlpExpr
class UnXRec p where
@@ -121,24 +148,33 @@ pattern LitE' e = LitE () e
pattern VarE' :: (XVarE p ~ ()) => IdP p -> RlpExpr p
pattern VarE' e = VarE () e
type Where p = [Bind p]
type Where p = [Binding p]
-- do we want guards?
data Alt p = AltA (Pat' p) (RlpExpr' p)
data Bind p = PatB (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)
deriving instance (Show (XRec p Pat), Show (XRec p RlpExpr), Show (IdP p)
) => Show (Binding p)
data Pat p = VarP (IdP p)
| LitP (Lit' p)
| ConP (IdP p) [Pat' p]
deriving instance (PhaseShow p) => Show (Pat p)
type Pat' p = XRec p Pat
data Lit p = IntL Int
| CharL Char
| ListL [RlpExpr' p]
deriving instance (PhaseShow p) => Show (Lit p)
type Lit' p = XRec p Lit
-- instance HasLHS Alt Alt Pat Pat where