mirror of
https://github.com/simonmichael/hledger.git
synced 2024-09-20 10:47:29 +03:00
131 lines
3.7 KiB
Haskell
131 lines
3.7 KiB
Haskell
{-# LANGUAGE FlexibleContexts #-}
|
|
{-# LANGUAGE TypeFamilies #-}
|
|
|
|
module Hledger.Utils.Parse (
|
|
SimpleStringParser,
|
|
SimpleTextParser,
|
|
TextParser,
|
|
JournalParser,
|
|
ErroringJournalParser,
|
|
|
|
choice',
|
|
choiceInState,
|
|
surroundedBy,
|
|
parsewith,
|
|
parsewithString,
|
|
parseWithState,
|
|
parseWithState',
|
|
fromparse,
|
|
parseerror,
|
|
showDateParseError,
|
|
nonspace,
|
|
isNonNewlineSpace,
|
|
spacenonewline,
|
|
restofline,
|
|
eolof,
|
|
|
|
-- * re-exports
|
|
CustomErr
|
|
)
|
|
where
|
|
|
|
import Control.Monad.Except (ExceptT)
|
|
import Control.Monad.State.Strict (StateT, evalStateT)
|
|
import Data.Char
|
|
import Data.Functor.Identity (Identity(..))
|
|
import Data.List
|
|
import Data.Text (Text)
|
|
import Text.Megaparsec
|
|
import Text.Megaparsec.Char
|
|
import Text.Megaparsec.Custom
|
|
import Text.Printf
|
|
|
|
import Hledger.Data.Types
|
|
import Hledger.Utils.UTF8IOCompat (error')
|
|
|
|
-- | A parser of string to some type.
|
|
type SimpleStringParser a = Parsec CustomErr String a
|
|
|
|
-- | A parser of strict text to some type.
|
|
type SimpleTextParser = Parsec CustomErr Text -- XXX an "a" argument breaks the CsvRulesParser declaration somehow
|
|
|
|
-- | A parser of text in some monad.
|
|
type TextParser m a = ParsecT CustomErr Text m a
|
|
|
|
-- | A parser of text in some monad, with a journal as state.
|
|
type JournalParser m a = StateT Journal (ParsecT CustomErr Text m) a
|
|
|
|
-- | A parser of text in some monad, with a journal as state, that can throw a
|
|
-- "final" parse error that does not backtrack.
|
|
type ErroringJournalParser m a =
|
|
StateT Journal (ParsecT CustomErr Text (ExceptT FinalParseError m)) a
|
|
|
|
-- | Backtracking choice, use this when alternatives share a prefix.
|
|
-- Consumes no input if all choices fail.
|
|
choice' :: [TextParser m a] -> TextParser m a
|
|
choice' = choice . map try
|
|
|
|
-- | Backtracking choice, use this when alternatives share a prefix.
|
|
-- Consumes no input if all choices fail.
|
|
choiceInState :: [StateT s (ParsecT CustomErr Text m) a] -> StateT s (ParsecT CustomErr Text m) a
|
|
choiceInState = choice . map try
|
|
|
|
surroundedBy :: Applicative m => m openclose -> m a -> m a
|
|
surroundedBy p = between p p
|
|
|
|
parsewith :: Parsec e Text a -> Text -> Either (ParseErrorBundle Text e) a
|
|
parsewith p = runParser p ""
|
|
|
|
parsewithString
|
|
:: Parsec e String a -> String -> Either (ParseErrorBundle String e) a
|
|
parsewithString p = runParser p ""
|
|
|
|
-- | Run a stateful parser with some initial state on a text.
|
|
-- See also: runTextParser, runJournalParser.
|
|
parseWithState
|
|
:: Monad m
|
|
=> st
|
|
-> StateT st (ParsecT CustomErr Text m) a
|
|
-> Text
|
|
-> m (Either (ParseErrorBundle Text CustomErr) a)
|
|
parseWithState ctx p s = runParserT (evalStateT p ctx) "" s
|
|
|
|
parseWithState'
|
|
:: (Stream s)
|
|
=> st
|
|
-> StateT st (ParsecT e s Identity) a
|
|
-> s
|
|
-> (Either (ParseErrorBundle s e) a)
|
|
parseWithState' ctx p s = runParser (evalStateT p ctx) "" s
|
|
|
|
fromparse
|
|
:: (Show t, Show (Token t), Show e) => Either (ParseErrorBundle t e) a -> a
|
|
fromparse = either parseerror id
|
|
|
|
parseerror :: (Show t, Show (Token t), Show e) => ParseErrorBundle t e -> a
|
|
parseerror e = error' $ showParseError e
|
|
|
|
showParseError
|
|
:: (Show t, Show (Token t), Show e)
|
|
=> ParseErrorBundle t e -> String
|
|
showParseError e = "parse error at " ++ show e
|
|
|
|
showDateParseError
|
|
:: (Show t, Show (Token t), Show e) => ParseErrorBundle t e -> String
|
|
showDateParseError e = printf "date parse error (%s)" (intercalate ", " $ tail $ lines $ show e)
|
|
|
|
nonspace :: TextParser m Char
|
|
nonspace = satisfy (not . isSpace)
|
|
|
|
isNonNewlineSpace :: Char -> Bool
|
|
isNonNewlineSpace c = c /= '\n' && isSpace c
|
|
|
|
spacenonewline :: (Stream s, Char ~ Token s) => ParsecT CustomErr s m Char
|
|
spacenonewline = satisfy isNonNewlineSpace
|
|
|
|
restofline :: TextParser m String
|
|
restofline = anySingle `manyTill` newline
|
|
|
|
eolof :: TextParser m ()
|
|
eolof = (newline >> return ()) <|> eof
|