-- SPDX-FileCopyrightText: 2022 Serokell <https://serokell.io/>
--
-- SPDX-License-Identifier: MPL-2.0

module Text.Interpolation.Nyan.Core.Internal.Parser where

import Control.Applicative (many)
import Control.Monad (guard, when, (<=<))
import Control.Monad.State (MonadState, execStateT, get, put)
import Data.Bifunctor (first)
import Data.Char (isAlphaNum, isSpace)
import Data.Foldable (asum)
import Data.Functor (($>))
import Data.Text (Text)
import qualified Data.Text as T
import Fmt (Builder, build, fmt)
import Text.Interpolation.Nyan.Core.Internal.Base
import Text.Megaparsec (Parsec, customFailure, eof, errorBundlePretty, label, lookAhead, parse,
                        single, takeWhile1P, takeWhileP)
import Text.Megaparsec.Error (ShowErrorComponent (..))

newtype OptionChanged = OptionChanged Bool
  deriving stock (Int -> OptionChanged -> ShowS
[OptionChanged] -> ShowS
OptionChanged -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [OptionChanged] -> ShowS
$cshowList :: [OptionChanged] -> ShowS
show :: OptionChanged -> String
$cshow :: OptionChanged -> String
showsPrec :: Int -> OptionChanged -> ShowS
$cshowsPrec :: Int -> OptionChanged -> ShowS
Show, OptionChanged -> OptionChanged -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: OptionChanged -> OptionChanged -> Bool
$c/= :: OptionChanged -> OptionChanged -> Bool
== :: OptionChanged -> OptionChanged -> Bool
$c== :: OptionChanged -> OptionChanged -> Bool
Eq)

-- | An accumulator for switch options during parsing.
data SwitchesOptionsBuilder = SwitchesOptionsBuilder
  { SwitchesOptionsBuilder -> (OptionChanged, Maybe Bool)
spacesTrimmingB          :: (OptionChanged, Maybe Bool)
  , SwitchesOptionsBuilder -> (OptionChanged, Maybe Bool)
indentationStrippingB    :: (OptionChanged, Maybe Bool)
  , SwitchesOptionsBuilder -> (OptionChanged, Maybe Bool)
leadingNewlineStrippingB :: (OptionChanged, Maybe Bool)
  , SwitchesOptionsBuilder -> (OptionChanged, Maybe Bool)
trailingSpacesStrippingB :: (OptionChanged, Maybe Bool)
  , SwitchesOptionsBuilder -> (OptionChanged, Maybe ReturnType)
returnTypeB              :: (OptionChanged, Maybe ReturnType)
  , SwitchesOptionsBuilder -> (OptionChanged, Maybe Bool)
reducedNewlinesB         :: (OptionChanged, Maybe Bool)
  , SwitchesOptionsBuilder -> (OptionChanged, Maybe Bool)
monadicB                 :: (OptionChanged, Maybe Bool)
  , SwitchesOptionsBuilder -> PreviewLevel
previewLevelB            :: PreviewLevel
  }

toSwitchesOptionsBuilder :: DefaultSwitchesOptions -> SwitchesOptionsBuilder
toSwitchesOptionsBuilder :: DefaultSwitchesOptions -> SwitchesOptionsBuilder
toSwitchesOptionsBuilder DefaultSwitchesOptions{Maybe Bool
Maybe ReturnType
defMonadic :: DefaultSwitchesOptions -> Maybe Bool
defReturnType :: DefaultSwitchesOptions -> Maybe ReturnType
defReducedNewlines :: DefaultSwitchesOptions -> Maybe Bool
defTrailingSpacesStripping :: DefaultSwitchesOptions -> Maybe Bool
defLeadingNewlineStripping :: DefaultSwitchesOptions -> Maybe Bool
defIndentationStripping :: DefaultSwitchesOptions -> Maybe Bool
defSpacesTrimming :: DefaultSwitchesOptions -> Maybe Bool
defMonadic :: Maybe Bool
defReturnType :: Maybe ReturnType
defReducedNewlines :: Maybe Bool
defTrailingSpacesStripping :: Maybe Bool
defLeadingNewlineStripping :: Maybe Bool
defIndentationStripping :: Maybe Bool
defSpacesTrimming :: Maybe Bool
..} =
  SwitchesOptionsBuilder
  { spacesTrimmingB :: (OptionChanged, Maybe Bool)
spacesTrimmingB = (Bool -> OptionChanged
OptionChanged Bool
False, Maybe Bool
defSpacesTrimming)
  , indentationStrippingB :: (OptionChanged, Maybe Bool)
indentationStrippingB = (Bool -> OptionChanged
OptionChanged Bool
False, Maybe Bool
defIndentationStripping)
  , leadingNewlineStrippingB :: (OptionChanged, Maybe Bool)
leadingNewlineStrippingB = (Bool -> OptionChanged
OptionChanged Bool
False, Maybe Bool
defLeadingNewlineStripping)
  , trailingSpacesStrippingB :: (OptionChanged, Maybe Bool)
trailingSpacesStrippingB = (Bool -> OptionChanged
OptionChanged Bool
False, Maybe Bool
defTrailingSpacesStripping)
  , returnTypeB :: (OptionChanged, Maybe ReturnType)
returnTypeB = (Bool -> OptionChanged
OptionChanged Bool
False, Maybe ReturnType
defReturnType)
  , reducedNewlinesB :: (OptionChanged, Maybe Bool)
reducedNewlinesB = (Bool -> OptionChanged
OptionChanged Bool
False, Maybe Bool
defMonadic)
  , monadicB :: (OptionChanged, Maybe Bool)
monadicB = (Bool -> OptionChanged
OptionChanged Bool
False, Maybe Bool
defMonadic)
  , previewLevelB :: PreviewLevel
previewLevelB = PreviewLevel
PreviewNone
  }

finalizeSwitchesOptions :: MonadFail m => SwitchesOptionsBuilder -> m SwitchesOptions
finalizeSwitchesOptions :: forall (m :: * -> *).
MonadFail m =>
SwitchesOptionsBuilder -> m SwitchesOptions
finalizeSwitchesOptions SwitchesOptionsBuilder{(OptionChanged, Maybe Bool)
(OptionChanged, Maybe ReturnType)
PreviewLevel
previewLevelB :: PreviewLevel
monadicB :: (OptionChanged, Maybe Bool)
reducedNewlinesB :: (OptionChanged, Maybe Bool)
returnTypeB :: (OptionChanged, Maybe ReturnType)
trailingSpacesStrippingB :: (OptionChanged, Maybe Bool)
leadingNewlineStrippingB :: (OptionChanged, Maybe Bool)
indentationStrippingB :: (OptionChanged, Maybe Bool)
spacesTrimmingB :: (OptionChanged, Maybe Bool)
previewLevelB :: SwitchesOptionsBuilder -> PreviewLevel
monadicB :: SwitchesOptionsBuilder -> (OptionChanged, Maybe Bool)
reducedNewlinesB :: SwitchesOptionsBuilder -> (OptionChanged, Maybe Bool)
returnTypeB :: SwitchesOptionsBuilder -> (OptionChanged, Maybe ReturnType)
trailingSpacesStrippingB :: SwitchesOptionsBuilder -> (OptionChanged, Maybe Bool)
leadingNewlineStrippingB :: SwitchesOptionsBuilder -> (OptionChanged, Maybe Bool)
indentationStrippingB :: SwitchesOptionsBuilder -> (OptionChanged, Maybe Bool)
spacesTrimmingB :: SwitchesOptionsBuilder -> (OptionChanged, Maybe Bool)
..} = do
  Bool
spacesTrimming <- forall {m :: * -> *} {a} {a}.
MonadFail m =>
String -> (a, Maybe a) -> m a
fromOptional String
"spaces trimming" (OptionChanged, Maybe Bool)
spacesTrimmingB
  Bool
indentationStripping <- forall {m :: * -> *} {a} {a}.
MonadFail m =>
String -> (a, Maybe a) -> m a
fromOptional String
"indentation stripping" (OptionChanged, Maybe Bool)
indentationStrippingB
  Bool
leadingNewlineStripping <- forall {m :: * -> *} {a} {a}.
MonadFail m =>
String -> (a, Maybe a) -> m a
fromOptional String
"leading newline stripping" (OptionChanged, Maybe Bool)
leadingNewlineStrippingB
  Bool
trailingSpacesStripping <- forall {m :: * -> *} {a} {a}.
MonadFail m =>
String -> (a, Maybe a) -> m a
fromOptional String
"trailing spaces stripping" (OptionChanged, Maybe Bool)
trailingSpacesStrippingB
  ReturnType
returnType <- forall {m :: * -> *} {a} {a}.
MonadFail m =>
String -> (a, Maybe a) -> m a
fromOptional String
"return type" (OptionChanged, Maybe ReturnType)
returnTypeB
  Bool
reducedNewlines <- forall {m :: * -> *} {a} {a}.
MonadFail m =>
String -> (a, Maybe a) -> m a
fromOptional String
"reduced newlines" (OptionChanged, Maybe Bool)
reducedNewlinesB
  Bool
monadic <- forall {m :: * -> *} {a} {a}.
MonadFail m =>
String -> (a, Maybe a) -> m a
fromOptional String
"monadic" (OptionChanged, Maybe Bool)
monadicB
  let previewLevel :: PreviewLevel
previewLevel = PreviewLevel
previewLevelB
  forall (m :: * -> *) a. Monad m => a -> m a
return SwitchesOptions{Bool
PreviewLevel
ReturnType
previewLevel :: PreviewLevel
monadic :: Bool
reducedNewlines :: Bool
returnType :: ReturnType
trailingSpacesStripping :: Bool
leadingNewlineStripping :: Bool
indentationStripping :: Bool
spacesTrimming :: Bool
previewLevel :: PreviewLevel
monadic :: Bool
reducedNewlines :: Bool
returnType :: ReturnType
trailingSpacesStripping :: Bool
leadingNewlineStripping :: Bool
indentationStripping :: Bool
spacesTrimming :: Bool
..}
  where
    fromOptional :: String -> (a, Maybe a) -> m a
fromOptional String
desc (a
_, Maybe a
mval) = case Maybe a
mval of
      Maybe a
Nothing  -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Switch for " forall a. Semigroup a => a -> a -> a
<> String
desc forall a. Semigroup a => a -> a -> a
<> String
" must be specified"
      Just a
val -> forall (f :: * -> *) a. Applicative f => a -> f a
pure a
val

type SwitchesOptionsSetter m = (MonadState SwitchesOptionsBuilder m, MonadFail m)

setIfNew
  :: (MonadFail m, Eq a)
  => String -> a -> (OptionChanged, Maybe a) -> m (OptionChanged, Maybe a)
setIfNew :: forall (m :: * -> *) a.
(MonadFail m, Eq a) =>
String
-> a -> (OptionChanged, Maybe a) -> m (OptionChanged, Maybe a)
setIfNew String
desc a
new (OptionChanged Bool
ch, Maybe a
old)
  | Bool
ch = forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Modifying `" forall a. Semigroup a => a -> a -> a
<> String
desc forall a. Semigroup a => a -> a -> a
<> String
"` option for the second time"
  | Maybe a
old forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just a
new = forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Switch option `" forall a. Semigroup a => a -> a -> a
<> String
desc forall a. Semigroup a => a -> a -> a
<> String
"` is set redundantly"
  | Bool
otherwise = forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> OptionChanged
OptionChanged Bool
True, forall a. a -> Maybe a
Just a
new)

setSpacesTrimming :: SwitchesOptionsSetter m => Bool -> m ()
setSpacesTrimming :: forall (m :: * -> *). SwitchesOptionsSetter m => Bool -> m ()
setSpacesTrimming Bool
enable = do
  SwitchesOptionsBuilder
opts <- forall s (m :: * -> *). MonadState s m => m s
get
  (OptionChanged, Maybe Bool)
res <- forall (m :: * -> *) a.
(MonadFail m, Eq a) =>
String
-> a -> (OptionChanged, Maybe a) -> m (OptionChanged, Maybe a)
setIfNew String
"spaces trimming" Bool
enable (SwitchesOptionsBuilder -> (OptionChanged, Maybe Bool)
spacesTrimmingB SwitchesOptionsBuilder
opts)
  forall s (m :: * -> *). MonadState s m => s -> m ()
put SwitchesOptionsBuilder
opts{ spacesTrimmingB :: (OptionChanged, Maybe Bool)
spacesTrimmingB = (OptionChanged, Maybe Bool)
res }

setIndentationStripping :: SwitchesOptionsSetter m => Bool -> m ()
setIndentationStripping :: forall (m :: * -> *). SwitchesOptionsSetter m => Bool -> m ()
setIndentationStripping Bool
enable = do
  SwitchesOptionsBuilder
opts <- forall s (m :: * -> *). MonadState s m => m s
get
  (OptionChanged, Maybe Bool)
res <- forall (m :: * -> *) a.
(MonadFail m, Eq a) =>
String
-> a -> (OptionChanged, Maybe a) -> m (OptionChanged, Maybe a)
setIfNew String
"indentation stripping" Bool
enable (SwitchesOptionsBuilder -> (OptionChanged, Maybe Bool)
indentationStrippingB SwitchesOptionsBuilder
opts)
  forall s (m :: * -> *). MonadState s m => s -> m ()
put SwitchesOptionsBuilder
opts{ indentationStrippingB :: (OptionChanged, Maybe Bool)
indentationStrippingB = (OptionChanged, Maybe Bool)
res }

setLeadingNewlineStripping :: SwitchesOptionsSetter m => Bool -> m ()
setLeadingNewlineStripping :: forall (m :: * -> *). SwitchesOptionsSetter m => Bool -> m ()
setLeadingNewlineStripping Bool
enable = do
  SwitchesOptionsBuilder
opts <- forall s (m :: * -> *). MonadState s m => m s
get
  (OptionChanged, Maybe Bool)
res <- forall (m :: * -> *) a.
(MonadFail m, Eq a) =>
String
-> a -> (OptionChanged, Maybe a) -> m (OptionChanged, Maybe a)
setIfNew String
"leading newline stripping" Bool
enable (SwitchesOptionsBuilder -> (OptionChanged, Maybe Bool)
leadingNewlineStrippingB SwitchesOptionsBuilder
opts)
  forall s (m :: * -> *). MonadState s m => s -> m ()
put SwitchesOptionsBuilder
opts{ leadingNewlineStrippingB :: (OptionChanged, Maybe Bool)
leadingNewlineStrippingB = (OptionChanged, Maybe Bool)
res }

setTrailingSpacesStripping :: SwitchesOptionsSetter m => Bool -> m ()
setTrailingSpacesStripping :: forall (m :: * -> *). SwitchesOptionsSetter m => Bool -> m ()
setTrailingSpacesStripping Bool
enable = do
  SwitchesOptionsBuilder
opts <- forall s (m :: * -> *). MonadState s m => m s
get
  (OptionChanged, Maybe Bool)
res <- forall (m :: * -> *) a.
(MonadFail m, Eq a) =>
String
-> a -> (OptionChanged, Maybe a) -> m (OptionChanged, Maybe a)
setIfNew String
"trailing spaces stripping" Bool
enable (SwitchesOptionsBuilder -> (OptionChanged, Maybe Bool)
trailingSpacesStrippingB SwitchesOptionsBuilder
opts)
  forall s (m :: * -> *). MonadState s m => s -> m ()
put SwitchesOptionsBuilder
opts{ trailingSpacesStrippingB :: (OptionChanged, Maybe Bool)
trailingSpacesStrippingB = (OptionChanged, Maybe Bool)
res }

setReducedNewlines :: SwitchesOptionsSetter m => Bool -> m ()
setReducedNewlines :: forall (m :: * -> *). SwitchesOptionsSetter m => Bool -> m ()
setReducedNewlines Bool
enable = do
  SwitchesOptionsBuilder
opts <- forall s (m :: * -> *). MonadState s m => m s
get
  (OptionChanged, Maybe Bool)
res <- forall (m :: * -> *) a.
(MonadFail m, Eq a) =>
String
-> a -> (OptionChanged, Maybe a) -> m (OptionChanged, Maybe a)
setIfNew String
"reduced newlines" Bool
enable (SwitchesOptionsBuilder -> (OptionChanged, Maybe Bool)
reducedNewlinesB SwitchesOptionsBuilder
opts)
  forall s (m :: * -> *). MonadState s m => s -> m ()
put SwitchesOptionsBuilder
opts{ reducedNewlinesB :: (OptionChanged, Maybe Bool)
reducedNewlinesB = (OptionChanged, Maybe Bool)
res }

setMonadic :: SwitchesOptionsSetter m => Bool -> m ()
setMonadic :: forall (m :: * -> *). SwitchesOptionsSetter m => Bool -> m ()
setMonadic Bool
enable = do
  SwitchesOptionsBuilder
opts <- forall s (m :: * -> *). MonadState s m => m s
get
  (OptionChanged, Maybe Bool)
res <- forall (m :: * -> *) a.
(MonadFail m, Eq a) =>
String
-> a -> (OptionChanged, Maybe a) -> m (OptionChanged, Maybe a)
setIfNew String
"monadic" Bool
enable (SwitchesOptionsBuilder -> (OptionChanged, Maybe Bool)
monadicB SwitchesOptionsBuilder
opts)
  forall s (m :: * -> *). MonadState s m => s -> m ()
put SwitchesOptionsBuilder
opts{ monadicB :: (OptionChanged, Maybe Bool)
monadicB = (OptionChanged, Maybe Bool)
res }

setReturnType :: SwitchesOptionsSetter m => ReturnType -> m ()
setReturnType :: forall (m :: * -> *). SwitchesOptionsSetter m => ReturnType -> m ()
setReturnType ReturnType
ty = do
  SwitchesOptionsBuilder
opts <- forall s (m :: * -> *). MonadState s m => m s
get
  (OptionChanged, Maybe ReturnType)
res <- forall (m :: * -> *) a.
(MonadFail m, Eq a) =>
String
-> a -> (OptionChanged, Maybe a) -> m (OptionChanged, Maybe a)
setIfNew String
"return type" ReturnType
ty (SwitchesOptionsBuilder -> (OptionChanged, Maybe ReturnType)
returnTypeB SwitchesOptionsBuilder
opts)
  forall s (m :: * -> *). MonadState s m => s -> m ()
put SwitchesOptionsBuilder
opts{ returnTypeB :: (OptionChanged, Maybe ReturnType)
returnTypeB = (OptionChanged, Maybe ReturnType)
res }

accountPreview :: SwitchesOptionsSetter m => m ()
accountPreview :: forall (m :: * -> *). SwitchesOptionsSetter m => m ()
accountPreview = do
  SwitchesOptionsBuilder
opts <- forall s (m :: * -> *). MonadState s m => m s
get
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (SwitchesOptionsBuilder -> PreviewLevel
previewLevelB SwitchesOptionsBuilder
opts forall a. Eq a => a -> a -> Bool
== forall a. Bounded a => a
maxBound) forall a b. (a -> b) -> a -> b
$
    forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Too high preview level"
  forall s (m :: * -> *). MonadState s m => s -> m ()
put SwitchesOptionsBuilder
opts{ previewLevelB :: PreviewLevel
previewLevelB = forall a. Enum a => Int -> a
toEnum forall a b. (a -> b) -> a -> b
$ forall a. Enum a => a -> Int
fromEnum (SwitchesOptionsBuilder -> PreviewLevel
previewLevelB SwitchesOptionsBuilder
opts) forall a. Num a => a -> a -> a
+ Int
1 }

notAnyOf :: [Char -> Bool] -> Char -> Bool
notAnyOf :: [Char -> Bool] -> Char -> Bool
notAnyOf [Char -> Bool]
ps Char
c = Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *). Foldable t => t Bool -> Bool
or (forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [Char -> Bool]
ps Char
c)

one :: a -> [a]
one :: forall a. a -> [a]
one = (forall a. a -> [a] -> [a]
: [])

data CustomParserFailure
  = SwitchesHelpRequested DefaultSwitchesOptions

-- These instances are necessary for megaparsec
instance Eq CustomParserFailure where
  CustomParserFailure
a == :: CustomParserFailure -> CustomParserFailure -> Bool
== CustomParserFailure
b = forall a. Ord a => a -> a -> Ordering
compare CustomParserFailure
a CustomParserFailure
b forall a. Eq a => a -> a -> Bool
== Ordering
EQ
instance Ord CustomParserFailure where
  SwitchesHelpRequested{} compare :: CustomParserFailure -> CustomParserFailure -> Ordering
`compare` SwitchesHelpRequested{} = Ordering
EQ

instance ShowErrorComponent CustomParserFailure where
  showErrorComponent :: CustomParserFailure -> String
showErrorComponent = \case
    SwitchesHelpRequested DefaultSwitchesOptions
defSOpts -> forall b. FromBuilder b => Builder -> b
fmt forall a b. (a -> b) -> a -> b
$ DefaultSwitchesOptions -> Builder
switchesHelpMessage DefaultSwitchesOptions
defSOpts

switchesSectionP :: DefaultSwitchesOptions -> Parsec CustomParserFailure Text SwitchesOptions
switchesSectionP :: DefaultSwitchesOptions
-> Parsec CustomParserFailure Text SwitchesOptions
switchesSectionP DefaultSwitchesOptions
defSOpts =
  forall (m :: * -> *).
MonadFail m =>
SwitchesOptionsBuilder -> m SwitchesOptions
finalizeSwitchesOptions forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=<
  forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m s
execStateT (DefaultSwitchesOptions -> SwitchesOptionsBuilder
toSwitchesOptionsBuilder DefaultSwitchesOptions
defSOpts) forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Alternative f => f a -> f [a]
many forall a b. (a -> b) -> a -> b
$ forall e s (m :: * -> *) a.
MonadParsec e s m =>
String -> m a -> m a
label String
switchLabel forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum
    [ forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum
      [ forall e s (m :: * -> *).
MonadParsec e s m =>
Token s -> m (Token s)
single Char
's' forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Bool
True
      , forall e s (m :: * -> *).
MonadParsec e s m =>
Token s -> m (Token s)
single Char
'S' forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Bool
False
      ] forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *). SwitchesOptionsSetter m => Bool -> m ()
setSpacesTrimming

    , forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum
      [ forall e s (m :: * -> *).
MonadParsec e s m =>
Token s -> m (Token s)
single Char
'd' forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Bool
True
      , forall e s (m :: * -> *).
MonadParsec e s m =>
Token s -> m (Token s)
single Char
'D' forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Bool
False
      ] forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *). SwitchesOptionsSetter m => Bool -> m ()
setIndentationStripping

    , forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum
      [ forall e s (m :: * -> *).
MonadParsec e s m =>
Token s -> m (Token s)
single Char
'a' forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Bool
True
      , forall e s (m :: * -> *).
MonadParsec e s m =>
Token s -> m (Token s)
single Char
'A' forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Bool
False
      ] forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *). SwitchesOptionsSetter m => Bool -> m ()
setLeadingNewlineStripping

    , forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum
      [ forall e s (m :: * -> *).
MonadParsec e s m =>
Token s -> m (Token s)
single Char
'z' forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Bool
True
      , forall e s (m :: * -> *).
MonadParsec e s m =>
Token s -> m (Token s)
single Char
'Z' forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Bool
False
      ] forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *). SwitchesOptionsSetter m => Bool -> m ()
setTrailingSpacesStripping

    , forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum
      [ forall e s (m :: * -> *).
MonadParsec e s m =>
Token s -> m (Token s)
single Char
'n' forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Bool
True
      , forall e s (m :: * -> *).
MonadParsec e s m =>
Token s -> m (Token s)
single Char
'N' forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Bool
False
      ] forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *). SwitchesOptionsSetter m => Bool -> m ()
setReducedNewlines

    , forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum
      [ forall e s (m :: * -> *).
MonadParsec e s m =>
Token s -> m (Token s)
single Char
'm' forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Bool
True
      , forall e s (m :: * -> *).
MonadParsec e s m =>
Token s -> m (Token s)
single Char
'M' forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Bool
False
      ] forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *). SwitchesOptionsSetter m => Bool -> m ()
setMonadic

    , forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum
      [ forall e s (m :: * -> *).
MonadParsec e s m =>
Token s -> m (Token s)
single Char
'B' forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> ReturnType
AnyFromBuilder
      , forall e s (m :: * -> *).
MonadParsec e s m =>
Token s -> m (Token s)
single Char
'b' forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> ReturnType
ConcreteBuilder
      , forall e s (m :: * -> *).
MonadParsec e s m =>
Token s -> m (Token s)
single Char
't' forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> ReturnType
ConcreteText
      , forall e s (m :: * -> *).
MonadParsec e s m =>
Token s -> m (Token s)
single Char
'T' forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> ReturnType
ConcreteLText
      ] forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *). SwitchesOptionsSetter m => ReturnType -> m ()
setReturnType

    , forall e s (m :: * -> *).
MonadParsec e s m =>
Token s -> m (Token s)
single Char
'!' forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *). SwitchesOptionsSetter m => m ()
accountPreview

    , forall e s (m :: * -> *).
MonadParsec e s m =>
Token s -> m (Token s)
single Char
'?' forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall e s (m :: * -> *) a. MonadParsec e s m => e -> m a
customFailure (DefaultSwitchesOptions -> CustomParserFailure
SwitchesHelpRequested DefaultSwitchesOptions
defSOpts)

    ]
    where
      switchLabel :: String
switchLabel = String
"switch option (type '?' here for help)"

switchesHelpMessage :: DefaultSwitchesOptions -> Builder
switchesHelpMessage :: DefaultSwitchesOptions -> Builder
switchesHelpMessage DefaultSwitchesOptions
sopts =
  let SwitchesOptions
_exhaustivnessCheck :: SwitchesOptions = Bool
-> Bool
-> Bool
-> Bool
-> ReturnType
-> Bool
-> Bool
-> PreviewLevel
-> SwitchesOptions
SwitchesOptions
        (forall a. HasCallStack => String -> a
error String
"")
        (forall a. HasCallStack => String -> a
error String
"")
        (forall a. HasCallStack => String -> a
error String
"")
        (forall a. HasCallStack => String -> a
error String
"")
        (forall a. HasCallStack => String -> a
error String
"")
        (forall a. HasCallStack => String -> a
error String
"")
        (forall a. HasCallStack => String -> a
error String
"")
        (forall a. HasCallStack => String -> a
error String
"")
        -- ↑ Note: If you edit this, you may also need to update
        -- the help messages below.
  in forall a. Monoid a => [a] -> a
mconcat
    [ Builder
"\nHelp on switches:\n"
    , forall {a}. Eq a => a -> [(Text, Builder, a)] -> Builder
helpOnOptions (DefaultSwitchesOptions -> Maybe Bool
defSpacesTrimming DefaultSwitchesOptions
sopts)
        [ (Text
"s", Builder
"enable spaces trimming", forall a. a -> Maybe a
Just Bool
True)
        , (Text
"S", Builder
"disable spaces trimming", forall a. a -> Maybe a
Just Bool
False)
        ]

    , forall {a}. Eq a => a -> [(Text, Builder, a)] -> Builder
helpOnOptions (DefaultSwitchesOptions -> Maybe Bool
defIndentationStripping DefaultSwitchesOptions
sopts)
        [ (Text
"d", Builder
"enable indentation stripping", forall a. a -> Maybe a
Just Bool
True)
        , (Text
"D", Builder
"disable indentation stripping", forall a. a -> Maybe a
Just Bool
False)
        ]

    , forall {a}. Eq a => a -> [(Text, Builder, a)] -> Builder
helpOnOptions (DefaultSwitchesOptions -> Maybe Bool
defLeadingNewlineStripping DefaultSwitchesOptions
sopts)
        [ (Text
"a", Builder
"enable leading newline stripping", forall a. a -> Maybe a
Just Bool
True)
        , (Text
"A", Builder
"disable leading newline stripping", forall a. a -> Maybe a
Just Bool
False)
        ]

    , forall {a}. Eq a => a -> [(Text, Builder, a)] -> Builder
helpOnOptions (DefaultSwitchesOptions -> Maybe Bool
defTrailingSpacesStripping DefaultSwitchesOptions
sopts)
        [ (Text
"z", Builder
"enable trailing spaces stripping", forall a. a -> Maybe a
Just Bool
True)
        , (Text
"Z", Builder
"disable trailing spaces stripping", forall a. a -> Maybe a
Just Bool
False)
        ]

    , forall {a}. Eq a => a -> [(Text, Builder, a)] -> Builder
helpOnOptions (DefaultSwitchesOptions -> Maybe Bool
defReducedNewlines DefaultSwitchesOptions
sopts)
        [ (Text
"n", Builder
"enable newlines reducing", forall a. a -> Maybe a
Just Bool
True)
        , (Text
"N", Builder
"disable newlines reducing", forall a. a -> Maybe a
Just Bool
False)
        ]

    , forall {a}. Eq a => a -> [(Text, Builder, a)] -> Builder
helpOnOptions (DefaultSwitchesOptions -> Maybe Bool
defMonadic DefaultSwitchesOptions
sopts)
        [ (Text
"m", Builder
"enable monadic interpolated values", forall a. a -> Maybe a
Just Bool
True)
        , (Text
"M", Builder
"disable monadic interpolated values", forall a. a -> Maybe a
Just Bool
False)
        ]

    , forall {a}. Eq a => a -> [(Text, Builder, a)] -> Builder
helpOnOptions (DefaultSwitchesOptions -> Maybe ReturnType
defReturnType DefaultSwitchesOptions
sopts)
        [ (Text
"t", Builder
"return `Text`", forall a. a -> Maybe a
Just ReturnType
ConcreteText)
        , (Text
"T", Builder
"return lazy `Text`", forall a. a -> Maybe a
Just ReturnType
ConcreteLText)
        , (Text
"b", Builder
"return `Builder`", forall a. a -> Maybe a
Just ReturnType
ConcreteBuilder)
        , (Text
"B", Builder
"return any text-like type (`FromBuilder a => a`)", forall a. a -> Maybe a
Just ReturnType
AnyFromBuilder)
        ]

    , forall {a}. Eq a => a -> [(Text, Builder, a)] -> Builder
helpOnOptions PreviewLevel
PreviewNone
        [ (Text
"!", Builder
"show rendered text (without substitutions) as a warning", PreviewLevel
PreviewExact)
        , (Text
"!!", Builder
"like ! but also marks invisible characters like spaces", PreviewLevel
PreviewInvisible)
        ]
    ]
  where
    helpOnOptions :: a -> [(Text, Builder, a)] -> Builder
helpOnOptions a
defVal [(Text, Builder, a)]
available = forall a. Monoid a => [a] -> a
mconcat
      [ Builder
"· " forall a. Semigroup a => a -> a -> a
<> forall p. Buildable p => p -> Builder
build @Text Text
switch forall a. Semigroup a => a -> a -> a
<> Builder
" - " forall a. Semigroup a => a -> a -> a
<> Builder
help forall a. Semigroup a => a -> a -> a
<> Builder
"\n"
      | (Text
switch, Builder
help, a
val) <- [(Text, Builder, a)]
available
      , a
val forall a. Eq a => a -> a -> Bool
/= a
defVal
      ]

intPieceP :: Ord e => Parsec e Text [ParsedIntPiece]
intPieceP :: forall e. Ord e => Parsec e Text [ParsedIntPiece]
intPieceP = forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum
  [
    -- consume normal text
    forall a. a -> [a]
one forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ParsedIntPiece
PipString 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. Maybe a
Nothing ([Char -> Bool] -> Char -> Bool
notAnyOf [(forall a. Eq a => a -> a -> Bool
== Char
'\\'), (forall a. Eq a => a -> a -> Bool
== Char
'#'), Char -> Bool
isSpace])

    -- potentially interpolator case
  , forall e s (m :: * -> *).
MonadParsec e s m =>
Token s -> m (Token s)
single Char
'#' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> do
      Text
mode <- 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
isAlphaNum Token Text
c Bool -> Bool -> Bool
|| Token Text
c forall a. Eq a => a -> a -> Bool
== Char
'_'
      forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum
        [ do
            -- interpolator
            Token Text
_ <- forall e s (m :: * -> *).
MonadParsec e s m =>
Token s -> m (Token s)
single Char
'{'
            [Text]
intTxt <- forall (f :: * -> *) a. Alternative f => f a -> f [a]
many forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum
              [ forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe String -> (Token s -> Bool) -> m (Tokens s)
takeWhile1P (forall a. a -> Maybe a
Just String
"interpolated piece") forall a b. (a -> b) -> a -> b
$ [Char -> Bool] -> Char -> Bool
notAnyOf [(forall a. Eq a => a -> a -> Bool
== Char
'\\'), (forall a. Eq a => a -> a -> Bool
== Char
'}')]
              , forall e s (m :: * -> *).
MonadParsec e s m =>
Token s -> m (Token s)
single Char
'\\' forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> Text
T.singleton forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum
                [ forall e s (m :: * -> *).
MonadParsec e s m =>
Token s -> m (Token s)
single Char
'\\'
                , forall e s (m :: * -> *).
MonadParsec e s m =>
Token s -> m (Token s)
single Char
'}'
                ]
              ]
            Token Text
_ <- forall e s (m :: * -> *).
MonadParsec e s m =>
Token s -> m (Token s)
single Char
'}'

            forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> [a]
one forall a b. (a -> b) -> a -> b
$ IntData -> ParsedIntPiece
PipInt IntData
              { idMode :: Text
idMode = Text
mode
              , idCode :: Text
idCode = forall a. Monoid a => [a] -> a
mconcat [Text]
intTxt
              }

          -- just plain text
        , forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> [a]
one forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ParsedIntPiece
PipString forall a b. (a -> b) -> a -> b
$ Text
"#" forall a. Semigroup a => a -> a -> a
<> Text
mode
        ]

    -- escaped text
  , forall e s (m :: * -> *).
MonadParsec e s m =>
Token s -> m (Token s)
single Char
'\\' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum
      [ forall a. a -> [a]
one forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ParsedIntPiece
PipString forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Text
T.singleton forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e s (m :: * -> *).
MonadParsec e s m =>
Token s -> m (Token s)
single Char
'\\'
      , forall a. a -> [a]
one forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ParsedIntPiece
PipString forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Text
T.singleton forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e s (m :: * -> *).
MonadParsec e s m =>
Token s -> m (Token s)
single Char
'#'
        -- trailing '\' cancels newline feed
      , ParsecT e Text Identity ParsedIntPiece
newline forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT e Text Identity [ParsedIntPiece]
lineStart
      ]

    -- newline
  , (:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT e Text Identity ParsedIntPiece
newline forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParsecT e Text Identity [ParsedIntPiece]
lineStart

    -- fast spacing
  , forall a. a -> [a]
one forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ParsedIntPiece
PipString 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. Maybe a
Nothing Char -> Bool
isNonNewlineSpace

  , forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Unexpected: failed to consume some input"

  ]
  where
    newline :: ParsecT e Text Identity ParsedIntPiece
newline = Text -> ParsedIntPiece
PipNewline forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Text
T.singleton forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e s (m :: * -> *).
MonadParsec e s m =>
Token s -> m (Token s)
single Char
'\n'

    isNonNewlineSpace :: Char -> Bool
isNonNewlineSpace Char
c = Char -> Bool
isSpace Char
c Bool -> Bool -> Bool
&& Char
c forall a. Eq a => a -> a -> Bool
/= Char
'\n'

    -- Parse indentation
    lineStart :: ParsecT e Text Identity [ParsedIntPiece]
lineStart = forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum
      [ forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
lookAhead ParsecT e Text Identity ParsedIntPiece
newline forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> [ParsedIntPiece
PipEmptyLine]
      , do
          Word
wss <- forall a b. (Integral a, Num b) => a -> b
fromIntegral @Int @Word forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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)
takeWhileP forall a. Maybe a
Nothing Char -> Bool
isNonNewlineSpace
          forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Word
wss forall a. Ord a => a -> a -> Bool
> Word
0) forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Word -> ParsedIntPiece
PipLeadingWs Word
wss
      ]

-- | Since the parser may produce several 'PipString' with different kind of
-- content (e.g. spaces and words), we would like to glue those before passing
-- the interpolated string to the next stage.
glueParsedStrings :: ParsedInterpolatedString -> ParsedInterpolatedString
glueParsedStrings :: [ParsedIntPiece] -> [ParsedIntPiece]
glueParsedStrings = \case
  []                               -> []
  -- TODO: use Builder here
  PipString Text
s1 : PipString Text
s2 : [ParsedIntPiece]
ps -> [ParsedIntPiece] -> [ParsedIntPiece]
glueParsedStrings (Text -> ParsedIntPiece
PipString (Text
s1 forall a. Semigroup a => a -> a -> a
<> Text
s2) forall a. a -> [a] -> [a]
: [ParsedIntPiece]
ps)
  ParsedIntPiece
p : [ParsedIntPiece]
ps                           -> ParsedIntPiece
p forall a. a -> [a] -> [a]
: [ParsedIntPiece] -> [ParsedIntPiece]
glueParsedStrings [ParsedIntPiece]
ps

intStringP
  :: DefaultSwitchesOptions
  -> Parsec CustomParserFailure Text (SwitchesOptions, ParsedInterpolatedString)
intStringP :: DefaultSwitchesOptions
-> Parsec
     CustomParserFailure Text (SwitchesOptions, [ParsedIntPiece])
intStringP DefaultSwitchesOptions
sopts = do
  SwitchesOptions
switches <- DefaultSwitchesOptions
-> Parsec CustomParserFailure Text SwitchesOptions
switchesSectionP DefaultSwitchesOptions
sopts
  Token Text
_ <- forall e s (m :: * -> *).
MonadParsec e s m =>
Token s -> m (Token s)
single Char
'|'
  [ParsedIntPiece]
pieces <- [ParsedIntPiece] -> [ParsedIntPiece]
glueParsedStrings forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a. Alternative f => f a -> f [a]
many forall e. Ord e => Parsec e Text [ParsedIntPiece]
intPieceP
  forall e s (m :: * -> *). MonadParsec e s m => m ()
eof
  forall (m :: * -> *) a. Monad m => a -> m a
return (SwitchesOptions
switches, [ParsedIntPiece]
pieces)

parseIntString
  :: DefaultSwitchesOptions
  -> Text
  -> Either String (SwitchesOptions, ParsedInterpolatedString)
parseIntString :: DefaultSwitchesOptions
-> Text -> Either String (SwitchesOptions, [ParsedIntPiece])
parseIntString DefaultSwitchesOptions
defSOpts Text
txt =
  forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first forall s e.
(VisualStream s, TraversableStream s, ShowErrorComponent e) =>
ParseErrorBundle s e -> String
errorBundlePretty forall a b. (a -> b) -> a -> b
$
    forall e s a.
Parsec e s a -> String -> s -> Either (ParseErrorBundle s e) a
parse (DefaultSwitchesOptions
-> Parsec
     CustomParserFailure Text (SwitchesOptions, [ParsedIntPiece])
intStringP DefaultSwitchesOptions
defSOpts) String
"int QQ" Text
txt