rlp.cabal

@@ -60,6 +60,7 @@ library
                     , megaparsec                ^>=9.6.0
                     , text
                     , data-fix
+                    , utf8-string
 
     hs-source-dirs:   src
     default-language: GHC2021

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
+execP :: P a -> ParseState -> Maybe a
-    -- literals
+execP p st = runP p st & snd
-    = 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) }
+execP' :: P a -> Text -> Maybe a
-    deriving (Functor)
-
-execP :: P a -> ParseState -> Either String a
-execP p st = undefined
-
-execP' :: P a -> Text -> Either String a
 execP' p s = execP p st where
     st = initParseState s
 
 initParseState :: Text -> ParseState
 initParseState s = ParseState
     { _psLayoutStack = []
-    , _psLexState = [bol,0]
+    , _psLexState = [one,bol,0]
-    , _psInput = (undefined, s)
+    , _psInput = initAlexInput s
     }
 
-data ParseState = ParseState
+initAlexInput :: Text -> AlexInput
-    { _psLayoutStack        :: [Layout]
+initAlexInput s = AlexInput
-    , _psLexState           :: [Int]
+    { _aiPrevChar   = '\0'
-    , _psInput              :: AlexInput
+    , _aiSource     = s
+    , _aiBytes      = []
+    , _aiPos        = (1,1)
     }
 
-instance Applicative P where
+lexToken :: P (Located RlpToken)
-    pure a = P $ \st -> (st,Just a)
+lexToken = do
-    liftA2 = liftM2
+    inp <- getInput
-
+    c <- getLexState
-instance Monad P where
+    case alexScan inp c of
-    p >>= k = undefined
+        AlexEOF -> pure $ Located (inp ^. aiPos, 0) TokenEOF
-
+        AlexToken inp' l act -> do
-data Layout = Explicit
+            psInput .= inp'
-            | Implicit Int
+            traceM $ "l: " <> show l
-            deriving (Show, Eq)
+            traceShowM inp'
-
+            act inp l
-data Located a = Located (Int, Int) a
-    deriving (Show)
-
-lexer :: P (Located RlpToken)
-lexer = undefined
 
 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)
+indentLevel :: P Int
-lexToken = undefined
+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
 
 }
 

src/Rlp/Parse/Decls.hs

@@ -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))
-    ]
-

src/Rlp/Parse/Types.hs

@@ -1,57 +1,97 @@
 {-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE ImplicitParams, ViewPatterns, PatternSynonyms #-}
-{-
+{-# LANGUAGE LambdaCase #-}
-Description : Supporting types for the parser
+module Rlp.Parse.Types where
--}
+--------------------------------------------------------------------------------
-module Rlp.Parse.Types
+import Core.Syntax                  (Name)
-    (
+import Control.Monad
-    -- * Partial ASTs
+import Control.Monad.State.Class
-      Partial(..)
+import Data.Text                    (Text)
-    , PartialE
+import Data.Maybe
-    , 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.HashMap.Strict          qualified as H
-import Data.Maybe
+import Data.Word                    (Word8)
-import Text.Megaparsec              hiding (State)
-import Text.Printf
-import Lens.Micro
 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]
+data AlexInput = AlexInput
--- declarations. we should switch to a normal Parsec monad in the future
+    { _aiPrevChar   :: Char
-
+    , _aiSource     :: Text
-type Parser = ParsecT RlpParseError Text (State ParserState)
+    , _aiBytes      :: [Word8]
-
+    , _aiPos        :: Position
-data ParserState = ParserState
-    { _psOpTable :: OpTable
     }
     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 ''AlexInput
-
+makeLenses ''ParseState
-makeLenses ''ParserState
 

src/Rlp/Parse/Utils.hs

@@ -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
-