{-# OPTIONS_HADDOCK not-home #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TemplateHaskell #-}
module Hedgehog.Internal.TH (
    TExpQ
  , discover
  , discoverPrefix
  ) where

import qualified Data.List as List
import qualified Data.Map as Map
import qualified Data.Ord as Ord

import           Hedgehog.Internal.Discovery
import           Hedgehog.Internal.Property

import           Language.Haskell.TH (Exp(..), Q, location, runIO
#if MIN_VERSION_template_haskell(2,17,0)
  , CodeQ, joinCode, unTypeCode, unsafeCodeCoerce
#endif
  )
import           Language.Haskell.TH.Syntax (Loc(..), mkName
#if !MIN_VERSION_template_haskell(2,17,0)
  , TExp, unsafeTExpCoerce, unTypeQ
#endif
  )

#if MIN_VERSION_template_haskell(2,17,0)
type TExpQ a = CodeQ a
#else
-- Originally `Code` is a more polymorphic newtype wrapper, but for this module
-- we can get away with just making it a type alias.
type TExpQ a = Q (TExp a)
joinCode :: Q (TExpQ a) -> TExpQ a
joinCode = (>>= id)
unsafeCodeCoerce :: Q Exp -> TExpQ a
unsafeCodeCoerce = unsafeTExpCoerce
unTypeCode ::  TExpQ a -> Q Exp
unTypeCode = unTypeQ
#endif

-- | Discover all the properties in a module.
--
--   Functions starting with `prop_` are assumed to be properties.
--
discover :: TExpQ Group
discover :: TExpQ Group
discover = String -> TExpQ Group
discoverPrefix String
"prop_"

discoverPrefix :: String -> TExpQ Group
discoverPrefix :: String -> TExpQ Group
discoverPrefix String
prefix = forall (m :: * -> *) a. Monad m => m (Code m a) -> Code m a
joinCode forall a b. (a -> b) -> a -> b
$ do
  String
file <- Q String
getCurrentFile
  [(PropertyName, PropertySource)]
properties <- forall k a. Map k a -> [(k, a)]
Map.toList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. IO a -> Q a
runIO (forall (m :: * -> *).
MonadIO m =>
String -> String -> m (Map PropertyName PropertySource)
readProperties String
prefix String
file)

  let
    startLine :: (a, PropertySource) -> (a, PropertySource) -> Ordering
startLine =
      forall a b. Ord a => (b -> a) -> b -> b -> Ordering
Ord.comparing forall a b. (a -> b) -> a -> b
$
        Position -> LineNo
posLine forall b c a. (b -> c) -> (a -> b) -> a -> c
.
        forall a. Pos a -> Position
posPostion forall b c a. (b -> c) -> (a -> b) -> a -> c
.
        PropertySource -> Pos String
propertySource forall b c a. (b -> c) -> (a -> b) -> a -> c
.
        forall a b. (a, b) -> b
snd

    names :: [TExpQ (PropertyName, Property)]
names =
      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (PropertyName -> TExpQ (PropertyName, Property)
mkNamedProperty forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) forall a b. (a -> b) -> a -> b
$
      forall a. (a -> a -> Ordering) -> [a] -> [a]
List.sortBy forall {a}. (a, PropertySource) -> (a, PropertySource) -> Ordering
startLine [(PropertyName, PropertySource)]
properties

  forall (m :: * -> *) a. Monad m => a -> m a
return [|| Group $$(moduleName) $$(listTE names) ||]

mkNamedProperty :: PropertyName -> TExpQ (PropertyName, Property)
mkNamedProperty :: PropertyName -> TExpQ (PropertyName, Property)
mkNamedProperty PropertyName
name =
  [|| (name, $$(unsafeProperty name)) ||]

unsafeProperty :: PropertyName -> TExpQ Property
unsafeProperty :: PropertyName -> TExpQ Property
unsafeProperty =
  forall a (m :: * -> *). Quote m => m Exp -> Code m a
unsafeCodeCoerce forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Exp
VarE forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Name
mkName forall b c a. (b -> c) -> (a -> b) -> a -> c
. PropertyName -> String
unPropertyName

listTE :: [TExpQ a] -> TExpQ [a]
listTE :: forall a. [TExpQ a] -> TExpQ [a]
listTE [TExpQ a]
xs =
  forall a (m :: * -> *). Quote m => m Exp -> Code m a
unsafeCodeCoerce forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Exp] -> Exp
ListE forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall a (m :: * -> *). Quote m => Code m a -> m Exp
unTypeCode [TExpQ a]
xs

moduleName :: TExpQ GroupName
moduleName :: TExpQ GroupName
moduleName = forall (m :: * -> *) a. Monad m => m (Code m a) -> Code m a
joinCode forall a b. (a -> b) -> a -> b
$ do
  GroupName
loc <- String -> GroupName
GroupName forall b c a. (b -> c) -> (a -> b) -> a -> c
. Loc -> String
loc_module forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Q Loc
location
  forall (m :: * -> *) a. Monad m => a -> m a
return [|| loc ||]

getCurrentFile :: Q FilePath
getCurrentFile :: Q String
getCurrentFile =
  Loc -> String
loc_filename forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Q Loc
location