content: {-# LANGUAGE DeriveDataTypeable #-}
  {-# LANGUAGE FlexibleContexts #-}
  {-# LANGUAGE ScopedTypeVariables #-}
  --
  -- Copyright (c) 2009-2022   Stefan Wehr - http://www.stefanwehr.de
  --
  -- This library is free software; you can redistribute it and/or
  -- modify it under the terms of the GNU Lesser General Public
  -- License as published by the Free Software Foundation; either
  -- version 2.1 of the License, or (at your option) any later version.
  --
  -- This library is distributed in the hope that it will be useful,
  -- but WITHOUT ANY WARRANTY; without even the implied warranty of
  -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
  -- Lesser General Public License for more details.
  --
  -- You should have received a copy of the GNU Lesser General Public
  -- License along with this library; if not, write to the Free Software
  -- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA
  --
  
  {- |
  
  This module defines the API for HTF tests, i.e. unit tests and quickcheck properties.
  
  This functionality is mainly used internally in the code
  generated by the @hftpp@ pre-processor.
  -}
  
  module Test.Framework.TestInterface (
  
      Assertion, TestResult(..), FullTestResult(..), HTFFailureException(..)
    , HtfStackEntry(..), HtfStack, emptyHtfStack, mkHtfStack, formatHtfStack
    , failureLocationFromStack, failureLocation
    , restCallStack, htfStackToList
    , failHTF, subAssertHTF, addCallerToSubAssertStack
    , mkFullTestResult
  
  ) where
  
  import Test.Framework.Location
  import Test.Framework.Colors
  
  import Control.Monad.Trans.Control
  import Data.Typeable
  import GHC.Stack
  import qualified Data.List as L
  import qualified Control.Exception as Exc
  import qualified Control.Exception.Lifted as ExcLifted
  
  {- | An assertion is just an 'IO' action. Internally, the body of any test
  in HTF is of type 'Assertion'. If a test specification of a certain plugin
  has a type different from 'Assertion', the plugin's preprocessor pass must
  inject wrapper code to convert the test specification into an assertion.
  
  Assertions may use 'failHTF' to signal a 'TestResult' different from
  'Pass'. If the assertion finishes successfully, the tests passes
  implicitly.
  
  Please note: the assertion must not swallow any exceptions! Otherwise,
  timeouts and other things might not work as expected.
  -}
  type Assertion = IO ()
  
  -- | The summary result of a test.
  data TestResult = Pass | Pending | Fail | Error
                  deriving (Show, Read, Eq)
  
  data HtfStackEntry
      = HtfStackEntry
      { hse_location :: Location
      , hse_calledFunction :: String
      , hse_message :: Maybe String
      } deriving (Eq, Ord, Show, Read)
  
  -- The first entry in the list is the location of the assertion failure
  data HtfStack
      = HtfStack
        { hs_assertStack :: [HtfStackEntry]
        , hs_subAssertStack :: [HtfStackEntry]
        }
      deriving (Eq, Ord, Show, Read)
  
  mkHtfStack :: CallStack -> HtfStack
  mkHtfStack cs = HtfStack (map mkHtfStackEntry (removeHtfPrefix (getCallStack cs))) []
  
  removeHtfPrefix :: [(String, SrcLoc)] -> [(String, SrcLoc)]
  removeHtfPrefix [] = []
  removeHtfPrefix all@((_, srcLoc) : rest) =
      if "Test.Framework" `L.isPrefixOf` srcLocModule srcLoc
      then removeHtfPrefix rest
      else all
  
  mkHtfStackEntry :: (String, SrcLoc) -> HtfStackEntry
  mkHtfStackEntry x = mkHtfStackEntry' x Nothing
  
  mkHtfStackEntry' :: (String, SrcLoc) -> Maybe String -> HtfStackEntry
  mkHtfStackEntry' (funName, srcLoc) mMsg =
      HtfStackEntry
      { hse_location = makeLoc (srcLocFile srcLoc) (srcLocStartLine srcLoc)
      , hse_calledFunction = funName
      , hse_message = mMsg
      }
  
  htfStackToList :: HtfStack -> [HtfStackEntry]
  htfStackToList s = hs_assertStack s ++ reverse (hs_subAssertStack s)
  
  emptyHtfStack :: HtfStack
  emptyHtfStack = HtfStack [] []
  
  failureLocation :: HasCallStack => Maybe Location
  failureLocation = failureLocationFromStack (mkHtfStack callStack)
  
  failureLocationFromStack :: HtfStack -> Maybe Location
  failureLocationFromStack stack =
      case htfStackToList stack of
        [] -> Nothing
        e:_ -> Just (hse_location e)
  
  restCallStack :: HtfStack -> [HtfStackEntry]
  restCallStack stack =
      case htfStackToList stack of
        [] -> []
        _:rest -> rest
  
  -- | Formats a stack trace.
  formatHtfStack :: HtfStack -> String
  formatHtfStack stack =
      unlines $ map formatStackElem $ zip [0..] $ htfStackToList stack
      where
        formatStackElem (pos, HtfStackEntry loc _ mMsg) =
            let pref = if pos > 0 then "  called from " else "  at "
            in pref ++ showLoc loc ++ showMsg mMsg
        showMsg Nothing = ""
        showMsg (Just m) = " (" ++ m ++ ")"
  
  -- | The full result of a test, as used by HTF plugins.
  data FullTestResult
      = FullTestResult
        { ftr_stack :: HtfStack                  -- ^ The stack to the location of a possible failure
        , ftr_message :: Maybe ColorString       -- ^ An error message
        , ftr_result :: Maybe TestResult         -- ^ The outcome of the test, 'Nothing' means timeout
        } deriving (Eq, Show, Read)
  
  -- | Auxiliary function for contructing a 'FullTestResult'.
  mkFullTestResult :: TestResult -> Maybe String -> FullTestResult
  mkFullTestResult r msg =
      FullTestResult
      { ftr_stack = emptyHtfStack
      , ftr_message = fmap noColor msg
      , ftr_result = Just r
      }
  
  -- Internal exception type for propagating exceptions.
  data HTFFailureException
      = HTFFailure FullTestResult
        deriving (Show, Typeable)
  
  instance Exc.Exception HTFFailureException
  
  {- |
  Terminate a HTF test, usually to signal a failure. The result of the test
  is given in the 'FullTestResult' argument.
  -}
  failHTF :: MonadBaseControl IO m => FullTestResult -> m a
  -- Important: force the string argument, otherwise an error embedded
  -- lazily inside the string might escape.
  failHTF r = length (show r) `seq` ExcLifted.throwIO (HTFFailure r)
  
  addCallerToSubAssertStack :: CallStack -> HtfStack -> Maybe String -> HtfStack
  addCallerToSubAssertStack ghcStack stack@(HtfStack s1 s2) mMsg =
      case removeHtfPrefix (getCallStack ghcStack) of
        [] -> stack
        (entry : _) -> HtfStack s1 ((mkHtfStackEntry' entry mMsg) : s2)
  
  {- |
  Opens a new assertion stack frame to allow for sensible location information.
  This function should be used if the function being called does not carry
  a 'HasCallStack' annotation.
  -}
  subAssertHTF :: (HasCallStack, MonadBaseControl IO m) => Maybe String -> m a -> m a
  subAssertHTF mMsg action =
      let stack = callStack
      in action `ExcLifted.catch`
                    (\(HTFFailure res) ->
                         let newRes =
                                 res { ftr_stack =
                                           addCallerToSubAssertStack stack (ftr_stack res) mMsg }
                         in failHTF newRes)
  