{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveLift #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TemplateHaskellQuotes #-}

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)

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

-- | State information for mocking Q functionality.
data QState (mode :: MockedMode) = QState
  { forall (mode :: MockedMode). QState mode -> QMode mode
mode :: QMode mode
  , forall (mode :: MockedMode). QState mode -> [(String, Name)]
knownNames :: [(String, Name)]
  -- ^ Names that can be looked up with 'lookupTypeName' or 'lookupValueName'
  , forall (mode :: MockedMode). 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
$cshowsPrec :: forall (mode :: MockedMode). Int -> QState mode -> ShowS
showsPrec :: Int -> QState mode -> ShowS
$cshow :: forall (mode :: MockedMode). QState mode -> String
show :: QState mode -> String
$cshowList :: forall (mode :: MockedMode). [QState mode] -> ShowS
showList :: [QState mode] -> ShowS
Show, (forall (m :: * -> *). Quote m => QState mode -> m Exp)
-> (forall (m :: * -> *).
    Quote m =>
    QState mode -> Code m (QState mode))
-> Lift (QState mode)
forall t.
(forall (m :: * -> *). Quote m => t -> m Exp)
-> (forall (m :: * -> *). Quote m => t -> Code m t) -> Lift t
forall (mode :: MockedMode) (m :: * -> *).
Quote m =>
QState mode -> m Exp
forall (mode :: MockedMode) (m :: * -> *).
Quote m =>
QState mode -> Code m (QState mode)
forall (m :: * -> *). Quote m => QState mode -> m Exp
forall (m :: * -> *).
Quote m =>
QState mode -> Code m (QState mode)
$clift :: forall (mode :: MockedMode) (m :: * -> *).
Quote m =>
QState mode -> m Exp
lift :: forall (m :: * -> *). Quote m => QState mode -> m Exp
$cliftTyped :: forall (mode :: MockedMode) (m :: * -> *).
Quote m =>
QState mode -> Code m (QState mode)
liftTyped :: forall (m :: * -> *).
Quote m =>
QState mode -> Code m (QState mode)
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
$cshowsPrec :: Int -> ReifyInfo -> ShowS
showsPrec :: Int -> ReifyInfo -> ShowS
$cshow :: ReifyInfo -> String
show :: ReifyInfo -> String
$cshowList :: [ReifyInfo] -> ShowS
showList :: [ReifyInfo] -> ShowS
Show, (forall (m :: * -> *). Quote m => ReifyInfo -> m Exp)
-> (forall (m :: * -> *). Quote m => ReifyInfo -> Code m ReifyInfo)
-> Lift ReifyInfo
forall t.
(forall (m :: * -> *). Quote m => t -> m Exp)
-> (forall (m :: * -> *). Quote m => t -> Code m t) -> Lift t
forall (m :: * -> *). Quote m => ReifyInfo -> m Exp
forall (m :: * -> *). Quote m => ReifyInfo -> Code m ReifyInfo
$clift :: forall (m :: * -> *). Quote m => ReifyInfo -> m Exp
lift :: forall (m :: * -> *). Quote m => ReifyInfo -> m Exp
$cliftTyped :: forall (m :: * -> *). Quote m => ReifyInfo -> Code m ReifyInfo
liftTyped :: forall (m :: * -> *). Quote m => ReifyInfo -> Code m ReifyInfo
Lift)

-- | A helper for loading names for 'reifyInfo'
--
--  Usage:
--
--  > QState
--  >   { reifyInfo = $(loadNames [''Int, ''Maybe])
--  >   , ...
--  >   }
loadNames :: [Name] -> ExpQ
loadNames :: [Name] -> ExpQ
loadNames [Name]
names = [ExpQ] -> ExpQ
forall (m :: * -> *). Quote m => [m Exp] -> m Exp
listE ([ExpQ] -> ExpQ) -> [ExpQ] -> ExpQ
forall a b. (a -> b) -> a -> b
$ ((Name -> ExpQ) -> [Name] -> [ExpQ])
-> [Name] -> (Name -> ExpQ) -> [ExpQ]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Name -> ExpQ) -> [Name] -> [ExpQ]
forall a b. (a -> b) -> [a] -> [b]
map [Name]
names ((Name -> ExpQ) -> [ExpQ]) -> (Name -> ExpQ) -> [ExpQ]
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 a. a -> Q a
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
  Type
infoType <- Name -> Q Type
reifyType Name
name

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

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