rc #13
@@ -81,6 +81,7 @@ Listed in order of importance.
|
||||
- [ ] CLI usage
|
||||
- [ ] Tail call optimisation
|
||||
- [ ] Parsing rlp
|
||||
- [ ] Trees That Grow
|
||||
- [ ] Tests
|
||||
- [x] Generic example programs
|
||||
- [ ] Parser
|
||||
|
||||
@@ -75,6 +75,8 @@ library
|
||||
|
||||
default-extensions:
|
||||
OverloadedStrings
|
||||
TypeFamilies
|
||||
LambdaCase
|
||||
|
||||
executable rlpc
|
||||
import: warnings
|
||||
|
||||
@@ -193,13 +193,13 @@ readInt = T.foldr f 0 where
|
||||
constToken :: RlpToken -> LexerAction (Located RlpToken)
|
||||
constToken t inp l = do
|
||||
pos <- use (psInput . aiPos)
|
||||
pure (Located (pos,l) t)
|
||||
pure (Located (spanFromPos pos l) t)
|
||||
|
||||
tokenWith :: (Text -> RlpToken) -> LexerAction (Located RlpToken)
|
||||
tokenWith tf inp l = do
|
||||
pos <- getPos
|
||||
let t = tf (T.take l $ inp ^. aiSource)
|
||||
pure (Located (pos,l) t)
|
||||
pure (Located (spanFromPos pos l) t)
|
||||
|
||||
getPos :: P Position
|
||||
getPos = use (psInput . aiPos)
|
||||
@@ -207,7 +207,8 @@ getPos = use (psInput . aiPos)
|
||||
alexEOF :: P (Located RlpToken)
|
||||
alexEOF = do
|
||||
inp <- getInput
|
||||
pure (Located undefined TokenEOF)
|
||||
pos <- getPos
|
||||
pure (Located (spanFromPos pos 0) TokenEOF)
|
||||
|
||||
initParseState :: Text -> ParseState
|
||||
initParseState s = ParseState
|
||||
@@ -238,7 +239,7 @@ lexToken = do
|
||||
st <- use id
|
||||
-- traceM $ "st: " <> show st
|
||||
case alexScan inp c of
|
||||
AlexEOF -> pure $ Located (inp ^. aiPos, 0) TokenEOF
|
||||
AlexEOF -> pure $ Located (spanFromPos (inp^.aiPos) 0) TokenEOF
|
||||
AlexSkip inp' l -> do
|
||||
psInput .= inp'
|
||||
lexToken
|
||||
@@ -274,7 +275,7 @@ indentLevel = do
|
||||
insertToken :: RlpToken -> P (Located RlpToken)
|
||||
insertToken t = do
|
||||
pos <- use (psInput . aiPos)
|
||||
pure (Located (pos, 0) t)
|
||||
pure (Located (spanFromPos pos 0) t)
|
||||
|
||||
popLayout :: P Layout
|
||||
popLayout = do
|
||||
|
||||
@@ -9,13 +9,13 @@ import Rlp.Lex
|
||||
import Rlp.Syntax
|
||||
import Rlp.Parse.Types
|
||||
import Rlp.Parse.Associate
|
||||
import Lens.Micro
|
||||
import Lens.Micro.Mtl
|
||||
import Lens.Micro.Platform ()
|
||||
import Lens.Micro.Platform
|
||||
import Data.List.Extra
|
||||
import Data.Fix
|
||||
import Data.Functor.Const
|
||||
import Data.Functor
|
||||
import Data.Text qualified as T
|
||||
import Data.Void
|
||||
}
|
||||
|
||||
%name parseRlpProg StandaloneProgram
|
||||
@@ -26,12 +26,12 @@ import Data.Text qualified as T
|
||||
%tokentype { Located RlpToken }
|
||||
|
||||
%token
|
||||
varname { Located _ (TokenVarName $$) }
|
||||
conname { Located _ (TokenConName $$) }
|
||||
consym { Located _ (TokenConSym $$) }
|
||||
varsym { Located _ (TokenVarSym $$) }
|
||||
varname { Located _ (TokenVarName _) }
|
||||
conname { Located _ (TokenConName _) }
|
||||
consym { Located _ (TokenConSym _) }
|
||||
varsym { Located _ (TokenVarSym _) }
|
||||
data { Located _ TokenData }
|
||||
litint { Located _ (TokenLitInt $$) }
|
||||
litint { Located _ (TokenLitInt _) }
|
||||
'=' { Located _ TokenEquals }
|
||||
'|' { Located _ TokenPipe }
|
||||
';' { Located _ TokenSemicolon }
|
||||
@@ -51,7 +51,7 @@ import Data.Text qualified as T
|
||||
|
||||
%%
|
||||
|
||||
StandaloneProgram :: { RlpProgram' }
|
||||
StandaloneProgram :: { RlpProgram RlpcPs }
|
||||
StandaloneProgram : '{' Decls '}' {% mkProgram $2 }
|
||||
| VL DeclsV VR {% mkProgram $2 }
|
||||
|
||||
@@ -62,12 +62,12 @@ VR :: { () }
|
||||
VR : vrbrace { () }
|
||||
| error { () }
|
||||
|
||||
Decls :: { [PartialDecl'] }
|
||||
Decls :: { [Decl' RlpcPs] }
|
||||
Decls : Decl ';' Decls { $1 : $3 }
|
||||
| Decl ';' { [$1] }
|
||||
| Decl { [$1] }
|
||||
|
||||
DeclsV :: { [PartialDecl'] }
|
||||
DeclsV :: { [Decl' RlpcPs] }
|
||||
DeclsV : Decl VS Decls { $1 : $3 }
|
||||
| Decl VS { [$1] }
|
||||
| Decl { [$1] }
|
||||
@@ -76,12 +76,12 @@ VS :: { Located RlpToken }
|
||||
VS : ';' { $1 }
|
||||
| vsemi { $1 }
|
||||
|
||||
Decl :: { PartialDecl' }
|
||||
Decl :: { Decl' RlpcPs }
|
||||
: FunDecl { $1 }
|
||||
| DataDecl { $1 }
|
||||
| InfixDecl { $1 }
|
||||
|
||||
InfixDecl :: { PartialDecl' }
|
||||
InfixDecl :: { Decl' RlpcPs }
|
||||
: InfixWord litint InfixOp {% mkInfixD $1 $2 $3 }
|
||||
|
||||
InfixWord :: { Assoc }
|
||||
@@ -89,18 +89,18 @@ InfixWord :: { Assoc }
|
||||
| infixr { InfixR }
|
||||
| infix { Infix }
|
||||
|
||||
DataDecl :: { PartialDecl' }
|
||||
DataDecl :: { Decl' RlpcPs }
|
||||
: data Con TyParams '=' DataCons { DataD $2 $3 $5 }
|
||||
|
||||
TyParams :: { [Name] }
|
||||
TyParams :: { [PsName] }
|
||||
: {- epsilon -} { [] }
|
||||
| TyParams varname { $1 `snoc` $2 }
|
||||
|
||||
DataCons :: { [ConAlt] }
|
||||
DataCons :: { [ConAlt RlpcPs] }
|
||||
: DataCons '|' DataCon { $1 `snoc` $3 }
|
||||
| DataCon { [$1] }
|
||||
|
||||
DataCon :: { ConAlt }
|
||||
DataCon :: { ConAlt RlpcPs }
|
||||
: Con Type1s { ConAlt $1 $2 }
|
||||
|
||||
Type1s :: { [Type] }
|
||||
@@ -116,22 +116,22 @@ Type :: { Type }
|
||||
: Type '->' Type { $1 :-> $3 }
|
||||
| Type1 { $1 }
|
||||
|
||||
FunDecl :: { PartialDecl' }
|
||||
FunDecl : Var Params '=' Expr { FunD $1 $2 (Const $4) Nothing }
|
||||
FunDecl :: { Decl' RlpcPs }
|
||||
FunDecl : Var Params '=' Expr { FunD $1 $2 $4 Nothing }
|
||||
|
||||
Params :: { [Pat'] }
|
||||
Params :: { [Pat' RlpcPs] }
|
||||
Params : {- epsilon -} { [] }
|
||||
| Params Pat1 { $1 `snoc` $2 }
|
||||
|
||||
Pat1 :: { Pat' }
|
||||
Pat1 :: { Pat' RlpcPs }
|
||||
: Var { VarP $1 }
|
||||
| Lit { LitP $1 }
|
||||
|
||||
Expr :: { PartialExpr' }
|
||||
Expr :: { RlpExpr' RlpcPs }
|
||||
: Expr1 varsym Expr { Fix $ B $2 (unFix $1) (unFix $3) }
|
||||
| Expr1 { $1 }
|
||||
|
||||
Expr1 :: { PartialExpr' }
|
||||
Expr1 :: { RlpExpr' RlpcPs }
|
||||
: '(' Expr ')' { wrapFix . Par . unwrapFix $ $2 }
|
||||
| Lit { Fix . E $ LitEF $1 }
|
||||
| Var { Fix . E $ VarEF $1 }
|
||||
@@ -139,34 +139,43 @@ Expr1 :: { PartialExpr' }
|
||||
-- TODO: happy prefers left-associativity. doing such would require adjusting
|
||||
-- the code in Rlp.Parse.Associate to expect left-associative input rather than
|
||||
-- right.
|
||||
InfixExpr :: { PartialExpr' }
|
||||
InfixExpr :: { RlpExpr' RlpcPs }
|
||||
: Expr1 varsym Expr { Fix $ B $2 (unFix $1) (unFix $3) }
|
||||
|
||||
InfixOp :: { Name }
|
||||
InfixOp :: { PsName }
|
||||
: consym { $1 }
|
||||
| varsym { $1 }
|
||||
|
||||
Lit :: { Lit' }
|
||||
Lit : litint { IntL $1 }
|
||||
-- TODO: microlens-pro save me microlens-pro (rewrite this with prisms)
|
||||
Lit :: { Lit' RlpcPs }
|
||||
: litint { $1 <&> (IntL . (\ (TokenLitInt n) -> n)) }
|
||||
|
||||
Var :: { VarId }
|
||||
Var : varname { NameVar $1 }
|
||||
Var :: { Located PsName }
|
||||
Var : varname { mkPsName $1 }
|
||||
|
||||
Con :: { ConId }
|
||||
: conname { NameCon $1 }
|
||||
Con :: { Located PsName }
|
||||
: 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
|
||||
pt <- use psOpTable
|
||||
pure $ RlpProgram (associate pt <$> ds)
|
||||
|
||||
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
|
||||
|
||||
mkInfixD :: Assoc -> Int -> Name -> P PartialDecl'
|
||||
mkInfixD :: Assoc -> Int -> PsName -> P (Decl' RlpcPs)
|
||||
mkInfixD a p n = do
|
||||
let opl :: Lens' ParseState (Maybe OpInfo)
|
||||
opl = psOpTable . at n
|
||||
@@ -176,6 +185,7 @@ mkInfixD a p n = do
|
||||
l = T.length n
|
||||
Nothing -> pure (Just (a,p))
|
||||
)
|
||||
pure $ InfixD a p n
|
||||
pos <- use (psInput . aiPos)
|
||||
pure $ Located (spanFromPos pos 0) (InfixD' a p n)
|
||||
|
||||
}
|
||||
|
||||
@@ -1,6 +1,7 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE PatternSynonyms, ViewPatterns, ImplicitParams #-}
|
||||
module Rlp.Parse.Associate
|
||||
{-# WARNING "temporarily unimplemented" #-}
|
||||
( associate
|
||||
)
|
||||
where
|
||||
@@ -13,88 +14,6 @@ import Rlp.Parse.Types
|
||||
import Rlp.Syntax
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
associate :: OpTable -> PartialDecl' -> Decl' RlpExpr
|
||||
associate pt (FunD n as b w) = FunD n as b' w
|
||||
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))
|
||||
]
|
||||
|
||||
associate = undefined
|
||||
{-# WARNING associate "temporarily undefined" #-}
|
||||
|
||||
|
||||
@@ -2,38 +2,24 @@
|
||||
{-# LANGUAGE ImplicitParams, ViewPatterns, PatternSynonyms #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
module Rlp.Parse.Types
|
||||
( LexerAction
|
||||
, MsgEnvelope(..)
|
||||
, RlpcError(..)
|
||||
, AlexInput(..)
|
||||
, Position(..)
|
||||
, RlpToken(..)
|
||||
, P(..)
|
||||
, ParseState(..)
|
||||
, psLayoutStack
|
||||
, psLexState
|
||||
, psInput
|
||||
, psOpTable
|
||||
, Layout(..)
|
||||
, Located(..)
|
||||
, OpTable
|
||||
, OpInfo
|
||||
, RlpParseError(..)
|
||||
, PartialDecl'
|
||||
, Partial(..)
|
||||
, pL, pR
|
||||
, PartialE
|
||||
, pattern WithInfo
|
||||
, opInfoOrDef
|
||||
, PartialExpr'
|
||||
, aiPrevChar
|
||||
, aiSource
|
||||
, aiBytes
|
||||
, aiPos
|
||||
, addFatal
|
||||
, addWound
|
||||
, addFatalHere
|
||||
, addWoundHere
|
||||
(
|
||||
-- * Trees That Grow
|
||||
RlpcPs
|
||||
|
||||
-- * Parser monad and state
|
||||
, P(..), ParseState(..), Layout(..), OpTable, OpInfo
|
||||
-- ** Lenses
|
||||
, psLayoutStack, psLexState, psInput, psOpTable
|
||||
|
||||
-- * Other parser types
|
||||
, RlpToken(..), AlexInput(..), Position(..), spanFromPos, LexerAction
|
||||
, Located(..), PsName
|
||||
-- ** Lenses
|
||||
, aiPrevChar, aiSource, aiBytes, aiPos, posLine, posColumn
|
||||
|
||||
-- * Error handling
|
||||
, MsgEnvelope(..), RlpcError(..), RlpParseError(..)
|
||||
, addFatal, addWound, addFatalHere, addWoundHere
|
||||
)
|
||||
where
|
||||
--------------------------------------------------------------------------------
|
||||
@@ -49,12 +35,26 @@ import Data.Functor.Foldable
|
||||
import Data.Functor.Const
|
||||
import Data.Functor.Classes
|
||||
import Data.HashMap.Strict qualified as H
|
||||
import Data.Void
|
||||
import Data.Word (Word8)
|
||||
import Lens.Micro.TH
|
||||
import Lens.Micro
|
||||
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
|
||||
|
||||
data AlexInput = AlexInput
|
||||
@@ -106,7 +106,7 @@ data RlpToken
|
||||
| TokenLParen
|
||||
| TokenRParen
|
||||
-- 'virtual' control symbols, inserted by the lexer without any correlation
|
||||
-- to a specific symbol
|
||||
-- to a specific part of the input
|
||||
| TokenSemicolonV
|
||||
| TokenLBraceV
|
||||
| TokenRBraceV
|
||||
@@ -154,8 +154,14 @@ data Layout = Explicit
|
||||
| Implicit Int
|
||||
deriving (Show, Eq)
|
||||
|
||||
data Located a = Located (Position, Int) a
|
||||
deriving (Show)
|
||||
-- | Token wrapped with a span (line, column, length)
|
||||
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 OpInfo = (Assoc, Int)
|
||||
@@ -171,47 +177,6 @@ data RlpParseError = RlpParErrOutOfBoundsPrecedence Int
|
||||
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 ''ParseState
|
||||
|
||||
@@ -1,40 +1,28 @@
|
||||
-- recursion-schemes
|
||||
{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-}
|
||||
-- recursion-schemes
|
||||
{-# LANGUAGE TemplateHaskell, TypeFamilies #-}
|
||||
{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable
|
||||
, TemplateHaskell, TypeFamilies #-}
|
||||
{-# LANGUAGE OverloadedStrings, PatternSynonyms #-}
|
||||
{-# LANGUAGE TypeFamilies, TypeFamilyDependencies #-}
|
||||
module Rlp.Syntax
|
||||
( RlpModule(..)
|
||||
, RlpProgram(..)
|
||||
, RlpProgram'
|
||||
, rlpmodName
|
||||
, rlpmodProgram
|
||||
, RlpExpr(..)
|
||||
, RlpExpr'
|
||||
, RlpExprF(..)
|
||||
, RlpExprF'
|
||||
, Decl(..)
|
||||
, Decl'
|
||||
, Bind(..)
|
||||
, Where
|
||||
, Where'
|
||||
, ConAlt(..)
|
||||
, Type(..)
|
||||
, pattern (:->)
|
||||
(
|
||||
-- * AST
|
||||
RlpProgram(..)
|
||||
, Decl(..), Decl', RlpExpr(..), RlpExpr'
|
||||
, Pat(..), Pat'
|
||||
, Assoc(..)
|
||||
, VarId(..)
|
||||
, ConId(..)
|
||||
, Pat(..)
|
||||
, Pat'
|
||||
, Lit(..)
|
||||
, Lit'
|
||||
, Name
|
||||
, Lit(..), Lit'
|
||||
, Type(..)
|
||||
, ConAlt(..)
|
||||
|
||||
-- TODO: ugh move this somewhere else later
|
||||
, showsTernaryWith
|
||||
-- * Pattern synonyms for unused extensions
|
||||
, pattern InfixD'
|
||||
|
||||
-- * Convenience re-exports
|
||||
, Text
|
||||
-- * Trees That Grow extensions
|
||||
, XRec, IdP
|
||||
-- ** RlpExpr
|
||||
, XLetE, XVarE, XConE, XLamE, XCaseE, XIfE, XAppE, XLitE, XXRlpExpr
|
||||
-- ** Decl
|
||||
, XFunD, XTySigD, XDataD, XInfixD, XXDecl
|
||||
)
|
||||
where
|
||||
----------------------------------------------------------------------------------
|
||||
@@ -49,87 +37,91 @@ import Core.Syntax hiding (Lit)
|
||||
import Core (HasRHS(..), HasLHS(..))
|
||||
----------------------------------------------------------------------------------
|
||||
|
||||
data RlpModule b = RlpModule
|
||||
data RlpModule p = RlpModule
|
||||
{ _rlpmodName :: Text
|
||||
, _rlpmodProgram :: RlpProgram b
|
||||
, _rlpmodProgram :: RlpProgram p
|
||||
}
|
||||
|
||||
newtype RlpProgram b = RlpProgram [Decl RlpExpr b]
|
||||
deriving Show
|
||||
newtype RlpProgram p = RlpProgram [Decl p]
|
||||
|
||||
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
|
||||
-- first parse all top-level declarations in order to extract infix[lr]
|
||||
-- declarations. This process yields a @[Decl (Const Text) Name]@, where @Const
|
||||
-- Text@ stores the remaining unparsed function bodies. Once infixities are
|
||||
-- accounted for, we may complete the parsing task and get a proper @[Decl
|
||||
-- RlpExpr Name]@.
|
||||
type family XFunD p
|
||||
type family XTySigD p
|
||||
type family XDataD p
|
||||
type family XInfixD p
|
||||
type family XXDecl p
|
||||
|
||||
data Decl e b = FunD VarId [Pat b] (e b) (Maybe (Where b))
|
||||
| TySigD [VarId] Type
|
||||
| DataD ConId [Name] [ConAlt]
|
||||
| InfixD Assoc Int Name
|
||||
deriving Show
|
||||
pattern InfixD' :: (XInfixD p ~ ()) => Assoc -> Int -> (IdP p) -> Decl p
|
||||
pattern InfixD' a p n = InfixD () a p n
|
||||
|
||||
type Decl' e = Decl e Name
|
||||
type Decl' p = XRec p Decl
|
||||
|
||||
data Assoc = InfixL
|
||||
| InfixR
|
||||
| Infix
|
||||
deriving Show
|
||||
deriving (Show)
|
||||
|
||||
data ConAlt = ConAlt ConId [Type]
|
||||
deriving Show
|
||||
data ConAlt p = ConAlt (IdP p) [Type]
|
||||
|
||||
data RlpExpr b = LetE [Bind b] (RlpExpr b)
|
||||
| VarE VarId
|
||||
| ConE ConId
|
||||
| LamE [Pat b] (RlpExpr b)
|
||||
| CaseE (RlpExpr b) [(Alt b, Where b)]
|
||||
| IfE (RlpExpr b) (RlpExpr b) (RlpExpr b)
|
||||
| AppE (RlpExpr b) (RlpExpr b)
|
||||
| LitE (Lit b)
|
||||
deriving Show
|
||||
data RlpExpr p = LetE (XLetE p) [Bind 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)
|
||||
| XRlpExpr !(XXRlpExpr p)
|
||||
|
||||
type RlpExpr' = RlpExpr Name
|
||||
type RlpExpr' p = XRec p RlpExpr
|
||||
|
||||
type Where b = [Bind b]
|
||||
type Where' = [Bind Name]
|
||||
class UnXRec p where
|
||||
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?
|
||||
data Alt b = AltA (Pat b) (RlpExpr b)
|
||||
deriving Show
|
||||
data Alt p = AltA (Pat' p) (RlpExpr' p)
|
||||
|
||||
data Bind b = PatB (Pat b) (RlpExpr b)
|
||||
| FunB VarId [Pat b] (RlpExpr b)
|
||||
deriving Show
|
||||
data Bind p = PatB (Pat' p) (RlpExpr' p)
|
||||
| FunB (IdP p) [Pat' p] (RlpExpr' p)
|
||||
|
||||
data VarId = NameVar Text
|
||||
| SymVar Text
|
||||
deriving Show
|
||||
data Pat p = VarP (IdP p)
|
||||
| LitP (Lit' p)
|
||||
| ConP (IdP p) [Pat' p]
|
||||
|
||||
instance IsString VarId where
|
||||
-- TODO: use symvar if it's an operator
|
||||
fromString = NameVar . T.pack
|
||||
type Pat' p = XRec p Pat
|
||||
|
||||
data ConId = NameCon Text
|
||||
| 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
|
||||
data Lit p = IntL Int
|
||||
| CharL Char
|
||||
| ListL [RlpExpr b]
|
||||
deriving Show
|
||||
| ListL [RlpExpr' p]
|
||||
|
||||
type Lit' = Lit Name
|
||||
type Lit' p = XRec p Lit
|
||||
|
||||
-- instance HasLHS Alt Alt Pat Pat where
|
||||
-- _lhs = lens
|
||||
@@ -143,33 +135,17 @@ type Lit' = Lit Name
|
||||
|
||||
makeBaseFunctor ''RlpExpr
|
||||
|
||||
deriving instance (Show b, Show a) => Show (RlpExprF b a)
|
||||
|
||||
type RlpExprF' = RlpExprF Name
|
||||
|
||||
-- society if derivable Show1
|
||||
instance (Show b) => Show1 (RlpExprF b) where
|
||||
liftShowsPrec sp _ p m = case m of
|
||||
(LetEF bs e) -> showsBinaryWith showsPrec sp "LetEF" p bs e
|
||||
(VarEF n) -> showsUnaryWith showsPrec "VarEF" p n
|
||||
(ConEF n) -> showsUnaryWith showsPrec "ConEF" p n
|
||||
(LamEF bs e) -> showsBinaryWith showsPrec sp "LamEF" p bs e
|
||||
(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
|
||||
-- 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
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
|
||||
Reference in New Issue
Block a user