i did not realise my fs is case insensitive
This commit is contained in:
crumbtoo
372
src/Rlp/Parse/Decls.hs
Normal file
372
src/Rlp/Parse/Decls.hs
Normal file
@@ -0,0 +1,372 @@
|
||||
{-# LANGUAGE RecursiveDo #-}
|
||||
{-# LANGUAGE ViewPatterns #-}
|
||||
{-# LANGUAGE ImplicitParams #-}
|
||||
{-# LANGUAGE LambdaCase, BlockArguments #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
module Rlp.Parse.Decls
|
||||
(
|
||||
)
|
||||
where
|
||||
----------------------------------------------------------------------------------
|
||||
import Control.Monad
|
||||
import Control.Monad.State
|
||||
import Text.Megaparsec hiding (State)
|
||||
import Text.Megaparsec.Char
|
||||
import Text.Megaparsec.Char.Lexer qualified as L
|
||||
import Data.Functor.Classes
|
||||
import Data.Functor.Foldable
|
||||
import Data.Text (Text)
|
||||
import Data.Text qualified as T
|
||||
import Data.HashMap.Strict qualified as H
|
||||
import Data.Maybe (maybeToList)
|
||||
import Data.List (foldl1')
|
||||
import Data.Char
|
||||
import Data.Function (fix)
|
||||
import Data.Functor
|
||||
import Data.Functor.Const
|
||||
import Data.Fix hiding (cata)
|
||||
import GHC.Exts (IsString)
|
||||
import Lens.Micro
|
||||
import Lens.Micro.Platform
|
||||
import Rlp.Parse.Types
|
||||
import Rlp.Parse.Utils
|
||||
import Rlp.Syntax
|
||||
----------------------------------------------------------------------------------
|
||||
|
||||
parseTest' :: (Show a) => Parser a -> Text -> IO ()
|
||||
parseTest' p s = case runState (runParserT p "test" s) init of
|
||||
(Left e, _) -> putStr (errorBundlePretty e)
|
||||
(Right x, st) -> print st *> print x
|
||||
where
|
||||
init = ParserState mempty
|
||||
|
||||
lexeme :: Parser a -> Parser a
|
||||
lexeme = L.lexeme sc
|
||||
|
||||
symbol :: Text -> Parser Text
|
||||
symbol = L.symbol sc
|
||||
|
||||
sc :: Parser ()
|
||||
sc = L.space hspace1 (void lineComment) (void blockComment)
|
||||
|
||||
scn :: Parser ()
|
||||
scn = L.space space1 (void lineComment) (void blockComment)
|
||||
|
||||
type OnFold = (?foldGuard :: Parser ())
|
||||
|
||||
-- TODO: return comment text
|
||||
-- TODO: '---' should not start a comment
|
||||
lineComment :: Parser Text
|
||||
lineComment = L.skipLineComment "--" $> "<unimpl>"
|
||||
|
||||
-- TODO: return comment text
|
||||
blockComment :: Parser Text
|
||||
blockComment = L.skipBlockCommentNested "{-" "-}" $> "<unimpl>"
|
||||
|
||||
layout :: forall a. ((OnFold) => Parser a) -> Parser [a]
|
||||
layout item = scn *> (explicit <|> implicit) where
|
||||
explicit :: Parser [a]
|
||||
explicit = let ?foldGuard = scn -- line folds just go to the semicolon
|
||||
in sym "{" *> fix \items -> choice
|
||||
[ sym "}" $> []
|
||||
, (:) <$> item
|
||||
<*> (sym ";" *> items <|> sym "}" $> [])
|
||||
]
|
||||
where
|
||||
sym = L.symbol scn
|
||||
|
||||
implicit :: Parser [a]
|
||||
implicit = do
|
||||
i <- L.indentLevel
|
||||
-- items must be aligned
|
||||
let indentGuard = L.indentGuard scn EQ i
|
||||
-- override foldGuard in order with new indentation
|
||||
let ?foldGuard = void $ L.indentGuard scn GT i
|
||||
fix \ds -> (:) <$> (indentGuard *> item)
|
||||
<*> (ds <|> pure [])
|
||||
|
||||
t :: (?foldGuard :: Parser ()) => Parser [Text]
|
||||
t = (:) <$> lexeme "soge" <*> many (flexeme "doge")
|
||||
|
||||
decl :: (OnFold) => Parser PartialDecl'
|
||||
decl = choice
|
||||
-- declarations that begin with a keyword before those beginning with an
|
||||
-- arbitrary name
|
||||
[ infixD
|
||||
, dataD
|
||||
, funD
|
||||
, tySigD
|
||||
]
|
||||
|
||||
funD :: (OnFold) => Parser PartialDecl'
|
||||
funD = FunD <$> lexeme varid <*> params <*> (fsymbol "=" *> body) <*> whereClause
|
||||
where
|
||||
params = many pat1
|
||||
body = fmap Const partialExpr
|
||||
|
||||
-- we may not need to call scn here
|
||||
fsymbol :: (OnFold) => Text -> Parser Text
|
||||
fsymbol p = try ?foldGuard *> symbol p
|
||||
|
||||
-- we may not need to call scn here
|
||||
flexeme :: (OnFold) => Parser a -> Parser a
|
||||
flexeme p = try ?foldGuard *> lexeme p
|
||||
|
||||
whereClause :: Parser Where'
|
||||
whereClause = optionalList $
|
||||
lexeme "where" *> pure
|
||||
[ FunB "fixme" [] (VarE "fixme")
|
||||
]
|
||||
|
||||
standalonePartialExpr :: Parser PartialExpr'
|
||||
standalonePartialExpr = standaloneOf partialExpr
|
||||
where ?foldGuard = undefined
|
||||
|
||||
standaloneOf :: Parser a -> Parser a
|
||||
standaloneOf = (<* eof)
|
||||
|
||||
partialExpr :: (OnFold) => Parser PartialExpr'
|
||||
partialExpr = choice
|
||||
[ try $ Fix <$> infixExpr
|
||||
, application
|
||||
]
|
||||
<?> "expression"
|
||||
where
|
||||
application = foldl1' mkApp <$> some (flexeme partialExpr1)
|
||||
infixExpr = mkB <$> partialExpr1' <*> infixOp' <*> partialExpr'
|
||||
|
||||
mkB a f b = B f a b
|
||||
partialExpr1' = unFix <$> partialExpr1
|
||||
partialExpr' = unFix <$> partialExpr
|
||||
infixOp' = lexeme infixOp
|
||||
|
||||
mkApp :: PartialExpr' -> PartialExpr' -> PartialExpr'
|
||||
mkApp f x = Fix . E $ f `AppEF` x
|
||||
|
||||
partialExpr1 :: (OnFold) => Parser PartialExpr'
|
||||
partialExpr1 = choice
|
||||
[ try $ lexeme "(" *> partialExpr' <* lexeme ")"
|
||||
, Fix <$> varid'
|
||||
, Fix <$> lit'
|
||||
]
|
||||
<?> "expression"
|
||||
where
|
||||
partialExpr' = wrapFix . P . unwrapFix <$> partialExpr
|
||||
varid' = E . VarEF <$> varid
|
||||
lit' = E . LitEF <$> lit
|
||||
|
||||
infixOp :: Parser Name
|
||||
infixOp = symvar <|> symcon <?> "operator"
|
||||
|
||||
symvar :: Parser Name
|
||||
symvar = T.cons <$> satisfy isVarSym <*> takeWhileP Nothing isSym
|
||||
|
||||
symcon :: Parser Name
|
||||
symcon = T.cons <$> char ':' <*> takeWhileP Nothing isSym
|
||||
|
||||
pat1 :: (OnFold) => Parser Pat'
|
||||
pat1 = VarP <$> flexeme varid
|
||||
<?> "pattern"
|
||||
|
||||
conid :: Parser ConId
|
||||
conid = NameCon <$> lexeme namecon
|
||||
<|> SymCon <$> lexeme (char '(' *> symcon <* char ')')
|
||||
<?> "constructor identifier"
|
||||
|
||||
namecon :: Parser Name
|
||||
namecon = T.cons <$> satisfy isUpper <*> takeWhileP Nothing isNameTail
|
||||
|
||||
varid :: Parser VarId
|
||||
varid = NameVar <$> try (lexeme namevar)
|
||||
<|> SymVar <$> lexeme (char '(' *> symvar <* char ')')
|
||||
<?> "variable identifier"
|
||||
|
||||
decls :: Parser [PartialDecl']
|
||||
decls = layout decl <* eof
|
||||
|
||||
-- decls :: Parser [PartialDecl']
|
||||
-- decls = do
|
||||
-- space
|
||||
-- i <- L.indentLevel
|
||||
-- let indentGuard = L.indentGuard scn EQ i
|
||||
-- let ?foldGuard = void $ L.indentGuard scn GT i
|
||||
-- fix \ds -> (:) <$> (indentGuard *> decl)
|
||||
-- <*> (try ds <|> eof *> pure [])
|
||||
|
||||
namevar :: Parser Name
|
||||
namevar = word
|
||||
& withPredicate (`notElem` keywords) empty
|
||||
where
|
||||
word = T.cons <$> satisfy isLower <*> takeWhileP Nothing isNameTail
|
||||
|
||||
keywords :: (IsString a) => [a]
|
||||
keywords =
|
||||
[ "where"
|
||||
, "infix"
|
||||
, "infixr"
|
||||
, "infixl"
|
||||
]
|
||||
|
||||
isNameTail :: Char -> Bool
|
||||
isNameTail c = isAlphaNum c
|
||||
|| c == '\''
|
||||
|| c == '_'
|
||||
|
||||
isVarSym :: Char -> Bool
|
||||
isVarSym = (`T.elem` "\\!#$%&*+./<=>?@^|-~")
|
||||
|
||||
isSym :: Char -> Bool
|
||||
isSym c = c == ':' || isVarSym c
|
||||
|
||||
infixD :: Parser (Decl' e)
|
||||
infixD = do
|
||||
o <- getOffset
|
||||
a <- infixWord
|
||||
p <- prec
|
||||
op <- infixOp
|
||||
region (setErrorOffset o) $ updateOpTable a p op
|
||||
pure $ InfixD a p op
|
||||
where
|
||||
infixWord :: Parser Assoc
|
||||
infixWord = choice $ lexeme <$>
|
||||
[ "infixr" $> InfixR
|
||||
, "infixl" $> InfixL
|
||||
, "infix" $> Infix
|
||||
]
|
||||
|
||||
prec :: Parser Int
|
||||
prec = do
|
||||
o <- getOffset
|
||||
n <- lexeme L.decimal <?> "precedence level (an integer)"
|
||||
if 0 <= n && n <= 9 then
|
||||
pure n
|
||||
else
|
||||
region (setErrorOffset o) $
|
||||
registerCustomFailure (RlpParErrOutOfBoundsPrecedence n)
|
||||
$> 9
|
||||
|
||||
updateOpTable :: Assoc -> Int -> Name -> Parser ()
|
||||
updateOpTable a p op = do
|
||||
t <- use psOpTable
|
||||
psOpTable <~ H.alterF f op t
|
||||
where
|
||||
f Nothing = pure (Just (a,p))
|
||||
f (Just x) = registerCustomFailure RlpParErrDuplicateInfixD
|
||||
$> Just x
|
||||
|
||||
tySigD :: Parser (Decl' e)
|
||||
tySigD = undefined -- TySigD <$> (flexeme)
|
||||
|
||||
dataD :: Parser (Decl' e)
|
||||
dataD = DataD <$> (lexeme "data" *> conid) <*> many typaram
|
||||
<*> optionalList (symbol "=" *> conalts)
|
||||
where
|
||||
typaram :: Parser Name
|
||||
typaram = lexeme namevar
|
||||
|
||||
conalts :: Parser [ConAlt]
|
||||
conalts = (:) <$> conalt <*> optionalList (symbol "|" *> conalts)
|
||||
|
||||
conalt :: Parser ConAlt
|
||||
conalt = ConAlt <$> conid <*> many type1
|
||||
|
||||
type1 :: Parser Type
|
||||
type1 = choice
|
||||
[ lexeme "(" *> type_ <* lexeme ")"
|
||||
, TyVar <$> namevar
|
||||
, TyCon <$> namecon
|
||||
]
|
||||
|
||||
type_ :: Parser Type
|
||||
type_ = choice
|
||||
[ try $ (:->) <$> type1 <*> (lexeme "->" *> type_)
|
||||
, type1
|
||||
]
|
||||
|
||||
lit :: Parser Lit'
|
||||
lit = int
|
||||
<?> "literal"
|
||||
where
|
||||
int = IntL <$> L.decimal
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- completing partial expressions
|
||||
|
||||
complete :: (?pt :: OpTable) => PartialExpr' -> RlpExpr'
|
||||
complete = cata completePartial
|
||||
|
||||
completePartial :: (?pt :: OpTable) => PartialE -> RlpExpr'
|
||||
completePartial (E e) = completeRlpExpr e
|
||||
completePartial p@(B o l r) = completeB (build p)
|
||||
completePartial (P 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
|
||||
P 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@(P _) = p
|
||||
|
||||
go :: (?pt :: OpTable)
|
||||
=> (PartialE -> PartialE)
|
||||
-> PartialE -> PartialE -> PartialE
|
||||
go f p@(WithInfo o _ r) = case r of
|
||||
E _ -> mkHole o (f . f')
|
||||
P _ -> 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@(P _) = 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))
|
||||
]
|
||||
|
||||
119
src/Rlp/Parse/Types.hs
Normal file
119
src/Rlp/Parse/Types.hs
Normal file
@@ -0,0 +1,119 @@
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE ImplicitParams, ViewPatterns, PatternSynonyms #-}
|
||||
{-
|
||||
Description : Supporting types for the parser
|
||||
-}
|
||||
module Rlp.Parse.Types
|
||||
(
|
||||
-- * Partial ASTs
|
||||
Partial(..)
|
||||
, PartialE
|
||||
, PartialExpr'
|
||||
, PartialDecl'
|
||||
, pattern WithInfo
|
||||
, pR
|
||||
, pL
|
||||
|
||||
-- * Parser types
|
||||
, Parser
|
||||
, ParserState(..)
|
||||
, psOpTable
|
||||
, RlpParseError(..)
|
||||
, OpTable
|
||||
, OpInfo
|
||||
)
|
||||
where
|
||||
----------------------------------------------------------------------------------
|
||||
import Control.Monad.State
|
||||
import Data.HashMap.Strict qualified as H
|
||||
import Data.Fix
|
||||
import Data.Functor.Foldable
|
||||
import Data.Functor.Const
|
||||
import Data.Functor.Classes
|
||||
import Data.Void
|
||||
import Data.Maybe
|
||||
import Text.Megaparsec hiding (State)
|
||||
import Text.Printf
|
||||
import Lens.Micro
|
||||
import Lens.Micro.TH
|
||||
import Rlp.Syntax
|
||||
----------------------------------------------------------------------------------
|
||||
|
||||
-- parser types
|
||||
|
||||
type Parser = ParsecT RlpParseError Text (State ParserState)
|
||||
|
||||
data ParserState = ParserState
|
||||
{ _psOpTable :: OpTable
|
||||
}
|
||||
deriving Show
|
||||
|
||||
type OpTable = H.HashMap Name OpInfo
|
||||
type OpInfo = (Assoc, Int)
|
||||
|
||||
-- data WithLocation a = WithLocation [String] a
|
||||
|
||||
data RlpParseError = RlpParErrOutOfBoundsPrecedence Int
|
||||
| RlpParErrDuplicateInfixD
|
||||
deriving (Eq, Ord, Show)
|
||||
|
||||
instance ShowErrorComponent RlpParseError where
|
||||
showErrorComponent = \case
|
||||
-- TODO: wrap text to 80 characters
|
||||
RlpParErrOutOfBoundsPrecedence n ->
|
||||
printf "%d is an invalid precedence level! rl' currently only\
|
||||
\allows custom precedences between 0 and 9 (inclusive).\
|
||||
\ This is an arbitrary limit put in place for legibility\
|
||||
\ concerns, and may change in the future." n
|
||||
RlpParErrDuplicateInfixD ->
|
||||
"duplicate infix decl"
|
||||
|
||||
----------------------------------------------------------------------------------
|
||||
|
||||
-- absolute psycho shit (partial ASTs)
|
||||
|
||||
type PartialDecl' = Decl (Const PartialExpr') Name
|
||||
|
||||
data Partial a = E (RlpExprF Name a)
|
||||
| B Name (Partial a) (Partial a)
|
||||
| P (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
|
||||
(P e) -> showsUnaryWith lshow "P" p e
|
||||
where
|
||||
lshow :: forall f. (Show1 f) => Int -> f a -> ShowS
|
||||
lshow = liftShowsPrec sp sl
|
||||
|
||||
type PartialExpr' = Fix Partial
|
||||
|
||||
----------------------------------------------------------------------------------
|
||||
|
||||
makeLenses ''ParserState
|
||||
|
||||
30
src/Rlp/Parse/Utils.hs
Normal file
30
src/Rlp/Parse/Utils.hs
Normal file
@@ -0,0 +1,30 @@
|
||||
module Rlp.Parse.Utils
|
||||
( withPredicate
|
||||
, registerCustomFailure
|
||||
, optionalList
|
||||
)
|
||||
where
|
||||
--------------------------------------------------------------------------------
|
||||
import Text.Megaparsec
|
||||
import Rlp.Parse.Types
|
||||
import Data.Set qualified as S
|
||||
import Data.Maybe
|
||||
import Control.Monad
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
-- TODO: generalise type sig
|
||||
withPredicate :: (a -> Bool)
|
||||
-> Parser a -- ^ action to run should the predicate fail
|
||||
-> Parser a
|
||||
-> Parser a
|
||||
withPredicate f r p = do
|
||||
o <- getOffset
|
||||
a <- p
|
||||
if f a then pure a else setOffset o *> r
|
||||
|
||||
registerCustomFailure :: MonadParsec e s m => e -> m ()
|
||||
registerCustomFailure = registerFancyFailure . S.singleton . ErrorCustom
|
||||
|
||||
optionalList :: Parser [a] -> Parser [a]
|
||||
optionalList = fmap (join . maybeToList) . optional
|
||||
|
||||
172
src/Rlp/Syntax.hs
Normal file
172
src/Rlp/Syntax.hs
Normal file
@@ -0,0 +1,172 @@
|
||||
-- recursion-schemes
|
||||
{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-}
|
||||
-- recursion-schemes
|
||||
{-# LANGUAGE TemplateHaskell, TypeFamilies #-}
|
||||
{-# LANGUAGE OverloadedStrings, PatternSynonyms #-}
|
||||
module Rlp.Syntax
|
||||
( RlpModule(..)
|
||||
, rlpmodName
|
||||
, rlpmodProgram
|
||||
, RlpExpr(..)
|
||||
, RlpExpr'
|
||||
, RlpExprF(..)
|
||||
, RlpExprF'
|
||||
, Decl(..)
|
||||
, Decl'
|
||||
, Bind(..)
|
||||
, Where
|
||||
, Where'
|
||||
, ConAlt(..)
|
||||
, Type(..)
|
||||
, pattern (:->)
|
||||
, Assoc(..)
|
||||
, VarId(..)
|
||||
, ConId(..)
|
||||
, Pat(..)
|
||||
, Pat'
|
||||
, Lit(..)
|
||||
, Lit'
|
||||
, Name
|
||||
|
||||
-- TODO: ugh move this somewhere else later
|
||||
, showsTernaryWith
|
||||
|
||||
-- * Convenience re-exports
|
||||
, Text
|
||||
)
|
||||
where
|
||||
----------------------------------------------------------------------------------
|
||||
import Data.Text (Text)
|
||||
import Data.Text qualified as T
|
||||
import Data.String (IsString(..))
|
||||
import Data.Functor.Foldable.TH (makeBaseFunctor)
|
||||
import Data.Functor.Classes
|
||||
import Lens.Micro
|
||||
import Lens.Micro.TH
|
||||
import Core.Syntax hiding (Lit)
|
||||
import Core (HasRHS(..), HasLHS(..))
|
||||
----------------------------------------------------------------------------------
|
||||
|
||||
data RlpModule b = RlpModule
|
||||
{ _rlpmodName :: Text
|
||||
, _rlpmodProgram :: RlpProgram b
|
||||
}
|
||||
|
||||
newtype RlpProgram b = RlpProgram [Decl RlpExpr b]
|
||||
|
||||
-- | 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]@.
|
||||
|
||||
data Decl e b = FunD VarId [Pat b] (e b) (Where b)
|
||||
| TySigD [VarId] Type
|
||||
| DataD ConId [Name] [ConAlt]
|
||||
| InfixD Assoc Int Name
|
||||
deriving Show
|
||||
|
||||
type Decl' e = Decl e Name
|
||||
|
||||
data Assoc = InfixL
|
||||
| InfixR
|
||||
| Infix
|
||||
deriving Show
|
||||
|
||||
data ConAlt = ConAlt ConId [Type]
|
||||
deriving Show
|
||||
|
||||
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
|
||||
|
||||
type RlpExpr' = RlpExpr Name
|
||||
|
||||
type Where b = [Bind b]
|
||||
type Where' = [Bind Name]
|
||||
|
||||
-- do we want guards?
|
||||
data Alt b = AltA (Pat b) (RlpExpr b)
|
||||
deriving Show
|
||||
|
||||
data Bind b = PatB (Pat b) (RlpExpr b)
|
||||
| FunB VarId [Pat b] (RlpExpr b)
|
||||
deriving Show
|
||||
|
||||
data VarId = NameVar Text
|
||||
| SymVar Text
|
||||
deriving Show
|
||||
|
||||
instance IsString VarId where
|
||||
-- TODO: use symvar if it's an operator
|
||||
fromString = NameVar . T.pack
|
||||
|
||||
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
|
||||
| CharL Char
|
||||
| ListL [RlpExpr b]
|
||||
deriving Show
|
||||
|
||||
type Lit' = Lit Name
|
||||
|
||||
-- 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
|
||||
|
||||
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
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
makeLenses ''RlpModule
|
||||
|
||||
Reference in New Issue
Block a user