rc #13
@@ -33,6 +33,7 @@ library
|
|||||||
, Rlp.Syntax
|
, Rlp.Syntax
|
||||||
-- , Rlp.Parse.Decls
|
-- , Rlp.Parse.Decls
|
||||||
, Rlp.Parse
|
, Rlp.Parse
|
||||||
|
, Rlp.Parse.Associate
|
||||||
, Rlp.Lex
|
, Rlp.Lex
|
||||||
, Rlp.Parse.Types
|
, Rlp.Parse.Types
|
||||||
|
|
||||||
@@ -66,6 +67,7 @@ library
|
|||||||
, recursion-schemes >= 5.2.2 && < 5.3
|
, recursion-schemes >= 5.2.2 && < 5.3
|
||||||
, data-fix >= 0.3.2 && < 0.4
|
, data-fix >= 0.3.2 && < 0.4
|
||||||
, utf8-string >= 1.0.2 && < 1.1
|
, utf8-string >= 1.0.2 && < 1.1
|
||||||
|
, extra >= 1.7.0 && < 2
|
||||||
|
|
||||||
hs-source-dirs: src
|
hs-source-dirs: src
|
||||||
default-language: GHC2021
|
default-language: GHC2021
|
||||||
|
|||||||
@@ -1,280 +0,0 @@
|
|||||||
{
|
|
||||||
{-# LANGUAGE GeneralisedNewtypeDeriving #-}
|
|
||||||
{-# LANGUAGE TemplateHaskell #-}
|
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
|
||||||
module Rlp.Lex
|
|
||||||
( P(..)
|
|
||||||
, RlpToken(..)
|
|
||||||
, Located(..)
|
|
||||||
, AlexPosn
|
|
||||||
, lexer
|
|
||||||
, lexerCont
|
|
||||||
)
|
|
||||||
where
|
|
||||||
import Control.Monad
|
|
||||||
import Data.Functor.Identity
|
|
||||||
import Data.Char (digitToInt)
|
|
||||||
import Core.Syntax (Name)
|
|
||||||
import Data.Monoid (First)
|
|
||||||
import Data.Maybe
|
|
||||||
import Data.Text (Text)
|
|
||||||
import Data.Text qualified as T
|
|
||||||
import Data.Default
|
|
||||||
import Lens.Micro.Mtl
|
|
||||||
import Lens.Micro
|
|
||||||
import Lens.Micro.TH
|
|
||||||
|
|
||||||
import Debug.Trace
|
|
||||||
}
|
|
||||||
|
|
||||||
$whitechar = [ \t\n\r\f\v]
|
|
||||||
|
|
||||||
$lower = [a-z \_]
|
|
||||||
$upper = [A-Z]
|
|
||||||
$alpha = [$lower $upper]
|
|
||||||
$digit = 0-9
|
|
||||||
|
|
||||||
$nl = [\n\r]
|
|
||||||
$white_no_nl = $white # $nl
|
|
||||||
|
|
||||||
$namechar = [$alpha $digit \' \#]
|
|
||||||
|
|
||||||
@varname = $lower $namechar*
|
|
||||||
|
|
||||||
@digits = $digit+
|
|
||||||
|
|
||||||
rlp :-
|
|
||||||
|
|
||||||
-- skip whitespace
|
|
||||||
$white_no_nl+ ;
|
|
||||||
-- TODO: don't treat operators like (-->) as comments
|
|
||||||
"--".* ;
|
|
||||||
";" { constToken TokenSemicolon }
|
|
||||||
-- "{" { explicitLBrace }
|
|
||||||
-- "}" { explicitRBrace }
|
|
||||||
|
|
||||||
<0>
|
|
||||||
{
|
|
||||||
\n { begin bol }
|
|
||||||
}
|
|
||||||
|
|
||||||
<one>
|
|
||||||
{
|
|
||||||
@varname { tokenWith TokenVarName }
|
|
||||||
@digits { tokenWith (TokenLitInt . readInt) }
|
|
||||||
"=" { constToken TokenEquals }
|
|
||||||
\n { begin bol }
|
|
||||||
}
|
|
||||||
|
|
||||||
-- consume all whitespace leaving us at the beginning of the next non-empty
|
|
||||||
-- line. we then compare the indentation of that line to the enclosing layout
|
|
||||||
-- context and proceed accordingly
|
|
||||||
<bol>
|
|
||||||
{
|
|
||||||
$whitechar ;
|
|
||||||
\n ;
|
|
||||||
() { doBol `andBegin` one }
|
|
||||||
}
|
|
||||||
|
|
||||||
{
|
|
||||||
|
|
||||||
readInt :: Text -> Int
|
|
||||||
readInt = T.foldr f 0 where
|
|
||||||
f c n = digitToInt c + 10*n
|
|
||||||
|
|
||||||
-- | @andBegin@, with the subtle difference that the start code is set
|
|
||||||
-- /after/ the action
|
|
||||||
thenBegin :: AlexAction a -> Int -> AlexAction a
|
|
||||||
thenBegin act c inp l = do
|
|
||||||
a <- act inp l
|
|
||||||
alexSetStartCode c
|
|
||||||
pure a
|
|
||||||
|
|
||||||
constToken :: RlpToken -> AlexAction (Located RlpToken)
|
|
||||||
constToken t inp _ = pure $ Located (inp ^. _1) t
|
|
||||||
|
|
||||||
tokenWith :: (Text -> RlpToken) -> AlexAction (Located RlpToken)
|
|
||||||
tokenWith tf (p,_,_,s) l = pure $ Located p (tf $ T.take l s)
|
|
||||||
|
|
||||||
alexEOF :: Alex (Located RlpToken)
|
|
||||||
alexEOF = do
|
|
||||||
inp <- alexGetInput
|
|
||||||
pure (Located (inp ^. _1) 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)
|
|
||||||
|
|
||||||
newtype P a = P { runP :: ParseState -> Alex (ParseState, Maybe a) }
|
|
||||||
deriving (Functor)
|
|
||||||
|
|
||||||
execP :: P a -> ParseState -> Text -> Either String a
|
|
||||||
execP p st s = snd <$> runAlex s (runP p st)
|
|
||||||
|
|
||||||
execP' :: P a -> Text -> Either String a
|
|
||||||
execP' p = execP p def
|
|
||||||
|
|
||||||
data ParseState = ParseState
|
|
||||||
{ _psLayoutStack :: [Layout]
|
|
||||||
, _psLexState :: [Int]
|
|
||||||
}
|
|
||||||
|
|
||||||
instance Default ParseState where
|
|
||||||
def = ParseState { }
|
|
||||||
|
|
||||||
instance Applicative P where
|
|
||||||
pure a = P $ \st -> pure (st,a)
|
|
||||||
liftA2 = liftM2
|
|
||||||
|
|
||||||
instance Monad P where
|
|
||||||
p >>= k = P $ \st -> do
|
|
||||||
(st',a) <- runP p st
|
|
||||||
runP (k a) st'
|
|
||||||
|
|
||||||
data Layout = Explicit
|
|
||||||
| Implicit Int
|
|
||||||
deriving (Show, Eq)
|
|
||||||
|
|
||||||
data Located a = Located AlexPosn a
|
|
||||||
deriving (Show)
|
|
||||||
|
|
||||||
psLayoutStack :: Lens' AlexUserState [Layout]
|
|
||||||
psLayoutStack = lens _psLayoutStack
|
|
||||||
(\ s l -> s { _psLayoutStack = l })
|
|
||||||
|
|
||||||
lexer :: P (Located RlpToken)
|
|
||||||
lexer = P $ \st -> (st,) <$> lexToken
|
|
||||||
|
|
||||||
lexerCont :: (Located RlpToken -> P a) -> P a
|
|
||||||
lexerCont = (lexer >>=)
|
|
||||||
|
|
||||||
lexStream :: Alex [RlpToken]
|
|
||||||
lexStream = do
|
|
||||||
t <- lexToken
|
|
||||||
case t of
|
|
||||||
Located _ TokenEOF -> pure [TokenEOF]
|
|
||||||
Located _ a -> (a:) <$> lexStream
|
|
||||||
|
|
||||||
lexTest :: Text -> Either String [RlpToken]
|
|
||||||
lexTest = flip runAlex lexStream
|
|
||||||
|
|
||||||
lexToken :: Alex (Located RlpToken)
|
|
||||||
lexToken = alexMonadScan
|
|
||||||
|
|
||||||
getsAus :: (AlexUserState -> b) -> Alex b
|
|
||||||
getsAus k = alexGetUserState <&> k
|
|
||||||
|
|
||||||
useAus :: Getting a AlexUserState a -> Alex a
|
|
||||||
useAus l = do
|
|
||||||
aus <- alexGetUserState
|
|
||||||
pure (aus ^. l)
|
|
||||||
|
|
||||||
preuseAus :: Getting (First a) AlexUserState a -> Alex (Maybe a)
|
|
||||||
preuseAus l = do
|
|
||||||
aus <- alexGetUserState
|
|
||||||
pure (aus ^? l)
|
|
||||||
|
|
||||||
modifyingAus :: ASetter' AlexUserState a -> (a -> a) -> Alex ()
|
|
||||||
modifyingAus l f = do
|
|
||||||
aus <- alexGetUserState
|
|
||||||
alexSetUserState (aus & l %~ f)
|
|
||||||
|
|
||||||
indentLevel :: Alex Int
|
|
||||||
indentLevel = do
|
|
||||||
inp <- alexGetInput
|
|
||||||
let col = inp ^. _1
|
|
||||||
& \ (AlexPn _ _ c) -> c
|
|
||||||
pure col
|
|
||||||
|
|
||||||
cmpLayout :: Alex Ordering
|
|
||||||
cmpLayout = do
|
|
||||||
i <- indentLevel
|
|
||||||
ctx <- preuseAus (ausLayoutStack . _head)
|
|
||||||
case ctx ^. non (Implicit 1) of
|
|
||||||
Implicit n -> pure (i `compare` n)
|
|
||||||
Explicit -> pure GT
|
|
||||||
|
|
||||||
insertToken :: RlpToken -> Alex (Located RlpToken)
|
|
||||||
insertToken t = do
|
|
||||||
inp <- alexGetInput
|
|
||||||
pure (Located (inp ^. _1) t)
|
|
||||||
|
|
||||||
insertSemicolon, insertLBrace, insertRBrace :: Alex (Located RlpToken)
|
|
||||||
insertSemicolon = traceM "inserting semi" >> insertToken TokenSemicolonV
|
|
||||||
insertLBrace = traceM "inserting lbrace" >> insertToken TokenLBraceV
|
|
||||||
insertRBrace = traceM "inserting rbrace" >> insertToken TokenRBraceV
|
|
||||||
|
|
||||||
-- pop the layout stack and jump to the popped return code
|
|
||||||
popLayout :: Alex Layout
|
|
||||||
popLayout = do
|
|
||||||
traceM "pop layout"
|
|
||||||
ctx <- preuseAus (ausLayoutStack . _head)
|
|
||||||
modifyingAus ausLayoutStack (drop 1)
|
|
||||||
case ctx of
|
|
||||||
Just l -> pure l
|
|
||||||
Nothing -> error "uhh"
|
|
||||||
|
|
||||||
pushLayout :: Layout -> Alex ()
|
|
||||||
pushLayout l = do
|
|
||||||
traceM "push layout"
|
|
||||||
modifyingAus ausLayoutStack (l:)
|
|
||||||
|
|
||||||
pushLexState :: Alex ()
|
|
||||||
pushLexState = do
|
|
||||||
undefined
|
|
||||||
|
|
||||||
doBol :: AlexAction (Located RlpToken)
|
|
||||||
doBol inp len = 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
|
|
||||||
|
|
||||||
explicitLBrace, explicitRBrace :: AlexAction (Located RlpToken)
|
|
||||||
|
|
||||||
explicitLBrace _ _ = do
|
|
||||||
pushLayout Explicit
|
|
||||||
insertToken TokenLBrace
|
|
||||||
|
|
||||||
explicitRBrace _ _ = do
|
|
||||||
popLayout
|
|
||||||
insertToken TokenRBrace
|
|
||||||
|
|
||||||
doLayout :: AlexAction (Located RlpToken)
|
|
||||||
doLayout _ _ = do
|
|
||||||
i <- indentLevel
|
|
||||||
pushLayout (Implicit i)
|
|
||||||
traceM $ "layout " <> show i
|
|
||||||
insertLBrace
|
|
||||||
|
|
||||||
}
|
|
||||||
|
|
||||||
@@ -1,327 +0,0 @@
|
|||||||
{
|
|
||||||
{-# LANGUAGE ViewPatterns, LambdaCase #-}
|
|
||||||
{-# LANGUAGE GeneralisedNewtypeDeriving #-}
|
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
|
||||||
module Rlp.Lex
|
|
||||||
( P(..)
|
|
||||||
, RlpToken(..)
|
|
||||||
, Located(..)
|
|
||||||
, 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 Data.Monoid (First)
|
|
||||||
import Data.Maybe
|
|
||||||
import Data.Text (Text)
|
|
||||||
import Data.Text qualified as T
|
|
||||||
import Data.Word
|
|
||||||
import Data.Default
|
|
||||||
import Lens.Micro.Mtl
|
|
||||||
import Lens.Micro
|
|
||||||
|
|
||||||
import Debug.Trace
|
|
||||||
import Rlp.Parse.Types
|
|
||||||
}
|
|
||||||
|
|
||||||
$whitechar = [ \t\n\r\f\v]
|
|
||||||
|
|
||||||
$lower = [a-z \_]
|
|
||||||
$upper = [A-Z]
|
|
||||||
$alpha = [$lower $upper]
|
|
||||||
$digit = 0-9
|
|
||||||
|
|
||||||
$nl = [\n\r]
|
|
||||||
$white_no_nl = $white # $nl
|
|
||||||
|
|
||||||
$namechar = [$alpha $digit \' \#]
|
|
||||||
$reservedsym = [\(\)\,\;\[\]\`\{\}]
|
|
||||||
$asciisym = [\!\#\$\%\&\*\+\.\/\<\=\>\?\@\\\^\|\-\~\:]
|
|
||||||
$namesym = $asciisym # \;
|
|
||||||
|
|
||||||
@reservedop =
|
|
||||||
"=" | \\ | "->" | "::" | "|"
|
|
||||||
|
|
||||||
@varname = $lower $namechar*
|
|
||||||
@conname = $upper $namechar*
|
|
||||||
@varsym = $namesym+
|
|
||||||
@consym = \: $namesym*
|
|
||||||
|
|
||||||
|
|
||||||
@decimal = $digit+
|
|
||||||
|
|
||||||
rlp :-
|
|
||||||
|
|
||||||
-- skip whitespace
|
|
||||||
$white_no_nl+ ;
|
|
||||||
-- TODO: don't treat operators like (-->) as comments
|
|
||||||
"--".* ;
|
|
||||||
|
|
||||||
<0>
|
|
||||||
{
|
|
||||||
\n { beginPush bol }
|
|
||||||
@varname { tokenWith TokenVarName }
|
|
||||||
@decimal { tokenWith (TokenLitInt . readInt) }
|
|
||||||
@reservedop { tokenWith readReservedOp }
|
|
||||||
}
|
|
||||||
|
|
||||||
-- control characters
|
|
||||||
<0>
|
|
||||||
{
|
|
||||||
"{" { explicitLBrace }
|
|
||||||
"}" { explicitRBrace }
|
|
||||||
";" { constToken TokenSemicolon }
|
|
||||||
}
|
|
||||||
|
|
||||||
-- consume all whitespace leaving us at the beginning of the next non-empty
|
|
||||||
-- line. we then compare the indentation of that line to the enclosing layout
|
|
||||||
-- context and proceed accordingly
|
|
||||||
<bol>
|
|
||||||
{
|
|
||||||
$whitechar ;
|
|
||||||
\n ;
|
|
||||||
() { doBol }
|
|
||||||
}
|
|
||||||
|
|
||||||
<layout_top>
|
|
||||||
{
|
|
||||||
\n ;
|
|
||||||
"{" { explicitLBrace `thenDo` popLexState }
|
|
||||||
() { doLayout }
|
|
||||||
}
|
|
||||||
|
|
||||||
{
|
|
||||||
|
|
||||||
readReservedOp :: Text -> RlpToken
|
|
||||||
readReservedOp = \case
|
|
||||||
"=" -> TokenEquals
|
|
||||||
"\\" -> TokenLambda
|
|
||||||
"->" -> TokenArrow
|
|
||||||
"::" -> TokenHasType
|
|
||||||
s -> error (show s)
|
|
||||||
|
|
||||||
-- | @andBegin@, with the subtle difference that the start code is set
|
|
||||||
-- /after/ the action
|
|
||||||
thenBegin :: LexerAction a -> Int -> LexerAction a
|
|
||||||
thenBegin act c inp l = do
|
|
||||||
a <- act inp l
|
|
||||||
psLexState . _head .= c
|
|
||||||
pure a
|
|
||||||
|
|
||||||
andBegin :: LexerAction a -> Int -> LexerAction a
|
|
||||||
andBegin act c inp l = do
|
|
||||||
psLexState . _head .= c
|
|
||||||
act inp l
|
|
||||||
|
|
||||||
beginPush :: Int -> LexerAction (Located RlpToken)
|
|
||||||
beginPush n _ _ = pushLexState n >> lexToken
|
|
||||||
|
|
||||||
alexGetByte :: AlexInput -> Maybe (Word8, AlexInput)
|
|
||||||
alexGetByte inp = case inp ^. aiBytes of
|
|
||||||
[] -> do
|
|
||||||
(c,t) <- T.uncons (inp ^. aiSource)
|
|
||||||
let (b:bs) = encodeChar c
|
|
||||||
-- tail the source
|
|
||||||
inp' = inp & aiSource .~ t
|
|
||||||
-- record the excess bytes for successive calls
|
|
||||||
& aiBytes .~ bs
|
|
||||||
-- report the previous char
|
|
||||||
& aiPrevChar .~ c
|
|
||||||
-- update the position
|
|
||||||
& aiPos %~ \ (ln,col) ->
|
|
||||||
if (inp ^. aiPrevChar) == '\n'
|
|
||||||
then (ln+1,1)
|
|
||||||
else (ln,col+1)
|
|
||||||
pure (b, inp')
|
|
||||||
|
|
||||||
_ -> Just (head bs, inp')
|
|
||||||
where
|
|
||||||
(bs, inp') = inp & aiBytes <<%~ drop 1
|
|
||||||
|
|
||||||
getInput :: P AlexInput
|
|
||||||
getInput = use psInput
|
|
||||||
|
|
||||||
takeInput :: Int -> AlexInput -> Text
|
|
||||||
takeInput n inp = T.cons c cs
|
|
||||||
where
|
|
||||||
c = inp ^. aiPrevChar
|
|
||||||
cs = T.take (max 0 (n-1)) $ inp ^. aiSource
|
|
||||||
|
|
||||||
getLexState :: P Int
|
|
||||||
getLexState = use (psLexState . singular _head)
|
|
||||||
|
|
||||||
alexInputPrevChar :: AlexInput -> Char
|
|
||||||
alexInputPrevChar = view aiPrevChar
|
|
||||||
|
|
||||||
pushLexState :: Int -> P ()
|
|
||||||
pushLexState n = psLexState %= (n:)
|
|
||||||
|
|
||||||
readInt :: Text -> Int
|
|
||||||
readInt = T.foldr f 0 where
|
|
||||||
f c n = digitToInt c + 10*n
|
|
||||||
|
|
||||||
constToken :: RlpToken -> LexerAction (Located RlpToken)
|
|
||||||
constToken t inp l = do
|
|
||||||
pos <- use (psInput . aiPos)
|
|
||||||
pure (Located (pos,l) t)
|
|
||||||
|
|
||||||
tokenWith :: (Text -> RlpToken) -> LexerAction (Located RlpToken)
|
|
||||||
tokenWith tf inp l = do
|
|
||||||
pos <- getPos
|
|
||||||
let t = takeInput l inp
|
|
||||||
pure (Located (pos,l) (tf t))
|
|
||||||
|
|
||||||
getPos :: P Position
|
|
||||||
getPos = use (psInput . aiPos)
|
|
||||||
|
|
||||||
alexEOF :: P (Located RlpToken)
|
|
||||||
alexEOF = do
|
|
||||||
inp <- getInput
|
|
||||||
pure (Located undefined TokenEOF)
|
|
||||||
|
|
||||||
execP :: P a -> ParseState -> Maybe a
|
|
||||||
execP p st = runP p st & snd
|
|
||||||
|
|
||||||
execP' :: P a -> Text -> Maybe a
|
|
||||||
execP' p s = execP p st where
|
|
||||||
st = initParseState s
|
|
||||||
|
|
||||||
initParseState :: Text -> ParseState
|
|
||||||
initParseState s = ParseState
|
|
||||||
{ _psLayoutStack = []
|
|
||||||
-- IMPORTANT: the initial state is `bol` to begin the top-level layout,
|
|
||||||
-- which then returns to state 0 which continues the normal lexing process.
|
|
||||||
, _psLexState = [layout_top,0]
|
|
||||||
, _psInput = initAlexInput s
|
|
||||||
}
|
|
||||||
|
|
||||||
initAlexInput :: Text -> AlexInput
|
|
||||||
<<<<<<< Updated upstream
|
|
||||||
initAlexInput s = AlexInput
|
|
||||||
{ _aiPrevChar = '\0'
|
|
||||||
=======
|
|
||||||
initAlexInput t = AlexInput
|
|
||||||
{ _aiPrevChar = c
|
|
||||||
>>>>>>> Stashed changes
|
|
||||||
, _aiSource = s
|
|
||||||
, _aiBytes = []
|
|
||||||
, _aiPos = (1,1)
|
|
||||||
}
|
|
||||||
where
|
|
||||||
(c,s) = fromJust $ T.uncons t
|
|
||||||
b = encodeChar c
|
|
||||||
|
|
||||||
lexToken :: P (Located RlpToken)
|
|
||||||
lexToken = do
|
|
||||||
inp <- getInput
|
|
||||||
c <- getLexState
|
|
||||||
st <- use id
|
|
||||||
traceM $ "st: " <> show st
|
|
||||||
case alexScan inp c of
|
|
||||||
AlexEOF -> pure $ Located (inp ^. aiPos, 0) TokenEOF
|
|
||||||
AlexSkip inp' l -> do
|
|
||||||
psInput .= inp'
|
|
||||||
lexToken
|
|
||||||
AlexToken inp' l act -> do
|
|
||||||
psInput .= inp'
|
|
||||||
traceShowM inp'
|
|
||||||
act inp l
|
|
||||||
|
|
||||||
lexerCont :: (Located RlpToken -> P a) -> P a
|
|
||||||
lexerCont = undefined
|
|
||||||
|
|
||||||
lexStream :: P [RlpToken]
|
|
||||||
lexStream = do
|
|
||||||
t <- lexToken
|
|
||||||
case t of
|
|
||||||
Located _ TokenEOF -> pure [TokenEOF]
|
|
||||||
Located _ t -> (t:) <$> lexStream
|
|
||||||
|
|
||||||
lexTest :: Text -> Maybe [RlpToken]
|
|
||||||
lexTest s = execP' lexStream s
|
|
||||||
|
|
||||||
indentLevel :: P Int
|
|
||||||
indentLevel = do
|
|
||||||
pos <- use (psInput . aiPos)
|
|
||||||
pure (pos ^. _2)
|
|
||||||
|
|
||||||
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)
|
|
||||||
psLayoutStack %= (drop 1)
|
|
||||||
case ctx of
|
|
||||||
Just l -> pure l
|
|
||||||
Nothing -> error "uhh"
|
|
||||||
|
|
||||||
pushLayout :: Layout -> P ()
|
|
||||||
pushLayout l = do
|
|
||||||
traceM "push layout"
|
|
||||||
psLayoutStack %= (l:)
|
|
||||||
|
|
||||||
popLexState :: P ()
|
|
||||||
popLexState = do
|
|
||||||
psLexState %= tail
|
|
||||||
|
|
||||||
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 of
|
|
||||||
Just (Implicit n) -> pure (i `compare` n)
|
|
||||||
_ -> pure GT
|
|
||||||
|
|
||||||
doBol :: LexerAction (Located RlpToken)
|
|
||||||
doBol inp l = do
|
|
||||||
off <- cmpLayout
|
|
||||||
i <- indentLevel
|
|
||||||
traceM $ "i: " <> show i
|
|
||||||
-- important that we pop the lex state lest we find our lexer diverging
|
|
||||||
popLexState
|
|
||||||
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 -> lexToken
|
|
||||||
-- the line is indented less than the previous, pop the layout stack and
|
|
||||||
-- insert a closing brace.
|
|
||||||
LT -> popLayout >> insertRBrace
|
|
||||||
|
|
||||||
thenDo :: LexerAction a -> P b -> LexerAction a
|
|
||||||
thenDo act p inp l = act inp l <* p
|
|
||||||
|
|
||||||
explicitLBrace :: LexerAction (Located RlpToken)
|
|
||||||
explicitLBrace inp l = do
|
|
||||||
pushLayout Explicit
|
|
||||||
constToken TokenLBrace inp l
|
|
||||||
|
|
||||||
explicitRBrace :: LexerAction (Located RlpToken)
|
|
||||||
explicitRBrace inp l = do
|
|
||||||
popLayout
|
|
||||||
constToken TokenRBrace inp l
|
|
||||||
|
|
||||||
doLayout :: LexerAction (Located RlpToken)
|
|
||||||
doLayout _ _ = do
|
|
||||||
i <- indentLevel
|
|
||||||
pushLayout (Implicit i)
|
|
||||||
popLexState
|
|
||||||
insertLBrace
|
|
||||||
|
|
||||||
}
|
|
||||||
|
|
||||||
@@ -1,18 +1,19 @@
|
|||||||
{
|
{
|
||||||
module Rlp.Parse
|
module Rlp.Parse
|
||||||
( parseRlpProgram
|
( parseRlpProgram
|
||||||
, parseTest
|
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
import Rlp.Lex
|
import Rlp.Lex
|
||||||
import Rlp.Syntax
|
import Rlp.Syntax
|
||||||
import Rlp.Parse.Types
|
import Rlp.Parse.Types
|
||||||
|
import Rlp.Parse.Associate
|
||||||
|
import Lens.Micro.Mtl
|
||||||
|
import Data.List.Extra
|
||||||
import Data.Fix
|
import Data.Fix
|
||||||
import Data.Functor.Const
|
import Data.Functor.Const
|
||||||
}
|
}
|
||||||
|
|
||||||
%name parseRlpProgram StandaloneProgram
|
%name parseRlpProgram StandaloneProgram
|
||||||
%name parseTest VL
|
|
||||||
|
|
||||||
%monad { P }
|
%monad { P }
|
||||||
%lexer { lexDebug } { Located _ TokenEOF }
|
%lexer { lexDebug } { Located _ TokenEOF }
|
||||||
@@ -27,17 +28,22 @@ import Data.Functor.Const
|
|||||||
'=' { Located _ TokenEquals }
|
'=' { Located _ TokenEquals }
|
||||||
'|' { Located _ TokenPipe }
|
'|' { Located _ TokenPipe }
|
||||||
';' { Located _ TokenSemicolon }
|
';' { Located _ TokenSemicolon }
|
||||||
|
'(' { Located _ TokenLParen }
|
||||||
|
')' { Located _ TokenRParen }
|
||||||
|
'->' { Located _ TokenArrow }
|
||||||
vsemi { Located _ TokenSemicolonV }
|
vsemi { Located _ TokenSemicolonV }
|
||||||
'{' { Located _ TokenLBrace }
|
'{' { Located _ TokenLBrace }
|
||||||
'}' { Located _ TokenRBrace }
|
'}' { Located _ TokenRBrace }
|
||||||
vlbrace { Located _ TokenLBraceV }
|
vlbrace { Located _ TokenLBraceV }
|
||||||
vrbrace { Located _ TokenRBraceV }
|
vrbrace { Located _ TokenRBraceV }
|
||||||
|
|
||||||
|
%right '->'
|
||||||
|
|
||||||
%%
|
%%
|
||||||
|
|
||||||
StandaloneProgram :: { [PartialDecl'] }
|
StandaloneProgram :: { RlpProgram' }
|
||||||
StandaloneProgram : '{' Decls '}' { $2 }
|
StandaloneProgram : '{' Decls '}' {% mkProgram $2 }
|
||||||
| VL Decls VR { $2 }
|
| VL DeclsV VR {% mkProgram $2 }
|
||||||
|
|
||||||
VL :: { () }
|
VL :: { () }
|
||||||
VL : vlbrace { () }
|
VL : vlbrace { () }
|
||||||
@@ -47,12 +53,14 @@ VR : vrbrace { () }
|
|||||||
| error { () }
|
| error { () }
|
||||||
|
|
||||||
Decls :: { [PartialDecl'] }
|
Decls :: { [PartialDecl'] }
|
||||||
Decls : Decl VS Decls { $1 : $3 }
|
Decls : Decl ';' Decls { $1 : $3 }
|
||||||
| Decl VS { [$1] }
|
| Decl ';' { [$1] }
|
||||||
| Decl { [$1] }
|
| Decl { [$1] }
|
||||||
|
|
||||||
Semi :: { Located RlpToken }
|
DeclsV :: { [PartialDecl'] }
|
||||||
Semi : ';' { $1 }
|
DeclsV : Decl VS Decls { $1 : $3 }
|
||||||
|
| Decl VS { [$1] }
|
||||||
|
| Decl { [$1] }
|
||||||
|
|
||||||
VS :: { Located RlpToken }
|
VS :: { Located RlpToken }
|
||||||
VS : ';' { $1 }
|
VS : ';' { $1 }
|
||||||
@@ -60,22 +68,66 @@ VS : ';' { $1 }
|
|||||||
|
|
||||||
Decl :: { PartialDecl' }
|
Decl :: { PartialDecl' }
|
||||||
Decl : FunDecl { $1 }
|
Decl : FunDecl { $1 }
|
||||||
|
| DataDecl { $1 }
|
||||||
|
|
||||||
|
DataDecl :: { PartialDecl' }
|
||||||
|
: data Con TyParams '=' DataCons { DataD $2 $3 $5 }
|
||||||
|
|
||||||
|
TyParams :: { [Name] }
|
||||||
|
: {- epsilon -} { [] }
|
||||||
|
| TyParams varname { $1 `snoc` $2 }
|
||||||
|
|
||||||
|
DataCons :: { [ConAlt] }
|
||||||
|
: DataCons '|' DataCon { $1 `snoc` $3 }
|
||||||
|
| DataCon { [$1] }
|
||||||
|
|
||||||
|
DataCon :: { ConAlt }
|
||||||
|
: Con Type1s { ConAlt $1 $2 }
|
||||||
|
|
||||||
|
Type1s :: { [Type] }
|
||||||
|
: {- epsilon -} { [] }
|
||||||
|
| Type1s Type1 { $1 `snoc` $2 }
|
||||||
|
|
||||||
|
Type1 :: { Type }
|
||||||
|
: '(' Type ')' { $2 }
|
||||||
|
| conname { TyCon $1 }
|
||||||
|
| varname { TyVar $1 }
|
||||||
|
|
||||||
|
Type :: { Type }
|
||||||
|
: Type '->' Type { $1 :-> $3 }
|
||||||
|
| Type1 { $1 }
|
||||||
|
|
||||||
FunDecl :: { PartialDecl' }
|
FunDecl :: { PartialDecl' }
|
||||||
FunDecl : Var '=' Expr { FunD $1 [] (Const $3) Nothing }
|
FunDecl : Var Params '=' Expr { FunD $1 $2 (Const $4) Nothing }
|
||||||
|
|
||||||
|
Params :: { [Pat'] }
|
||||||
|
Params : {- epsilon -} { [] }
|
||||||
|
| Params Pat1 { $1 `snoc` $2 }
|
||||||
|
|
||||||
|
Pat1 :: { Pat' }
|
||||||
|
: Var { VarP $1 }
|
||||||
|
| Lit { LitP $1 }
|
||||||
|
|
||||||
Expr :: { PartialExpr' }
|
Expr :: { PartialExpr' }
|
||||||
Expr : Literal { Fix . E $ LitEF $1 }
|
Expr : Lit { Fix . E $ LitEF $1 }
|
||||||
| Var { Fix . E $ VarEF $1 }
|
| Var { Fix . E $ VarEF $1 }
|
||||||
|
|
||||||
Literal :: { Lit' }
|
Lit :: { Lit' }
|
||||||
Literal : litint { IntL $1 }
|
Lit : litint { IntL $1 }
|
||||||
|
|
||||||
Var :: { VarId }
|
Var :: { VarId }
|
||||||
Var : varname { NameVar $1 }
|
Var : varname { NameVar $1 }
|
||||||
|
|
||||||
|
Con :: { ConId }
|
||||||
|
: conname { NameCon $1 }
|
||||||
|
|
||||||
{
|
{
|
||||||
|
|
||||||
|
mkProgram :: [PartialDecl'] -> P RlpProgram'
|
||||||
|
mkProgram ds = do
|
||||||
|
pt <- use psOpTable
|
||||||
|
pure $ RlpProgram (associate pt <$> ds)
|
||||||
|
|
||||||
parseError :: Located RlpToken -> P a
|
parseError :: Located RlpToken -> P a
|
||||||
parseError = error . show
|
parseError = error . show
|
||||||
|
|
||||||
|
|||||||
99
src/Rlp/Parse/Associate.hs
Normal file
99
src/Rlp/Parse/Associate.hs
Normal file
@@ -0,0 +1,99 @@
|
|||||||
|
{-# LANGUAGE PatternSynonyms, ViewPatterns, ImplicitParams #-}
|
||||||
|
module Rlp.Parse.Associate
|
||||||
|
( associate
|
||||||
|
)
|
||||||
|
where
|
||||||
|
--------------------------------------------------------------------------------
|
||||||
|
import Data.HashMap.Strict qualified as H
|
||||||
|
import Data.Functor.Foldable
|
||||||
|
import Data.Functor.Const
|
||||||
|
import Lens.Micro
|
||||||
|
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))
|
||||||
|
]
|
||||||
|
|
||||||
|
|
||||||
@@ -58,6 +58,8 @@ data RlpToken
|
|||||||
| TokenSemicolon
|
| TokenSemicolon
|
||||||
| TokenLBrace
|
| TokenLBrace
|
||||||
| TokenRBrace
|
| TokenRBrace
|
||||||
|
| TokenLParen
|
||||||
|
| 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 symbol
|
||||||
| TokenSemicolonV
|
| TokenSemicolonV
|
||||||
|
|||||||
@@ -55,6 +55,7 @@ data RlpModule b = RlpModule
|
|||||||
}
|
}
|
||||||
|
|
||||||
newtype RlpProgram b = RlpProgram [Decl RlpExpr b]
|
newtype RlpProgram b = RlpProgram [Decl RlpExpr b]
|
||||||
|
deriving Show
|
||||||
|
|
||||||
type RlpProgram' = RlpProgram Name
|
type RlpProgram' = RlpProgram Name
|
||||||
|
|
||||||
|
|||||||
Reference in New Issue
Block a user