module Org.Parser.Common where

import Data.Char (digitToInt, isAsciiLower, isAsciiUpper)
import Data.Text qualified as T
import Org.Parser.Definitions
import Prelude hiding (State, many, some)

-- | Read the start of a header line, return the header level
headingStart :: OrgParser Int
headingStart :: OrgParser Int
headingStart =
  forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try forall a b. (a -> b) -> a -> b
$
    (Text -> Int
T.length forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe String -> (Token s -> Bool) -> m (Tokens s)
takeWhile1P (forall a. a -> Maybe a
Just String
"heading bullets") (forall a. Eq a => a -> a -> Bool
== Char
'*'))
      forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
' '
      forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall (m :: * -> *). MonadParser m => m Text
skipSpaces

parseTime :: OrgParser Time
parseTime :: OrgParser Time
parseTime = do
  Int
hour <- (Int -> OrgParser Int
number Int
2 forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Int -> OrgParser Int
number Int
1) forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
':'
  Int
minute <- Int -> OrgParser Int
number Int
2
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
hour, Int
minute)

-- | The same as 'string'', but cheaper (?)
string'' :: MonadParser m => Text -> m Text
string'' :: forall (m :: * -> *). MonadParser m => Text -> m Text
string'' = forall e s (m :: * -> *).
MonadParsec e s m =>
(Tokens s -> Tokens s -> Bool) -> Tokens s -> m (Tokens s)
tokens (forall a. Eq a => a -> a -> Bool
(==) forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` Text -> Text
T.toLower)
{-# INLINE string'' #-}

digitIntChar :: MonadParser m => m Int
digitIntChar :: forall (m :: * -> *). MonadParser m => m Int
digitIntChar = Char -> Int
digitToInt forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
digitChar

digits :: MonadParser m => m Text
digits :: forall (m :: * -> *). MonadParser m => m Text
digits = forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe String -> (Token s -> Bool) -> m (Tokens s)
takeWhileP (forall a. a -> Maybe a
Just String
"digits") Char -> Bool
isDigit

digits1 :: MonadParser m => m Text
digits1 :: forall (m :: * -> *). MonadParser m => m Text
digits1 = forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe String -> (Token s -> Bool) -> m (Tokens s)
takeWhile1P (forall a. a -> Maybe a
Just String
"digits") Char -> Bool
isDigit

integer :: MonadParser m => m Int
integer :: forall (m :: * -> *). MonadParser m => m Int
integer = forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try forall a b. (a -> b) -> a -> b
$ do
  [Int]
digits' <- forall a. [a] -> [a]
reverse forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
some forall (m :: * -> *). MonadParser m => m Int
digitIntChar
  let toInt :: [a] -> a
toInt (a
x : [a]
xs) = a
10 forall a. Num a => a -> a -> a
* [a] -> a
toInt [a]
xs forall a. Num a => a -> a -> a
+ a
x
      toInt [] = a
0
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall {a}. Num a => [a] -> a
toInt [Int]
digits'

number ::
  Int ->
  OrgParser Int
number :: Int -> OrgParser Int
number Int
1 = forall (m :: * -> *). MonadParser m => m Int
digitIntChar
number Int
n | Int
n forall a. Ord a => a -> a -> Bool
> Int
1 = forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try forall a b. (a -> b) -> a -> b
$ do
  Int
d <- forall (m :: * -> *). MonadParser m => m Int
digitIntChar
  (Int
10 forall a b. (Num a, Integral b) => a -> b -> a
^ (Int
n forall a. Num a => a -> a -> a
- Int
1) forall a. Num a => a -> a -> a
* Int
d forall a. Num a => a -> a -> a
+) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> OrgParser Int
number (Int
n forall a. Num a => a -> a -> a
- Int
1)
number Int
_ = forall a t. (HasCallStack, IsText t) => t -> a
error Text
"Number of digits to parse must be positive!"

-- * ASCII alphabet character classes

isAsciiAlpha :: Char -> Bool
isAsciiAlpha :: Char -> Bool
isAsciiAlpha Char
c = Char -> Bool
isAsciiLower Char
c Bool -> Bool -> Bool
|| Char -> Bool
isAsciiUpper Char
c

upperAscii' :: MonadParser m => m Int
upperAscii' :: forall (m :: * -> *). MonadParser m => m Int
upperAscii' = do
  Char
c <- forall (m :: * -> *). MonadParser m => m Char
upperAscii
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Char -> Int
ord Char
c forall a. Num a => a -> a -> a
- Char -> Int
ord Char
'A' forall a. Num a => a -> a -> a
+ Int
1

lowerAscii' :: MonadParser m => m Int
lowerAscii' :: forall (m :: * -> *). MonadParser m => m Int
lowerAscii' = do
  Char
c <- forall (m :: * -> *). MonadParser m => m Char
lowerAscii
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Char -> Int
ord Char
c forall a. Num a => a -> a -> a
- Char -> Int
ord Char
'a' forall a. Num a => a -> a -> a
+ Int
1

asciiAlpha' :: MonadParser m => m Int
asciiAlpha' :: forall (m :: * -> *). MonadParser m => m Int
asciiAlpha' = forall (m :: * -> *). MonadParser m => m Int
lowerAscii' forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (m :: * -> *). MonadParser m => m Int
upperAscii'

upperAscii :: MonadParser m => m Char
upperAscii :: forall (m :: * -> *). MonadParser m => m Char
upperAscii =
  forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Token s)
satisfy Char -> Bool
isAsciiUpper
    forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> String -> m a
<?> String
"uppercase A-Z character"

lowerAscii :: MonadParser m => m Char
lowerAscii :: forall (m :: * -> *). MonadParser m => m Char
lowerAscii =
  forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Token s)
satisfy Char -> Bool
isAsciiLower
    forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> String -> m a
<?> String
"lowercase a-z character"

asciiAlpha :: MonadParser m => m Char
asciiAlpha :: forall (m :: * -> *). MonadParser m => m Char
asciiAlpha =
  forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Token s)
satisfy Char -> Bool
isAsciiAlpha
    forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> String -> m a
<?> String
"a-z or A-Z character"

manyAsciiAlpha :: OrgParser Text
manyAsciiAlpha :: OrgParser Text
manyAsciiAlpha =
  forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe String -> (Token s -> Bool) -> m (Tokens s)
takeWhileP
    (forall a. a -> Maybe a
Just String
"a-z or A-Z characters")
    Char -> Bool
isAsciiAlpha

someAsciiAlpha :: MonadParser m => m Text
someAsciiAlpha :: forall (m :: * -> *). MonadParser m => m Text
someAsciiAlpha =
  forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe String -> (Token s -> Bool) -> m (Tokens s)
takeWhile1P
    (forall a. a -> Maybe a
Just String
"a-z or A-Z characters")
    Char -> Bool
isAsciiAlpha

someNonSpace :: OrgParser Text
someNonSpace :: OrgParser Text
someNonSpace = forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe String -> (Token s -> Bool) -> m (Tokens s)
takeWhile1P (forall a. a -> Maybe a
Just String
"not whitespace") (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isSpace)

isSpaceOrTab :: Char -> Bool
isSpaceOrTab :: Char -> Bool
isSpaceOrTab Char
c = Char
c forall a. Eq a => a -> a -> Bool
== Char
' ' Bool -> Bool -> Bool
|| Char
c forall a. Eq a => a -> a -> Bool
== Char
'\t'

spaceOrTab :: OrgParser Char
spaceOrTab :: OrgParser Char
spaceOrTab = forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Token s)
satisfy Char -> Bool
isSpaceOrTab forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> String -> m a
<?> String
"space or tab character"

countSpaces :: Int -> Text -> Int
countSpaces :: Int -> Text -> Int
countSpaces Int
tabWidth = forall a. (Char -> a -> a) -> a -> Text -> a
T.foldr Char -> Int -> Int
go Int
0
  where
    go :: Char -> Int -> Int
go Char
' ' = (forall a. Num a => a -> a -> a
+ Int
1)
    go Char
'\t' = (forall a. Num a => a -> a -> a
+ Int
tabWidth)
    go Char
_ = forall a. a -> a
id

spacesOrTabs :: OrgParser Int
spacesOrTabs :: OrgParser Int
spacesOrTabs = do
  Int
tw <- forall a. (OrgOptions -> a) -> OrgParser a
getsO OrgOptions -> Int
orgSrcTabWidth
  Int -> Text -> Int
countSpaces Int
tw forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). MonadParser m => m Text
skipSpaces

spacesOrTabs1 :: OrgParser Int
spacesOrTabs1 :: OrgParser Int
spacesOrTabs1 = do
  Int
tw <- forall a. (OrgOptions -> a) -> OrgParser a
getsO OrgOptions -> Int
orgSrcTabWidth
  Int -> Text -> Int
countSpaces Int
tw forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). MonadParser m => m Text
skipSpaces1

-- | Skips one or more spaces or tabs.
skipSpaces1 :: MonadParser m => m Text
skipSpaces1 :: forall (m :: * -> *). MonadParser m => m Text
skipSpaces1 = forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe String -> (Token s -> Bool) -> m (Tokens s)
takeWhile1P (forall a. a -> Maybe a
Just String
"at least one space or tab whitespace") Char -> Bool
isSpaceOrTab

-- | Skips zero or more spaces or tabs.
skipSpaces :: MonadParser m => m Text
skipSpaces :: forall (m :: * -> *). MonadParser m => m Text
skipSpaces = forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe String -> (Token s -> Bool) -> m (Tokens s)
takeWhileP (forall a. a -> Maybe a
Just String
"spaces or tabs") Char -> Bool
isSpaceOrTab

-- | Makes sure a value is Just, else fail with a custom
-- error message.
guardMaybe :: (MonadFail m, MonadParser m) => String -> Maybe a -> m a
guardMaybe :: forall (m :: * -> *) a.
(MonadFail m, MonadParser m) =>
String -> Maybe a -> m a
guardMaybe String
_ (Just a
x) = forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x
guardMaybe String
err Maybe a
_ = forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
err

-- | Parse a newline or EOF. Consumes no input at EOF!
newline' :: MonadParser m => m ()
newline' :: forall (m :: * -> *). MonadParser m => m ()
newline' = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
newline forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall e s (m :: * -> *). MonadParsec e s m => m ()
eof

-- | Parse the rest of line, returning the contents without the final newline.
anyLine :: MonadParser m => m (Tokens Text)
anyLine :: forall (m :: * -> *). MonadParser m => m (Tokens Text)
anyLine =
  forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe String -> (Token s -> Bool) -> m (Tokens s)
takeWhileP (forall a. a -> Maybe a
Just String
"rest of line") (forall a. Eq a => a -> a -> Bool
/= Char
'\n')
    forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
newline
{-# INLINE anyLine #-}

-- | Parse the rest of line, returning the contents without the final newline or EOF.
-- Consumes no input at EOF!
anyLine' :: MonadParser m => m (Tokens Text)
anyLine' :: forall (m :: * -> *). MonadParser m => m (Tokens Text)
anyLine' =
  forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe String -> (Token s -> Bool) -> m (Tokens s)
takeWhileP (forall a. a -> Maybe a
Just String
"rest of line") (forall a. Eq a => a -> a -> Bool
/= Char
'\n')
    forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall (m :: * -> *). MonadParser m => m ()
newline'

-- | Consumes the rest of input
takeInput :: MonadParser m => m Text
takeInput :: forall (m :: * -> *). MonadParser m => m Text
takeInput = forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe String -> (Token s -> Bool) -> m (Tokens s)
takeWhileP forall a. Maybe a
Nothing (forall a b. a -> b -> a
const Bool
True)

-- | Parse a line with whitespace contents, and consume a newline at the end.
blankline :: MonadParser m => m ()
blankline :: forall (m :: * -> *). MonadParser m => m ()
blankline = forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try forall a b. (a -> b) -> a -> b
$ forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
hspace forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
newline

-- | Parse a line with whitespace contents, line may end with EOF. CAUTION: this
-- function may consume NO INPUT! Be mindful of infinite loops!
blankline' :: MonadParser m => m ()
blankline' :: forall (m :: * -> *). MonadParser m => m ()
blankline' = forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try forall a b. (a -> b) -> a -> b
$ forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
hspace forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall (m :: * -> *). MonadParser m => m ()
newline'

parseFromText :: FullState -> Text -> OrgParser b -> OrgParser b
parseFromText :: forall b. FullState -> Text -> OrgParser b -> OrgParser b
parseFromText (State Text Void
prevPS, OrgParserState
prevOS) Text
txt OrgParser b
parser = do
  (State Text Void
cPS, OrgParserState
cOS) <- OrgParser FullState
getFullState
  FullState -> OrgParser ()
setFullState
    ( State Text Void
prevPS {stateInput :: Text
stateInput = Text
txt},
      -- NOTE: using cOS instead of prevOS
      -- is an implementation quirk. We
      -- don't want neither the changes of
      -- state done by the end parser in
      -- markupContext nor the ones in the
      -- fromText parser to be lost. But
      -- this will have the effect of
      -- commuting the change of state: the
      -- end changes will be registered
      -- before the body ones. This is not a
      -- problem because most of state
      -- building is commutative and most
      -- querying is done in Future anyway.
      -- The problematic ones are either
      -- irrelevant to a paragraph (like the
      -- order in which title keywords are
      -- concatenated) or must be handled
      -- manually like affiliated keywords.
      OrgParserState
cOS
        { orgStateLastChar :: Maybe Char
orgStateLastChar = OrgParserState -> Maybe Char
orgStateLastChar OrgParserState
prevOS
        }
    )
  b
result <- OrgParser b
parser
  (State Text Void
aPS, OrgParserState
aOS) <- OrgParser FullState
getFullState
  FullState -> OrgParser ()
setFullState
    ( State Text Void
cPS
        { stateParseErrors :: [ParseError Text Void]
stateParseErrors =
            forall s e. State s e -> [ParseError s e]
stateParseErrors State Text Void
cPS
              forall a. [a] -> [a] -> [a]
++ forall s e. State s e -> [ParseError s e]
stateParseErrors State Text Void
aPS
        },
      OrgParserState
aOS
        { orgStateLastChar :: Maybe Char
orgStateLastChar =
            OrgParserState -> Maybe Char
orgStateLastChar OrgParserState
cOS
        }
    )
  forall (f :: * -> *) a. Applicative f => a -> f a
pure b
result