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

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
forall (m :: * -> *). Quote m => Lit -> m Exp
litE (String -> Lit
stringL String
""))
    (Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m 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
forall (m :: * -> *). Quote m => Lit -> m Exp
litE (Lit -> Q Exp) -> (String -> Lit) -> String -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Lit
stringL)
    (\Q Exp
e1 Q Exp
e2 -> [|$Q Exp
e1 <> $Q Exp
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 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
== Char
'_'))
        ReadP (String -> String) -> ReadP String -> ReadP String
forall a b. ReadP (a -> b) -> ReadP a -> ReadP b
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
'\'') (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
'_'))
    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
'{') (Char -> ReadP Char
char Char
'}')
    -- parse a var, a '$' followed by an ident
    var :: ReadP (Either String b)
var =
      Char -> ReadP Char
char Char
'$' ReadP Char -> ReadP (Either String b) -> ReadP (Either String b)
forall a b. ReadP a -> ReadP b -> ReadP 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 a. a -> ReadP a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (b -> Either String b
forall a b. b -> Either a b
Right b
"$"))
    -- 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
'$') (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
'\\'))
    -- escape a $
    escape :: ReadP (Either a String)
escape = Char -> ReadP Char
char Char
'\\' ReadP Char -> ReadP (Either a String) -> ReadP (Either a String)
forall a b. ReadP a -> ReadP b -> ReadP b
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 String
"$" ReadP String -> ReadP String -> ReadP String
forall a. ReadP a -> ReadP a -> ReadP a
<++ String -> ReadP String
forall a. a -> ReadP a
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
"\\"))
    -- 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 a b. ReadP a -> ReadP b -> ReadP a
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
      [([Either String String]
r, String
"")] -> (Either String String
 -> [Either String String] -> [Either String String])
-> [Either String String]
-> [Either String String]
-> [Either String String]
forall a b. (a -> b -> b) -> b -> [a] -> b
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
      [([Either String String], String)]
_ -> String -> [Either String String]
forall a. HasCallStack => String -> a
error String
"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 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 String
n -> \case
    (Right String
m : [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
    [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
<||> :: forall (f :: * -> *). Applicative f => f Bool -> f Bool -> f Bool
(<||>) = (Bool -> Bool -> Bool) -> f Bool -> f Bool -> f Bool
forall a b c. (a -> b -> c) -> f a -> f b -> f c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 Bool -> Bool -> Bool
(||)
<&&> :: forall (f :: * -> *). Applicative f => f Bool -> f Bool -> f Bool
(<&&>) = (Bool -> Bool -> Bool) -> f Bool -> f Bool -> f Bool
forall a b c. (a -> b -> c) -> f a -> f b -> f c
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 String
n = (if Char -> Bool
isLower (String -> Char
forall a. HasCallStack => [a] -> a
head String
n) then Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE else Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m 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 :: forall (t :: * -> *) c a b.
(Foldable t, Functor t) =>
c -> (a -> c) -> (b -> c) -> (c -> c -> c) -> t (Either a b) -> c
foldEither c
i a -> c
l b -> c
r c -> c -> c
f = (c -> c -> c) -> c -> t c -> c
forall a b. (a -> b -> b) -> b -> t a -> b
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 a b. (a -> b) -> t a -> t b
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)