Interpolate.hs

{-# 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 =
  foldEither
    (litE (stringL ""))
    (appE (varE 'show) . varOrConE)
    (litE . stringL)
    (\e1 e2 -> [|$e1 <> $e2|])
    . 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 s =
  let
    -- A haskell var or con
    ident =
      (:)
        <$> satisfy (isLower <||> isUpper <||> (== '_'))
        <*> munch
          (isAlphaNum <||> (== '\'') <||> (== '_'))
    braces = between (char '{') (char '}')
    -- parse a var, a '$' followed by an ident
    var =
      char '$' *> ((Left <$> (ident +++ braces ident)) <++ pure (Right "$"))
    -- Everything up to a '$' or '\'
    normal = Right <$> munch1 ((/= '$') <&&> (/= '\\'))
    -- escape a $
    escape = char '\\' *> (Right <$> (string "$" <++ pure "\\"))
    -- One normal or var
    -- - Check escaped '$' first
    -- - variables, starting with $
    -- - normal string
    one = normal +++ var +++ escape
    parser = many one <* eof
  in
    case readP_to_S parser s of
      [(r, "")] -> foldr mergeRights [] r
      _ -> error "Failed to parse string"

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

(<&&>), (<||>) :: (Applicative f) => f Bool -> f Bool -> f Bool
(<||>) = liftA2 (||)
(<&&>) = liftA2 (&&)

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

varOrConE :: String -> ExpQ
varOrConE n = (if isLower (head n) then varE else conE) . mkName $ n

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