{- | This module used to define a "subparsing" monad but this was later
absorbed into OrgState. Maybe I should move its contents elsewhere.
-}
module Org.Parser.MarkupContexts where

import Data.Set (notMember)
import Data.Text qualified as T
import Org.Parser.Common
import Org.Parser.Definitions

skipManyTill' ::
  forall skip end m.
  MonadParser m =>
  m skip ->
  m end ->
  m (Text, end)
skipManyTill' :: forall skip end (m :: * -> *).
MonadParser m =>
m skip -> m end -> m (Text, end)
skipManyTill' m skip
skip m end
end = forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try forall a b. (a -> b) -> a -> b
$ do
  Int
o0 <- forall e s (m :: * -> *). MonadParsec e s m => m Int
getOffset
  Text
s0 <- forall e s (m :: * -> *). MonadParsec e s m => m s
getInput
  -- note: skipManyTill tries end parser first
  (Int
o1, end
final) <- forall (m :: * -> *) a end. MonadPlus m => m a -> m end -> m end
skipManyTill m skip
skip (forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (,) forall e s (m :: * -> *). MonadParsec e s m => m Int
getOffset m end
end)
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int -> Text -> Text
T.take (Int
o1 forall a. Num a => a -> a -> a
- Int
o0) Text
s0, end
final)
{-# INLINEABLE skipManyTill' #-}

findSkipping ::
  forall end.
  (Char -> Bool) ->
  OrgParser end ->
  OrgParser (Text, end)
findSkipping :: forall end.
(Char -> Bool) -> OrgParser end -> OrgParser (Text, end)
findSkipping Char -> Bool
skip = forall skip end (m :: * -> *).
MonadParser m =>
m skip -> m end -> m (Text, end)
skipManyTill' OrgParser (Tokens Text)
toSkip
  where
    toSkip :: OrgParser (Tokens Text)
toSkip = forall e s (m :: * -> *). MonadParsec e s m => m (Token s)
anySingle forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe String -> (Token s -> Bool) -> m (Tokens s)
takeWhileP forall a. Maybe a
Nothing Char -> Bool
skip
{-# INLINEABLE findSkipping #-}

withContext__ ::
  forall a end skip.
  OrgParser skip ->
  OrgParser end ->
  OrgParser a ->
  OrgParser (a, end, Text)
withContext__ :: forall a end skip.
OrgParser skip
-> OrgParser end -> OrgParser a -> OrgParser (a, end, Text)
withContext__ OrgParser skip
skip OrgParser end
end OrgParser a
p = forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try do
  OrgParser ()
clearLastChar
  FullState
st <- OrgParser FullState
getFullState
  (Text
str, end
final) <- forall skip end (m :: * -> *).
MonadParser m =>
m skip -> m end -> m (Text, end)
skipManyTill' OrgParser skip
skip OrgParser end
end
  forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ Text -> Bool
T.null Text
str)
  (,end
final,Text
str) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall b. FullState -> Text -> OrgParser b -> OrgParser b
parseFromText FullState
st Text
str OrgParser a
p
{-# INLINEABLE withContext__ #-}

withContext_ ::
  forall a end skip.
  OrgParser skip ->
  OrgParser end ->
  OrgParser a ->
  OrgParser (a, end)
withContext_ :: forall a end skip.
OrgParser skip
-> OrgParser end -> OrgParser a -> OrgParser (a, end)
withContext_ OrgParser skip
skip OrgParser end
end OrgParser a
p =
  forall a end skip.
OrgParser skip
-> OrgParser end -> OrgParser a -> OrgParser (a, end, Text)
withContext__ OrgParser skip
skip OrgParser end
end OrgParser a
p forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \(a
x, end
y, Text
_) -> (a
x, end
y)
{-# INLINEABLE withContext_ #-}

withContext ::
  forall a end skip.
  OrgParser skip ->
  OrgParser end ->
  OrgParser a ->
  OrgParser a
withContext :: forall a end skip.
OrgParser skip -> OrgParser end -> OrgParser a -> OrgParser a
withContext OrgParser skip
skip OrgParser end
end = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a end skip.
OrgParser skip
-> OrgParser end -> OrgParser a -> OrgParser (a, end)
withContext_ OrgParser skip
skip OrgParser end
end
{-# INLINEABLE withContext #-}

withMContext ::
  forall a b.
  (Char -> Bool) ->
  (Char -> Bool) ->
  OrgParser b ->
  OrgParser a ->
  OrgParser a
withMContext :: forall a b.
(Char -> Bool)
-> (Char -> Bool) -> OrgParser b -> OrgParser a -> OrgParser a
withMContext Char -> Bool
allowed Char -> Bool
skip OrgParser b
end OrgParser a
p = forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try do
  OrgParser ()
clearLastChar
  FullState
st <- OrgParser FullState
getFullState
  Text
prelim <- forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe String -> (Token s -> Bool) -> m (Tokens s)
takeWhileP forall a. Maybe a
Nothing \Token Text
c -> Char -> Bool
skip Token Text
c Bool -> Bool -> Bool
&& Char -> Bool
allowed Token Text
c
  ((Text
prelim forall a. Semigroup a => a -> a -> a
<>) -> Text
str, b
_) <- forall skip end (m :: * -> *).
MonadParser m =>
m skip -> m end -> m (Text, end)
skipManyTill' OrgParser (Tokens Text)
toSkip OrgParser b
end
  forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ Text -> Bool
T.null Text
str)
  forall b. FullState -> Text -> OrgParser b -> OrgParser b
parseFromText FullState
st Text
str OrgParser a
p
  where
    toSkip :: OrgParser (Tokens Text)
toSkip = forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Token s)
satisfy Char -> Bool
allowed forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe String -> (Token s -> Bool) -> m (Tokens s)
takeWhileP forall a. Maybe a
Nothing \Token Text
c -> Char -> Bool
skip Token Text
c Bool -> Bool -> Bool
&& Char -> Bool
allowed Token Text
c
{-# INLINEABLE withMContext #-}

withBalancedContext ::
  Char ->
  Char ->
  -- | Allowed
  (Char -> Bool) ->
  OrgParser a ->
  OrgParser a
withBalancedContext :: forall a.
Char -> Char -> (Char -> Bool) -> OrgParser a -> OrgParser a
withBalancedContext Char
lchar Char
rchar Char -> Bool
allowed OrgParser a
p = forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try do
  Token Text
_ <- forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
lchar
  let skip :: StateT Int OrgParser ()
      skip :: StateT Int OrgParser ()
skip = do
        Tokens Text
_ <-
          forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe String -> (Token s -> Bool) -> m (Tokens s)
takeWhileP
            (forall a. a -> Maybe a
Just String
"insides of markup")
            (\Token Text
c -> Char -> Bool
allowed Token Text
c Bool -> Bool -> Bool
&& Token Text
c forall a. Eq a => a -> a -> Bool
/= Char
lchar Bool -> Bool -> Bool
&& Token Text
c forall a. Eq a => a -> a -> Bool
/= Char
rchar)
        Char
c <- forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
lookAhead (forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Token s)
satisfy Char -> Bool
allowed) forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> String -> m a
<?> String
"balanced delimiters"
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Char
c forall a. Eq a => a -> a -> Bool
== Char
lchar) forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (forall a. Num a => a -> a -> a
+ Int
1)
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Char
c forall a. Eq a => a -> a -> Bool
== Char
rchar) forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (forall a. Num a => a -> a -> a
subtract Int
1)
        forall s (m :: * -> *). MonadState s m => m s
get forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          Int
balance
            | Int
balance forall a. Ord a => a -> a -> Bool
< Int
0 -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"unbalaced delimiters"
            | Int
balance forall a. Eq a => a -> a -> Bool
== Int
0 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
            | Bool
otherwise -> forall (f :: * -> *) a. Functor f => f a -> f ()
void forall e s (m :: * -> *). MonadParsec e s m => m (Token s)
anySingle
      end :: StateT Int OrgParser ()
end = forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try do
        forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Eq a => a -> a -> Bool
== Int
0) forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall s (m :: * -> *). MonadState s m => m s
get
        Token Text
_ <- forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
rchar
        forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ Char -> OrgParser ()
putLastChar Char
rchar
  FullState
st <- OrgParser FullState
getFullState
  (Text
str, ()
_) <- forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT (forall skip end (m :: * -> *).
MonadParser m =>
m skip -> m end -> m (Text, end)
skipManyTill' StateT Int OrgParser ()
skip StateT Int OrgParser ()
end) Int
1
  forall b. FullState -> Text -> OrgParser b -> OrgParser b
parseFromText FullState
st Text
str OrgParser a
p

{- | Parse inside a "context": text that is not captured by the parser `elems`
   gets converted to the type `k` via the function `f`.
-}
markupContext ::
  Monoid k =>
  (Text -> k) ->
  Marked OrgParser k ->
  OrgParser k
markupContext :: forall k.
Monoid k =>
(Text -> k) -> Marked OrgParser k -> OrgParser k
markupContext Text -> k
f Marked OrgParser k
elems = OrgParser k
go
  where
    go :: OrgParser k
go = forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try forall a b. (a -> b) -> a -> b
$ do
      let Set Char
specials :: Set Char = forall l. IsList l => [Item l] -> l
fromList forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Marked m a -> String
getMarks Marked OrgParser k
elems
      Maybe Text
str <-
        forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional forall a b. (a -> b) -> a -> b
$
          forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe String -> (Token s -> Bool) -> m (Tokens s)
takeWhile1P
            forall a. Maybe a
Nothing
            (forall a. Ord a => a -> Set a -> Bool
`notMember` Set Char
specials)
      -- traceM $ "consumed: " ++ show str
      let self :: k
self = forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Monoid a => a
mempty Text -> k
f Maybe Text
str
      Maybe Char -> OrgParser ()
setLastChar (Text -> Char
T.last forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text
str)
      (k
self forall a. Semigroup a => a -> a -> a
<>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (OrgParser k
finishSelf forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> OrgParser k
anotherEl forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> OrgParser k
nextChar)
      where
        finishSelf :: OrgParser k
finishSelf = forall e s (m :: * -> *). MonadParsec e s m => m ()
eof forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> forall a. Monoid a => a
mempty
        anotherEl :: OrgParser k
anotherEl = forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try forall a b. (a -> b) -> a -> b
$ do
          k
el <- forall (m :: * -> *) a. Marked m a -> m a
getParser Marked OrgParser k
elems
          k
rest <- OrgParser k
go
          forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ k
el forall a. Semigroup a => a -> a -> a
<> k
rest
        nextChar :: OrgParser k
nextChar = forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try forall a b. (a -> b) -> a -> b
$ do
          Char
c <- forall e s (m :: * -> *). MonadParsec e s m => m (Token s)
anySingle
          -- traceM $ "parsed char: " ++ show c
          Char -> OrgParser ()
putLastChar Char
c
          k
rest <- OrgParser k
go
          forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Text -> k
f (forall x. One x => OneItem x -> x
one Char
c) forall a. Semigroup a => a -> a -> a
<> k
rest