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

-- | Internal module exporting utilities for making string interpolation quasiquoters
module Morley.Util.Interpolate.Internal
  ( Transformation(..)
  , Transformations
  , transformationsPowerSet
  , mkQuoter
  , generateName
  ) where

import Prelude hiding (lift)

import Data.Char (isSpace)
import Data.List qualified as List
import Data.Set qualified as S
import Data.Text.Internal.Builder (Builder, fromLazyText, toLazyText)
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 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
/= :: Transformation -> Transformation -> Bool
$c/= :: Transformation -> Transformation -> Bool
== :: Transformation -> Transformation -> Bool
$c== :: 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
min :: Transformation -> Transformation -> Transformation
$cmin :: Transformation -> Transformation -> Transformation
max :: Transformation -> Transformation -> Transformation
$cmax :: Transformation -> Transformation -> Transformation
>= :: Transformation -> Transformation -> Bool
$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
compare :: Transformation -> Transformation -> Ordering
$ccompare :: Transformation -> Transformation -> Ordering
$cp1Ord :: Eq 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
enumFromThenTo :: Transformation
-> Transformation -> Transformation -> [Transformation]
$cenumFromThenTo :: Transformation
-> Transformation -> Transformation -> [Transformation]
enumFromTo :: Transformation -> Transformation -> [Transformation]
$cenumFromTo :: Transformation -> Transformation -> [Transformation]
enumFromThen :: Transformation -> Transformation -> [Transformation]
$cenumFromThen :: Transformation -> Transformation -> [Transformation]
enumFrom :: Transformation -> [Transformation]
$cenumFrom :: Transformation -> [Transformation]
fromEnum :: Transformation -> Int
$cfromEnum :: Transformation -> Int
toEnum :: Int -> Transformation
$ctoEnum :: Int -> Transformation
pred :: Transformation -> Transformation
$cpred :: Transformation -> Transformation
succ :: Transformation -> Transformation
$csucc :: Transformation -> Transformation
Enum, Transformation
Transformation -> Transformation -> Bounded Transformation
forall a. a -> a -> Bounded a
maxBound :: Transformation
$cmaxBound :: Transformation
minBound :: Transformation
$cminBound :: 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 = String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$
     Transformation -> String -> String -> String
t Transformation
Unescaping String
"" String
"l" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"i" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Transformation -> String -> String -> String
t Transformation
Trimming String
"t" String
""
  String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Transformation -> String -> String -> String
t Transformation
Unindenting String
"u" String
"" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Transformation -> String -> String -> String
t Transformation
Polymorphic String
"" String
"b"
  where t :: Transformation -> String -> String -> String
t Transformation
el String
tru String
fls = if Transformation -> Transformations -> Bool
forall a. Ord a => a -> Set a -> Bool
S.member Transformation
el Transformations
ls then String
tru else String
fls

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

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

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

-- | A version of @Fmt.indentF'@ that doesn't indent the first line, and keeps the final line break
-- intact.
indentF'' :: Int -> Builder -> Builder
indentF'' :: Int -> Builder -> Builder
indentF'' Int
indent Builder
bld = case (Char -> Bool) -> Text -> NonEmpty Text
splitTextLazy (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'\n') (Text -> NonEmpty Text) -> Text -> NonEmpty Text
forall a b. (a -> b) -> a -> b
$ Builder -> Text
toLazyText Builder
bld of
  (Text
x :| [Text]
xs) -> Text -> Builder
fromLazyText (Text -> Builder) -> ([Text] -> Text) -> [Text] -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text] -> Text
TL.intercalate Text
"\n" ([Text] -> Builder) -> [Text] -> Builder
forall a b. (a -> b) -> a -> b
$ Text
x Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: (Text -> Text) -> [Text] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map Text -> Text
addIndent [Text]
xs
  where
    addIndent :: Text -> Text
addIndent Text
str | Text -> Bool
forall t. Container t => t -> Bool
null Text
str = Text
str
                  | Bool
otherwise = Text
spaces Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
str
    spaces :: Text
spaces = Int64 -> Text -> Text
TL.replicate (Int -> Int64
forall a b. (Integral a, Integral b, CheckIntSubType a b) => a -> b
fromIntegral Int
indent) Text
" "

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 :: String -> String
dropLeadingNewline (Char
'\n':String
xs) = String
xs
dropLeadingNewline String
xs = String
xs

unindent :: String -> String
unindent :: String -> String
unindent String
s =
  case [String] -> Maybe (NonEmpty String)
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty ((String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (String -> Bool) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Bool
forall t. Container t => t -> Bool
null) [String]
ls) of
    Just NonEmpty String
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
$ String -> Int
indentOf (String -> Int) -> NonEmpty String -> NonEmpty Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty String
ne
      -- See Note [lines/unlines] below about the use of 'intercalate'
      in String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"\n" ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ Int -> String -> String
forall a. Int -> [a] -> [a]
drop Int
minIndent (String -> String) -> [String] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String]
ls
    Maybe (NonEmpty String)
Nothing -> String
s
  where
    ls :: [String]
ls = (Char -> Bool) -> String -> [String]
split (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'\n') String
s
    indentOf :: String -> Int
indentOf = String -> Int
forall t. Container t => t -> Int
length (String -> Int) -> (String -> String) -> String -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> String -> String
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) -> String -> [String]
split Char -> Bool
cond String
s = case (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break Char -> Bool
cond String
s of
  (String
pfx, Char
_:String
suf) -> String
pfx String -> [String] -> [String]
forall a. a -> [a] -> [a]
: (Char -> Bool) -> String -> [String]
split Char -> Bool
cond String
suf
  (String
pfx, String
"") -> [String
pfx]

trim :: String -> String
trim :: String -> String
trim = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"\n" ([String] -> String) -> (String -> [String]) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
List.dropWhileEnd ((Element String -> Bool) -> String -> Bool
forall t. Container t => (Element t -> Bool) -> t -> Bool
all (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' '))
     -- See Note [lines/unlines] below about the use of 'intercalate'
     ([String] -> [String])
-> (String -> [String]) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile ((Element String -> Bool) -> String -> Bool
forall t. Container t => (Element t -> Bool) -> t -> Bool
all (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ')) ([String] -> [String])
-> (String -> [String]) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> String -> [String]
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

-}