diff --git a/rlp.cabal b/rlp.cabal index 411434b..5d3fa6a 100644 --- a/rlp.cabal +++ b/rlp.cabal @@ -60,6 +60,7 @@ library , megaparsec ^>=9.6.0 , text , data-fix + , utf8-string hs-source-dirs: src default-language: GHC2021 diff --git a/src/Rlp/Lex.x b/src/Rlp/Lex.x index 9d41eb4..d81e432 100644 --- a/src/Rlp/Lex.x +++ b/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 } diff --git a/src/Rlp/Parse/Decls.hs b/src/Rlp/Parse/Decls.hs deleted file mode 100644 index fb6d875..0000000 --- a/src/Rlp/Parse/Decls.hs +++ /dev/null @@ -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 "--" $> "" - --- TODO: return comment text -blockComment :: Parser Text -blockComment = L.skipBlockCommentNested "{-" "-}" $> "" - -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)) - ] - diff --git a/src/Rlp/Parse/Types.hs b/src/Rlp/Parse/Types.hs index 41e67f8..d25c27b 100644 --- a/src/Rlp/Parse/Types.hs +++ b/src/Rlp/Parse/Types.hs @@ -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 diff --git a/src/Rlp/Parse/Utils.hs b/src/Rlp/Parse/Utils.hs deleted file mode 100644 index cf5fb8c..0000000 --- a/src/Rlp/Parse/Utils.hs +++ /dev/null @@ -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 -