{-# OPTIONS_HADDOCK not-home #-}
{-# 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, TExp, location, runIO)
import           Language.Haskell.TH.Syntax (Loc(..), mkName, unTypeQ, unsafeTExpCoerce)

type TExpQ a =
  Q (TExp a)

-- | 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 = 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

  [|| Group $$(moduleName) $$(listTE names) ||]

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

unsafeProperty :: PropertyName -> TExpQ Property
unsafeProperty :: PropertyName -> TExpQ Property
unsafeProperty =
  Q Exp -> TExpQ Property
forall a. Q Exp -> Q (TExp a)
unsafeTExpCoerce (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 = do
  Q Exp -> TExpQ [a]
forall a. Q Exp -> Q (TExp a)
unsafeTExpCoerce (Q Exp -> TExpQ [a]) -> ([Exp] -> Q Exp) -> [Exp] -> TExpQ [a]
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) -> ([Exp] -> Exp) -> [Exp] -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Exp] -> Exp
ListE ([Exp] -> TExpQ [a]) -> Q [Exp] -> TExpQ [a]
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. Q (TExp a) -> Q Exp
unTypeQ [TExpQ a]
xs

moduleName :: TExpQ GroupName
moduleName :: TExpQ GroupName
moduleName = 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
  [|| 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