{-# 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
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, 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)
liftTyped :: forall (m :: * -> *).
Quote m =>
QState mode -> Code m (QState mode)
$cliftTyped :: forall (mode :: MockedMode) (m :: * -> *).
Quote m =>
QState mode -> Code m (QState mode)
lift :: forall (m :: * -> *). Quote m => QState mode -> m Exp
$clift :: forall (mode :: MockedMode) (m :: * -> *).
Quote m =>
QState mode -> m 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
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, 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
liftTyped :: forall (m :: * -> *). Quote m => ReifyInfo -> Code m ReifyInfo
$cliftTyped :: forall (m :: * -> *). Quote m => ReifyInfo -> Code m ReifyInfo
lift :: forall (m :: * -> *). Quote m => ReifyInfo -> m Exp
$clift :: forall (m :: * -> *). Quote m => ReifyInfo -> m Exp
Lift)

{- | A helper for loading names for 'reifyInfo'

 Usage:

 > QState
 >   { reifyInfo = $(loadNames [''Int, ''Maybe])
 >   , ...
 >   }
-}
loadNames :: [Name] -> ExpQ
loadNames :: [Name] -> ExpQ
loadNames [Name]
names = forall (m :: * -> *). Quote m => [m Exp] -> m Exp
listE forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. (a -> b) -> [a] -> [b]
map [Name]
names 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 <- forall a. Q a -> Q a -> Q a
recover (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing) forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just 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 = []
    }