decent starting point

This commit is contained in:
crumbtoo
2024-01-11 11:49:46 -07:00
parent bec376b7c7
commit aff1c6b4c6
2 changed files with 49 additions and 11 deletions

2
.ghci Normal file
View File

@@ -0,0 +1,2 @@
:set -XOverloadedStrings

View File

@@ -9,6 +9,7 @@ module Rlp.Lex
, lexer , lexer
) )
where where
import Control.Monad
import Data.Functor.Identity import Data.Functor.Identity
import Core.Syntax (Name) import Core.Syntax (Name)
import Data.Text (Text) import Data.Text (Text)
@@ -18,17 +19,32 @@ import Lens.Micro
%wrapper "monad-strict-text" %wrapper "monad-strict-text"
$whitechar = [ \t\n\r\f\v]
rlp :- rlp :-
-- skip whitespace
$white+ ;
-- TODO: don't treat operators like (-->) as comments
"--".* ;
";" { constToken TokenSemicolon }
"{" { constToken TokenLBrace }
"}" { constToken TokenRBrace }
<0> <0>
{ {
"a" { const $ const $ pure $ Located (AlexPn 0 0 0) (TokenVarName "a") } "a" { const $ const $ pure $ Located (AlexPn 0 0 0) (TokenVarName "a") }
"" { undefined }
} }
{ {
alexEOF :: Alex a constToken :: RlpToken -> AlexAction (Located RlpToken)
alexEOF = undefined constToken t inp _ = pure $ Located (inp ^. _1) t
alexEOF :: Alex (Located RlpToken)
alexEOF = do
inp <- alexGetInput
pure (Located (inp ^. _1) TokenEOF)
data RlpToken = TokenEquals data RlpToken = TokenEquals
| TokenLitInt Int | TokenLitInt Int
@@ -38,27 +54,47 @@ data RlpToken = TokenEquals
| TokenConSym Name | TokenConSym Name
| TokenData | TokenData
| TokenPipe | TokenPipe
-- syntax control
| TokenSemicolon
| TokenLBrace
| TokenRBrace
| TokenEOF | TokenEOF
deriving (Show) deriving (Show)
newtype P a = P { runP :: Text -> Either String a } newtype P a = P { runP :: PState -> Text -> Either String a }
deriving (Functor) deriving (Functor)
instance Applicative P where data PState = PState
pure = P . const . Right { psLayoutStack :: [Layout]
}
liftA2 f p q = P $ \s -> undefined data Layout = ExplicitLayout
| ImplicitLayout Int
deriving (Show)
instance Applicative P where
pure = P . const . const . Right
liftA2 = liftM2
instance Monad P where instance Monad P where
m >>= k = P $ \s -> case runP m s of m >>= k = P $ \st s -> case runP m st s of
Right a -> runP (k a) s Right a -> runP (k a) st s
Left e -> Left e Left e -> Left e
data Located a = Located AlexPosn a data Located a = Located AlexPosn a
deriving (Show) deriving (Show)
lexer :: (Located RlpToken -> P a) -> P a lexer :: (Located RlpToken -> P a) -> P a
lexer f = P $ \s -> case runAlex s ((,) <$> alexMonadScan <*> alexGetInput) of lexer f = P $ \st s -> case m s of
Right (a,s') -> runP (f a) (s' ^. _4) Right (a,s') -> runP (f a) st (s' ^. _4)
Left e -> error (show e)
where
m s = runAlex s ((,) <$> alexMonadScan <*> alexGetInput)
lexStream :: P [RlpToken]
lexStream = lexer go where
go (Located _ TokenEOF) = pure [TokenEOF]
go (Located _ t) = (t:) <$> lexStream
} }