{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE ViewPatterns #-}

-- | A lot of quasiquoters to format and interpolate string expressions.
module PyF
  ( fmt,
    fmtTrim,
    str,
    strTrim,
    raw,
    module PyF.Class,

    -- * Whitespace utilities
    trimIndent,

    -- * Configuration
    mkFormatter,
    defaultConfig,
    fmtConfig,
    strConfig,
    addTrim,
    addFormatting,
  )
where

import Data.Char (isSpace)
import Data.List (intercalate)
import Language.Haskell.TH.Quote (QuasiQuoter (..))
import PyF.Class
import PyF.Internal.QQ (Config (..), expQQ, toExp, wrapFromString)

-- | Generic formatter, can format an expression to any @t@ as long as
--   @t@ is an instance of 'IsString'.
fmt :: QuasiQuoter
fmt :: QuasiQuoter
fmt = String -> Config -> QuasiQuoter
mkFormatter String
"fmt" Config
fmtConfig

-- | Format with whitespace trimming.
fmtTrim :: QuasiQuoter
fmtTrim :: QuasiQuoter
fmtTrim = String -> Config -> QuasiQuoter
mkFormatter String
"fmtTrim" (Config -> Config
addTrim Config
fmtConfig)

-- | Multiline string, no interpolation.
str :: QuasiQuoter
str :: QuasiQuoter
str = String -> Config -> QuasiQuoter
mkFormatter String
"str" Config
strConfig

-- | Multiline string, no interpolation, but does indentation trimming.
strTrim :: QuasiQuoter
strTrim :: QuasiQuoter
strTrim = String -> Config -> QuasiQuoter
mkFormatter String
"strTrim" (Config -> Config
addTrim Config
strConfig)

-- | Raw string, neither interpolation nor escaping is performed.
raw :: QuasiQuoter
raw :: QuasiQuoter
raw = String -> (String -> Q Exp) -> QuasiQuoter
expQQ String
"raw" (\String
s -> [|s|])

-- | Removes the trailing whitespace of a string.
--
-- - First line is ignored if it only contains whitespaces
-- - All other line common indentation is removed, ignoring lines with only whitespaces.
--
-- >>> trimIndent "\n   hello\n   - a\n   - b\n   "
-- "hello\n- a\n- b\n"
--
-- See 'fmtTrim' for a quasiquoter with this behavior.
trimIndent :: String -> String
trimIndent :: String -> String
trimIndent String
s =
  case String -> [String]
lines String
s of
    [] -> String
""
    [String
_] -> String
s
    (String
firstLine : [String]
others) ->
      let -- Discard the first line if needed
          usedLines :: [String]
usedLines
            | (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isSpace String
firstLine = [String]
others [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
trail
            | Bool
otherwise = String
firstLine String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
others [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
trail

          -- If the string ends with a newline, `lines` will discard it. We restore it.
          trail :: [String]
trail
            | String -> Char
forall a. HasCallStack => [a] -> a
last String
s Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\n' = [String
""]
            | Bool
otherwise = []
          -- Find the minimum indent common to all lines
          biggestLines :: [Int]
biggestLines = (String -> Int) -> [String] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> 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 -> Bool
isSpace) ((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
. (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isSpace) [String]
usedLines)

          stripLen :: Int
stripLen = case [Int]
biggestLines of
            [] -> Int
0
            [Int]
_ -> [Int] -> Int
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum [Int]
biggestLines

          -- drop them
          trimmedLines :: [String]
trimmedLines = (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> String -> String
forall a. Int -> [a] -> [a]
drop Int
stripLen) [String]
usedLines
       in String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"\n" [String]
trimmedLines

-- | This is an empty configuration. No formatting, no post processing
defaultConfig :: Config
defaultConfig :: Config
defaultConfig =
  Config
    { delimiters :: Maybe (Char, Char)
delimiters = Maybe (Char, Char)
forall a. Maybe a
Nothing,
      postProcess :: Q Exp -> Q Exp
postProcess = Q Exp -> Q Exp
forall a. a -> a
id
    }

-- | Configuration for 'str'. It just wraps the multiline string with 'fromString'.
strConfig :: Config
strConfig :: Config
strConfig =
  Config
    { delimiters :: Maybe (Char, Char)
delimiters = Maybe (Char, Char)
forall a. Maybe a
Nothing,
      postProcess :: Q Exp -> Q Exp
postProcess = Q Exp -> Q Exp
wrapFromString
    }

-- | The config for 'fmt'.
fmtConfig :: Config
fmtConfig :: Config
fmtConfig = (Char, Char) -> Config -> Config
addFormatting (Char
'{', Char
'}') Config
strConfig

-- | Add indentation trimming to a configuration.
addTrim :: Config -> Config
addTrim :: Config -> Config
addTrim Config
config =
  Config
config
    { postProcess = \Q Exp
q -> Config -> Q Exp -> Q Exp
postProcess Config
config [|PyF.trimIndent $(Q Exp
q)|]
    }

-- | Enable formatting.
addFormatting :: (Char, Char) -> Config -> Config
addFormatting :: (Char, Char) -> Config -> Config
addFormatting (Char, Char)
delims Config
c = Config
c {delimiters = Just delims}

-- | Build a formatter. See the 'Config' type for details, as well as
-- 'fmtConfig' and 'strConfig' for examples.
mkFormatter :: String -> Config -> QuasiQuoter
mkFormatter :: String -> Config -> QuasiQuoter
mkFormatter String
name Config
config = String -> (String -> Q Exp) -> QuasiQuoter
expQQ String
name (Config -> String -> Q Exp
toExp Config
config)