mirror of
https://github.com/simonmichael/hledger.git
synced 2024-09-19 18:29:36 +03:00
4cfd3cb590
(SourcePos, SourcePos). This has been marked for possible removal for a while. We are keeping strictly more information. Possible edge cases arise with Timeclock and CsvReader, but I think these are covered. The particular motivation for getting rid of this is that GenericSourcePos is creating some awkward import considerations for little gain. Removing this enables some flattening of the module dependency tree.
172 lines
5.0 KiB
Haskell
172 lines
5.0 KiB
Haskell
{-# LANGUAGE FlexibleContexts #-}
|
|
{-# LANGUAGE TypeFamilies #-}
|
|
|
|
module Hledger.Utils.Parse (
|
|
SimpleStringParser,
|
|
SimpleTextParser,
|
|
TextParser,
|
|
|
|
SourcePos(..),
|
|
mkPos,
|
|
unPos,
|
|
initialPos,
|
|
|
|
-- * SourcePos
|
|
showSourcePosPair,
|
|
showSourcePos,
|
|
|
|
choice',
|
|
choiceInState,
|
|
surroundedBy,
|
|
parsewith,
|
|
runTextParser,
|
|
rtp,
|
|
parsewithString,
|
|
parseWithState,
|
|
parseWithState',
|
|
fromparse,
|
|
parseerror,
|
|
showDateParseError,
|
|
nonspace,
|
|
isNewline,
|
|
isNonNewlineSpace,
|
|
restofline,
|
|
eolof,
|
|
|
|
spacenonewline,
|
|
skipNonNewlineSpaces,
|
|
skipNonNewlineSpaces1,
|
|
skipNonNewlineSpaces',
|
|
|
|
-- * re-exports
|
|
CustomErr
|
|
)
|
|
where
|
|
|
|
import Control.Monad.State.Strict (StateT, evalStateT)
|
|
import Data.Char
|
|
import Data.Functor (void)
|
|
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
|
|
|
|
-- | 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 that runs in some monad.
|
|
type TextParser m a = ParsecT CustomErr Text m a
|
|
|
|
-- | Render source position in human-readable form.
|
|
showSourcePos :: SourcePos -> String
|
|
showSourcePos (SourcePos fp l c) =
|
|
show fp ++ " (line " ++ show (unPos l) ++ ", column " ++ show (unPos c) ++ ")"
|
|
|
|
-- | Render a pair of source position in human-readable form.
|
|
showSourcePosPair :: (SourcePos, SourcePos) -> String
|
|
showSourcePosPair (SourcePos fp l1 _, SourcePos _ l2 c2) =
|
|
show fp ++ " (lines " ++ show (unPos l1) ++ "-" ++ show l2' ++ ")"
|
|
where l2' = if unPos c2 == 1 then unPos l2 - 1 else unPos l2 -- might be at end of file withat last new-line
|
|
|
|
-- | 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 ""
|
|
|
|
-- | Run a text parser in the identity monad. See also: parseWithState.
|
|
runTextParser, rtp
|
|
:: TextParser Identity a -> Text -> Either (ParseErrorBundle Text CustomErr) a
|
|
runTextParser = parsewith
|
|
rtp = runTextParser
|
|
|
|
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 = runParserT (evalStateT p ctx) ""
|
|
|
|
parseWithState'
|
|
:: (Stream s)
|
|
=> st
|
|
-> StateT st (ParsecT e s Identity) a
|
|
-> s
|
|
-> (Either (ParseErrorBundle s e) a)
|
|
parseWithState' ctx p = runParser (evalStateT p ctx) ""
|
|
|
|
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 = errorWithoutStackTrace $ showParseError e -- PARTIAL:
|
|
|
|
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)
|
|
|
|
isNewline :: Char -> Bool
|
|
isNewline '\n' = True
|
|
isNewline _ = False
|
|
|
|
nonspace :: TextParser m Char
|
|
nonspace = satisfy (not . isSpace)
|
|
|
|
isNonNewlineSpace :: Char -> Bool
|
|
isNonNewlineSpace c = not (isNewline c) && isSpace c
|
|
|
|
spacenonewline :: (Stream s, Char ~ Token s) => ParsecT CustomErr s m Char
|
|
spacenonewline = satisfy isNonNewlineSpace
|
|
{-# INLINABLE spacenonewline #-}
|
|
|
|
restofline :: TextParser m String
|
|
restofline = anySingle `manyTill` eolof
|
|
|
|
-- Skip many non-newline spaces.
|
|
skipNonNewlineSpaces :: (Stream s, Token s ~ Char) => ParsecT CustomErr s m ()
|
|
skipNonNewlineSpaces = () <$ takeWhileP Nothing isNonNewlineSpace
|
|
{-# INLINABLE skipNonNewlineSpaces #-}
|
|
|
|
-- Skip many non-newline spaces, failing if there are none.
|
|
skipNonNewlineSpaces1 :: (Stream s, Token s ~ Char) => ParsecT CustomErr s m ()
|
|
skipNonNewlineSpaces1 = () <$ takeWhile1P Nothing isNonNewlineSpace
|
|
{-# INLINABLE skipNonNewlineSpaces1 #-}
|
|
|
|
-- Skip many non-newline spaces, returning True if any have been skipped.
|
|
skipNonNewlineSpaces' :: (Stream s, Token s ~ Char) => ParsecT CustomErr s m Bool
|
|
skipNonNewlineSpaces' = True <$ skipNonNewlineSpaces1 <|> pure False
|
|
{-# INLINABLE skipNonNewlineSpaces' #-}
|
|
|
|
|
|
eolof :: TextParser m ()
|
|
eolof = void newline <|> eof
|