-- SPDX-FileCopyrightText: 2021 Oxhead Alpha
-- SPDX-License-Identifier: LicenseRef-MIT-OA

{-# OPTIONS_HADDOCK not-home #-}

-- | Internal module exporting utilities for making string interpolation quasiquoters
module Morley.Util.Interpolate.Internal
  ( module Morley.Util.Interpolate.Internal
  ) where

import Prelude hiding (lift)

import Data.Char (isSpace)
import Data.List qualified as List
import Data.Set qualified as S
import Data.Text.Lazy qualified as TL
import Fmt (build, fmt)
import Language.Haskell.TH (Exp, Name, Q, lookupValueName, mkName, reportWarning, varE)
import Language.Haskell.TH.Quote (QuasiQuoter(..))
import Prettyprinter (align)
import Text.ParserCombinators.ReadP (readP_to_S)
import Text.Read.Lex (lexChar)

-- | Datatype encoding transformations we apply to a quoter input and output.
-- Note the order is important! We first unescape, then unindent, then trim.
data Transformation
  = Unescaping
  | Unindenting
  | Trimming
  | Polymorphic
  deriving stock (Transformation -> Transformation -> Bool
(Transformation -> Transformation -> Bool)
-> (Transformation -> Transformation -> Bool) -> Eq Transformation
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Transformation -> Transformation -> Bool
== :: Transformation -> Transformation -> Bool
$c/= :: Transformation -> Transformation -> Bool
/= :: Transformation -> Transformation -> Bool
Eq, Eq Transformation
Eq Transformation
-> (Transformation -> Transformation -> Ordering)
-> (Transformation -> Transformation -> Bool)
-> (Transformation -> Transformation -> Bool)
-> (Transformation -> Transformation -> Bool)
-> (Transformation -> Transformation -> Bool)
-> (Transformation -> Transformation -> Transformation)
-> (Transformation -> Transformation -> Transformation)
-> Ord Transformation
Transformation -> Transformation -> Bool
Transformation -> Transformation -> Ordering
Transformation -> Transformation -> Transformation
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
$ccompare :: Transformation -> Transformation -> Ordering
compare :: Transformation -> Transformation -> Ordering
$c< :: Transformation -> Transformation -> Bool
< :: Transformation -> Transformation -> Bool
$c<= :: Transformation -> Transformation -> Bool
<= :: Transformation -> Transformation -> Bool
$c> :: Transformation -> Transformation -> Bool
> :: Transformation -> Transformation -> Bool
$c>= :: Transformation -> Transformation -> Bool
>= :: Transformation -> Transformation -> Bool
$cmax :: Transformation -> Transformation -> Transformation
max :: Transformation -> Transformation -> Transformation
$cmin :: Transformation -> Transformation -> Transformation
min :: Transformation -> Transformation -> Transformation
Ord, Int -> Transformation
Transformation -> Int
Transformation -> [Transformation]
Transformation -> Transformation
Transformation -> Transformation -> [Transformation]
Transformation
-> Transformation -> Transformation -> [Transformation]
(Transformation -> Transformation)
-> (Transformation -> Transformation)
-> (Int -> Transformation)
-> (Transformation -> Int)
-> (Transformation -> [Transformation])
-> (Transformation -> Transformation -> [Transformation])
-> (Transformation -> Transformation -> [Transformation])
-> (Transformation
    -> Transformation -> Transformation -> [Transformation])
-> Enum Transformation
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
$csucc :: Transformation -> Transformation
succ :: Transformation -> Transformation
$cpred :: Transformation -> Transformation
pred :: Transformation -> Transformation
$ctoEnum :: Int -> Transformation
toEnum :: Int -> Transformation
$cfromEnum :: Transformation -> Int
fromEnum :: Transformation -> Int
$cenumFrom :: Transformation -> [Transformation]
enumFrom :: Transformation -> [Transformation]
$cenumFromThen :: Transformation -> Transformation -> [Transformation]
enumFromThen :: Transformation -> Transformation -> [Transformation]
$cenumFromTo :: Transformation -> Transformation -> [Transformation]
enumFromTo :: Transformation -> Transformation -> [Transformation]
$cenumFromThenTo :: Transformation
-> Transformation -> Transformation -> [Transformation]
enumFromThenTo :: Transformation
-> Transformation -> Transformation -> [Transformation]
Enum, Transformation
Transformation -> Transformation -> Bounded Transformation
forall a. a -> a -> Bounded a
$cminBound :: Transformation
minBound :: Transformation
$cmaxBound :: Transformation
maxBound :: Transformation
Bounded)

-- | A 'Set' of 'Transformation'
type Transformations = Set Transformation

-- | Used to generate quasi-quoters
transformationsPowerSet :: [Transformations]
transformationsPowerSet :: [Transformations]
transformationsPowerSet = Set Transformations -> [Element (Set Transformations)]
forall t. Container t => t -> [Element t]
toList (Set Transformations -> [Element (Set Transformations)])
-> Set Transformations -> [Element (Set Transformations)]
forall a b. (a -> b) -> a -> b
$ Transformations -> Set Transformations
forall a. Set a -> Set (Set a)
S.powerSet (Transformations -> Set Transformations)
-> Transformations -> Set Transformations
forall a b. (a -> b) -> a -> b
$ [Transformation] -> Transformations
forall a. Eq a => [a] -> Set a
S.fromAscList [Transformation
forall a. Bounded a => a
minBound..Transformation
forall a. Bounded a => a
maxBound]

-- | Generate TH 'Name' for a quoter based on a set of transformations
generateName :: Transformations -> Name
generateName :: Transformations -> Name
generateName Transformations
ls = [Char] -> Name
mkName ([Char] -> Name) -> [Char] -> Name
forall a b. (a -> b) -> a -> b
$
     Transformation -> [Char] -> [Char] -> [Char]
t Transformation
Unescaping [Char]
"" [Char]
"l" [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
"i" [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Transformation -> [Char] -> [Char] -> [Char]
t Transformation
Trimming [Char]
"t" [Char]
""
  [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Transformation -> [Char] -> [Char] -> [Char]
t Transformation
Unindenting [Char]
"u" [Char]
"" [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Transformation -> [Char] -> [Char] -> [Char]
t Transformation
Polymorphic [Char]
"" [Char]
"b"
  where t :: Transformation -> [Char] -> [Char] -> [Char]
t Transformation
el [Char]
tru [Char]
fls = if Transformation -> Transformations -> Bool
forall a. Ord a => a -> Set a -> Bool
S.member Transformation
el Transformations
ls then [Char]
tru else [Char]
fls

-- | Make a 'QuasiQuoter' using a given set of transformaions
mkQuoter :: Transformations -> QuasiQuoter
mkQuoter :: Transformations -> QuasiQuoter
mkQuoter Transformations
ts = QuasiQuoter
  { quoteExp :: [Char] -> Q Exp
quoteExp = (Element [Transformation] -> ([Char] -> Q Exp) -> [Char] -> Q Exp)
-> ([Char] -> Q Exp) -> [Transformation] -> [Char] -> Q Exp
forall t b. Container t => (Element t -> b -> b) -> b -> t -> b
forall b.
(Element [Transformation] -> b -> b) -> b -> [Transformation] -> b
foldr Element [Transformation] -> ([Char] -> Q Exp) -> [Char] -> Q Exp
Transformation -> ([Char] -> Q Exp) -> [Char] -> Q Exp
go [Char] -> Q Exp
makeBuilder ([Transformation] -> [Char] -> Q Exp)
-> [Transformation] -> [Char] -> Q Exp
forall a b. (a -> b) -> a -> b
$ Transformations -> [Element Transformations]
forall t. Container t => t -> [Element t]
toList Transformations
ts
  , quotePat :: [Char] -> Q Pat
quotePat = \[Char]
_ -> [Char] -> Q Pat
forall a. [Char] -> Q a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"Cannot be used at pattern position"
  , quoteType :: [Char] -> Q Type
quoteType = \[Char]
_ -> [Char] -> Q Type
forall a. [Char] -> Q a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"Cannot be used at type position"
  , quoteDec :: [Char] -> Q [Dec]
quoteDec = \[Char]
_ -> [Char] -> Q [Dec]
forall a. [Char] -> Q a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"Cannot be used as declaration"
  }
  where
    go :: Transformation -> ([Char] -> Q Exp) -> [Char] -> Q Exp
go Transformation
Unescaping  [Char] -> Q Exp
f = [Char] -> Q Exp
f ([Char] -> Q Exp) -> ([Char] -> Q [Char]) -> [Char] -> Q Exp
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< [Char] -> Q [Char]
unescape
    go Transformation
Unindenting [Char] -> Q Exp
f = [Char] -> Q Exp
f ([Char] -> Q Exp) -> ([Char] -> [Char]) -> [Char] -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char]
unindent ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char]
dropLeadingNewline
    go Transformation
Trimming    [Char] -> Q Exp
f = [Char] -> Q Exp
f ([Char] -> Q Exp) -> ([Char] -> [Char]) -> [Char] -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char]
trim
    go Transformation
Polymorphic [Char] -> Q Exp
f = \[Char]
s -> [| fmt $([Char] -> Q Exp
f [Char]
s) |]

unescape :: String -> Q String
unescape :: [Char] -> Q [Char]
unescape (Char
'\\':Char
'#':[Char]
xs) = (Char
'\\'Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
:) ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char
'#'Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
:) ([Char] -> [Char]) -> Q [Char] -> Q [Char]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> Q [Char]
unescape [Char]
xs
unescape (Char
'\\':Char
'&':[Char]
xs) = [Char] -> Q [Char]
unescape [Char]
xs
unescape xs :: [Char]
xs@(Char
'\\':Char
c:[Char]
cs) = case ReadP Char -> ReadS Char
forall a. ReadP a -> ReadS a
readP_to_S ReadP Char
lexChar [Char]
xs of
  (Char
ch, [Char]
rest):[(Char, [Char])]
_ -> (Char
ch Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
:) ([Char] -> [Char]) -> Q [Char] -> Q [Char]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> Q [Char]
unescape [Char]
rest
  [] -> do
    [Char] -> Q ()
reportWarning ([Char] -> Q ()) -> [Char] -> Q ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Unrecognized escape sequence near '" [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> (Char -> Bool) -> [Char] -> [Char]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Bool -> Bool
forall a. Boolean a => a -> a
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isSpace) [Char]
xs [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
"'"
    (Char
c Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
:) ([Char] -> [Char]) -> Q [Char] -> Q [Char]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> Q [Char]
unescape [Char]
cs
unescape (Char
c:[Char]
cs) = (Char
c Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
:) ([Char] -> [Char]) -> Q [Char] -> Q [Char]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> Q [Char]
unescape [Char]
cs
unescape [] = [Char] -> Q [Char]
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []

makeBuilder :: String -> Q Exp
makeBuilder :: [Char] -> Q Exp
makeBuilder = Doc () -> [Char] -> Q Exp
go Doc ()
forall a. Monoid a => a
mempty
  where
    go :: Doc () -> [Char] -> Q Exp
go Doc ()
tacc (Char
'\\':Char
'#':[Char]
xs) = Doc () -> [Char] -> Q Exp
go (Doc ()
tacc Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> Doc ()
"#") [Char]
xs
    go Doc ()
tacc (Char
'#':Char
'{':[Char]
xs)
      | ([Char]
expr, Char
'}':[Char]
ys) <- (Char -> Bool) -> [Char] -> ([Char], [Char])
forall a. (a -> Bool) -> [a] -> ([a], [a])
List.span (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'}') [Char]
xs
      = [Char] -> Q (Maybe Name)
lookupValueName [Char]
expr Q (Maybe Name) -> (Maybe Name -> Q Exp) -> Q Exp
forall a b. Q a -> (a -> Q b) -> Q b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          Just Name
valueName ->
            let txt :: Text
txt = Doc () -> Text
forall a. FromDoc a => Doc () -> a
fmt Doc ()
tacc :: Text
            in [| build txt <> align (build $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
valueName)) <> $(Doc () -> [Char] -> Q Exp
go Doc ()
forall a. Monoid a => a
mempty [Char]
ys) |]
          Maybe Name
Nothing -> [Char] -> Q Exp
forall a. [Char] -> Q a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> Q Exp) -> [Char] -> Q Exp
forall a b. (a -> b) -> a -> b
$ [Char]
"Variable '" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
expr [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"' is not in scope"
    go Doc ()
tacc (Char
c:[Char]
cs) = case (Char -> Bool) -> [Char] -> ([Char], [Char])
forall a. (a -> Bool) -> [a] -> ([a], [a])
List.span (Element [Char] -> [Char] -> Bool
forall t. (Container t, Eq (Element t)) => Element t -> t -> Bool
`notElem` [Char
'\\', Char
'#']) [Char]
cs of
      ([Char]
str, [Char]
rest) -> Doc () -> [Char] -> Q Exp
go (Doc ()
tacc Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
<> [Char] -> Doc ()
forall a. Buildable a => a -> Doc ()
build (Char
cChar -> [Char] -> [Char]
forall a. a -> [a] -> [a]
:[Char]
str)) [Char]
rest
    go Doc ()
tacc [] = let txt :: Text
txt = forall a. FromDoc a => Doc () -> a
fmt @Text Doc ()
tacc in [| build txt |]

splitTextLazy :: (Char -> Bool) -> TL.Text -> NonEmpty TL.Text
splitTextLazy :: (Char -> Bool) -> Text -> NonEmpty Text
splitTextLazy Char -> Bool
p Text
t = case [Text] -> Maybe (NonEmpty Text)
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty ([Text] -> Maybe (NonEmpty Text))
-> [Text] -> Maybe (NonEmpty Text)
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> Text -> [Text]
TL.split Char -> Bool
p Text
t of
  Just NonEmpty Text
ne -> NonEmpty Text
ne
  Maybe (NonEmpty Text)
Nothing -> Text -> NonEmpty Text
forall a. HasCallStack => Text -> a
error Text
"Morley.Util.Interpolate.splitTextLazy: the impossible happened"

dropLeadingNewline :: String -> String
dropLeadingNewline :: [Char] -> [Char]
dropLeadingNewline (Char
'\n':[Char]
xs) = [Char]
xs
dropLeadingNewline [Char]
xs = [Char]
xs

unindent :: String -> String
unindent :: [Char] -> [Char]
unindent [Char]
s =
  case [[Char]] -> Maybe (NonEmpty [Char])
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty (([Char] -> Bool) -> [[Char]] -> [[Char]]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
forall a. Boolean a => a -> a
not (Bool -> Bool) -> ([Char] -> Bool) -> [Char] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Bool
forall t. Container t => t -> Bool
null) [[Char]]
ls) of
    Just NonEmpty [Char]
ne ->
      let minIndent :: Int
minIndent = NonEmpty Int -> Int
forall a. Ord a => NonEmpty a -> a
minimum (NonEmpty Int -> Int) -> NonEmpty Int -> Int
forall a b. (a -> b) -> a -> b
$ [Char] -> Int
indentOf ([Char] -> Int) -> NonEmpty [Char] -> NonEmpty Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty [Char]
ne
      -- See Note [lines/unlines] below about the use of 'intercalate'
      in [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
"\n" ([[Char]] -> [Char]) -> [[Char]] -> [Char]
forall a b. (a -> b) -> a -> b
$ Int -> [Char] -> [Char]
forall a. Int -> [a] -> [a]
drop Int
minIndent ([Char] -> [Char]) -> [[Char]] -> [[Char]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [[Char]]
ls
    Maybe (NonEmpty [Char])
Nothing -> [Char]
s
  where
    ls :: [[Char]]
ls = (Char -> Bool) -> [Char] -> [[Char]]
split (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\n') [Char]
s
    indentOf :: [Char] -> Int
indentOf = [Char] -> Int
forall i a.
(Integral i, Container a,
 DefaultToInt (IsIntSubType Length i) i) =>
a -> i
length ([Char] -> Int) -> ([Char] -> [Char]) -> [Char] -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> [Char] -> [Char]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ')

-- See Note [lines/unlines] below about the use of this function
split :: (Char -> Bool) -> String -> [String]
split :: (Char -> Bool) -> [Char] -> [[Char]]
split Char -> Bool
cond [Char]
s = case (Char -> Bool) -> [Char] -> ([Char], [Char])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break Char -> Bool
cond [Char]
s of
  ([Char]
pfx, Char
_:[Char]
suf) -> [Char]
pfx [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: (Char -> Bool) -> [Char] -> [[Char]]
split Char -> Bool
cond [Char]
suf
  ([Char]
pfx, [Char]
"") -> [[Char]
pfx]

trim :: String -> String
trim :: [Char] -> [Char]
trim = [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
"\n" ([[Char]] -> [Char]) -> ([Char] -> [[Char]]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char] -> Bool) -> [[Char]] -> [[Char]]
forall a. (a -> Bool) -> [a] -> [a]
List.dropWhileEnd ((Element [Char] -> Bool) -> [Char] -> Bool
forall c b.
(Container c, BooleanMonoid b) =>
(Element c -> b) -> c -> b
all (Element [Char] -> Element [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== Char
Element [Char]
' '))
     -- See Note [lines/unlines] below about the use of 'intercalate'
     ([[Char]] -> [[Char]])
-> ([Char] -> [[Char]]) -> [Char] -> [[Char]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char] -> Bool) -> [[Char]] -> [[Char]]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile ((Element [Char] -> Bool) -> [Char] -> Bool
forall c b.
(Container c, BooleanMonoid b) =>
(Element c -> b) -> c -> b
all (Element [Char] -> Element [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== Char
Element [Char]
' ')) ([[Char]] -> [[Char]])
-> ([Char] -> [[Char]]) -> [Char] -> [[Char]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> [Char] -> [[Char]]
split (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\n')

{- Note [lines/unlines]
   ~~~~~~~~~~~~~~~~~~~~

lines/unlines don't actually satisfy our requirements here due to
some edge case behaviour.

First of all, `lines` and `unlines` aren't strictly speaking inverse
of each other: `unlines` always adds a trailing newline. Consider:

>>> unlines . lines $ "hello\nworld"
"hello\nworld\n"

Furthermore, `lines` itself does "gobble" the trailing empty line, consider:

>>> lines $ "hello\nworld\n"
["hello","world"]

We actually need this to be `["hello","world",""]` for the unindenting
algorithm to work correctly (i.e. not unindent anything if the last indent is 0),
but that doesn't work with `lines` (also we either lose a trailing newline
or get an extra one with `unlines`). I could use `lines` with `trim`,
but for consistency chose not to.

Long story short, I use `split (=='\n')` and `Text.Lazy.split (=='\n')`
to get a list of lines, and `intercalate "\n"` to glue them back.
This has the behaviour we need.

- @lierdakil

-}