{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE CPP #-}
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
#include "DocTestUnicodeString.hs"
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
$cshowsPrec :: Int -> StrSegment -> ShowS
showsPrec :: Int -> StrSegment -> ShowS
$cshow :: StrSegment -> String
show :: StrSegment -> String
$cshowList :: [StrSegment] -> ShowS
showList :: [StrSegment] -> ShowS
Show, StrSegment -> StrSegment -> Bool
(StrSegment -> StrSegment -> Bool)
-> (StrSegment -> StrSegment -> Bool) -> Eq StrSegment
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: StrSegment -> StrSegment -> Bool
== :: StrSegment -> StrSegment -> Bool
$c/= :: StrSegment -> StrSegment -> Bool
/= :: 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 a. Parser Char m a -> Parser Char m a -> Parser Char m a
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 a. Parser Char m a -> Parser Char m a -> Parser Char m a
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 a b. Parser Char m a -> Parser Char m b -> Parser Char m b
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 a b. a -> Parser Char m b -> Parser Char m a
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 a b. Parser Char m a -> Parser Char m b -> Parser Char m b
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 a b. Parser Char m a -> Parser Char m b -> Parser Char m b
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 a b. Parser Char m a -> Parser Char m b -> Parser Char m b
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 a b. Parser Char m a -> Parser Char m b -> Parser Char m a
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
'#'
content :: Parser Char m StrSegment
content = Parser Char m StrSegment
plainText Parser Char m StrSegment
-> Parser Char m StrSegment -> Parser Char m StrSegment
forall a. Parser Char m a -> Parser Char m a -> Parser Char m a
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 a. Parser Char m a -> Parser Char m a -> Parser Char m a
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 a. Parser Char m a -> Parser Char m a -> Parser Char m a
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 a. Parser Char m a -> Parser Char m a -> Parser Char m a
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 a. String -> Q a
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 a. String -> Q a
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
str :: QuasiQuoter
str :: QuasiQuoter
str =
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."