{-# LANGUAGE CPP #-}
#ifndef MIN_VERSION_template_haskell
#define MIN_VERSION_template_haskell(x,y,z) 1
#endif
-- template-haskell is only safe since GHC-8.2
#if __GLASGOW_HASKELL__ >= 802
{-# LANGUAGE Safe #-}
#elif __GLASGOW_HASKELL__ >= 702
{-# LANGUAGE Trustworthy #-}
#endif
module Data.Proxy.TH
  ( pr
#if MIN_VERSION_template_haskell(2,8,0)
  , pr1
#endif
  ) where

import Data.Char
#if __GLASGOW_HASKELL__ < 710
import Data.Functor
#endif
#if __GLASGOW_HASKELL__ < 707
import Data.Version (showVersion)
import Paths_tagged
#endif
import Language.Haskell.TH
import Language.Haskell.TH.Quote
import Language.Haskell.TH.Syntax

proxy_d, proxy_tc :: Name
#if __GLASGOW_HASKELL__ >= 707
proxy_d :: Name
proxy_d  = String -> String -> String -> Name
mkNameG_d String
"base" String
"Data.Proxy" String
"Proxy"
proxy_tc :: Name
proxy_tc = String -> String -> String -> Name
mkNameG_tc String
"base" String
"Data.Proxy" String
"Proxy"
#else
proxy_d  = mkNameG_d taggedPackageKey "Data.Proxy" "Proxy"
proxy_tc = mkNameG_tc taggedPackageKey "Data.Proxy" "Proxy"

-- note: On 7.10+ this would use CURRENT_PACKAGE_KEY if we still housed the key.
taggedPackageKey :: String
taggedPackageKey = "tagged-" ++ showVersion version
#endif

proxyTypeQ :: TypeQ -> TypeQ
proxyTypeQ :: TypeQ -> TypeQ
proxyTypeQ TypeQ
t = TypeQ -> TypeQ -> TypeQ
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (Name -> TypeQ
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
proxy_tc) TypeQ
t

proxyExpQ :: TypeQ -> ExpQ
proxyExpQ :: TypeQ -> ExpQ
proxyExpQ TypeQ
t = ExpQ -> TypeQ -> ExpQ
forall (m :: * -> *). Quote m => m Exp -> m Type -> m Exp
sigE (Name -> ExpQ
forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
proxy_d) (TypeQ -> TypeQ
proxyTypeQ TypeQ
t)

proxyPatQ :: TypeQ -> PatQ
proxyPatQ :: TypeQ -> PatQ
proxyPatQ TypeQ
t = PatQ -> TypeQ -> PatQ
forall (m :: * -> *). Quote m => m Pat -> m Type -> m Pat
sigP (Name -> [PatQ] -> PatQ
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
proxy_d []) (TypeQ -> TypeQ
proxyTypeQ TypeQ
t)

-- | A proxy value quasiquoter. @[pr|T|]@ will splice an expression
-- @Proxy::Proxy T@, while @[pr|A,B,C|]@ will splice in a value of
-- @Proxy :: Proxy [A,B,C]@.

-- TODO: parse a richer syntax for the types involved here so we can include spaces, applications, etc.
pr :: QuasiQuoter
pr :: QuasiQuoter
pr = (String -> ExpQ)
-> (String -> PatQ)
-> (String -> TypeQ)
-> (String -> Q [Dec])
-> QuasiQuoter
QuasiQuoter ((TypeQ -> ExpQ) -> String -> ExpQ
forall r. (TypeQ -> r) -> String -> r
mkProxy TypeQ -> ExpQ
proxyExpQ) ((TypeQ -> PatQ) -> String -> PatQ
forall r. (TypeQ -> r) -> String -> r
mkProxy TypeQ -> PatQ
proxyPatQ) ((TypeQ -> TypeQ) -> String -> TypeQ
forall r. (TypeQ -> r) -> String -> r
mkProxy TypeQ -> TypeQ
proxyTypeQ) String -> Q [Dec]
forall a. HasCallStack => a
undefined where
  mkProxy :: (TypeQ -> r) -> String -> r
  mkProxy :: forall r. (TypeQ -> r) -> String -> r
mkProxy TypeQ -> r
p String
s = case [String]
ts of
    [h :: String
h@(Char
t:String
_)]
       | Char -> Bool
isUpper Char
t -> TypeQ -> r
p (TypeQ -> r) -> TypeQ -> r
forall a b. (a -> b) -> a -> b
$ Name -> TypeQ
forall (m :: * -> *). Quote m => Name -> m Type
conT (Name -> TypeQ) -> Name -> TypeQ
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
h
       | Bool
otherwise -> TypeQ -> r
p (TypeQ -> r) -> TypeQ -> r
forall a b. (a -> b) -> a -> b
$ Name -> TypeQ
forall (m :: * -> *). Quote m => Name -> m Type
varT (Name -> TypeQ) -> Name -> TypeQ
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
h
#if MIN_VERSION_template_haskell(2,8,0)
    [String]
_ -> TypeQ -> r
p (TypeQ -> r) -> TypeQ -> r
forall a b. (a -> b) -> a -> b
$ [Type] -> Type
mkList ([Type] -> Type) -> Q [Type] -> TypeQ
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Q [Type]
cons
#endif
    where
      ts :: [String]
ts = (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map String -> String
strip ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ Char -> String -> [String]
forall a. Eq a => a -> [a] -> [[a]]
splitOn Char
',' String
s
      cons :: Q [Type]
cons = (String -> TypeQ) -> [String] -> Q [Type]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Name -> TypeQ
forall (m :: * -> *). Quote m => Name -> m Type
conT (Name -> TypeQ) -> (String -> Name) -> String -> TypeQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Name
mkName) [String]
ts
#if MIN_VERSION_template_haskell(2,8,0)
      mkList :: [Type] -> Type
mkList = (Type -> Type -> Type) -> Type -> [Type] -> Type
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Type -> Type -> Type
AppT (Type -> Type -> Type) -> (Type -> Type) -> Type -> Type -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Type -> Type
AppT Type
PromotedConsT) Type
PromotedNilT
#endif

#if MIN_VERSION_template_haskell(2,8,0)
-- | Like 'pr', but takes a single type, which is used to produce a
-- 'Proxy' for a single-element list containing only that type. This
-- is useful for passing a single type to a function that wants a list
-- of types.

-- TODO: parse a richer syntax for the types involved here so we can include spaces, applications, etc.
pr1 :: QuasiQuoter
pr1 :: QuasiQuoter
pr1 = (String -> ExpQ)
-> (String -> PatQ)
-> (String -> TypeQ)
-> (String -> Q [Dec])
-> QuasiQuoter
QuasiQuoter ((TypeQ -> ExpQ) -> String -> ExpQ
forall {f :: * -> *} {t}. Quote f => (f Type -> t) -> String -> t
mkProxy TypeQ -> ExpQ
proxyExpQ) ((TypeQ -> PatQ) -> String -> PatQ
forall {f :: * -> *} {t}. Quote f => (f Type -> t) -> String -> t
mkProxy TypeQ -> PatQ
proxyPatQ) ((TypeQ -> TypeQ) -> String -> TypeQ
forall {f :: * -> *} {t}. Quote f => (f Type -> t) -> String -> t
mkProxy TypeQ -> TypeQ
proxyTypeQ) String -> Q [Dec]
forall a. HasCallStack => a
undefined where
  sing :: Type -> Type
sing Type
x = Type -> Type -> Type
AppT (Type -> Type -> Type
AppT Type
PromotedConsT Type
x) Type
PromotedNilT
  mkProxy :: (f Type -> t) -> String -> t
mkProxy f Type -> t
p String
s = case String
s of
    Char
t:String
_
      | Char -> Bool
isUpper Char
t -> f Type -> t
p ((Type -> Type) -> f Type -> f Type
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Type -> Type
sing (Name -> f Type
forall (m :: * -> *). Quote m => Name -> m Type
conT (Name -> f Type) -> Name -> f Type
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
s))
      | Bool
otherwise -> f Type -> t
p ((Type -> Type) -> f Type -> f Type
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Type -> Type
sing (Name -> f Type
forall (m :: * -> *). Quote m => Name -> m Type
varT (Name -> f Type) -> Name -> f Type
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
s))
    String
_ -> String -> t
forall a. HasCallStack => String -> a
error String
"Empty string passed to pr1"
#endif

-- | Split on a delimiter.
splitOn :: Eq a => a -> [a] -> [[a]]
splitOn :: forall a. Eq a => a -> [a] -> [[a]]
splitOn a
d = [a] -> [[a]]
go where
  go :: [a] -> [[a]]
go [] = []
  go [a]
xs = case [a]
t of
      [] -> [[a]
h]
      (a
_:[a]
t') -> [a]
h [a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
: [a] -> [[a]]
go [a]
t'
    where ([a]
h,[a]
t) = (a -> Bool) -> [a] -> ([a], [a])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
d) [a]
xs

-- | Remove white space from both ends of a 'String'.
strip :: String -> String
strip :: String -> String
strip = (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isSpace) (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace