{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE FlexibleContexts #-}

-- | Internal utilities used for HMock implementation.
module Test.Predicates.Internal.Util where

import Data.Generics (Data, everywhere, mkT)
import Data.MonoTraversable (Element)
import qualified Data.Sequences as Seq
import GHC.Stack (CallStack, getCallStack, prettySrcLoc)
import Language.Haskell.TH.Syntax (NameFlavour (..))

-- | A value together with its source location.
data Located a = Loc (Maybe String) a deriving (a -> Located b -> Located a
(a -> b) -> Located a -> Located b
(forall a b. (a -> b) -> Located a -> Located b)
-> (forall a b. a -> Located b -> Located a) -> Functor Located
forall a b. a -> Located b -> Located a
forall a b. (a -> b) -> Located a -> Located b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> Located b -> Located a
$c<$ :: forall a b. a -> Located b -> Located a
fmap :: (a -> b) -> Located a -> Located b
$cfmap :: forall a b. (a -> b) -> Located a -> Located b
Functor)

-- | Annotates a value with its source location from the call stack.
locate :: CallStack -> a -> Located a
locate :: CallStack -> a -> Located a
locate CallStack
stack = case (([Char], SrcLoc) -> SrcLoc) -> [([Char], SrcLoc)] -> [SrcLoc]
forall a b. (a -> b) -> [a] -> [b]
map ([Char], SrcLoc) -> SrcLoc
forall a b. (a, b) -> b
snd (CallStack -> [([Char], SrcLoc)]
getCallStack CallStack
stack) of
  (SrcLoc
loc : [SrcLoc]
_) -> Maybe [Char] -> a -> Located a
forall a. Maybe [Char] -> a -> Located a
Loc ([Char] -> Maybe [Char]
forall a. a -> Maybe a
Just (SrcLoc -> [Char]
prettySrcLoc SrcLoc
loc))
  [SrcLoc]
_ -> Maybe [Char] -> a -> Located a
forall a. Maybe [Char] -> a -> Located a
Loc Maybe [Char]
forall a. Maybe a
Nothing

-- | Formats a 'Located' 'String' to include its source location.
withLoc :: Located String -> String
withLoc :: Located [Char] -> [Char]
withLoc (Loc Maybe [Char]
Nothing [Char]
s) = [Char]
s
withLoc (Loc (Just [Char]
loc) [Char]
s) = [Char]
s [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" at " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
loc

-- | Returns all ways to choose one element from a list, and the corresponding
-- remaining list.
choices :: [a] -> [(a, [a])]
choices :: [a] -> [(a, [a])]
choices [] = []
choices (a
x : [a]
xs) = (a
x, [a]
xs) (a, [a]) -> [(a, [a])] -> [(a, [a])]
forall a. a -> [a] -> [a]
: (([a] -> [a]) -> (a, [a]) -> (a, [a])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
:) ((a, [a]) -> (a, [a])) -> [(a, [a])] -> [(a, [a])]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [a] -> [(a, [a])]
forall a. [a] -> [(a, [a])]
choices [a]
xs)

-- | Checks if one sequence is a subsequence of another.
isSubsequenceOf :: (Seq.IsSequence t, Eq (Element t)) => t -> t -> Bool
t
xs isSubsequenceOf :: t -> t -> Bool
`isSubsequenceOf` t
ys = case t -> Maybe (Element t, t)
forall seq. IsSequence seq => seq -> Maybe (Element seq, seq)
Seq.uncons t
xs of
  Maybe (Element t, t)
Nothing -> Bool
True
  Just (Element t
x, t
xs') -> case t -> Maybe (Element t, t)
forall seq. IsSequence seq => seq -> Maybe (Element seq, seq)
Seq.uncons ((t, t) -> t
forall a b. (a, b) -> b
snd ((Element t -> Bool) -> t -> (t, t)
forall seq.
IsSequence seq =>
(Element seq -> Bool) -> seq -> (seq, seq)
Seq.break (Element t -> Element t -> Bool
forall a. Eq a => a -> a -> Bool
== Element t
x) t
ys)) of
    Maybe (Element t, t)
Nothing -> Bool
False
    Just (Element t
_, t
ys') -> t
xs' t -> t -> Bool
forall t. (IsSequence t, Eq (Element t)) => t -> t -> Bool
`isSubsequenceOf` t
ys'

-- | Removes all module names from Template Haskell names in the given value, so
-- that it will pretty-print more cleanly.
removeModNames :: Data a => a -> a
removeModNames :: a -> a
removeModNames = (forall a. Data a => a -> a) -> forall a. Data a => a -> a
everywhere ((NameFlavour -> NameFlavour) -> a -> a
forall a b. (Typeable a, Typeable b) => (b -> b) -> a -> a
mkT NameFlavour -> NameFlavour
unMod)
  where
    unMod :: NameFlavour -> NameFlavour
unMod NameG {} = NameFlavour
NameS
    unMod NameFlavour
other = NameFlavour
other