see previous commit and scale back the part where i'm joking
This commit is contained in:
crumbtoo
177
src/Rlp/Lex.x
177
src/Rlp/Lex.x
@@ -1,19 +1,19 @@
|
||||
{
|
||||
{-# LANGUAGE GeneralisedNewtypeDeriving #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
module Rlp.Lex
|
||||
( P(..)
|
||||
, RlpToken(..)
|
||||
, Located(..)
|
||||
, lexer
|
||||
, lexToken
|
||||
, lexerCont
|
||||
)
|
||||
where
|
||||
import Codec.Binary.UTF8.String (encodeChar)
|
||||
import Control.Monad
|
||||
import Core.Syntax (Name)
|
||||
import Data.Functor.Identity
|
||||
import Data.Char (digitToInt)
|
||||
import Core.Syntax (Name)
|
||||
import Data.Monoid (First)
|
||||
import Data.Maybe
|
||||
import Data.Text (Text)
|
||||
@@ -22,9 +22,9 @@ import Data.Word
|
||||
import Data.Default
|
||||
import Lens.Micro.Mtl
|
||||
import Lens.Micro
|
||||
import Lens.Micro.TH
|
||||
|
||||
import Debug.Trace
|
||||
import Rlp.Parse.Types
|
||||
}
|
||||
|
||||
$whitechar = [ \t\n\r\f\v]
|
||||
@@ -78,23 +78,31 @@ rlp :-
|
||||
|
||||
{
|
||||
|
||||
begin :: Int -> LexerAction a
|
||||
begin = undefined
|
||||
|
||||
type LexerAction a = AlexInput -> Int -> P a
|
||||
|
||||
type AlexInput =
|
||||
( Char -- prev char
|
||||
, Text -- input
|
||||
)
|
||||
|
||||
alexGetByte :: AlexInput -> Maybe (Word8, AlexInput)
|
||||
alexGetByte (_,s) = undefined
|
||||
alexGetByte inp = case inp ^. aiBytes of
|
||||
[] -> do
|
||||
(c,t) <- T.uncons (inp ^. aiSource)
|
||||
let (b:bs) = encodeChar c
|
||||
inp' = inp & aiSource .~ t
|
||||
& aiBytes .~ bs
|
||||
& aiPrevChar .~ c
|
||||
pure (b, inp')
|
||||
|
||||
_ -> Just (head bs, inp')
|
||||
where
|
||||
(bs, inp') = inp & aiBytes <<%~ drop 1
|
||||
|
||||
getInput :: P AlexInput
|
||||
getInput = undefined
|
||||
getInput = use psInput
|
||||
|
||||
getLexState :: P Int
|
||||
getLexState = use (psLexState . singular _head)
|
||||
|
||||
alexInputPrevChar :: AlexInput -> Char
|
||||
alexInputPrevChar = (^. _1)
|
||||
alexInputPrevChar = view aiPrevChar
|
||||
|
||||
readInt :: Text -> Int
|
||||
readInt = T.foldr f 0 where
|
||||
@@ -108,95 +116,116 @@ thenBegin act c inp l = do
|
||||
undefined
|
||||
|
||||
constToken :: RlpToken -> LexerAction (Located RlpToken)
|
||||
constToken t inp _ = undefined
|
||||
constToken t inp l = do
|
||||
pos <- use (psInput . aiPos)
|
||||
pure (Located (pos,l) t)
|
||||
|
||||
tokenWith :: (Text -> RlpToken) -> LexerAction (Located RlpToken)
|
||||
tokenWith tf inp l = undefined
|
||||
tokenWith tf inp l = do
|
||||
pos <- getPos
|
||||
let t = tf (T.take l $ inp ^. aiSource)
|
||||
pure (Located (pos,l) t)
|
||||
|
||||
getPos :: P Position
|
||||
getPos = use (psInput . aiPos)
|
||||
|
||||
alexEOF :: P (Located RlpToken)
|
||||
alexEOF = do
|
||||
inp <- getInput
|
||||
pure (Located undefined TokenEOF)
|
||||
|
||||
data RlpToken
|
||||
-- literals
|
||||
= TokenLitInt Int
|
||||
-- identifiers
|
||||
| TokenVarName Name
|
||||
| TokenConName Name
|
||||
| TokenVarSym Name
|
||||
| TokenConSym Name
|
||||
-- keywords
|
||||
| TokenData
|
||||
| TokenPipe
|
||||
| TokenLet
|
||||
| TokenIn
|
||||
-- control symbols
|
||||
| TokenEquals
|
||||
| TokenSemicolon
|
||||
| TokenLBrace
|
||||
| TokenRBrace
|
||||
-- 'virtual' control symbols, inserted by the lexer without any correlation
|
||||
-- to a specific symbol
|
||||
| TokenSemicolonV
|
||||
| TokenLBraceV
|
||||
| TokenRBraceV
|
||||
| TokenEOF
|
||||
deriving (Show)
|
||||
execP :: P a -> ParseState -> Maybe a
|
||||
execP p st = runP p st & snd
|
||||
|
||||
newtype P a = P { runP :: ParseState -> (ParseState, Maybe a) }
|
||||
deriving (Functor)
|
||||
|
||||
execP :: P a -> ParseState -> Either String a
|
||||
execP p st = undefined
|
||||
|
||||
execP' :: P a -> Text -> Either String a
|
||||
execP' :: P a -> Text -> Maybe a
|
||||
execP' p s = execP p st where
|
||||
st = initParseState s
|
||||
|
||||
initParseState :: Text -> ParseState
|
||||
initParseState s = ParseState
|
||||
{ _psLayoutStack = []
|
||||
, _psLexState = [bol,0]
|
||||
, _psInput = (undefined, s)
|
||||
, _psLexState = [one,bol,0]
|
||||
, _psInput = initAlexInput s
|
||||
}
|
||||
|
||||
data ParseState = ParseState
|
||||
{ _psLayoutStack :: [Layout]
|
||||
, _psLexState :: [Int]
|
||||
, _psInput :: AlexInput
|
||||
initAlexInput :: Text -> AlexInput
|
||||
initAlexInput s = AlexInput
|
||||
{ _aiPrevChar = '\0'
|
||||
, _aiSource = s
|
||||
, _aiBytes = []
|
||||
, _aiPos = (1,1)
|
||||
}
|
||||
|
||||
instance Applicative P where
|
||||
pure a = P $ \st -> (st,Just a)
|
||||
liftA2 = liftM2
|
||||
|
||||
instance Monad P where
|
||||
p >>= k = undefined
|
||||
|
||||
data Layout = Explicit
|
||||
| Implicit Int
|
||||
deriving (Show, Eq)
|
||||
|
||||
data Located a = Located (Int, Int) a
|
||||
deriving (Show)
|
||||
|
||||
lexer :: P (Located RlpToken)
|
||||
lexer = undefined
|
||||
lexToken :: P (Located RlpToken)
|
||||
lexToken = do
|
||||
inp <- getInput
|
||||
c <- getLexState
|
||||
case alexScan inp c of
|
||||
AlexEOF -> pure $ Located (inp ^. aiPos, 0) TokenEOF
|
||||
AlexToken inp' l act -> do
|
||||
psInput .= inp'
|
||||
traceM $ "l: " <> show l
|
||||
traceShowM inp'
|
||||
act inp l
|
||||
|
||||
lexerCont :: (Located RlpToken -> P a) -> P a
|
||||
lexerCont = undefined
|
||||
|
||||
lexStream :: P [RlpToken]
|
||||
lexStream = undefined
|
||||
lexStream = do
|
||||
t <- lexToken
|
||||
case t of
|
||||
Located _ TokenEOF -> pure [TokenEOF]
|
||||
Located _ t -> (t:) <$> lexStream
|
||||
|
||||
lexTest :: Text -> Either String [RlpToken]
|
||||
lexTest = undefined
|
||||
|
||||
lexToken :: P (Located RlpToken)
|
||||
lexToken = undefined
|
||||
indentLevel :: P Int
|
||||
indentLevel = do
|
||||
pos <- use (psInput . aiPos)
|
||||
pure (pos ^. _2)
|
||||
|
||||
doBol = undefined
|
||||
insertToken :: RlpToken -> P (Located RlpToken)
|
||||
insertToken t = do
|
||||
pos <- use (psInput . aiPos)
|
||||
pure (Located (pos, 0) t)
|
||||
|
||||
popLayout :: P Layout
|
||||
popLayout = do
|
||||
traceM "pop layout"
|
||||
ctx <- preuse (psLayoutStack . _head)
|
||||
modifying psLayoutStack (drop 1)
|
||||
case ctx of
|
||||
Just l -> pure l
|
||||
Nothing -> error "uhh"
|
||||
|
||||
insertSemicolon, insertLBrace, insertRBrace :: P (Located RlpToken)
|
||||
insertSemicolon = traceM "inserting semi" >> insertToken TokenSemicolonV
|
||||
insertLBrace = traceM "inserting lbrace" >> insertToken TokenLBraceV
|
||||
insertRBrace = traceM "inserting rbrace" >> insertToken TokenRBraceV
|
||||
|
||||
cmpLayout :: P Ordering
|
||||
cmpLayout = do
|
||||
i <- indentLevel
|
||||
ctx <- preuse (psLayoutStack . _head)
|
||||
case ctx ^. non (Implicit 1) of
|
||||
Implicit n -> pure (i `compare` n)
|
||||
Explicit -> pure GT
|
||||
|
||||
doBol :: LexerAction (Located RlpToken)
|
||||
doBol inp l = do
|
||||
off <- cmpLayout
|
||||
case off of
|
||||
-- the line is aligned with the previous. it therefore belongs to the
|
||||
-- same list
|
||||
EQ -> insertSemicolon
|
||||
-- the line is indented further than the previous, so we assume it is a
|
||||
-- line continuation. ignore it and move on!
|
||||
GT -> undefined -- alexSetStartCode one >> lexToken
|
||||
-- the line is indented less than the previous, pop the layout stack and
|
||||
-- insert a closing brace.
|
||||
LT -> popLayout >> insertRBrace
|
||||
|
||||
}
|
||||
|
||||
|
||||
@@ -1,381 +0,0 @@
|
||||
{-# 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 <* scn)
|
||||
<*> (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
|
||||
, try 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
|
||||
[ ifExpr
|
||||
, try $ infixExpr
|
||||
, application
|
||||
]
|
||||
<?> "expression"
|
||||
where
|
||||
application = foldl1' mkApp <$> some (flexeme partialExpr1)
|
||||
infixExpr = fmap Fix $
|
||||
mkB <$> partialExpr1' <*> infixOp' <*> partialExpr'
|
||||
|
||||
ifExpr :: Parser PartialExpr'
|
||||
ifExpr = fmap (Fix . E) $
|
||||
IfEF <$> (flexeme "if" *> partialExpr)
|
||||
<*> (flexeme "then" *> partialExpr)
|
||||
<*> (flexeme "else" *> partialExpr)
|
||||
|
||||
mkB a f b = B f a b
|
||||
partialExpr1' = unFix <$> partialExpr1
|
||||
partialExpr' = unFix <$> partialExpr
|
||||
infixOp' = flexeme 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"
|
||||
|
||||
program :: Parser [Decl' RlpExpr]
|
||||
program = do
|
||||
ds <- layout decl <* eof
|
||||
pt <- use psOpTable
|
||||
pure $ complete pt <$> ds
|
||||
|
||||
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 :: (OnFold) => Parser (Decl' e)
|
||||
tySigD = TySigD <$> (pure <$> varid) <*> (flexeme "::" *> flexeme type_)
|
||||
|
||||
dataD :: (OnFold) => 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 :: (OnFold) => Parser Type
|
||||
type1 = choice
|
||||
[ lexeme "(" *> type_ <* lexeme ")"
|
||||
, TyVar <$> namevar
|
||||
, TyCon <$> namecon
|
||||
]
|
||||
|
||||
type_ :: (OnFold) => Parser Type
|
||||
type_ = choice
|
||||
[ try $ (:->) <$> type1 <*> (flexeme "->" *> type_)
|
||||
, type1
|
||||
]
|
||||
|
||||
lit :: Parser Lit'
|
||||
lit = int
|
||||
<?> "literal"
|
||||
where
|
||||
int = IntL <$> L.decimal
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- completing partial expressions
|
||||
|
||||
complete :: OpTable -> PartialDecl' -> Decl' RlpExpr
|
||||
complete pt (FunD n as b w) = FunD n as b' w
|
||||
where b' = let ?pt = pt in completeExpr (getConst b)
|
||||
complete pt (TySigD ns t) = TySigD ns t
|
||||
complete pt (DataD n as cs) = DataD n as cs
|
||||
complete 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 (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))
|
||||
]
|
||||
|
||||
@@ -1,57 +1,97 @@
|
||||
{-# 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
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
module Rlp.Parse.Types where
|
||||
--------------------------------------------------------------------------------
|
||||
import Core.Syntax (Name)
|
||||
import Control.Monad
|
||||
import Control.Monad.State.Class
|
||||
import Data.Text (Text)
|
||||
import Data.Maybe
|
||||
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 Data.HashMap.Strict qualified as H
|
||||
import Data.Word (Word8)
|
||||
import Lens.Micro.TH
|
||||
import Lens.Micro
|
||||
import Rlp.Syntax
|
||||
----------------------------------------------------------------------------------
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
-- parser types
|
||||
type LexerAction a = AlexInput -> Int -> P a
|
||||
|
||||
-- TODO: the State is only used for building an operator table from infix[lr]
|
||||
-- declarations. we should switch to a normal Parsec monad in the future
|
||||
|
||||
type Parser = ParsecT RlpParseError Text (State ParserState)
|
||||
|
||||
data ParserState = ParserState
|
||||
{ _psOpTable :: OpTable
|
||||
data AlexInput = AlexInput
|
||||
{ _aiPrevChar :: Char
|
||||
, _aiSource :: Text
|
||||
, _aiBytes :: [Word8]
|
||||
, _aiPos :: Position
|
||||
}
|
||||
deriving Show
|
||||
|
||||
type Position =
|
||||
( Int -- line
|
||||
, Int -- column
|
||||
)
|
||||
|
||||
data RlpToken
|
||||
-- literals
|
||||
= TokenLitInt Int
|
||||
-- identifiers
|
||||
| TokenVarName Name
|
||||
| TokenConName Name
|
||||
| TokenVarSym Name
|
||||
| TokenConSym Name
|
||||
-- keywords
|
||||
| TokenData
|
||||
| TokenPipe
|
||||
| TokenLet
|
||||
| TokenIn
|
||||
-- control symbols
|
||||
| TokenEquals
|
||||
| TokenSemicolon
|
||||
| TokenLBrace
|
||||
| TokenRBrace
|
||||
-- 'virtual' control symbols, inserted by the lexer without any correlation
|
||||
-- to a specific symbol
|
||||
| TokenSemicolonV
|
||||
| TokenLBraceV
|
||||
| TokenRBraceV
|
||||
| TokenEOF
|
||||
deriving (Show)
|
||||
|
||||
newtype P a = P { runP :: ParseState -> (ParseState, Maybe a) }
|
||||
deriving (Functor)
|
||||
|
||||
instance Applicative P where
|
||||
pure a = P $ \st -> (st,Just a)
|
||||
liftA2 = liftM2
|
||||
|
||||
instance Monad P where
|
||||
p >>= k = P $ \st ->
|
||||
let (st',a) = runP p st
|
||||
in case a of
|
||||
Just x -> runP (k x) st'
|
||||
Nothing -> (st', Nothing)
|
||||
|
||||
instance MonadState ParseState P where
|
||||
state f = P $ \st ->
|
||||
let (a,st') = f st
|
||||
in (st', Just a)
|
||||
|
||||
data ParseState = ParseState
|
||||
{ _psLayoutStack :: [Layout]
|
||||
, _psLexState :: [Int]
|
||||
, _psInput :: AlexInput
|
||||
}
|
||||
|
||||
data Layout = Explicit
|
||||
| Implicit Int
|
||||
deriving (Show, Eq)
|
||||
|
||||
data Located a = Located (Position, Int) a
|
||||
deriving (Show)
|
||||
|
||||
type OpTable = H.HashMap Name OpInfo
|
||||
type OpInfo = (Assoc, Int)
|
||||
|
||||
@@ -61,17 +101,6 @@ 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)
|
||||
@@ -80,7 +109,7 @@ type PartialDecl' = Decl (Const PartialExpr') Name
|
||||
|
||||
data Partial a = E (RlpExprF Name a)
|
||||
| B Name (Partial a) (Partial a)
|
||||
| P (Partial a)
|
||||
| Par (Partial a)
|
||||
deriving (Show, Functor)
|
||||
|
||||
pL :: Traversal' (Partial a) (Partial a)
|
||||
@@ -109,14 +138,13 @@ instance Show1 Partial where
|
||||
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
|
||||
(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 ''ParserState
|
||||
makeLenses ''AlexInput
|
||||
makeLenses ''ParseState
|
||||
|
||||
|
||||
@@ -1,30 +0,0 @@
|
||||
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
|
||||
|
||||
Reference in New Issue
Block a user