{-# 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 :: Q (TExpQ a) -> TExpQ a
joinCode = (Q (TExpQ a) -> (TExpQ a -> TExpQ a) -> TExpQ a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= TExpQ a -> TExpQ a
forall a. a -> a
id)
unsafeCodeCoerce :: Q Exp -> TExpQ a
unsafeCodeCoerce :: Q Exp -> TExpQ a
unsafeCodeCoerce = Q Exp -> TExpQ a
forall a. Q Exp -> Q (TExp a)
unsafeTExpCoerce
unTypeCode ::  TExpQ a -> Q Exp
unTypeCode :: TExpQ a -> Q Exp
unTypeCode = TExpQ a -> Q Exp
forall a. Q (TExp a) -> Q Exp
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 = Q (TExpQ Group) -> TExpQ Group
forall a. Q (TExpQ a) -> TExpQ a
joinCode (Q (TExpQ Group) -> TExpQ Group) -> Q (TExpQ Group) -> TExpQ Group
forall a b. (a -> b) -> a -> b
$ do
  String
file <- Q String
getCurrentFile
  [(PropertyName, PropertySource)]
properties <- Map PropertyName PropertySource -> [(PropertyName, PropertySource)]
forall k a. Map k a -> [(k, a)]
Map.toList (Map PropertyName PropertySource
 -> [(PropertyName, PropertySource)])
-> Q (Map PropertyName PropertySource)
-> Q [(PropertyName, PropertySource)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (Map PropertyName PropertySource)
-> Q (Map PropertyName PropertySource)
forall a. IO a -> Q a
runIO (String -> String -> IO (Map PropertyName PropertySource)
forall (m :: * -> *).
MonadIO m =>
String -> String -> m (Map PropertyName PropertySource)
readProperties String
prefix String
file)

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

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

  TExpQ Group -> Q (TExpQ Group)
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 =
  Q Exp -> TExpQ Property
forall a. Q Exp -> TExpQ a
unsafeCodeCoerce (Q Exp -> TExpQ Property)
-> (PropertyName -> Q Exp) -> PropertyName -> TExpQ Property
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Exp -> Q Exp
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> Q Exp) -> (PropertyName -> Exp) -> PropertyName -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Exp
VarE (Name -> Exp) -> (PropertyName -> Name) -> PropertyName -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Name
mkName (String -> Name)
-> (PropertyName -> String) -> PropertyName -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PropertyName -> String
unPropertyName

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

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

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