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

some

Browse Source
This commit is contained in:
crumbtoo
2024-01-26 15:12:10 -07:00
parent 559fd49f2b
commit 6a6076f26e
7 changed files with 190 additions and 316 deletions
Download Patch File Download Diff File Expand all files Collapse all files

1
README.md
View File

@@ -81,6 +81,7 @@ Listed in order of importance.
- [ ] CLI usage - [ ] CLI usage
- [ ] Tail call optimisation - [ ] Tail call optimisation
- [ ] Parsing rlp - [ ] Parsing rlp
- [ ] Trees That Grow
- [ ] Tests - [ ] Tests
- [x] Generic example programs - [x] Generic example programs
- [ ] Parser - [ ] Parser

2
rlp.cabal
View File

@@ -75,6 +75,8 @@ library
default-extensions: default-extensions:
OverloadedStrings OverloadedStrings
TypeFamilies
LambdaCase
executable rlpc executable rlpc
import: warnings import: warnings

11
src/Rlp/Lex.x
View File

@@ -193,13 +193,13 @@ readInt = T.foldr f 0 where
constToken :: RlpToken -> LexerAction (Located RlpToken) constToken :: RlpToken -> LexerAction (Located RlpToken)
constToken t inp l = do constToken t inp l = do
pos <- use (psInput . aiPos) pos <- use (psInput . aiPos)
pure (Located (pos,l) t) pure (Located (spanFromPos pos l) t)
tokenWith :: (Text -> RlpToken) -> LexerAction (Located RlpToken) tokenWith :: (Text -> RlpToken) -> LexerAction (Located RlpToken)
tokenWith tf inp l = do tokenWith tf inp l = do
pos <- getPos pos <- getPos
let t = tf (T.take l $ inp ^. aiSource) let t = tf (T.take l $ inp ^. aiSource)
pure (Located (pos,l) t) pure (Located (spanFromPos pos l) t)
getPos :: P Position getPos :: P Position
getPos = use (psInput . aiPos) getPos = use (psInput . aiPos)
@@ -207,7 +207,8 @@ getPos = use (psInput . aiPos)
alexEOF :: P (Located RlpToken) alexEOF :: P (Located RlpToken)
alexEOF = do alexEOF = do
inp <- getInput inp <- getInput
pure (Located undefined TokenEOF) pos <- getPos
pure (Located (spanFromPos pos 0) TokenEOF)
initParseState :: Text -> ParseState initParseState :: Text -> ParseState
initParseState s = ParseState initParseState s = ParseState
@@ -238,7 +239,7 @@ lexToken = do
st <- use id st <- use id
-- traceM $ "st: " <> show st -- traceM $ "st: " <> show st
case alexScan inp c of case alexScan inp c of
AlexEOF -> pure $ Located (inp ^. aiPos, 0) TokenEOF AlexEOF -> pure $ Located (spanFromPos (inp^.aiPos) 0) TokenEOF
AlexSkip inp' l -> do AlexSkip inp' l -> do
psInput .= inp' psInput .= inp'
lexToken lexToken
@@ -274,7 +275,7 @@ indentLevel = do
insertToken :: RlpToken -> P (Located RlpToken) insertToken :: RlpToken -> P (Located RlpToken)
insertToken t = do insertToken t = do
pos <- use (psInput . aiPos) pos <- use (psInput . aiPos)
pure (Located (pos, 0) t) pure (Located (spanFromPos pos 0) t)
popLayout :: P Layout popLayout :: P Layout
popLayout = do popLayout = do

80
src/Rlp/Parse.y
View File

@@ -9,13 +9,13 @@ 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 Lens.Micro import Lens.Micro.Platform
import Lens.Micro.Mtl
import Lens.Micro.Platform ()
import Data.List.Extra import Data.List.Extra
import Data.Fix import Data.Fix
import Data.Functor.Const import Data.Functor.Const
import Data.Functor
import Data.Text qualified as T import Data.Text qualified as T
import Data.Void
} }
%name parseRlpProg StandaloneProgram %name parseRlpProg StandaloneProgram
@@ -26,12 +26,12 @@ import Data.Text qualified as T
%tokentype { Located RlpToken } %tokentype { Located RlpToken }
%token %token
varname { Located _ (TokenVarName $$) } varname { Located _ (TokenVarName _) }
conname { Located _ (TokenConName $$) } conname { Located _ (TokenConName _) }
consym { Located _ (TokenConSym $$) } consym { Located _ (TokenConSym _) }
varsym { Located _ (TokenVarSym $$) } varsym { Located _ (TokenVarSym _) }
data { Located _ TokenData } data { Located _ TokenData }
litint { Located _ (TokenLitInt $$) } litint { Located _ (TokenLitInt _) }
'=' { Located _ TokenEquals } '=' { Located _ TokenEquals }
'|' { Located _ TokenPipe } '|' { Located _ TokenPipe }
';' { Located _ TokenSemicolon } ';' { Located _ TokenSemicolon }
@@ -51,7 +51,7 @@ import Data.Text qualified as T
%% %%
StandaloneProgram :: { RlpProgram' } StandaloneProgram :: { RlpProgram RlpcPs }
StandaloneProgram : '{' Decls '}' {% mkProgram $2 } StandaloneProgram : '{' Decls '}' {% mkProgram $2 }
| VL DeclsV VR {% mkProgram $2 } | VL DeclsV VR {% mkProgram $2 }
@@ -62,12 +62,12 @@ VR :: { () }
VR : vrbrace { () } VR : vrbrace { () }
| error { () } | error { () }
Decls :: { [PartialDecl'] } Decls :: { [Decl' RlpcPs] }
Decls : Decl ';' Decls { $1 : $3 } Decls : Decl ';' Decls { $1 : $3 }
| Decl ';' { [$1] } | Decl ';' { [$1] }
| Decl { [$1] } | Decl { [$1] }
DeclsV :: { [PartialDecl'] } DeclsV :: { [Decl' RlpcPs] }
DeclsV : Decl VS Decls { $1 : $3 } DeclsV : Decl VS Decls { $1 : $3 }
| Decl VS { [$1] } | Decl VS { [$1] }
| Decl { [$1] } | Decl { [$1] }
@@ -76,12 +76,12 @@ VS :: { Located RlpToken }
VS : ';' { $1 } VS : ';' { $1 }
| vsemi { $1 } | vsemi { $1 }
Decl :: { PartialDecl' } Decl :: { Decl' RlpcPs }
: FunDecl { $1 } : FunDecl { $1 }
| DataDecl { $1 } | DataDecl { $1 }
| InfixDecl { $1 } | InfixDecl { $1 }
InfixDecl :: { PartialDecl' } InfixDecl :: { Decl' RlpcPs }
: InfixWord litint InfixOp {% mkInfixD $1 $2 $3 } : InfixWord litint InfixOp {% mkInfixD $1 $2 $3 }
InfixWord :: { Assoc } InfixWord :: { Assoc }
@@ -89,18 +89,18 @@ InfixWord :: { Assoc }
| infixr { InfixR } | infixr { InfixR }
| infix { Infix } | infix { Infix }
DataDecl :: { PartialDecl' } DataDecl :: { Decl' RlpcPs }
: data Con TyParams '=' DataCons { DataD $2 $3 $5 } : data Con TyParams '=' DataCons { DataD $2 $3 $5 }
TyParams :: { [Name] } TyParams :: { [PsName] }
: {- epsilon -} { [] } : {- epsilon -} { [] }
| TyParams varname { $1 `snoc` $2 } | TyParams varname { $1 `snoc` $2 }
DataCons :: { [ConAlt] } DataCons :: { [ConAlt RlpcPs] }
: DataCons '|' DataCon { $1 `snoc` $3 } : DataCons '|' DataCon { $1 `snoc` $3 }
| DataCon { [$1] } | DataCon { [$1] }
DataCon :: { ConAlt } DataCon :: { ConAlt RlpcPs }
: Con Type1s { ConAlt $1 $2 } : Con Type1s { ConAlt $1 $2 }
Type1s :: { [Type] } Type1s :: { [Type] }
@@ -116,22 +116,22 @@ Type :: { Type }
: Type '->' Type { $1 :-> $3 } : Type '->' Type { $1 :-> $3 }
| Type1 { $1 } | Type1 { $1 }
FunDecl :: { PartialDecl' } FunDecl :: { Decl' RlpcPs }
FunDecl : Var Params '=' Expr { FunD $1 $2 (Const $4) Nothing } FunDecl : Var Params '=' Expr { FunD $1 $2 $4 Nothing }
Params :: { [Pat'] } Params :: { [Pat' RlpcPs] }
Params : {- epsilon -} { [] } Params : {- epsilon -} { [] }
| Params Pat1 { $1 `snoc` $2 } | Params Pat1 { $1 `snoc` $2 }
Pat1 :: { Pat' } Pat1 :: { Pat' RlpcPs }
: Var { VarP $1 } : Var { VarP $1 }
| Lit { LitP $1 } | Lit { LitP $1 }
Expr :: { PartialExpr' } Expr :: { RlpExpr' RlpcPs }
: Expr1 varsym Expr { Fix $ B $2 (unFix $1) (unFix $3) } : Expr1 varsym Expr { Fix $ B $2 (unFix $1) (unFix $3) }
| Expr1 { $1 } | Expr1 { $1 }
Expr1 :: { PartialExpr' } Expr1 :: { RlpExpr' RlpcPs }
: '(' Expr ')' { wrapFix . Par . unwrapFix $ $2 } : '(' Expr ')' { wrapFix . Par . unwrapFix $ $2 }
| Lit { Fix . E $ LitEF $1 } | Lit { Fix . E $ LitEF $1 }
| Var { Fix . E $ VarEF $1 } | Var { Fix . E $ VarEF $1 }
@@ -139,34 +139,43 @@ Expr1 :: { PartialExpr' }
-- TODO: happy prefers left-associativity. doing such would require adjusting -- TODO: happy prefers left-associativity. doing such would require adjusting
-- the code in Rlp.Parse.Associate to expect left-associative input rather than -- the code in Rlp.Parse.Associate to expect left-associative input rather than
-- right. -- right.
InfixExpr :: { PartialExpr' } InfixExpr :: { RlpExpr' RlpcPs }
: Expr1 varsym Expr { Fix $ B $2 (unFix $1) (unFix $3) } : Expr1 varsym Expr { Fix $ B $2 (unFix $1) (unFix $3) }
InfixOp :: { Name } InfixOp :: { PsName }
: consym { $1 } : consym { $1 }
| varsym { $1 } | varsym { $1 }
Lit :: { Lit' } -- TODO: microlens-pro save me microlens-pro (rewrite this with prisms)
Lit : litint { IntL $1 } Lit :: { Lit' RlpcPs }
: litint { $1 <&> (IntL . (\ (TokenLitInt n) -> n)) }
Var :: { VarId } Var :: { Located PsName }
Var : varname { NameVar $1 } Var : varname { mkPsName $1 }
Con :: { ConId } Con :: { Located PsName }
: conname { NameCon $1 } : conname { mkPsName $1 }
{ {
mkProgram :: [PartialDecl'] -> P RlpProgram' mkPsName :: Located RlpToken -> Located PsName
mkPsName = fmap $ \case
TokenVarName n -> n
TokenConName n -> n
TokenConSym n -> n
TokenVarSym n -> n
_ -> error "mkPsName: not an identifier"
mkProgram :: [Decl' RlpcPs] -> P (RlpProgram RlpcPs)
mkProgram ds = do mkProgram ds = do
pt <- use psOpTable pt <- use psOpTable
pure $ RlpProgram (associate pt <$> ds) pure $ RlpProgram (associate pt <$> ds)
parseError :: Located RlpToken -> P a parseError :: Located RlpToken -> P a
parseError (Located ((l,c),s) t) = addFatal $ parseError (Located (l,c,s) t) = addFatal $
errorMsg (SrcSpan l c s) RlpParErrUnexpectedToken errorMsg (SrcSpan l c s) RlpParErrUnexpectedToken
mkInfixD :: Assoc -> Int -> Name -> P PartialDecl' mkInfixD :: Assoc -> Int -> PsName -> P (Decl' RlpcPs)
mkInfixD a p n = do mkInfixD a p n = do
let opl :: Lens' ParseState (Maybe OpInfo) let opl :: Lens' ParseState (Maybe OpInfo)
opl = psOpTable . at n opl = psOpTable . at n
@@ -176,6 +185,7 @@ mkInfixD a p n = do
l = T.length n l = T.length n
Nothing -> pure (Just (a,p)) Nothing -> pure (Just (a,p))
) )
pure $ InfixD a p n pos <- use (psInput . aiPos)
pure $ Located (spanFromPos pos 0) (InfixD' a p n)
} }

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

@@ -1,6 +1,7 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms, ViewPatterns, ImplicitParams #-} {-# LANGUAGE PatternSynonyms, ViewPatterns, ImplicitParams #-}
module Rlp.Parse.Associate module Rlp.Parse.Associate
{-# WARNING "temporarily unimplemented" #-}
( associate ( associate
) )
where where
@@ -13,88 +14,6 @@ import Rlp.Parse.Types
import Rlp.Syntax import Rlp.Syntax
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
associate :: OpTable -> PartialDecl' -> Decl' RlpExpr associate = undefined
associate pt (FunD n as b w) = FunD n as b' w {-# WARNING associate "temporarily undefined" #-}
where b' = let ?pt = pt in completeExpr (getConst b)
associate pt (TySigD ns t) = TySigD ns t
associate pt (DataD n as cs) = DataD n as cs
associate pt (InfixD a p n) = InfixD a p n
completeExpr :: (?pt :: OpTable) => PartialExpr' -> RlpExpr'
completeExpr = cata completePartial
completePartial :: (?pt :: OpTable) => PartialE -> RlpExpr'
completePartial (E e) = completeRlpExpr e
completePartial p@(B o l r) = completeB (build p)
completePartial (Par e) = completePartial e
completeRlpExpr :: (?pt :: OpTable) => RlpExprF' RlpExpr' -> RlpExpr'
completeRlpExpr = embed
completeB :: (?pt :: OpTable) => PartialE -> RlpExpr'
completeB p = case build p of
B o l r -> (o' `AppE` l') `AppE` r'
where
-- TODO: how do we know it's symbolic?
o' = VarE (SymVar o)
l' = completeB l
r' = completeB r
Par e -> completeB e
E e -> completeRlpExpr e
build :: (?pt :: OpTable) => PartialE -> PartialE
build e = go id e (rightmost e) where
rightmost :: PartialE -> PartialE
rightmost (B _ _ r) = rightmost r
rightmost p@(E _) = p
rightmost p@(Par _) = p
go :: (?pt :: OpTable)
=> (PartialE -> PartialE)
-> PartialE -> PartialE -> PartialE
go f p@(WithInfo o _ r) = case r of
E _ -> mkHole o (f . f')
Par _ -> mkHole o (f . f')
B _ _ _ -> go (mkHole o (f . f')) r
where f' r' = p & pR .~ r'
go f _ = id
mkHole :: (?pt :: OpTable)
=> OpInfo
-> (PartialE -> PartialE)
-> PartialE
-> PartialE
mkHole _ hole p@(Par _) = hole p
mkHole _ hole p@(E _) = hole p
mkHole (a,d) hole p@(WithInfo (a',d') _ _)
| d' < d = above
| d' > d = below
| d == d' = case (a,a') of
-- left-associative operators of equal precedence are
-- associated left
(InfixL,InfixL) -> above
-- right-associative operators are handled similarly
(InfixR,InfixR) -> below
-- non-associative operators of equal precedence, or equal
-- precedence operators of different associativities are
-- invalid
(_, _) -> error "invalid expression"
where
above = p & pL %~ hole
below = hole p
examplePrecTable :: OpTable
examplePrecTable = H.fromList
[ ("+", (InfixL,6))
, ("*", (InfixL,7))
, ("^", (InfixR,8))
, (".", (InfixR,7))
, ("~", (Infix, 9))
, ("=", (Infix, 4))
, ("&&", (Infix, 3))
, ("||", (Infix, 2))
, ("$", (InfixR,0))
, ("&", (InfixL,0))
]

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

@@ -2,38 +2,24 @@
{-# LANGUAGE ImplicitParams, ViewPatterns, PatternSynonyms #-} {-# LANGUAGE ImplicitParams, ViewPatterns, PatternSynonyms #-}
{-# LANGUAGE LambdaCase #-} {-# LANGUAGE LambdaCase #-}
module Rlp.Parse.Types module Rlp.Parse.Types
( LexerAction (
, MsgEnvelope(..) -- * Trees That Grow
, RlpcError(..) RlpcPs
, AlexInput(..)
, Position(..) -- * Parser monad and state
, RlpToken(..) , P(..), ParseState(..), Layout(..), OpTable, OpInfo
, P(..) -- ** Lenses
, ParseState(..) , psLayoutStack, psLexState, psInput, psOpTable
, psLayoutStack
, psLexState -- * Other parser types
, psInput , RlpToken(..), AlexInput(..), Position(..), spanFromPos, LexerAction
, psOpTable , Located(..), PsName
, Layout(..) -- ** Lenses
, Located(..) , aiPrevChar, aiSource, aiBytes, aiPos, posLine, posColumn
, OpTable
, OpInfo -- * Error handling
, RlpParseError(..) , MsgEnvelope(..), RlpcError(..), RlpParseError(..)
, PartialDecl' , addFatal, addWound, addFatalHere, addWoundHere
, Partial(..)
, pL, pR
, PartialE
, pattern WithInfo
, opInfoOrDef
, PartialExpr'
, aiPrevChar
, aiSource
, aiBytes
, aiPos
, addFatal
, addWound
, addFatalHere
, addWoundHere
) )
where where
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
@@ -49,12 +35,26 @@ import Data.Functor.Foldable
import Data.Functor.Const import Data.Functor.Const
import Data.Functor.Classes import Data.Functor.Classes
import Data.HashMap.Strict qualified as H import Data.HashMap.Strict qualified as H
import Data.Void
import Data.Word (Word8) import Data.Word (Word8)
import Lens.Micro.TH import Lens.Micro.TH
import Lens.Micro import Lens.Micro
import Rlp.Syntax import Rlp.Syntax
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Phantom type identifying rlpc's parser phase
data RlpcPs
type instance XRec RlpcPs f = Located (f RlpcPs)
type instance IdP RlpcPs = PsName
type instance XInfixD RlpcPs = ()
type PsName = Text
--------------------------------------------------------------------------------
type LexerAction a = AlexInput -> Int -> P a type LexerAction a = AlexInput -> Int -> P a
data AlexInput = AlexInput data AlexInput = AlexInput
@@ -106,7 +106,7 @@ data RlpToken
| TokenLParen | TokenLParen
| TokenRParen | TokenRParen
-- 'virtual' control symbols, inserted by the lexer without any correlation -- 'virtual' control symbols, inserted by the lexer without any correlation
-- to a specific symbol -- to a specific part of the input
| TokenSemicolonV | TokenSemicolonV
| TokenLBraceV | TokenLBraceV
| TokenRBraceV | TokenRBraceV
@@ -154,8 +154,14 @@ data Layout = Explicit
| Implicit Int | Implicit Int
deriving (Show, Eq) deriving (Show, Eq)
data Located a = Located (Position, Int) a -- | Token wrapped with a span (line, column, length)
deriving (Show) data Located a = Located !(Int, Int, Int) a
deriving (Show, Functor)
spanFromPos :: Position -> Int -> (Int, Int, Int)
spanFromPos (l,c) s = (l,c,s)
{-# INLINE spanFromPos #-}
type OpTable = H.HashMap Name OpInfo type OpTable = H.HashMap Name OpInfo
type OpInfo = (Assoc, Int) type OpInfo = (Assoc, Int)
@@ -171,47 +177,6 @@ data RlpParseError = RlpParErrOutOfBoundsPrecedence Int
instance IsRlpcError RlpParseError where instance IsRlpcError RlpParseError where
---------------------------------------------------------------------------------- ----------------------------------------------------------------------------------
-- absolute psycho shit (partial ASTs)
type PartialDecl' = Decl (Const PartialExpr') Name
data Partial a = E (RlpExprF Name a)
| B Name (Partial a) (Partial a)
| Par (Partial a)
deriving (Show, Functor)
pL :: Traversal' (Partial a) (Partial a)
pL k (B o l r) = (\l' -> B o l' r) <$> k l
pL _ x = pure x
pR :: Traversal' (Partial a) (Partial a)
pR k (B o l r) = (\r' -> B o l r') <$> k r
pR _ x = pure x
type PartialE = Partial RlpExpr'
-- i love you haskell
pattern WithInfo :: (?pt :: OpTable) => OpInfo -> PartialE -> PartialE -> PartialE
pattern WithInfo p l r <- B (opInfoOrDef -> p) l r
opInfoOrDef :: (?pt :: OpTable) => Name -> OpInfo
opInfoOrDef c = fromMaybe (InfixL,9) $ H.lookup c ?pt
-- required to satisfy constraint on Fix's show instance
instance Show1 Partial where
liftShowsPrec :: forall a. (Int -> a -> ShowS)
-> ([a] -> ShowS)
-> Int -> Partial a -> ShowS
liftShowsPrec sp sl p m = case m of
(E e) -> showsUnaryWith lshow "E" p e
(B f a b) -> showsTernaryWith showsPrec lshow lshow "B" p f a b
(Par e) -> showsUnaryWith lshow "Par" p e
where
lshow :: forall f. (Show1 f) => Int -> f a -> ShowS
lshow = liftShowsPrec sp sl
type PartialExpr' = Fix Partial
makeLenses ''AlexInput makeLenses ''AlexInput
makeLenses ''ParseState makeLenses ''ParseState

208
src/Rlp/Syntax.hs
View File

@@ -1,40 +1,28 @@
-- recursion-schemes -- recursion-schemes
{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-} {-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable
-- recursion-schemes , TemplateHaskell, TypeFamilies #-}
{-# LANGUAGE TemplateHaskell, TypeFamilies #-}
{-# LANGUAGE OverloadedStrings, PatternSynonyms #-} {-# LANGUAGE OverloadedStrings, PatternSynonyms #-}
{-# LANGUAGE TypeFamilies, TypeFamilyDependencies #-}
module Rlp.Syntax module Rlp.Syntax
( RlpModule(..) (
, RlpProgram(..) -- * AST
, RlpProgram' RlpProgram(..)
, rlpmodName , Decl(..), Decl', RlpExpr(..), RlpExpr'
, rlpmodProgram , Pat(..), Pat'
, RlpExpr(..)
, RlpExpr'
, RlpExprF(..)
, RlpExprF'
, Decl(..)
, Decl'
, Bind(..)
, Where
, Where'
, ConAlt(..)
, Type(..)
, pattern (:->)
, Assoc(..) , Assoc(..)
, VarId(..) , Lit(..), Lit'
, ConId(..) , Type(..)
, Pat(..) , ConAlt(..)
, Pat'
, Lit(..)
, Lit'
, Name
-- TODO: ugh move this somewhere else later -- * Pattern synonyms for unused extensions
, showsTernaryWith , pattern InfixD'
-- * Convenience re-exports -- * Trees That Grow extensions
, Text , XRec, IdP
-- ** RlpExpr
, XLetE, XVarE, XConE, XLamE, XCaseE, XIfE, XAppE, XLitE, XXRlpExpr
-- ** Decl
, XFunD, XTySigD, XDataD, XInfixD, XXDecl
) )
where where
---------------------------------------------------------------------------------- ----------------------------------------------------------------------------------
@@ -49,87 +37,91 @@ import Core.Syntax hiding (Lit)
import Core (HasRHS(..), HasLHS(..)) import Core (HasRHS(..), HasLHS(..))
---------------------------------------------------------------------------------- ----------------------------------------------------------------------------------
data RlpModule b = RlpModule data RlpModule p = RlpModule
{ _rlpmodName :: Text { _rlpmodName :: Text
, _rlpmodProgram :: RlpProgram b , _rlpmodProgram :: RlpProgram p
} }
newtype RlpProgram b = RlpProgram [Decl RlpExpr b] newtype RlpProgram p = RlpProgram [Decl p]
deriving Show
type RlpProgram' = RlpProgram Name data Decl p = FunD (XFunD p) (IdP p) [Pat p] (RlpExpr p) (Maybe (Where p))
| TySigD (XTySigD p) [IdP p] Type
| DataD (XDataD p) (IdP p) [IdP p] [ConAlt p]
| InfixD (XInfixD p) Assoc Int (IdP p)
| XDecl !(XXDecl p)
-- | The @e@ parameter is used for partial results. When parsing an input, we type family XFunD p
-- first parse all top-level declarations in order to extract infix[lr] type family XTySigD p
-- declarations. This process yields a @[Decl (Const Text) Name]@, where @Const type family XDataD p
-- Text@ stores the remaining unparsed function bodies. Once infixities are type family XInfixD p
-- accounted for, we may complete the parsing task and get a proper @[Decl type family XXDecl p
-- RlpExpr Name]@.
data Decl e b = FunD VarId [Pat b] (e b) (Maybe (Where b)) pattern InfixD' :: (XInfixD p ~ ()) => Assoc -> Int -> (IdP p) -> Decl p
| TySigD [VarId] Type pattern InfixD' a p n = InfixD () a p n
| DataD ConId [Name] [ConAlt]
| InfixD Assoc Int Name
deriving Show
type Decl' e = Decl e Name type Decl' p = XRec p Decl
data Assoc = InfixL data Assoc = InfixL
| InfixR | InfixR
| Infix | Infix
deriving Show deriving (Show)
data ConAlt = ConAlt ConId [Type] data ConAlt p = ConAlt (IdP p) [Type]
deriving Show
data RlpExpr b = LetE [Bind b] (RlpExpr b) data RlpExpr p = LetE (XLetE p) [Bind p] (RlpExpr' p)
| VarE VarId | VarE (XVarE p) (IdP p)
| ConE ConId | LamE (XLamE p) [Pat p] (RlpExpr' p)
| LamE [Pat b] (RlpExpr b) | CaseE (XCaseE p) (RlpExpr' p) [(Alt p, Where p)]
| CaseE (RlpExpr b) [(Alt b, Where b)] | IfE (XIfE p) (RlpExpr' p) (RlpExpr' p) (RlpExpr' p)
| IfE (RlpExpr b) (RlpExpr b) (RlpExpr b) | AppE (XAppE p) (RlpExpr' p) (RlpExpr' p)
| AppE (RlpExpr b) (RlpExpr b) | LitE (XLitE p) (Lit p)
| LitE (Lit b) | ParE (XParE p) (RlpExpr' p)
deriving Show | OAppE (XOAppE p) (IdP p) (RlpExpr' p) (RlpExpr' p)
| XRlpExpr !(XXRlpExpr p)
type RlpExpr' = RlpExpr Name type RlpExpr' p = XRec p RlpExpr
type Where b = [Bind b] class UnXRec p where
type Where' = [Bind Name] unXRec :: XRec p f -> f p
class MapXRec p where
mapXRec :: (f p -> f p) -> XRec p f -> XRec p f
type family XRec p (f :: * -> *) = (r :: *) | r -> p f
type family XLetE p
type family XVarE p
type family XConE 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 XXRlpExpr p
type family IdP p
type Where p = [Bind p]
-- do we want guards? -- do we want guards?
data Alt b = AltA (Pat b) (RlpExpr b) data Alt p = AltA (Pat' p) (RlpExpr' p)
deriving Show
data Bind b = PatB (Pat b) (RlpExpr b) data Bind p = PatB (Pat' p) (RlpExpr' p)
| FunB VarId [Pat b] (RlpExpr b) | FunB (IdP p) [Pat' p] (RlpExpr' p)
deriving Show
data VarId = NameVar Text data Pat p = VarP (IdP p)
| SymVar Text | LitP (Lit' p)
deriving Show | ConP (IdP p) [Pat' p]
instance IsString VarId where type Pat' p = XRec p Pat
-- TODO: use symvar if it's an operator
fromString = NameVar . T.pack
data ConId = NameCon Text data Lit p = IntL Int
| SymCon Text
deriving Show
data Pat b = VarP VarId
| LitP (Lit b)
| ConP ConId [Pat b]
deriving Show
type Pat' = Pat Name
data Lit b = IntL Int
| CharL Char | CharL Char
| ListL [RlpExpr b] | ListL [RlpExpr' p]
deriving Show
type Lit' = Lit Name type Lit' p = XRec p Lit
-- instance HasLHS Alt Alt Pat Pat where -- instance HasLHS Alt Alt Pat Pat where
-- _lhs = lens -- _lhs = lens
@@ -143,33 +135,17 @@ type Lit' = Lit Name
makeBaseFunctor ''RlpExpr makeBaseFunctor ''RlpExpr
deriving instance (Show b, Show a) => Show (RlpExprF b a) -- showsTernaryWith :: (Int -> x -> ShowS)
-- -> (Int -> y -> ShowS)
type RlpExprF' = RlpExprF Name -- -> (Int -> z -> ShowS)
-- -> String -> Int
-- society if derivable Show1 -- -> x -> y -> z
instance (Show b) => Show1 (RlpExprF b) where -- -> ShowS
liftShowsPrec sp _ p m = case m of -- showsTernaryWith sa sb sc name p a b c = showParen (p > 10)
(LetEF bs e) -> showsBinaryWith showsPrec sp "LetEF" p bs e -- $ showString name
(VarEF n) -> showsUnaryWith showsPrec "VarEF" p n -- . showChar ' ' . sa 11 a
(ConEF n) -> showsUnaryWith showsPrec "ConEF" p n -- . showChar ' ' . sb 11 b
(LamEF bs e) -> showsBinaryWith showsPrec sp "LamEF" p bs e -- . showChar ' ' . sc 11 c
(CaseEF e as) -> showsBinaryWith sp showsPrec "CaseEF" p e as
(IfEF a b c) -> showsTernaryWith sp sp sp "IfEF" p a b c
(AppEF f x) -> showsBinaryWith sp sp "AppEF" p f x
(LitEF l) -> showsUnaryWith showsPrec "LitEF" p l
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
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------