now we're fucking GETTING SOMEWHERE
This commit is contained in:
crumbtoo
@@ -33,6 +33,7 @@ library
|
||||
, Rlp.Syntax
|
||||
-- , Rlp.Parse.Decls
|
||||
, Rlp.Parse
|
||||
, Rlp.Parse.Associate
|
||||
, Rlp.Lex
|
||||
, Rlp.Parse.Types
|
||||
|
||||
@@ -66,6 +67,7 @@ library
|
||||
, recursion-schemes >= 5.2.2 && < 5.3
|
||||
, data-fix >= 0.3.2 && < 0.4
|
||||
, utf8-string >= 1.0.2 && < 1.1
|
||||
, extra >= 1.7.0 && < 2
|
||||
|
||||
hs-source-dirs: src
|
||||
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
|
||||
( parseRlpProgram
|
||||
, parseTest
|
||||
)
|
||||
where
|
||||
import Rlp.Lex
|
||||
import Rlp.Syntax
|
||||
import Rlp.Parse.Types
|
||||
import Rlp.Parse.Associate
|
||||
import Lens.Micro.Mtl
|
||||
import Data.List.Extra
|
||||
import Data.Fix
|
||||
import Data.Functor.Const
|
||||
}
|
||||
|
||||
%name parseRlpProgram StandaloneProgram
|
||||
%name parseTest VL
|
||||
|
||||
%monad { P }
|
||||
%lexer { lexDebug } { Located _ TokenEOF }
|
||||
@@ -27,17 +28,22 @@ import Data.Functor.Const
|
||||
'=' { Located _ TokenEquals }
|
||||
'|' { Located _ TokenPipe }
|
||||
';' { Located _ TokenSemicolon }
|
||||
'(' { Located _ TokenLParen }
|
||||
')' { Located _ TokenRParen }
|
||||
'->' { Located _ TokenArrow }
|
||||
vsemi { Located _ TokenSemicolonV }
|
||||
'{' { Located _ TokenLBrace }
|
||||
'}' { Located _ TokenRBrace }
|
||||
vlbrace { Located _ TokenLBraceV }
|
||||
vrbrace { Located _ TokenRBraceV }
|
||||
|
||||
%right '->'
|
||||
|
||||
%%
|
||||
|
||||
StandaloneProgram :: { [PartialDecl'] }
|
||||
StandaloneProgram : '{' Decls '}' { $2 }
|
||||
| VL Decls VR { $2 }
|
||||
StandaloneProgram :: { RlpProgram' }
|
||||
StandaloneProgram : '{' Decls '}' {% mkProgram $2 }
|
||||
| VL DeclsV VR {% mkProgram $2 }
|
||||
|
||||
VL :: { () }
|
||||
VL : vlbrace { () }
|
||||
@@ -47,12 +53,14 @@ VR : vrbrace { () }
|
||||
| error { () }
|
||||
|
||||
Decls :: { [PartialDecl'] }
|
||||
Decls : Decl VS Decls { $1 : $3 }
|
||||
| Decl VS { [$1] }
|
||||
Decls : Decl ';' Decls { $1 : $3 }
|
||||
| Decl ';' { [$1] }
|
||||
| Decl { [$1] }
|
||||
|
||||
Semi :: { Located RlpToken }
|
||||
Semi : ';' { $1 }
|
||||
DeclsV :: { [PartialDecl'] }
|
||||
DeclsV : Decl VS Decls { $1 : $3 }
|
||||
| Decl VS { [$1] }
|
||||
| Decl { [$1] }
|
||||
|
||||
VS :: { Located RlpToken }
|
||||
VS : ';' { $1 }
|
||||
@@ -60,22 +68,66 @@ VS : ';' { $1 }
|
||||
|
||||
Decl :: { PartialDecl' }
|
||||
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 : 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 : Literal { Fix . E $ LitEF $1 }
|
||||
Expr : Lit { Fix . E $ LitEF $1 }
|
||||
| Var { Fix . E $ VarEF $1 }
|
||||
|
||||
Literal :: { Lit' }
|
||||
Literal : litint { IntL $1 }
|
||||
Lit :: { Lit' }
|
||||
Lit : litint { IntL $1 }
|
||||
|
||||
Var :: { VarId }
|
||||
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 = 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
|
||||
| TokenLBrace
|
||||
| TokenRBrace
|
||||
| TokenLParen
|
||||
| TokenRParen
|
||||
-- 'virtual' control symbols, inserted by the lexer without any correlation
|
||||
-- to a specific symbol
|
||||
| TokenSemicolonV
|
||||
|
||||
@@ -55,6 +55,7 @@ data RlpModule b = RlpModule
|
||||
}
|
||||
|
||||
newtype RlpProgram b = RlpProgram [Decl RlpExpr b]
|
||||
deriving Show
|
||||
|
||||
type RlpProgram' = RlpProgram Name
|
||||
|
||||
|
||||
Reference in New Issue
Block a user