Interpolate.hs

-- |
-- Module      : Data.String.Interpolate
-- Description : Unicode-aware string interpolation that handles all textual types.
-- Copyright   : (c) William Yao, 2019-2020
-- License     : BSD-3
-- Maintainer  : williamyaoh@gmail.com
-- Stability   : experimental
-- Portability : POSIX
--
-- This module provides three quasiquoters, `i', `__i', and `iii', which:
--
-- * handle all of String\/Text\/ByteString, both strict and lazy
-- * can interpolate /into/ anything that implements `IsString'
-- * can interpolate anything that implements `Show'
-- * are Unicode aware
-- * are fast
-- * handle multiline strings
--
-- `i' leaves newlines and whitespace intact as they are in the source
-- code. `__i' strips leading indentation and surrounding blank lines, while
-- leaving linebreaks intact. `iii' collapses newlines/whitespace into single
-- spaces, putting all the output on a single line.
--
-- As an example,
--
-- > {-# LANGUAGE OverloadedStrings #-}
-- >
-- > import Data.Text
-- > import Data.String.Interpolate ( i )
-- >
-- > λ> age = 33 :: Int
-- > λ> name = "Tatiana" :: Text
-- > λ> [i|{"name": "#{name}", "age": #{age}}|] :: String
-- > >>> "{\"name\": \"Tatiana\", \"age\": 33}"
-- >
-- > λ> [i|
-- > Name: #{name}
-- > Age: #{age}
-- > |] :: String
-- > >>> "\nName: Tatiana\nAge: 33\n"
--
-- See the README at <https://gitlab.com/williamyaoh/string-interpolate/blob/master/README.md>
-- for more details and examples.

{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE LambdaCase      #-}

module Data.String.Interpolate
  ( i, __i, iii )
where

import Data.Proxy
import Data.Function ( on )
import Data.Semigroup ( Min(..) )
import Data.List
import Data.List.Split

import qualified Language.Haskell.Exts.Extension as Ext
import           Language.Haskell.Exts.Parser
  ( ParseMode(..), ParseResult(..), defaultParseMode, parseExpWithMode )
import           Language.Haskell.Meta           ( ToExp(..) )
import           Language.Haskell.TH
import           Language.Haskell.TH.Quote       ( QuasiQuoter(..) )

import Data.String.Interpolate.Conversion ( build, chompSpaces, finalize, interpolate, ofString )
import Data.String.Interpolate.Parse      ( InterpSegment(..), dosToUnix, parseInterpSegments )

--------------------
-- QUASIQUOTERS
--------------------

-- |
-- The basic, no-frills interpolator. Will interpolate anything you wrap in @#{}@, and
-- otherwise leaves what you write alone.
i :: QuasiQuoter
i = QuasiQuoter
  { quoteExp  = toExp . parseInterpSegments . dosToUnix
  , quotePat  = errQQType "i" "pattern"
  , quoteType = errQQType "i" "type"
  , quoteDec  = errQQType "i" "declaration"
  }
  where toExp :: Either String [InterpSegment] -> Q Exp
        toExp parseResult = case parseResult of
          Left msg   -> errQQ "i" msg
          Right segs -> interpToExp segs

-- |
-- An interpolator that handles indentation. Will interpolate anything you wrap in @#{}@,
-- remove leading indentation, and remove any blank lines before and after the content.
--
-- If the contained interpolation uses both tabs and spaces for indentation, @__i@
-- will assume the indentation type it finds in the first nonblank line, ignoring
-- indentation of the other type. Please don't use mixed indentation.
--
-- Note that only indentation you actually write in source code will be stripped;
-- @__i@ does not touch any lines or whitespace inserted by interpolations themselves.
--
-- There is no extra performance penalty for using @__i@.
__i :: QuasiQuoter
__i = QuasiQuoter
  { quoteExp  = toExp . parseInterpSegments . dosToUnix
  , quotePat  = errQQType "__i" "pattern"
  , quoteType = errQQType "__i" "type"
  , quoteDec  = errQQType "__i" "declaration"
  }
  where toExp :: Either String [InterpSegment] -> Q Exp
        toExp parseResult = case parseResult of
          Left msg   -> errQQ "__i" msg
          Right segs -> unindent segs >>= interpToExp

        unindent :: [InterpSegment] -> Q [InterpSegment]
        unindent segs =
          let lines = interpLines segs
              mindent = mindentation lines
          in warnMixedIndent mindent lines >>
             (pure $! (interpUnlines . removeBlanksAround . reduceIndents mindent) lines)

-- |
-- An interpolator that strips excess whitespace. Will collapse any sequences of
-- multiple spaces or whitespace into a single space, putting the output onto a
-- single line with surrounding whitespace removed.
--
-- Incurs a performance penalty when used, compared to @i@. This penalty will
-- be removed in 0.3.0.0.
iii :: QuasiQuoter
iii = QuasiQuoter
  { quoteExp  = toExp . parseInterpSegments . dosToUnix
  , quotePat  = errQQType "iii" "pattern"
  , quoteType = errQQType "iii" "type"
  , quoteDec  = errQQType "iii" "declaration"
  }
  where toExp :: Either String [InterpSegment] -> Q Exp
        toExp parseResult = case parseResult of
          Left msg   -> errQQ "iii" msg
          Right segs -> [|chompSpaces $(interpToExp segs)|]

--------------------
-- CONVERTING EXPRS
--------------------

interpLines :: [InterpSegment] -> [[InterpSegment]]
interpLines = split $ dropDelims $ whenElt (== Newline)

interpUnlines :: [[InterpSegment]] -> [InterpSegment]
interpUnlines = intercalate [Newline]

data Mindent = UsesSpaces Int | UsesTabs Int

mindentation :: [[InterpSegment]] -> Mindent
mindentation lines =
  let nonblank = filter (not . blankLine) lines
      withIndent = find (\case { Spaces _ : _ -> True; Tabs _ : _ -> True; _ -> False }) nonblank
  in case withIndent of
      Nothing -> UsesSpaces 0
      Just (Spaces _ : _) ->
        maybe (UsesSpaces 0) UsesSpaces $
          findMinIndent (\case { Spaces n -> Just n; _ -> Nothing }) Nothing nonblank
      Just (Tabs _ : _) ->
        maybe (UsesSpaces 0) UsesTabs $
          findMinIndent (\case { Tabs n -> Just n; _ -> Nothing }) Nothing nonblank
      Just _ -> UsesSpaces 0
  where findMinIndent :: (InterpSegment -> Maybe Int) -> Maybe Int -> [[InterpSegment]] -> Maybe Int
        findMinIndent _ found [] = found
        findMinIndent f found ((seg:_):rest) =
          findMinIndent f (getMin <$> on mappend (fmap Min) (f seg) found) rest
        findMinIndent f found ([]:rest) = findMinIndent f found rest

warnMixedIndent :: Mindent -> [[InterpSegment]] -> Q ()
warnMixedIndent mindent = go 1 . removeBlanksAround
  where go :: Int -> [[InterpSegment]] -> Q ()
        go _lineno [] = pure ()
        go lineno (line:lines) = do
          let ind = indentation line
          case (mindent, any isSpaces ind, any isTabs ind) of
            (UsesSpaces _, _, True) ->
              reportWarning $
                "splice line " ++ show lineno ++ ": found TAB character in indentation"
            (UsesTabs _, True, _) ->
              reportWarning $
                "splice line " ++ show lineno ++ ": found SPACE character in indentation"
            _ -> pure ()
          go (lineno+1) lines

        indentation :: [InterpSegment] -> [InterpSegment]
        indentation =
          takeWhile (\case { Spaces _ -> True; Tabs _ -> True; _ -> False })

        isSpaces :: InterpSegment -> Bool
        isSpaces (Spaces n) = n > 0
        isSpaces _          = False

        isTabs :: InterpSegment -> Bool
        isTabs (Tabs n) = n > 0
        isTabs _        = False

reduceIndents :: Mindent -> [[InterpSegment]] -> [[InterpSegment]]
reduceIndents _ [] = []
reduceIndents i@(UsesSpaces indent) ((Spaces n:line):rest) =
  (Spaces (n-indent):line) : reduceIndents i rest
reduceIndents i@(UsesTabs indent) ((Tabs n:line):rest) =
  (Tabs (n-indent):line) : reduceIndents i rest
reduceIndents i (line:rest) = line : reduceIndents i rest

removeBlanksAround :: [[InterpSegment]] -> [[InterpSegment]]
removeBlanksAround =
    reverse
  . dropWhile blankLine
  . reverse
  . dropWhile blankLine

blankLine :: [InterpSegment] -> Bool
blankLine [] = True
blankLine (Expression _ : _) = False
blankLine (Newline : rest) = blankLine rest
blankLine (Spaces _ : rest) = blankLine rest
blankLine (Tabs _ : rest) = blankLine rest
blankLine (Verbatim str:rest) = blank str && blankLine rest
  where blank :: String -> Bool
        blank = all (\c -> elem c [' ', '\t'])

interpToExp :: [InterpSegment] -> Q Exp
interpToExp segs = [|finalize Proxy $(go outputSegs)|]
  where outputSegs :: [OutputSegment]
        outputSegs = collapseStrings $ renderOutput segs

        renderExp :: OutputSegment -> Q Exp
        renderExp (OfString str) = [|ofString Proxy str|]
        renderExp (Interpolate expr) = [|interpolate Proxy $(reifyExpression expr)|]

        go :: [OutputSegment] -> Q Exp
        go = foldr
          (\seg qexp -> [|build Proxy $(renderExp seg) $(qexp)|])
          [|ofString Proxy ""|]

data OutputSegment
  = OfString String
  | Interpolate String

collapseStrings :: [OutputSegment] -> [OutputSegment]
collapseStrings [] = []
collapseStrings (OfString s1 : OfString s2 : rest) =
  collapseStrings ((OfString $ s1 ++ s2) : rest)
collapseStrings (other : rest) = other : collapseStrings rest

renderOutput :: [InterpSegment] -> [OutputSegment]
renderOutput = fmap renderSegment
  where renderSegment :: InterpSegment -> OutputSegment
        renderSegment (Verbatim str)   = OfString str
        renderSegment Newline          = OfString "\n"
        renderSegment (Spaces n)       = OfString (replicate n ' ')
        renderSegment (Tabs n)         = OfString (replicate n '\t')
        renderSegment (Expression str) = Interpolate str

--------------------
-- UTILITIES
--------------------

errQQ :: String -> String -> a
errQQ qqName msg =
  error ("Data.String.Interpolate." ++ qqName ++ ": " ++ msg)

errQQType :: String -> String -> a
errQQType qqName = errQQ qqName . ("This QuasiQuoter cannot be used as a " ++)

reifyExpression :: String -> Q Exp
reifyExpression s = do
  -- We want to explicitly use whatever extensions are enabled in current module
  exts      <- (fmap . fmap) (Ext.parseExtension . show) extsEnabled
  parseMode <- pure (defaultParseMode { extensions = exts })
  case parseExpWithMode parseMode s of
    ParseFailed _ err  -> fail $
      "Data.String.Interpolate.i: got error: '" ++ err ++ "' while parsing expression: " ++ s
    ParseOk e -> pure (toExp e)