{-# LANGUAGE TemplateHaskell #-}
module Data.String.Interpolate (
-- * String interpolation done right
-- |
-- The examples in this module use `QuasiQuotes`.  Make sure to enable the
-- corresponding language extension.
--
-- >>> :set -XQuasiQuotes
-- >>> import Data.String.Interpolate
  i
) where

import           Language.Haskell.TH.Quote (QuasiQuoter(..))
import           Language.Haskell.Meta.Parse (parseExp)

import           Data.String.Interpolate.Internal.Util
import           Data.String.Interpolate.Parse
import           Language.Haskell.TH

-- |
-- A `QuasiQuoter` for string interpolation.  Expression enclosed within
-- @#{...}@ are interpolated, the result has to be in the `Show` class.
--
-- It interpolates strings
--
-- >>> let name = "Marvin"
-- >>> putStrLn [i|name: #{name}|]
-- name: Marvin
--
-- or integers
--
-- >>> let age = 23
-- >>> putStrLn [i|age: #{age}|]
-- age: 23
--
-- or arbitrary Haskell expressions
--
-- >>> let profession = "\955-scientist"
-- >>> putStrLn [i|profession: #{unwords [name, "the", profession]}|]
-- profession: Marvin the λ-scientist
i :: QuasiQuoter
i :: QuasiQuoter
i = QuasiQuoter {
    quoteExp :: String -> Q Exp
quoteExp = [Node ()] -> Q Exp
toExp ([Node ()] -> Q Exp) -> (String -> [Node ()]) -> String -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [Node ()]
parseNodes (String -> [Node ()]) -> (String -> String) -> String -> [Node ()]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
decodeNewlines
  , quotePat :: String -> Q Pat
quotePat = String -> String -> Q Pat
forall {a}. String -> a
err String
"pattern"
  , quoteType :: String -> Q Type
quoteType = String -> String -> Q Type
forall {a}. String -> a
err String
"type"
  , quoteDec :: String -> Q [Dec]
quoteDec = String -> String -> Q [Dec]
forall {a}. String -> a
err String
"declaration"
  }
  where
    err :: String -> a
err String
name = String -> a
forall a. HasCallStack => String -> a
error (String
"Data.String.Interpolate.i: This QuasiQuoter can not be used as a " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"!")

    toExp :: [Node ()] -> Q Exp
    toExp :: [Node ()] -> Q Exp
toExp [Node ()]
input = do
      [Node Name]
nodes <- (Node () -> Q (Node Name)) -> [Node ()] -> Q [Node Name]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Node () -> Q (Node Name)
generateName [Node ()]
input
      Exp
e <- [Node Name] -> Q Exp
go [Node Name]
nodes
      Exp -> Q Exp
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ (Name -> Exp -> Exp) -> Exp -> [Name] -> Exp
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Name -> Exp -> Exp
lambda Exp
e [Name
name | Abstraction Name
name <- [Node Name]
nodes]
      where
        lambda :: Name -> Exp -> Exp
        lambda :: Name -> Exp -> Exp
lambda Name
name Exp
e = [Pat] -> Exp -> Exp
LamE [Name -> Pat
VarP Name
name] Exp
e

        generateName :: Node () -> Q (Node Name)
        generateName :: Node () -> Q (Node Name)
generateName (Abstraction ()) = Name -> Node Name
forall a. a -> Node a
Abstraction (Name -> Node Name) -> Q Name -> Q (Node Name)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"x"
        generateName (Literal String
s) = Node Name -> Q (Node Name)
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Node Name
forall a. String -> Node a
Literal String
s)
        generateName (Expression String
e) = Node Name -> Q (Node Name)
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Node Name
forall a. String -> Node a
Expression String
e)

        go :: [Node Name] -> Q Exp
        go :: [Node Name] -> Q Exp
go [Node Name]
nodes = case [Node Name]
nodes of
          [] -> [|""|]
          (Node Name
x:[Node Name]
xs) -> Node Name -> Q Exp
eval Node Name
x Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` [Node Name] -> Q Exp
go [Node Name]
xs
          where
            eval :: Node Name -> Q Exp
eval (Literal String
s) = [|showString s|]
            eval (Expression String
e) = Q Exp -> Q Exp
interpolate (String -> Q Exp
reifyExpression String
e)
            eval (Abstraction Name
name) = Q Exp -> Q Exp
interpolate (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ (Exp -> Q Exp
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Name -> Exp
VarE Name
name)

            interpolate :: Q Exp -> Q Exp
            interpolate :: Q Exp -> Q Exp
interpolate Q Exp
e = [|(showString . toString) $(Q Exp
e)|]

            reifyExpression :: String -> Q Exp
            reifyExpression :: String -> Q Exp
reifyExpression String
s = case String -> Either String Exp
parseExp String
s of
              Left String
_ -> do
                String -> Q Exp
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Parse error in expression!" :: Q Exp
              Right Exp
e -> Exp -> Q Exp
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Exp
e

decodeNewlines :: String -> String
decodeNewlines :: String -> String
decodeNewlines = String -> String
go
  where
    go :: String -> String
go String
xs = case String
xs of
      Char
'\r' : Char
'\n' : String
ys -> Char
'\n' Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
go String
ys
      Char
y : String
ys -> Char
y Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
go String
ys
      [] -> []