{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveLift #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TemplateHaskell #-}

module Language.Haskell.TH.TestUtils.QState
  ( QState(..)
  , ReifyInfo(..)
  , loadNames
  , unmockedState
  ) where

import Language.Haskell.TH
import Language.Haskell.TH.Instances ()
import Language.Haskell.TH.Syntax (Lift)
#if MIN_VERSION_template_haskell(2,16,0)
import qualified Language.Haskell.TH.Syntax as TH
#endif

import Language.Haskell.TH.TestUtils.QMode (MockedMode(..), QMode(..))

-- | State information for mocking Q functionality.
data QState (mode :: MockedMode) = QState
  { QState mode -> QMode mode
mode       :: QMode mode
  , QState mode -> [(String, Name)]
knownNames :: [(String, Name)]
    -- ^ Names that can be looked up with 'lookupTypeName' or 'lookupValueName'
  , QState mode -> [(Name, ReifyInfo)]
reifyInfo  :: [(Name, ReifyInfo)]
    -- ^ Reification information for Names to return when 'reify' is called.
  } deriving (Int -> QState mode -> ShowS
[QState mode] -> ShowS
QState mode -> String
(Int -> QState mode -> ShowS)
-> (QState mode -> String)
-> ([QState mode] -> ShowS)
-> Show (QState mode)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall (mode :: MockedMode). Int -> QState mode -> ShowS
forall (mode :: MockedMode). [QState mode] -> ShowS
forall (mode :: MockedMode). QState mode -> String
showList :: [QState mode] -> ShowS
$cshowList :: forall (mode :: MockedMode). [QState mode] -> ShowS
show :: QState mode -> String
$cshow :: forall (mode :: MockedMode). QState mode -> String
showsPrec :: Int -> QState mode -> ShowS
$cshowsPrec :: forall (mode :: MockedMode). Int -> QState mode -> ShowS
Show, QState mode -> Q Exp
QState mode -> Q (TExp (QState mode))
(QState mode -> Q Exp)
-> (QState mode -> Q (TExp (QState mode))) -> Lift (QState mode)
forall t. (t -> Q Exp) -> (t -> Q (TExp t)) -> Lift t
forall (mode :: MockedMode). QState mode -> Q Exp
forall (mode :: MockedMode). QState mode -> Q (TExp (QState mode))
liftTyped :: QState mode -> Q (TExp (QState mode))
$cliftTyped :: forall (mode :: MockedMode). QState mode -> Q (TExp (QState mode))
lift :: QState mode -> Q Exp
$clift :: forall (mode :: MockedMode). QState mode -> Q Exp
Lift)

data ReifyInfo = ReifyInfo
  { ReifyInfo -> Info
reifyInfoInfo   :: Info
  , ReifyInfo -> Maybe Fixity
reifyInfoFixity :: Maybe Fixity
  , ReifyInfo -> Maybe [Role]
reifyInfoRoles  :: Maybe [Role]
  , ReifyInfo -> Type
reifyInfoType   :: Type
  } deriving (Int -> ReifyInfo -> ShowS
[ReifyInfo] -> ShowS
ReifyInfo -> String
(Int -> ReifyInfo -> ShowS)
-> (ReifyInfo -> String)
-> ([ReifyInfo] -> ShowS)
-> Show ReifyInfo
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ReifyInfo] -> ShowS
$cshowList :: [ReifyInfo] -> ShowS
show :: ReifyInfo -> String
$cshow :: ReifyInfo -> String
showsPrec :: Int -> ReifyInfo -> ShowS
$cshowsPrec :: Int -> ReifyInfo -> ShowS
Show, ReifyInfo -> Q Exp
ReifyInfo -> Q (TExp ReifyInfo)
(ReifyInfo -> Q Exp)
-> (ReifyInfo -> Q (TExp ReifyInfo)) -> Lift ReifyInfo
forall t. (t -> Q Exp) -> (t -> Q (TExp t)) -> Lift t
liftTyped :: ReifyInfo -> Q (TExp ReifyInfo)
$cliftTyped :: ReifyInfo -> Q (TExp ReifyInfo)
lift :: ReifyInfo -> Q Exp
$clift :: ReifyInfo -> Q Exp
Lift)

-- | A helper for loading names for 'reifyInfo'
--
-- Usage:
--
-- > QState
-- >   { reifyInfo = $(loadNames [''Int, ''Maybe])
-- >   , ...
-- >   }
loadNames :: [Name] -> ExpQ
loadNames :: [Name] -> Q Exp
loadNames [Name]
names = [Q Exp] -> Q Exp
listE ([Q Exp] -> Q Exp) -> [Q Exp] -> Q Exp
forall a b. (a -> b) -> a -> b
$ ((Name -> Q Exp) -> [Name] -> [Q Exp])
-> [Name] -> (Name -> Q Exp) -> [Q Exp]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Name -> Q Exp) -> [Name] -> [Q Exp]
forall a b. (a -> b) -> [a] -> [b]
map [Name]
names ((Name -> Q Exp) -> [Q Exp]) -> (Name -> Q Exp) -> [Q Exp]
forall a b. (a -> b) -> a -> b
$ \Name
name -> do
  Info
info <- Name -> Q Info
reify Name
name
  Maybe Fixity
fixity <- Name -> Q (Maybe Fixity)
reifyFixity Name
name
  Maybe [Role]
roles <- Q (Maybe [Role]) -> Q (Maybe [Role]) -> Q (Maybe [Role])
forall a. Q a -> Q a -> Q a
recover (Maybe [Role] -> Q (Maybe [Role])
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe [Role]
forall a. Maybe a
Nothing) (Q (Maybe [Role]) -> Q (Maybe [Role]))
-> Q (Maybe [Role]) -> Q (Maybe [Role])
forall a b. (a -> b) -> a -> b
$ [Role] -> Maybe [Role]
forall a. a -> Maybe a
Just ([Role] -> Maybe [Role]) -> Q [Role] -> Q (Maybe [Role])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> Q [Role]
reifyRoles Name
name
#if MIN_VERSION_template_haskell(2,16,0)
  let infoType :: Q Exp
infoType = Name -> Q Type
reifyType Name
name Q Type -> (Type -> Q Exp) -> Q Exp
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Type -> Q Exp
forall t. Lift t => t -> Q Exp
TH.lift
#else
  let infoType = [| error "Your version of template-haskell does not have 'reifyType'" |]
#endif

  [| (name, ReifyInfo info fixity roles $infoType) |]

-- | A shortcut for defining an unmocked Q.
unmockedState :: QState 'NotMocked
unmockedState :: QState 'NotMocked
unmockedState = QState :: forall (mode :: MockedMode).
QMode mode
-> [(String, Name)] -> [(Name, ReifyInfo)] -> QState mode
QState
  { mode :: QMode 'NotMocked
mode = QMode 'NotMocked
AllowQ
  , knownNames :: [(String, Name)]
knownNames = []
  , reifyInfo :: [(Name, ReifyInfo)]
reifyInfo = []
  }