{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE CPP #-}
-- |
-- 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
    (
    -- * Setup
    -- | To execute the code examples provided in this module in ghci, please
    -- run the following commands first.
    --
    -- $setup

    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

#include "DocTestUnicodeString.hs"

--------------------------------------------------------------------------------
-- Parsing
--------------------------------------------------------------------------------

data StrSegment
    = StrText String
    | StrVar String
    deriving (Int -> StrSegment -> ShowS
[StrSegment] -> ShowS
StrSegment -> String
(Int -> StrSegment -> ShowS)
-> (StrSegment -> String)
-> ([StrSegment] -> ShowS)
-> Show StrSegment
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
(StrSegment -> StrSegment -> Bool)
-> (StrSegment -> StrSegment -> Bool) -> Eq StrSegment
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 = Parser Char m Char
forall (m :: * -> *). Monad m => Parser Char m Char
Parser.alphaNum Parser Char m Char -> Parser Char m Char -> Parser Char m Char
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Char -> Parser Char m Char
forall (m :: * -> *). Monad m => Char -> Parser Char m Char
Parser.char Char
'\'' Parser Char m Char -> Parser Char m Char -> Parser Char m Char
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Char -> Parser Char m Char
forall (m :: * -> *). Monad m => Char -> Parser Char m Char
Parser.char Char
'_'
     in Parser Char m Char -> Fold m Char String -> Parser Char m String
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 Fold m Char String
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 = Parser Char m StrSegment
-> Fold m StrSegment [StrSegment] -> Parser Char m [StrSegment]
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 Fold m StrSegment [StrSegment]
forall (m :: * -> *) a. Monad m => Fold m a [a]
Fold.toList

    where

    plainText :: Parser Char m StrSegment
plainText = String -> StrSegment
StrText (String -> StrSegment)
-> Parser Char m String -> Parser Char m StrSegment
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Bool) -> Fold m Char String -> Parser Char m String
forall (m :: * -> *) a b.
Monad m =>
(a -> Bool) -> Fold m a b -> Parser a m b
Parser.takeWhile1 (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'#') Fold m Char String
forall (m :: * -> *) a. Monad m => Fold m a [a]
Fold.toList
    escHash :: Parser Char m StrSegment
escHash = String -> StrSegment
StrText (String -> StrSegment) -> (Char -> String) -> Char -> StrSegment
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> ShowS
forall a. a -> [a] -> [a]
: []) (Char -> StrSegment)
-> Parser Char m Char -> Parser Char m StrSegment
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Parser Char m Char
forall (m :: * -> *). Monad m => Char -> Parser Char m Char
Parser.char Char
'#' Parser Char m Char -> Parser Char m Char -> Parser Char m Char
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Char -> Parser Char m Char
forall (m :: * -> *). Monad m => Char -> Parser Char m Char
Parser.char Char
'#')
    lineCont :: Parser Char m StrSegment
lineCont = String -> StrSegment
StrText [] StrSegment -> Parser Char m Char -> Parser Char m StrSegment
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ (Char -> Parser Char m Char
forall (m :: * -> *). Monad m => Char -> Parser Char m Char
Parser.char Char
'#' Parser Char m Char -> Parser Char m Char -> Parser Char m Char
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Char -> Parser Char m Char
forall (m :: * -> *). Monad m => Char -> Parser Char m Char
Parser.char Char
'\n')
    var :: Parser Char m StrSegment
var = String -> StrSegment
StrVar (String -> StrSegment)
-> Parser Char m String -> Parser Char m StrSegment
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
            (  Char -> Parser Char m Char
forall (m :: * -> *). Monad m => Char -> Parser Char m Char
Parser.char Char
'#'
            Parser Char m Char -> Parser Char m Char -> Parser Char m Char
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Char -> Parser Char m Char
forall (m :: * -> *). Monad m => Char -> Parser Char m Char
Parser.char Char
'{'
            Parser Char m Char -> Parser Char m String -> Parser Char m String
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Char m String
forall (m :: * -> *). Monad m => Parser Char m String
haskellIdentifier
            Parser Char m String -> Parser Char m Char -> Parser Char m String
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser Char m Char
forall (m :: * -> *). Monad m => Char -> Parser Char m Char
Parser.char Char
'}'
            )
    plainHash :: Parser Char m StrSegment
plainHash = String -> StrSegment
StrText (String -> StrSegment) -> (Char -> String) -> Char -> StrSegment
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> ShowS
forall a. a -> [a] -> [a]
: []) (Char -> StrSegment)
-> Parser Char m Char -> Parser Char m StrSegment
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Char -> Parser Char m Char
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 Parser Char m StrSegment
-> Parser Char m StrSegment -> Parser Char m StrSegment
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Char m StrSegment
escHash Parser Char m StrSegment
-> Parser Char m StrSegment -> Parser Char m StrSegment
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Char m StrSegment
lineCont Parser Char m StrSegment
-> Parser Char m StrSegment -> Parser Char m StrSegment
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Char m StrSegment
var Parser Char m StrSegment
-> Parser Char m StrSegment -> Parser Char m StrSegment
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) = String -> Q Exp
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 -> Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
vn
        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
"str quote: Haskell symbol `" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
name
                String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"` is not in scope"

strExp :: [StrSegment] -> Q Exp
strExp :: [StrSegment] -> Q Exp
strExp [StrSegment]
xs = Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE [| concat |] (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ [Q Exp] -> Q Exp
forall (m :: * -> *). Quote m => [m Exp] -> m Exp
listE ([Q Exp] -> Q Exp) -> [Q Exp] -> Q Exp
forall a b. (a -> b) -> a -> b
$ (StrSegment -> Q Exp) -> [StrSegment] -> [Q Exp]
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 Identity (Either ParseError [StrSegment])
-> Either ParseError [StrSegment]
forall a. Identity a -> a
runIdentity (Identity (Either ParseError [StrSegment])
 -> Either ParseError [StrSegment])
-> Identity (Either ParseError [StrSegment])
-> Either ParseError [StrSegment]
forall a b. (a -> b) -> a -> b
$ Parser Char Identity [StrSegment]
-> Stream Identity Char
-> Identity (Either ParseError [StrSegment])
forall (m :: * -> *) a b.
Monad m =>
Parser a m b -> Stream m a -> m (Either ParseError b)
Stream.parse Parser Char Identity [StrSegment]
forall (m :: * -> *). Monad m => Parser Char m [StrSegment]
strParser (String -> Stream Identity Char
forall (m :: * -> *) a. Applicative m => [a] -> Stream m a
Stream.fromList String
ln) of
        Left ParseError
e ->
            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
"str QuasiQuoter parse error: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ParseError -> String
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 :: (String -> Q Exp)
-> (String -> Q Pat)
-> (String -> Q Type)
-> (String -> Q [Dec])
-> QuasiQuoter
QuasiQuoter
        { quoteExp :: String -> Q Exp
quoteExp = String -> Q Exp
expandVars
        , quotePat :: String -> Q Pat
quotePat = String -> Q Pat
forall {a}. a
notSupported
        , quoteType :: String -> Q Type
quoteType = String -> Q Type
forall {a}. a
notSupported
        , quoteDec :: String -> Q [Dec]
quoteDec = String -> Q [Dec]
forall {a}. a
notSupported
        }

    where

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