module CustomInterpolation.Parser where

import Control.Monad.State (evalStateT, get, lift, modify, unless)
import CustomInterpolation.Config (Brackets (..), Interpolator (..))
import Data.Char (isDigit, isLetter)
import Data.Foldable (asum)
import Data.Functor (($>))
import Language.Haskell.Meta (parseExp)
import Language.Haskell.TH (Exp, Q)
import Text.Parsec (
  ParseError,
  State (statePos),
  anyChar,
  between,
  char,
  eof,
  getInput,
  incSourceColumn,
  lookAhead,
  manyTill,
  noneOf,
  parse,
  setInput,
  string,
  try,
  updateParserState,
  (<|>),
 )
import Text.Parsec.String (Parser)

-- | The raw segments the parser will cut the quasi-quoted string into
data StringPart a = Lit String | Esc Char | Anti (Interpolator a) (Q Exp)

data HsChompState = HsChompState
  { HsChompState -> QuoteState
quoteState :: QuoteState,
    HsChompState -> Int
braceCt :: Int,
    HsChompState -> String
consumed :: String,
    HsChompState -> Bool
prevCharWasIdentChar :: Bool
  }
  deriving (Int -> HsChompState -> ShowS
[HsChompState] -> ShowS
HsChompState -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [HsChompState] -> ShowS
$cshowList :: [HsChompState] -> ShowS
show :: HsChompState -> String
$cshow :: HsChompState -> String
showsPrec :: Int -> HsChompState -> ShowS
$cshowsPrec :: Int -> HsChompState -> ShowS
Show)

data QuoteState = None | Single EscapeState | Double EscapeState deriving (QuoteState -> QuoteState -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: QuoteState -> QuoteState -> Bool
$c/= :: QuoteState -> QuoteState -> Bool
== :: QuoteState -> QuoteState -> Bool
$c== :: QuoteState -> QuoteState -> Bool
Eq, Eq QuoteState
QuoteState -> QuoteState -> Bool
QuoteState -> QuoteState -> Ordering
QuoteState -> QuoteState -> QuoteState
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: QuoteState -> QuoteState -> QuoteState
$cmin :: QuoteState -> QuoteState -> QuoteState
max :: QuoteState -> QuoteState -> QuoteState
$cmax :: QuoteState -> QuoteState -> QuoteState
>= :: QuoteState -> QuoteState -> Bool
$c>= :: QuoteState -> QuoteState -> Bool
> :: QuoteState -> QuoteState -> Bool
$c> :: QuoteState -> QuoteState -> Bool
<= :: QuoteState -> QuoteState -> Bool
$c<= :: QuoteState -> QuoteState -> Bool
< :: QuoteState -> QuoteState -> Bool
$c< :: QuoteState -> QuoteState -> Bool
compare :: QuoteState -> QuoteState -> Ordering
$ccompare :: QuoteState -> QuoteState -> Ordering
Ord, Int -> QuoteState -> ShowS
[QuoteState] -> ShowS
QuoteState -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [QuoteState] -> ShowS
$cshowList :: [QuoteState] -> ShowS
show :: QuoteState -> String
$cshow :: QuoteState -> String
showsPrec :: Int -> QuoteState -> ShowS
$cshowsPrec :: Int -> QuoteState -> ShowS
Show)

data EscapeState = Escaped | Unescaped deriving (EscapeState
forall a. a -> a -> Bounded a
maxBound :: EscapeState
$cmaxBound :: EscapeState
minBound :: EscapeState
$cminBound :: EscapeState
Bounded, Int -> EscapeState
EscapeState -> Int
EscapeState -> [EscapeState]
EscapeState -> EscapeState
EscapeState -> EscapeState -> [EscapeState]
EscapeState -> EscapeState -> EscapeState -> [EscapeState]
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: EscapeState -> EscapeState -> EscapeState -> [EscapeState]
$cenumFromThenTo :: EscapeState -> EscapeState -> EscapeState -> [EscapeState]
enumFromTo :: EscapeState -> EscapeState -> [EscapeState]
$cenumFromTo :: EscapeState -> EscapeState -> [EscapeState]
enumFromThen :: EscapeState -> EscapeState -> [EscapeState]
$cenumFromThen :: EscapeState -> EscapeState -> [EscapeState]
enumFrom :: EscapeState -> [EscapeState]
$cenumFrom :: EscapeState -> [EscapeState]
fromEnum :: EscapeState -> Int
$cfromEnum :: EscapeState -> Int
toEnum :: Int -> EscapeState
$ctoEnum :: Int -> EscapeState
pred :: EscapeState -> EscapeState
$cpred :: EscapeState -> EscapeState
succ :: EscapeState -> EscapeState
$csucc :: EscapeState -> EscapeState
Enum, EscapeState -> EscapeState -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: EscapeState -> EscapeState -> Bool
$c/= :: EscapeState -> EscapeState -> Bool
== :: EscapeState -> EscapeState -> Bool
$c== :: EscapeState -> EscapeState -> Bool
Eq, Eq EscapeState
EscapeState -> EscapeState -> Bool
EscapeState -> EscapeState -> Ordering
EscapeState -> EscapeState -> EscapeState
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: EscapeState -> EscapeState -> EscapeState
$cmin :: EscapeState -> EscapeState -> EscapeState
max :: EscapeState -> EscapeState -> EscapeState
$cmax :: EscapeState -> EscapeState -> EscapeState
>= :: EscapeState -> EscapeState -> Bool
$c>= :: EscapeState -> EscapeState -> Bool
> :: EscapeState -> EscapeState -> Bool
$c> :: EscapeState -> EscapeState -> Bool
<= :: EscapeState -> EscapeState -> Bool
$c<= :: EscapeState -> EscapeState -> Bool
< :: EscapeState -> EscapeState -> Bool
$c< :: EscapeState -> EscapeState -> Bool
compare :: EscapeState -> EscapeState -> Ordering
$ccompare :: EscapeState -> EscapeState -> Ordering
Ord, Int -> EscapeState -> ShowS
[EscapeState] -> ShowS
EscapeState -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [EscapeState] -> ShowS
$cshowList :: [EscapeState] -> ShowS
show :: EscapeState -> String
$cshow :: EscapeState -> String
showsPrec :: Int -> EscapeState -> ShowS
$cshowsPrec :: Int -> EscapeState -> ShowS
Show)

parseInterpolations :: [Interpolator a] -> String -> Either ParseError [StringPart a]
parseInterpolations :: forall a.
[Interpolator a] -> String -> Either ParseError [StringPart a]
parseInterpolations [Interpolator a]
interps = forall s t a.
Stream s Identity t =>
Parsec s () a -> String -> s -> Either ParseError a
parse (forall a. [Interpolator a] -> Parser [StringPart a]
pInterp [Interpolator a]
interps) String
""

pInterp :: [Interpolator a] -> Parser [StringPart a]
pInterp :: forall a. [Interpolator a] -> Parser [StringPart a]
pInterp [Interpolator a]
interps = forall s (m :: * -> *) t u a end.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m end -> ParsecT s u m [a]
manyTill (forall a. [Interpolator a] -> Parser (StringPart a)
pStringPart [Interpolator a]
interps) forall s (m :: * -> *) t u.
(Stream s m t, Show t) =>
ParsecT s u m ()
eof

pStringPart :: [Interpolator a] -> Parser (StringPart a)
pStringPart :: forall a. [Interpolator a] -> Parser (StringPart a)
pStringPart [Interpolator a]
interps = forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum (forall a b. (a -> b) -> [a] -> [b]
map forall a. Interpolator a -> Parser (StringPart a)
pAnti [Interpolator a]
interps) forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> forall a. Parser (StringPart a)
pEsc forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> forall a. [Interpolator a] -> Parser (StringPart a)
pLit [Interpolator a]
interps

pAnti :: Interpolator a -> Parser (StringPart a)
pAnti :: forall a. Interpolator a -> Parser (StringPart a)
pAnti Interpolator a
interp =
  forall a. Interpolator a -> Q Exp -> StringPart a
Anti Interpolator a
interp forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Q Exp
parseExpQ
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s (m :: * -> *) t u open close a.
Stream s m t =>
ParsecT s u m open
-> ParsecT s u m close -> ParsecT s u m a -> ParsecT s u m a
between
      (forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try (forall a. Interpolator a -> Parser String
pAntiOpen Interpolator a
interp))
      (forall a. Interpolator a -> Parser String
pAntiClose Interpolator a
interp)
      (forall a. Interpolator a -> Parser String
pUntilUnbalancedCloseBracket Interpolator a
interp)

-- | 'parseExp' but in the 'Q' Monad ('fail's on parsing errors).
parseExpQ :: String -> Q Exp
parseExpQ :: String -> Q Exp
parseExpQ = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"Error while parsing Haskell expression:\n" forall a. Semigroup a => a -> a -> a
<>)) forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Either String Exp
parseExp

pAntiOpen :: Interpolator a -> Parser String
pAntiOpen :: forall a. Interpolator a -> Parser String
pAntiOpen Interpolator {String
prefix :: forall a. Interpolator a -> String
prefix :: String
prefix, Brackets
brackets :: forall a. Interpolator a -> Brackets
brackets :: Brackets
brackets} = forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string (String
prefix forall a. [a] -> [a] -> [a]
++ [Brackets -> Char
opening Brackets
brackets])

pAntiClose :: Interpolator a -> Parser String
pAntiClose :: forall a. Interpolator a -> Parser String
pAntiClose Interpolator {Brackets
brackets :: Brackets
brackets :: forall a. Interpolator a -> Brackets
brackets} = forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string [Brackets -> Char
closing Brackets
brackets]

pUntilUnbalancedCloseBracket :: Interpolator a -> Parser String
pUntilUnbalancedCloseBracket :: forall a. Interpolator a -> Parser String
pUntilUnbalancedCloseBracket Interpolator {brackets :: forall a. Interpolator a -> Brackets
brackets = Brackets {Char
opening :: Char
opening :: Brackets -> Char
opening, Char
closing :: Char
closing :: Brackets -> Char
closing}} =
  forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT StateT HsChompState (ParsecT String () Identity) String
go forall a b. (a -> b) -> a -> b
$ QuoteState -> Int -> String -> Bool -> HsChompState
HsChompState QuoteState
None Int
0 String
"" Bool
False
  where
    go :: StateT HsChompState (ParsecT String () Identity) String
go = do
      Char
c <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
anyChar
      forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \st :: HsChompState
st@HsChompState {String
consumed :: String
consumed :: HsChompState -> String
consumed} -> HsChompState
st {consumed :: String
consumed = Char
c forall a. a -> [a] -> [a]
: String
consumed}
      HsChompState {Bool
Int
String
QuoteState
prevCharWasIdentChar :: Bool
consumed :: String
braceCt :: Int
quoteState :: QuoteState
prevCharWasIdentChar :: HsChompState -> Bool
consumed :: HsChompState -> String
braceCt :: HsChompState -> Int
quoteState :: HsChompState -> QuoteState
..} <- forall s (m :: * -> *). MonadState s m => m s
get
      let next :: StateT HsChompState (ParsecT String () Identity) String
next = forall {m :: * -> *}. MonadState HsChompState m => Char -> m ()
setIdentifierCharState Char
c forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> StateT HsChompState (ParsecT String () Identity) String
go
      case QuoteState
quoteState of
        QuoteState
None ->
          if
              | Char
c forall a. Eq a => a -> a -> Bool
== Char
opening -> forall {m :: * -> *}. MonadState HsChompState m => Int -> m ()
incBraceCt Int
1 forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> StateT HsChompState (ParsecT String () Identity) String
next
              | Char
c forall a. Eq a => a -> a -> Bool
== Char
closing ->
                if Int
braceCt forall a. Ord a => a -> a -> Bool
> Int
0
                  then forall {m :: * -> *}. MonadState HsChompState m => Int -> m ()
incBraceCt (-Int
1) forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> StateT HsChompState (ParsecT String () Identity) String
next
                  else forall {u}. StateT HsChompState (ParsecT String u Identity) ()
stepBack forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> forall a. [a] -> [a]
reverse (forall a. [a] -> [a]
tail String
consumed)
              | Char
c forall a. Eq a => a -> a -> Bool
== Char
'\'' ->
                forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
prevCharWasIdentChar (forall {m :: * -> *}.
MonadState HsChompState m =>
QuoteState -> m ()
setQuoteState forall a b. (a -> b) -> a -> b
$ EscapeState -> QuoteState
Single EscapeState
Unescaped)
                  forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> StateT HsChompState (ParsecT String () Identity) String
next
              | Char
c forall a. Eq a => a -> a -> Bool
== Char
'"' -> forall {m :: * -> *}.
MonadState HsChompState m =>
QuoteState -> m ()
setQuoteState (EscapeState -> QuoteState
Double EscapeState
Unescaped) forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> StateT HsChompState (ParsecT String () Identity) String
next
              | Bool
otherwise -> StateT HsChompState (ParsecT String () Identity) String
next
        Single EscapeState
Unescaped -> do
          case Char
c of
            Char
'\\' -> forall {m :: * -> *}.
MonadState HsChompState m =>
QuoteState -> m ()
setQuoteState (EscapeState -> QuoteState
Single EscapeState
Escaped)
            Char
'\'' -> forall {m :: * -> *}.
MonadState HsChompState m =>
QuoteState -> m ()
setQuoteState QuoteState
None
            Char
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
          StateT HsChompState (ParsecT String () Identity) String
next
        Single EscapeState
Escaped -> forall {m :: * -> *}.
MonadState HsChompState m =>
QuoteState -> m ()
setQuoteState (EscapeState -> QuoteState
Single EscapeState
Unescaped) forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> StateT HsChompState (ParsecT String () Identity) String
next
        Double EscapeState
Unescaped -> do
          case Char
c of
            Char
'\\' -> forall {m :: * -> *}.
MonadState HsChompState m =>
QuoteState -> m ()
setQuoteState (EscapeState -> QuoteState
Double EscapeState
Escaped)
            Char
'"' -> forall {m :: * -> *}.
MonadState HsChompState m =>
QuoteState -> m ()
setQuoteState QuoteState
None
            Char
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
          StateT HsChompState (ParsecT String () Identity) String
next
        Double EscapeState
Escaped -> forall {m :: * -> *}.
MonadState HsChompState m =>
QuoteState -> m ()
setQuoteState (EscapeState -> QuoteState
Double EscapeState
Unescaped) forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> StateT HsChompState (ParsecT String () Identity) String
next
    stepBack :: StateT HsChompState (ParsecT String u Identity) ()
stepBack =
      forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$
        forall s u (m :: * -> *).
(State s u -> State s u) -> ParsecT s u m (State s u)
updateParserState
          (\State String u
s -> State String u
s {statePos :: SourcePos
statePos = SourcePos -> Int -> SourcePos
incSourceColumn (forall s u. State s u -> SourcePos
statePos State String u
s) (-Int
1)})
          forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (m :: * -> *) s u. Monad m => ParsecT s u m s
getInput
          forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) s u. Monad m => s -> ParsecT s u m ()
setInput forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char
closing forall a. a -> [a] -> [a]
:)
    incBraceCt :: Int -> m ()
incBraceCt Int
n = forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \st :: HsChompState
st@HsChompState {Int
braceCt :: Int
braceCt :: HsChompState -> Int
braceCt} ->
      HsChompState
st {braceCt :: Int
braceCt = Int
braceCt forall a. Num a => a -> a -> a
+ Int
n}
    setQuoteState :: QuoteState -> m ()
setQuoteState QuoteState
qs = forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \HsChompState
st -> HsChompState
st {quoteState :: QuoteState
quoteState = QuoteState
qs}
    setIdentifierCharState :: Char -> m ()
setIdentifierCharState Char
c = forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \HsChompState
st ->
      HsChompState
st
        { prevCharWasIdentChar :: Bool
prevCharWasIdentChar = forall (t :: * -> *). Foldable t => t Bool -> Bool
or [Char -> Bool
isLetter Char
c, Char -> Bool
isDigit Char
c, Char
c forall a. Eq a => a -> a -> Bool
== Char
'_', Char
c forall a. Eq a => a -> a -> Bool
== Char
'\'']
        }

pEsc :: Parser (StringPart a)
pEsc :: forall a. Parser (StringPart a)
pEsc = forall a. Char -> StringPart a
Esc forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'\\' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
anyChar)

pLit :: [Interpolator a] -> Parser (StringPart a)
pLit :: forall a. [Interpolator a] -> Parser (StringPart a)
pLit [Interpolator a]
prefixes =
  forall a. String -> StringPart a
Lit
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ( forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try (forall {u} {end}.
ParsecT String u Identity end -> ParsecT String u Identity String
litCharTill forall a b. (a -> b) -> a -> b
$ forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum (forall a b. (a -> b) -> [a] -> [b]
map (forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m a
lookAhead forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Interpolator a -> Parser String
pAntiOpen) [Interpolator a]
prefixes) forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m a
lookAhead (forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string String
"\\"))
            forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> forall {u} {end}.
ParsecT String u Identity end -> ParsecT String u Identity String
litCharTill forall s (m :: * -> *) t u.
(Stream s m t, Show t) =>
ParsecT s u m ()
eof
        )
  where
    litCharTill :: ParsecT String u Identity end -> ParsecT String u Identity String
litCharTill = forall s (m :: * -> *) t u a end.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m end -> ParsecT s u m [a]
manyTill forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m Char
noneOf [Char
'\\']