{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE QuasiQuotes #-}

module Vulkan.Utils.ShaderQQ.Interpolate
  ( interpExp
  ) where

import           Control.Applicative            ( liftA2 )
import           Data.Char
import           Language.Haskell.TH
import           Text.ParserCombinators.ReadP

-- $setup
-- >>> :set -XTemplateHaskell
-- >>> import Data.Proxy

-- | 'interpExp' performs very simple interpolation of Haskell
-- values into 'String's.
--
-- - Interpolated variables are prefixed with @$@
-- - They can optionally be surrounded with braces like @${foo}@
-- - Interpolated variables are converted to strings with 'show'
-- - To escape a @$@ use @\\$@
--
-- >>> let foo = 123 in $(interpExp "hello, $foo")
-- "hello, 123"
--
-- >>> let foo = "world" in $(interpExp "hello, \\$foo")
-- "hello, $foo"
--
-- >>> let foo = "world" in $(interpExp "hello\r\n\rworld")
-- "hello\r\n\rworld"
interpExp :: String -> Q Exp
interpExp :: String -> Q Exp
interpExp =
  Q Exp
-> (String -> Q Exp)
-> (String -> Q Exp)
-> (Q Exp -> Q Exp -> Q Exp)
-> [Either String String]
-> Q Exp
forall (t :: * -> *) c a b.
(Foldable t, Functor t) =>
c -> (a -> c) -> (b -> c) -> (c -> c -> c) -> t (Either a b) -> c
foldEither (Lit -> Q Exp
litE (String -> Lit
stringL ""))
             (Q Exp -> Q Exp -> Q Exp
appE (Name -> Q Exp
varE 'show) (Q Exp -> Q Exp) -> (String -> Q Exp) -> String -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Q Exp
varOrConE)
             (Lit -> Q Exp
litE (Lit -> Q Exp) -> (String -> Lit) -> String -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Lit
stringL)
             (\e1 :: Q Exp
e1 e2 :: Q Exp
e2 -> [|$e1 <> $e2|])
    ([Either String String] -> Q Exp)
-> (String -> [Either String String]) -> String -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [Either String String]
parse

----------------------------------------------------------------
-- The parser
----------------------------------------------------------------

type Var = String

-- | Extract variables and literals from string to be interpolated
--
-- >>> parse ""
-- []
--
-- >>> parse "hello $world"
-- [Right "hello ",Left "world"]
--
-- >>> parse "$hello$world"
-- [Left "hello",Left "world"]
--
-- >>> parse "$"
-- [Right "$"]
--
-- >>> parse "hi"
-- [Right "hi"]
--
-- >>> parse "h$hi"
-- [Right "h",Left "hi"]
--
-- >>> parse "$$hi"
-- [Right "$",Left "hi"]
--
-- >>> parse "$1"
-- [Right "$1"]
--
-- >>> parse "$$$"
-- [Right "$$$"]
--
-- >>> parse "\\"
-- [Right "\\"]
--
-- >>> parse "\\$"
-- [Right "$"]
--
-- >>> parse "\\$hi"
-- [Right "$hi"]
--
-- >>> parse "\\\\$hi"
-- [Right "\\$hi"]
--
-- >>> parse "\\hi"
-- [Right "\\hi"]
--
-- >>> parse "$hi\\$foo"
-- [Left "hi",Right "$foo"]
--
-- >>> parse "hello, \\$foo"
-- [Right "hello, $foo"]
--
-- >>> parse "${fo'o}bar"
-- [Left "fo'o",Right "bar"]
--
-- >>> parse "\\"
-- [Right "\\"]
--
-- >>> parse "\\\\$"
-- [Right "\\$"]
--
-- >>> parse "$"
-- [Right "$"]
parse :: String -> [Either Var String]
parse :: String -> [Either String String]
parse s :: String
s =
  let -- A haskell var or con
    ident :: ReadP String
ident = (:) (Char -> String -> String)
-> ReadP Char -> ReadP (String -> String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Bool) -> ReadP Char
satisfy (Char -> Bool
isLower (Char -> Bool) -> (Char -> Bool) -> Char -> Bool
forall (f :: * -> *). Applicative f => f Bool -> f Bool -> f Bool
<||> Char -> Bool
isUpper (Char -> Bool) -> (Char -> Bool) -> Char -> Bool
forall (f :: * -> *). Applicative f => f Bool -> f Bool -> f Bool
<||> (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '_')) ReadP (String -> String) -> ReadP String -> ReadP String
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Char -> Bool) -> ReadP String
munch
      (Char -> Bool
isAlphaNum (Char -> Bool) -> (Char -> Bool) -> Char -> Bool
forall (f :: * -> *). Applicative f => f Bool -> f Bool -> f Bool
<||> (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '\'') (Char -> Bool) -> (Char -> Bool) -> Char -> Bool
forall (f :: * -> *). Applicative f => f Bool -> f Bool -> f Bool
<||> (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '_'))
    braces :: ReadP a -> ReadP a
braces = ReadP Char -> ReadP Char -> ReadP a -> ReadP a
forall open close a.
ReadP open -> ReadP close -> ReadP a -> ReadP a
between (Char -> ReadP Char
char '{') (Char -> ReadP Char
char '}')
    -- parse a var, a '$' followed by an ident
    var :: ReadP (Either String b)
var =
      Char -> ReadP Char
char '$' ReadP Char -> ReadP (Either String b) -> ReadP (Either String b)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ((String -> Either String b
forall a b. a -> Either a b
Left (String -> Either String b)
-> ReadP String -> ReadP (Either String b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ReadP String
ident ReadP String -> ReadP String -> ReadP String
forall a. ReadP a -> ReadP a -> ReadP a
+++ ReadP String -> ReadP String
forall a. ReadP a -> ReadP a
braces ReadP String
ident)) ReadP (Either String b)
-> ReadP (Either String b) -> ReadP (Either String b)
forall a. ReadP a -> ReadP a -> ReadP a
<++ Either String b -> ReadP (Either String b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (b -> Either String b
forall a b. b -> Either a b
Right "$"))
    -- Everything up to a '$' or '\'
    normal :: ReadP (Either a String)
normal = String -> Either a String
forall a b. b -> Either a b
Right (String -> Either a String)
-> ReadP String -> ReadP (Either a String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Bool) -> ReadP String
munch1 ((Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= '$') (Char -> Bool) -> (Char -> Bool) -> Char -> Bool
forall (f :: * -> *). Applicative f => f Bool -> f Bool -> f Bool
<&&> (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= '\\'))
    -- escape a $
    escape :: ReadP (Either a String)
escape = Char -> ReadP Char
char '\\' ReadP Char -> ReadP (Either a String) -> ReadP (Either a String)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (String -> Either a String
forall a b. b -> Either a b
Right (String -> Either a String)
-> ReadP String -> ReadP (Either a String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (String -> ReadP String
string "$" ReadP String -> ReadP String -> ReadP String
forall a. ReadP a -> ReadP a -> ReadP a
<++ String -> ReadP String
forall (f :: * -> *) a. Applicative f => a -> f a
pure "\\"))
    -- One normal or var
    -- - Check escaped '$' first
    -- - variables, starting with $
    -- - normal string
    one :: ReadP (Either String String)
one    = ReadP (Either String String)
forall a. ReadP (Either a String)
normal ReadP (Either String String)
-> ReadP (Either String String) -> ReadP (Either String String)
forall a. ReadP a -> ReadP a -> ReadP a
+++ ReadP (Either String String)
forall b. IsString b => ReadP (Either String b)
var ReadP (Either String String)
-> ReadP (Either String String) -> ReadP (Either String String)
forall a. ReadP a -> ReadP a -> ReadP a
+++ ReadP (Either String String)
forall a. ReadP (Either a String)
escape
    parser :: ReadP [Either String String]
parser = ReadP (Either String String) -> ReadP [Either String String]
forall a. ReadP a -> ReadP [a]
many ReadP (Either String String)
one ReadP [Either String String]
-> ReadP () -> ReadP [Either String String]
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ReadP ()
eof
  in
    case ReadP [Either String String] -> ReadS [Either String String]
forall a. ReadP a -> ReadS a
readP_to_S ReadP [Either String String]
parser String
s of
      [(r :: [Either String String]
r, "")] -> (Either String String
 -> [Either String String] -> [Either String String])
-> [Either String String]
-> [Either String String]
-> [Either String String]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Either String String
-> [Either String String] -> [Either String String]
mergeRights [] [Either String String]
r
      _         -> String -> [Either String String]
forall a. HasCallStack => String -> a
error "Failed to parse string"

mergeRights :: Either Var String -> [Either Var String] -> [Either Var String]
mergeRights :: Either String String
-> [Either String String] -> [Either String String]
mergeRights = \case
  Left  v :: String
v -> (String -> Either String String
forall a b. a -> Either a b
Left String
v Either String String
-> [Either String String] -> [Either String String]
forall a. a -> [a] -> [a]
:)
  Right n :: String
n -> \case
    (Right m :: String
m : xs :: [Either String String]
xs) -> String -> Either String String
forall a b. b -> Either a b
Right (String
n String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
m) Either String String
-> [Either String String] -> [Either String String]
forall a. a -> [a] -> [a]
: [Either String String]
xs
    xs :: [Either String String]
xs             -> String -> Either String String
forall a b. b -> Either a b
Right String
n Either String String
-> [Either String String] -> [Either String String]
forall a. a -> [a] -> [a]
: [Either String String]
xs

(<&&>), (<||>) :: Applicative f => f Bool -> f Bool -> f Bool
<||> :: f Bool -> f Bool -> f Bool
(<||>) = (Bool -> Bool -> Bool) -> f Bool -> f Bool -> f Bool
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 Bool -> Bool -> Bool
(||)
<&&> :: f Bool -> f Bool -> f Bool
(<&&>) = (Bool -> Bool -> Bool) -> f Bool -> f Bool -> f Bool
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 Bool -> Bool -> Bool
(&&)

----------------------------------------------------------------
-- Misc utilities
----------------------------------------------------------------

varOrConE :: String -> ExpQ
varOrConE :: String -> Q Exp
varOrConE n :: String
n = (if Char -> Bool
isLower (String -> Char
forall a. [a] -> a
head String
n) then Name -> Q Exp
varE else Name -> Q Exp
conE) (Name -> Q Exp) -> (String -> Name) -> String -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Name
mkName (String -> Q Exp) -> String -> Q Exp
forall a b. (a -> b) -> a -> b
$ String
n

foldEither
  :: (Foldable t, Functor t)
  => c
  -> (a -> c)
  -> (b -> c)
  -> (c -> c -> c)
  -> t (Either a b)
  -> c
foldEither :: c -> (a -> c) -> (b -> c) -> (c -> c -> c) -> t (Either a b) -> c
foldEither i :: c
i l :: a -> c
l r :: b -> c
r f :: c -> c -> c
f = (c -> c -> c) -> c -> t c -> c
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr c -> c -> c
f c
i (t c -> c) -> (t (Either a b) -> t c) -> t (Either a b) -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Either a b -> c) -> t (Either a b) -> t c
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> c) -> (b -> c) -> Either a b -> c
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either a -> c
l b -> c
r)