{-# LANGUAGE CPP #-}
{-# LANGUAGE PackageImports #-}
{-# LANGUAGE ViewPatterns #-}

module Text.InterpolatedString.QM.Internal.Parsers.TH (parserTpl) where

import           "base" Control.Arrow ((&&&))
import qualified "template-haskell" Language.Haskell.TH as TH
import           "template-haskell" Language.Haskell.TH ( Pat (ListP, ViewP)
                                                        , Exp (ListE)
                                                        )

-- local imports
import Text.InterpolatedString.QM.Internal.Parsers.Types (LineBreaks (..))


data Decl

  =  C (Bool, TH.Pat, TH.Exp)
  -- ^ 'C' means 'Conditional'.
  --   First value of tuple is condition to add pattern or not.

  |  D (TH.Pat, TH.Exp)
  -- ^ 'D' means 'Declarative'.
  --   A pattern always will be added.

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


parserTpl :: String
          -- ^ Parser name
          -> Bool
          -- ^ Enable interpolation
          -> LineBreaks
          -> TH.DecsQ
parserTpl :: String -> Bool -> LineBreaks -> DecsQ
parserTpl (String -> Name
TH.mkName (String -> Name) -> (String -> Exp) -> String -> (Name, Exp)
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& String -> Exp
varE -> (Name
n, Exp
fE)) Bool
withInterpolation LineBreaks
lineBreaks = [Dec] -> DecsQ
forall (m :: * -> *) a. Monad m => a -> m a
return

  [ Name -> Type -> Dec
TH.SigD Name
n (Name -> Type
TH.ConT (Name -> Type) -> Name -> Type
forall a b. (a -> b) -> a -> b
$ String -> Name
TH.mkName String
"Parser") -- Type annotation for parser
  , Name -> [Clause] -> Dec
TH.FunD Name
n [Clause]
decls                          -- All patterns to match
  ]

  -- About naming variables:
  --   Suffixes (where `foo` is a variable name):
  --     * `fooP` means Pattern
  --     * `fooE` means Expression
  -- Variables:
  --   * `fE` - Quoter-parser's name (like `parseQM`), for recursive calls
  --   * `aE` - Result accumulator, defined for each pattern, like:
  --              `parseQM a …` where `…` is pattern and body
  --            For each from `decls` this prefix shown above
  --              is aproduced by `f` helper.
  --            For instance first pattern would be:
  --              `parseQM a [] = [Literal (reverse a)]`
  --   * `f` - Helper to prefix each pattern with `parseQM a`
  --           where `parseQM` is a name of parser from first argument.
  --  `apps` produces Expression,
  --    multiple function application with variate arity.
  where

    decls :: [Clause]
decls =

      let
        -- Filtering truthy conditional patterns,
        -- collecting declarative
        -- and applying `f`.
        reducer :: Decl -> [Clause] -> [Clause]
reducer Decl
x [Clause]
acc = case Decl
x of
                             C (Bool
True, Pat
pat, Exp
body) -> Pat -> Exp -> Clause
f Pat
pat Exp
body Clause -> [Clause] -> [Clause]
forall a. a -> [a] -> [a]
: [Clause]
acc
                             D (      Pat
pat, Exp
body) -> Pat -> Exp -> Clause
f Pat
pat Exp
body Clause -> [Clause] -> [Clause]
forall a. a -> [a] -> [a]
: [Clause]
acc
                             Decl
_                   -> [Clause]
acc -- Skipping

      in

      -- All patterns here are prefixed with "a" (`aE`) accumulator.
      --
      -- Means:
      --   ```
      --   D ( consP [varP "x", varP "xs"]
      --     , apps [fE, consE [varE "x", aE], varE "xs"]
      --     )
      --   ```
      -- will be for example:
      --   ```
      --   parseQM a (x:xs) = parseQM (x:a) xs
      --   ```
      (Decl -> [Clause] -> [Clause]) -> [Clause] -> [Decl] -> [Clause]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Decl -> [Clause] -> [Clause]
reducer [] [

        (Pat, Exp) -> Decl
D ( [Pat] -> Pat
ListP []
          , [Exp] -> Exp
ListE [[Exp] -> Exp
apps [String -> Exp
conE String
"Literal", [Exp] -> Exp
apps [String -> Exp
varE String
"reverse", Exp
aE]]]
          )

      , (Bool, Pat, Exp) -> Decl
C ( LineBreaks
lineBreaks LineBreaks -> [LineBreaks] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [LineBreaks
KeepLineBreaks, LineBreaks
ReplaceLineBreaksWithSpaces]
          , Exp -> Pat -> Pat
ViewP (String -> Exp
varE String
"clearLastQXXLineBreak") (Pat -> Pat) -> Pat -> Pat
forall a b. (a -> b) -> a -> b
$ String -> [Pat] -> Pat
conP String
"True" []
          , [Exp] -> Exp
apps [Exp
fE, Exp
aE, String -> Exp
strE String
""]
          )

        -- Cutting '\r' symbols off.
        -- Doing it here (also in '.Helpers' module) to prevent touching
        -- anything inside interpolation block, to make it be just pure
        -- untouched haskell code, with minimal specific details (such as
        -- ability to escape close bracket `\}` to prevent interpolation block
        -- from closing.
      , (Pat, Exp) -> Decl
D ( [Pat] -> Pat
consP [String -> Pat
varP String
"x", Char -> Pat
chrP Char
'\r', Char -> Pat
chrP Char
'\n', String -> Pat
varP String
"xs"]
          , [Exp] -> Exp
apps [Exp
fE, Exp
aE, [Exp] -> Exp
consE [String -> Exp
varE String
"x", Char -> Exp
chrE Char
'\n', String -> Exp
varE String
"xs"]]
          )
      , (Pat, Exp) -> Decl
D ( [Pat] -> Pat
consP [Char -> Pat
chrP Char
'\r', Char -> Pat
chrP Char
'\n', String -> Pat
varP String
"xs"]
          , [Exp] -> Exp
apps [Exp
fE, Exp
aE, [Exp] -> Exp
consE [Char -> Exp
chrE Char
'\n', String -> Exp
varE String
"xs"]]
          )

      , (Pat, Exp) -> Decl
D ( [Pat] -> Pat
consP [Char -> Pat
chrP Char
'\\', Char -> Pat
chrP Char
'\\', String -> Pat
varP String
"xs"]
          , [Exp] -> Exp
apps [Exp
fE, [Exp] -> Exp
consE [Char -> Exp
chrE Char
'\\', Exp
aE], String -> Exp
varE String
"xs"]
          )

      , (Bool, Pat, Exp) -> Decl
C ( Bool
withInterpolation
          , [Pat] -> Pat
consP [Char -> Pat
chrP Char
'\\', Char -> Pat
chrP Char
'{', String -> Pat
varP String
"xs"]
          , [Exp] -> Exp
apps [Exp
fE, [Exp] -> Exp
consE [Char -> Exp
chrE Char
'{', Exp
aE], String -> Exp
varE String
"xs"]
          )

      , (Pat, Exp) -> Decl
D ( [Pat] -> Pat
consP [Char -> Pat
chrP Char
'\\', Char -> Pat
chrP Char
' ', String -> Pat
varP String
"xs"]
          , [Exp] -> Exp
apps [Exp
fE, [Exp] -> Exp
consE [Char -> Exp
chrE Char
' ', Exp
aE], String -> Exp
varE String
"xs"]
          )

      , (Bool, Pat, Exp) -> Decl
C ( LineBreaks
lineBreaks LineBreaks -> LineBreaks -> Bool
forall a. Eq a => a -> a -> Bool
== LineBreaks
IgnoreLineBreaks
          , [Pat] -> Pat
consP [Char -> Pat
chrP Char
'\\', Char -> Pat
chrP Char
'\n', String -> Pat
varP String
"xs"]
          , [Exp] -> Exp
apps [Exp
fE, Exp
aE, [Exp] -> Exp
consE [Char -> Exp
chrE Char
'\n', String -> Exp
varE String
"xs"]]
          )

        -- Explicitly cutting off line breaks
      , (Bool, Pat, Exp) -> Decl
C ( LineBreaks
lineBreaks LineBreaks -> [LineBreaks] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [LineBreaks
KeepLineBreaks, LineBreaks
ReplaceLineBreaksWithSpaces]
          , [Pat] -> Pat
consP [Char -> Pat
chrP Char
'\\', Char -> Pat
chrP Char
'\n', String -> Pat
varP String
"xs"]

          , let cutOffFakeLnOrUseXS :: Exp -> Exp
cutOffFakeLnOrUseXS Exp
maybeVal =
                  [Exp] -> Exp
apps [String -> Exp
varE String
"maybe", String -> Exp
varE String
"xs", String -> Exp
varE String
"tail", Exp
maybeVal]

                clearNextLineIndentFromXS :: Exp
clearNextLineIndentFromXS =
                  -- Fake '\n' here to make `clearIndentAtSOF` works for this
                  [Exp] -> Exp
apps [String -> Exp
varE String
"clearIndentAtSOF", [Exp] -> Exp
consE [Char -> Exp
chrE Char
'\n', String -> Exp
varE String
"xs"]]

             in -- Recursively do stuff
                [Exp] -> Exp
apps [Exp
fE, Exp
aE, Exp -> Exp
cutOffFakeLnOrUseXS Exp
clearNextLineIndentFromXS]
          )

      , (Pat, Exp) -> Decl
D ( [Pat] -> Pat
consP [Char -> Pat
chrP Char
'\\', Char -> Pat
chrP Char
'n', String -> Pat
varP String
"xs"]
          , [Exp] -> Exp
apps [Exp
fE, [Exp] -> Exp
consE [Char -> Exp
chrE Char
'\n', Exp
aE], String -> Exp
varE String
"xs"]
          )

      , (Pat, Exp) -> Decl
D ( [Pat] -> Pat
consP [Char -> Pat
chrP Char
'\\', Char -> Pat
chrP Char
'\t', String -> Pat
varP String
"xs"]
          , [Exp] -> Exp
apps [Exp
fE, [Exp] -> Exp
consE [Char -> Exp
chrE Char
'\t', Exp
aE], String -> Exp
varE String
"xs"]
          )

      , (Pat, Exp) -> Decl
D ( [Pat] -> Pat
consP [Char -> Pat
chrP Char
'\\', Char -> Pat
chrP Char
't', String -> Pat
varP String
"xs"]
          , [Exp] -> Exp
apps [Exp
fE, [Exp] -> Exp
consE [Char -> Exp
chrE Char
'\t', Exp
aE], String -> Exp
varE String
"xs"]
          )

      , (Pat, Exp) -> Decl
D ( String -> Pat
strP String
"\\"
          , [Exp] -> Exp
apps [Exp
fE, [Exp] -> Exp
consE [Char -> Exp
chrE Char
'\\', Exp
aE], String -> Exp
strE String
""]
          )

      , (Bool, Pat, Exp) -> Decl
C ( Bool
withInterpolation
          , [Pat] -> Pat
consP [Char -> Pat
chrP Char
'{', String -> Pat
varP String
"xs"]
          , [Exp] -> Exp
consE [ [Exp] -> Exp
apps [String -> Exp
conE String
"Literal", [Exp] -> Exp
apps [String -> Exp
varE String
"reverse", Exp
aE]]
                  , [Exp] -> Exp
apps [String -> Exp
varE String
"unQX", Exp
fE, String -> Exp
strE String
"", String -> Exp
varE String
"xs"]
                  ]
          )

      , (Pat, Exp) -> Decl
D ( Exp -> Pat -> Pat
ViewP (String -> Exp
varE String
"clearIndentAtSOF") (Pat -> Pat) -> Pat -> Pat
forall a b. (a -> b) -> a -> b
$ String -> [Pat] -> Pat
conP String
"Just" [String -> Pat
varP String
"clean"]
          , [Exp] -> Exp
apps [Exp
fE, Exp
aE, String -> Exp
varE String
"clean"]
          )

      , (Pat, Exp) -> Decl
D ( Exp -> Pat -> Pat
ViewP (String -> Exp
varE String
"clearIndentTillEOF") (Pat -> Pat) -> Pat -> Pat
forall a b. (a -> b) -> a -> b
$ String -> [Pat] -> Pat
conP String
"Just" [String -> Pat
varP String
"clean"]
          , [Exp] -> Exp
apps [Exp
fE, Exp
aE, String -> Exp
varE String
"clean"]
          )

        -- Cutting off line breaks
      , (Bool, Pat, Exp) -> Decl
C ( LineBreaks
lineBreaks LineBreaks -> LineBreaks -> Bool
forall a. Eq a => a -> a -> Bool
== LineBreaks
IgnoreLineBreaks
          , [Pat] -> Pat
consP [Char -> Pat
chrP Char
'\n', String -> Pat
varP String
"xs"]
          , [Exp] -> Exp
apps [Exp
fE, Exp
aE, String -> Exp
varE String
"xs"]
          )

        -- Replacing line breaks with spaces
      , (Bool, Pat, Exp) -> Decl
C ( LineBreaks
lineBreaks LineBreaks -> LineBreaks -> Bool
forall a. Eq a => a -> a -> Bool
== LineBreaks
ReplaceLineBreaksWithSpaces
          , [Pat] -> Pat
consP [Char -> Pat
chrP Char
'\n', String -> Pat
varP String
"xs"]
          , [Exp] -> Exp
apps [Exp
fE, [Exp] -> Exp
consE [Char -> Exp
chrE Char
' ', Exp
aE], String -> Exp
varE String
"xs"]
          )

      , (Pat, Exp) -> Decl
D ( [Pat] -> Pat
consP [String -> Pat
varP String
"x", String -> Pat
varP String
"xs"]
          , [Exp] -> Exp
apps [Exp
fE, [Exp] -> Exp
consE [String -> Exp
varE String
"x", Exp
aE], String -> Exp
varE String
"xs"]
          )
      ]

    aE :: Exp
aE = String -> Exp
varE String
"a"
    f :: Pat -> Exp -> Clause
f Pat
pat Exp
body = [Pat] -> Body -> [Dec] -> Clause
TH.Clause [String -> Pat
varP String
"a", Pat
pat] (Exp -> Body
TH.NormalB Exp
body) []

    apps :: [Exp] -> Exp
apps [Exp
x] = Exp
x
    apps (Exp
x:Exp
y:[Exp]
zs) = [Exp] -> Exp
apps ([Exp] -> Exp) -> [Exp] -> Exp
forall a b. (a -> b) -> a -> b
$ Exp -> Exp -> Exp
TH.AppE Exp
x Exp
y Exp -> [Exp] -> [Exp]
forall a. a -> [a] -> [a]
: [Exp]
zs
    apps [] = String -> Exp
forall a. HasCallStack => String -> a
error String
"apps []"

    consP :: [Pat] -> Pat
consP [Pat
x] = Pat
x
    consP (Pat
x:Pat
y:[Pat]
zs) = [Pat] -> Pat
consP ([Pat] -> Pat) -> [Pat] -> Pat
forall a b. (a -> b) -> a -> b
$ Pat -> Name -> Pat -> Pat
TH.UInfixP Pat
x (String -> Name
TH.mkName String
":") Pat
y Pat -> [Pat] -> [Pat]
forall a. a -> [a] -> [a]
: [Pat]
zs
    consP [] = String -> Pat
forall a. HasCallStack => String -> a
error String
"consP []"

    consE :: [Exp] -> Exp
consE [Exp
x] = Exp
x
    consE (Exp
x:Exp
y:[Exp]
zs) = [Exp] -> Exp
consE ([Exp] -> Exp) -> [Exp] -> Exp
forall a b. (a -> b) -> a -> b
$ Exp -> Exp -> Exp -> Exp
TH.UInfixE Exp
x (String -> Exp
conE String
":") Exp
y Exp -> [Exp] -> [Exp]
forall a. a -> [a] -> [a]
: [Exp]
zs
    consE [] = String -> Exp
forall a. HasCallStack => String -> a
error String
"consE []"


varP :: String ->             TH.Pat ; varP :: String -> Pat
varP = Name -> Pat
TH.VarP (Name -> Pat) -> (String -> Name) -> String -> Pat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Name
TH.mkName
varE :: String ->             TH.Exp ; varE :: String -> Exp
varE = Name -> Exp
TH.VarE (Name -> Exp) -> (String -> Name) -> String -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Name
TH.mkName
#if MIN_VERSION_template_haskell(2,18,0)
conP :: String -> [TH.Pat] -> TH.Pat ; conP :: String -> [Pat] -> Pat
conP = (Name -> [Type] -> [Pat] -> Pat) -> [Type] -> Name -> [Pat] -> Pat
forall a b c. (a -> b -> c) -> b -> a -> c
flip Name -> [Type] -> [Pat] -> Pat
TH.ConP [Type]
forall a. Monoid a => a
mempty (Name -> [Pat] -> Pat)
-> (String -> Name) -> String -> [Pat] -> Pat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Name
TH.mkName
#else
conP :: String -> [TH.Pat] -> TH.Pat ; conP = TH.ConP . TH.mkName
#endif

conE :: String ->             TH.Exp ; conE :: String -> Exp
conE = Name -> Exp
TH.ConE (Name -> Exp) -> (String -> Name) -> String -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Name
TH.mkName

chrP :: Char   -> TH.Pat ; chrP :: Char -> Pat
chrP = Lit -> Pat
TH.LitP (Lit -> Pat) -> (Char -> Lit) -> Char -> Pat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Lit
TH.CharL
chrE :: Char   -> TH.Exp ; chrE :: Char -> Exp
chrE = Lit -> Exp
TH.LitE (Lit -> Exp) -> (Char -> Lit) -> Char -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Lit
TH.CharL
strP :: String -> TH.Pat ; strP :: String -> Pat
strP = Lit -> Pat
TH.LitP (Lit -> Pat) -> (String -> Lit) -> String -> Pat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Lit
TH.StringL
strE :: String -> TH.Exp ; strE :: String -> Exp
strE = Lit -> Exp
TH.LitE (Lit -> Exp) -> (String -> Lit) -> String -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Lit
TH.StringL