content: {-# 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 =
    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)
  