{-# LANGUAGE TemplateHaskell #-}
-- |
-- Module      : Streamly.Internal.Unicode.String
-- Copyright   : (c) 2022 Composewell Technologies
-- License     : BSD-3-Clause
-- Maintainer  : streamly@composewell.com
-- Stability   : experimental
-- Portability : GHC
--
-- Convenient template Haskell quasiquoters to format strings.

-- Design Notes:
--
-- Essential requirements are:
--
-- Haskell expression expansion
-- Newline treatment (continue without introducing a newline)
-- Indentation treatment
--
-- We choose #{expr} for patching a Haskell expression's value in a string. "$"
-- instead of "#" was another option (like in neat-interpolation package) but
-- we did not use that to avoid conflict with strings that are used as shell
-- commands. Another option was to use just "{}" (like in PyF package) but we
-- did not use that to avoid conflict with "${}" used in shell.
--
-- We use a "#" at the end of line to continue the line. We could use a "\"
-- as well but that may interfere with CPP.
--
-- Stripping is not part of the quasiquoter as it can be done by a Haskell
-- function. Other type of formatting on the Haskell expression can be done
-- using Haskell functions.

module Streamly.Internal.Unicode.String
    ( str
    ) where


import Control.Applicative (Alternative(..))
import Control.Exception (displayException)
import Data.Functor.Identity (runIdentity)
import Streamly.Internal.Data.Parser (Parser)

import Language.Haskell.TH
import Language.Haskell.TH.Quote

import qualified Streamly.Data.Fold as Fold
import qualified Streamly.Internal.Data.Parser as Parser
    (some, many, takeWhile1)
import qualified Streamly.Data.Stream as Stream  (fromList, parse)
import qualified Streamly.Internal.Unicode.Parser as Parser

-- $setup
-- >>> :m
-- >>> :set -XQuasiQuotes
-- >>> import Streamly.Internal.Unicode.String
--
--------------------------------------------------------------------------------
-- Parsing
--------------------------------------------------------------------------------

data StrSegment
    = StrText String
    | StrVar String
    deriving (Int -> StrSegment -> ShowS
[StrSegment] -> ShowS
StrSegment -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [StrSegment] -> ShowS
$cshowList :: [StrSegment] -> ShowS
show :: StrSegment -> String
$cshow :: StrSegment -> String
showsPrec :: Int -> StrSegment -> ShowS
$cshowsPrec :: Int -> StrSegment -> ShowS
Show, StrSegment -> StrSegment -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: StrSegment -> StrSegment -> Bool
$c/= :: StrSegment -> StrSegment -> Bool
== :: StrSegment -> StrSegment -> Bool
$c== :: StrSegment -> StrSegment -> Bool
Eq)

haskellIdentifier :: Monad m => Parser Char m String
haskellIdentifier :: forall (m :: * -> *). Monad m => Parser Char m String
haskellIdentifier =
    let p :: Parser Char m Char
p = forall (m :: * -> *). Monad m => Parser Char m Char
Parser.alphaNum forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (m :: * -> *). Monad m => Char -> Parser Char m Char
Parser.char Char
'\'' forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (m :: * -> *). Monad m => Char -> Parser Char m Char
Parser.char Char
'_'
     in forall (m :: * -> *) a b c.
Monad m =>
Parser a m b -> Fold m b c -> Parser a m c
Parser.some Parser Char m Char
p forall (m :: * -> *) a. Monad m => Fold m a [a]
Fold.toList

strParser :: Monad m => Parser Char m [StrSegment]
strParser :: forall (m :: * -> *). Monad m => Parser Char m [StrSegment]
strParser = forall (m :: * -> *) a b c.
Monad m =>
Parser a m b -> Fold m b c -> Parser a m c
Parser.many Parser Char m StrSegment
content forall (m :: * -> *) a. Monad m => Fold m a [a]
Fold.toList

    where

    plainText :: Parser Char m StrSegment
plainText = String -> StrSegment
StrText forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a b.
Monad m =>
(a -> Bool) -> Fold m a b -> Parser a m b
Parser.takeWhile1 (forall a. Eq a => a -> a -> Bool
/= Char
'#') forall (m :: * -> *) a. Monad m => Fold m a [a]
Fold.toList
    escHash :: Parser Char m StrSegment
escHash = String -> StrSegment
StrText forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. a -> [a] -> [a]
: []) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall (m :: * -> *). Monad m => Char -> Parser Char m Char
Parser.char Char
'#' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (m :: * -> *). Monad m => Char -> Parser Char m Char
Parser.char Char
'#')
    lineCont :: Parser Char m StrSegment
lineCont = String -> StrSegment
StrText [] forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ (forall (m :: * -> *). Monad m => Char -> Parser Char m Char
Parser.char Char
'#' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (m :: * -> *). Monad m => Char -> Parser Char m Char
Parser.char Char
'\n')
    var :: Parser Char m StrSegment
var = String -> StrSegment
StrVar forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
            (  forall (m :: * -> *). Monad m => Char -> Parser Char m Char
Parser.char Char
'#'
            forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (m :: * -> *). Monad m => Char -> Parser Char m Char
Parser.char Char
'{'
            forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (m :: * -> *). Monad m => Parser Char m String
haskellIdentifier
            forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall (m :: * -> *). Monad m => Char -> Parser Char m Char
Parser.char Char
'}'
            )
    plainHash :: Parser Char m StrSegment
plainHash = String -> StrSegment
StrText forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. a -> [a] -> [a]
: []) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). Monad m => Char -> Parser Char m Char
Parser.char Char
'#'

    -- order is important
    content :: Parser Char m StrSegment
content = Parser Char m StrSegment
plainText forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Char m StrSegment
escHash forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Char m StrSegment
lineCont forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Char m StrSegment
var forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Char m StrSegment
plainHash

strSegmentExp :: StrSegment -> Q Exp
strSegmentExp :: StrSegment -> Q Exp
strSegmentExp (StrText String
text) = forall (m :: * -> *). Quote m => String -> m Exp
stringE String
text
strSegmentExp (StrVar String
name) = do
    Maybe Name
valueName <- String -> Q (Maybe Name)
lookupValueName String
name
    case Maybe Name
valueName of
        Just Name
vn -> forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
vn
        Maybe Name
Nothing ->
            forall (m :: * -> *) a. MonadFail m => String -> m a
fail
                forall a b. (a -> b) -> a -> b
$ String
"str quote: Haskell symbol `" forall a. [a] -> [a] -> [a]
++ String
name
                forall a. [a] -> [a] -> [a]
++ String
"` is not in scope"

strExp :: [StrSegment] -> Q Exp
strExp :: [StrSegment] -> Q Exp
strExp [StrSegment]
xs = forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE [| concat |] forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => [m Exp] -> m Exp
listE forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map StrSegment -> Q Exp
strSegmentExp [StrSegment]
xs

expandVars :: String -> Q Exp
expandVars :: String -> Q Exp
expandVars String
ln =
    case forall a. Identity a -> a
runIdentity forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a b.
Monad m =>
Parser a m b -> Stream m a -> m (Either ParseError b)
Stream.parse forall (m :: * -> *). Monad m => Parser Char m [StrSegment]
strParser (forall (m :: * -> *) a. Applicative m => [a] -> Stream m a
Stream.fromList String
ln) of
        Left ParseError
e ->
            forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"str QuasiQuoter parse error: " forall a. [a] -> [a] -> [a]
++ forall e. Exception e => e -> String
displayException ParseError
e
        Right [StrSegment]
x ->
            [StrSegment] -> Q Exp
strExp [StrSegment]
x

-- | A QuasiQuoter that treats the input as a string literal:
--
-- >>> [str|x|]
-- "x"
--
-- Any @#{symbol}@ is replaced by the value of the Haskell symbol @symbol@
-- which is in scope:
--
-- >>> x = "hello"
-- >>> [str|#{x} world!|]
-- "hello world!"
--
-- @##@ means a literal @#@ without the special meaning for referencing
-- haskell symbols:
--
-- >>> [str|##{x} world!|]
-- "#{x} world!"
--
-- A @#@ at the end of line means the line continues to the next line without
-- introducing a newline character:
--
-- >>> :{
-- [str|hello#
-- world!|]
-- :}
-- "hello world!"
--
-- Bugs: because of a bug in parsers, a lone # at the end of input gets
-- removed.
--
str :: QuasiQuoter
str :: QuasiQuoter
str =
    QuasiQuoter
        { quoteExp :: String -> Q Exp
quoteExp = String -> Q Exp
expandVars
        , quotePat :: String -> Q Pat
quotePat = forall {a}. a
notSupported
        , quoteType :: String -> Q Type
quoteType = forall {a}. a
notSupported
        , quoteDec :: String -> Q [Dec]
quoteDec = forall {a}. a
notSupported
        }

    where

    notSupported :: a
notSupported = forall a. HasCallStack => String -> a
error String
"str: Not supported."