Internal.hs

-- 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 (Eq, Ord, Enum, Bounded)

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

-- | Used to generate quasi-quoters
transformationsPowerSet :: [Transformations]
transformationsPowerSet = toList $ S.powerSet $ S.fromAscList [minBound..maxBound]

-- | Generate TH 'Name' for a quoter based on a set of transformations
generateName :: Transformations -> Name
generateName ls = mkName $
     t Unescaping "" "l" <> "i" <> t Trimming "t" ""
  <> t Unindenting "u" "" <> t Polymorphic "" "b"
  where t el tru fls = if S.member el ls then tru else fls

-- | Make a 'QuasiQuoter' using a given set of transformaions
mkQuoter :: Transformations -> QuasiQuoter
mkQuoter ts = QuasiQuoter
  { quoteExp = foldr go makeBuilder $ toList ts
  , quotePat = \_ -> fail "Cannot be used at pattern position"
  , quoteType = \_ -> fail "Cannot be used at type position"
  , quoteDec = \_ -> fail "Cannot be used as declaration"
  }
  where
    go Unescaping  f = f <=< unescape
    go Unindenting f = f . unindent . dropLeadingNewline
    go Trimming    f = f . trim
    go Polymorphic f = \s -> [| fmt $(f s) |]

unescape :: String -> Q String
unescape ('\\':'#':xs) = ('\\':) . ('#':) <$> unescape xs
unescape ('\\':'&':xs) = unescape xs
unescape xs@('\\':c:cs) = case readP_to_S lexChar xs of
  (ch, rest):_ -> (ch :) <$> unescape rest
  [] -> do
    reportWarning $ "Unrecognized escape sequence near '" <> takeWhile (not . isSpace) xs <> "'"
    (c :) <$> unescape cs
unescape (c:cs) = (c :) <$> unescape cs
unescape [] = pure []

makeBuilder :: String -> Q Exp
makeBuilder = go mempty
  where
    go tacc ('\\':'#':xs) = go (tacc <> "#") xs
    go tacc ('#':'{':xs)
      | (expr, '}':ys) <- List.span (/='}') xs
      = lookupValueName expr >>= \case
          Just valueName ->
            let txt = fmt tacc
                ls = splitTextLazy (=='\n') txt
                indent = length . last $ ls
            in [| build txt <> indentF'' indent (build $(varE valueName)) <> $(go mempty ys) |]
          Nothing -> fail $ "Variable '" ++ expr ++ "' is not in scope"
    go tacc (c:cs) = case List.span (`notElem` ['\\', '#']) cs of
      (str, rest) -> go (tacc <> build (c:str)) rest
    go tacc [] = let txt = fmt @Text 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'' indent bld = case splitTextLazy (=='\n') $ toLazyText bld of
  (x :| xs) -> fromLazyText . TL.intercalate "\n" $ x : map addIndent xs
  where
    addIndent str | null str = str
                  | otherwise = spaces <> str
    spaces = TL.replicate (fromIntegral indent) " "

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

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

unindent :: String -> String
unindent s =
  case nonEmpty (filter (not . null) ls) of
    Just ne ->
      let minIndent = minimum $ indentOf <$> ne
      -- See Note [lines/unlines] below about the use of 'intercalate'
      in intercalate "\n" $ drop minIndent <$> ls
    Nothing -> s
  where
    ls = split (=='\n') s
    indentOf = length . takeWhile (== ' ')

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

trim :: String -> String
trim = intercalate "\n" . List.dropWhileEnd (all (== ' '))
     -- See Note [lines/unlines] below about the use of 'intercalate'
     . dropWhile (all (== ' ')) . split (=='\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

-}