{-# LANGUAGE CPP #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE TemplateHaskell #-}

{-|

Template Haskell helpers for StaticText.

-}

module Data.StaticText.TH
       ( st
       )

where

import           Prelude
import qualified Prelude as P (length)

import           Data.StaticText.Class
import           Data.String

import           Language.Haskell.TH


-- | A type with IsString instance to allow string literals in 'st'
-- argument without quoting.
newtype LitS = LitS String deriving String -> LitS
(String -> LitS) -> IsString LitS
forall a. (String -> a) -> IsString a
fromString :: String -> LitS
$cfromString :: String -> LitS
IsString


-- | Type-safe Static constructor macro for string literals.
--
-- Example:
--
-- > $(st "Foobar")
--
-- compiles to
--
-- > unsafeCreate "Foobar" :: forall a. (IsString a, IsStaticText a) => Static a 6
--
-- where 6 is the string length obtained at compile time.
st :: LitS -> Q Exp
st :: LitS -> Q Exp
st (LitS String
s) =
  do
    Name
at <- String -> Q Name
newName String
"a"
    Exp -> Q Exp
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Exp -> Type -> Exp
SigE (Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'unsafeCreate) (Lit -> Exp
LitE (Lit -> Exp) -> Lit -> Exp
forall a b. (a -> b) -> a -> b
$ String -> Lit
StringL String
s))
                ([TyVarBndr] -> Cxt -> Type -> Type
ForallT
#if MIN_VERSION_template_haskell(2,17,0)
                 [PlainTV at SpecifiedSpec]
#else
                 [Name -> TyVarBndr
PlainTV Name
at]
#endif
#if MIN_VERSION_template_haskell(2,10,0)
                 [ Type -> Type -> Type
AppT (Name -> Type
ConT ''IsString) (Name -> Type
VarT Name
at)
                 , Type -> Type -> Type
AppT (Name -> Type
ConT ''IsStaticText) (Name -> Type
VarT Name
at)] (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$
#else
                 [ ClassP ''IsString [VarT at]
                 , ClassP ''IsStaticText [VarT at]] $
#endif
                 Type -> Type -> Type
AppT
                 (Type -> Type -> Type
AppT
                  (Name -> Type
ConT ''Static)
                  (Name -> Type
VarT Name
at))
                 (TyLit -> Type
LitT (TyLit -> Type) -> TyLit -> Type
forall a b. (a -> b) -> a -> b
$ Integer -> TyLit
NumTyLit (Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Integer) -> Int -> Integer
forall a b. (a -> b) -> a -> b
$ String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
P.length String
s)))