{-# 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
interpExp :: String -> Q Exp
interpExp :: String -> Q Exp
interpExp =
forall (t :: * -> *) c a b.
(Foldable t, Functor t) =>
c -> (a -> c) -> (b -> c) -> (c -> c -> c) -> t (Either a b) -> c
foldEither (forall (m :: * -> *). Quote m => Lit -> m Exp
litE (String -> Lit
stringL String
""))
(forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (forall (m :: * -> *). Quote m => Name -> m Exp
varE 'show) forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Q Exp
varOrConE)
(forall (m :: * -> *). Quote m => Lit -> m Exp
litE forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Lit
stringL)
(\Q Exp
e1 Q Exp
e2 -> [|$e1 <> $e2|])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [Either String String]
parse
type Var = String
parse :: String -> [Either Var String]
parse :: String -> [Either String String]
parse String
s =
let
ident :: ReadP String
ident = (:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Bool) -> ReadP Char
satisfy (Char -> Bool
isLower forall (f :: * -> *). Applicative f => f Bool -> f Bool -> f Bool
<||> Char -> Bool
isUpper forall (f :: * -> *). Applicative f => f Bool -> f Bool -> f Bool
<||> (forall a. Eq a => a -> a -> Bool
== Char
'_')) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Char -> Bool) -> ReadP String
munch
(Char -> Bool
isAlphaNum forall (f :: * -> *). Applicative f => f Bool -> f Bool -> f Bool
<||> (forall a. Eq a => a -> a -> Bool
== Char
'\'') forall (f :: * -> *). Applicative f => f Bool -> f Bool -> f Bool
<||> (forall a. Eq a => a -> a -> Bool
== Char
'_'))
braces :: ReadP a -> ReadP a
braces = forall open close a.
ReadP open -> ReadP close -> ReadP a -> ReadP a
between (Char -> ReadP Char
char Char
'{') (Char -> ReadP Char
char Char
'}')
var :: ReadP (Either String b)
var =
Char -> ReadP Char
char Char
'$' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ((forall a b. a -> Either a b
Left forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ReadP String
ident forall a. ReadP a -> ReadP a -> ReadP a
+++ forall {a}. ReadP a -> ReadP a
braces ReadP String
ident)) forall a. ReadP a -> ReadP a -> ReadP a
<++ forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. b -> Either a b
Right b
"$"))
normal :: ReadP (Either a String)
normal = forall a b. b -> Either a b
Right forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Bool) -> ReadP String
munch1 ((forall a. Eq a => a -> a -> Bool
/= Char
'$') forall (f :: * -> *). Applicative f => f Bool -> f Bool -> f Bool
<&&> (forall a. Eq a => a -> a -> Bool
/= Char
'\\'))
escape :: ReadP (Either a String)
escape = Char -> ReadP Char
char Char
'\\' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (forall a b. b -> Either a b
Right forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (String -> ReadP String
string String
"$" forall a. ReadP a -> ReadP a -> ReadP a
<++ forall (f :: * -> *) a. Applicative f => a -> f a
pure String
"\\"))
one :: ReadP (Either String String)
one = forall {a}. ReadP (Either a String)
normal forall a. ReadP a -> ReadP a -> ReadP a
+++ forall {b}. IsString b => ReadP (Either String b)
var forall a. ReadP a -> ReadP a -> ReadP a
+++ forall {a}. ReadP (Either a String)
escape
parser :: ReadP [Either String String]
parser = forall a. ReadP a -> ReadP [a]
many ReadP (Either String String)
one forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ReadP ()
eof
in
case forall a. ReadP a -> ReadS a
readP_to_S ReadP [Either String String]
parser String
s of
[([Either String String]
r, 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
[([Either String 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 -> (forall a b. a -> Either a b
Left String
v forall a. a -> [a] -> [a]
:)
Right String
n -> \case
(Right String
m : [Either String String]
xs) -> forall a b. b -> Either a b
Right (String
n forall a. Semigroup a => a -> a -> a
<> String
m) forall a. a -> [a] -> [a]
: [Either String String]
xs
[Either String String]
xs -> forall a b. b -> Either a b
Right String
n 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
(<||>) = 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
(<&&>) = forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 Bool -> Bool -> Bool
(&&)
varOrConE :: String -> ExpQ
varOrConE :: String -> Q Exp
varOrConE String
n = (if Char -> Bool
isLower (forall a. [a] -> a
head String
n) then forall (m :: * -> *). Quote m => Name -> m Exp
varE else forall (m :: * -> *). Quote m => Name -> m Exp
conE) forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Name
mkName 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 = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr c -> c -> c
f c
i forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either a -> c
l b -> c
r)