FoldException.hs

-- | Artificial exceptions in folds
--
-- Intended for qualified import.
--
-- > import Test.Util.FoldException (FoldException(..))
-- > import Test.Util.FoldException qualified as FoldException
module Test.Util.FoldException (
    -- * Definition
    FoldException(..)
  , descrAt
  , descrTopLevel
  , handleAt
  , handleTopLevel
    -- * Instrumentation
  , Info(..)
  , defaultInfo
    -- ** Execution
  , parse
    -- * Model
  , model
  ) where

import Control.Exception (Exception)
import Control.Exception qualified as Exception
import Control.Monad
import Control.Monad.Except
import Data.String
import Test.QuickCheck
import Test.Util.AST (AST (..))
import Test.Util.AST qualified as AST
import Test.Util.Clang qualified as Clang
import Test.Util.Input (TestInput)

import Clang.HighLevel.Types hiding (FoldException)
import Clang.LowLevel.Core

{-------------------------------------------------------------------------------
  Definition
-------------------------------------------------------------------------------}

-- | Exception thrown by instrumented fold
--
-- The 'Int' parameter means that if we throw (and possibly catch) /multiple/
-- exceptions from inside a fold, that we end up with the correct one.
data FoldException = FoldException Int
  deriving stock (Show)
  deriving anyclass (Exception)

-- | Description generated by handler somewhere during folding
descrAt :: AST.Descr -> FoldException -> AST.Descr
descrAt (AST.Descr context) ex = AST.Descr $
    show ex ++ " at " ++ context

-- | Description generated by top-level handler (outside the fold entirely)
descrTopLevel :: FoldException -> AST.Descr
descrTopLevel ex = AST.Descr $
    show ex ++ " at top-level"

-- | Handler intended for use in folds
handleAt :: CXCursor -> FoldException -> IO (HandlerResult (Maybe (AST.Node AST.Descr)))
handleAt curr ex = do
    node <- AST.descrAt curr
    return $ HandlerResult $ Just $ AST.Node (descrAt node ex) $ AST.Siblings []

-- | Top-level handler
--
-- Since this handler is /outside/ the scope of the fold, we don't get a cursor,
-- and so cannot report an error location within the AST.
handleTopLevel :: FoldException -> IO (AST AST.Descr)
handleTopLevel ex = return $ AST . AST.Siblings $ [
      AST.Node (descrTopLevel ex) $ AST.Siblings []
    ]

{-------------------------------------------------------------------------------
  Info
-------------------------------------------------------------------------------}

-- | Local information about exception behaviour
--
-- This is the /local/ information at this node: does /this/ node catch or
-- /throw/ something. See also 'RecursiveInfo'.
data Info = Info {
      exceptionHandler :: Bool
    , throwInBody      :: Maybe Int
    , throwInSummarize :: Maybe Int
    }
  deriving stock (Show)

defaultInfo :: Info
defaultInfo = Info {
      exceptionHandler = False
    , throwInBody      = Nothing
    , throwInSummarize = Nothing
    }

instance Arbitrary Info where
  arbitrary =
      pure Info
        <*> arbitrary
        <*> arbitrary
        <*> arbitrary

  shrink info = concat [
        [ info{exceptionHandler = x} | x <- shrink exceptionHandler ]
      , [ info{throwInBody      = x} | x <- shrink throwInBody      ]
      , [ info{throwInSummarize = x} | x <- shrink throwInSummarize ]
      ]
    where
      Info{exceptionHandler, throwInBody, throwInSummarize} = info

instance AST.ShowComment Info where
  showComment info = Just $ fromString $ "// " <> show info

{-------------------------------------------------------------------------------
  Execution of 'Info'
-------------------------------------------------------------------------------}

fold :: (CXCursor -> IO Info) -> Fold IO (AST.Node AST.Descr)
fold infoForCursor = go
  where
    go :: Fold IO (AST.Node AST.Descr)
    go = foldWithHandler handler $ \curr -> do
        info <- infoForCursor curr
        case throwInBody info of
          Just n  -> Exception.throwIO $ FoldException n
          Nothing -> do
            node <- AST.descrAt curr
            foldRecurseWith go $ \children ->
              case throwInSummarize info of
                Just n  -> Exception.throwIO $ FoldException n
                Nothing -> return $ AST.Node node (AST.Siblings children)

    handler :: CXCursor -> FoldException -> IO (HandlerResult (Maybe (AST.Node AST.Descr)))
    handler curr e = do
        info <- infoForCursor curr
        if exceptionHandler info
          then handleAt curr e
          else return HandlerRethrow

parse :: (CXCursor -> IO Info) -> TestInput -> IO (AST AST.Descr)
parse infoForCursor input =
    Exception.handle handleTopLevel $
      AST . AST.Siblings <$> Clang.parseUsing (fold infoForCursor) input

{-------------------------------------------------------------------------------
  Model
-------------------------------------------------------------------------------}

-- | Model that tells us what should happen in the presence of exceptions
model :: AST (AST.Descr, Info) -> AST AST.Descr
model = \(AST siblings) ->
    either catchTopLevel id $
      AST <$> runExcept (goSiblings siblings)
  where
    -- Model equivalent of 'handleTopLevel'
    catchTopLevel :: FoldException -> AST AST.Descr
    catchTopLevel ex = AST . AST.Siblings $ [
          AST.Node (descrTopLevel ex) $ AST.Siblings []
        ]

    goSiblings ::
         AST.Siblings (AST.Descr, Info)
      -> Except FoldException (AST.Siblings AST.Descr)
    goSiblings (AST.Siblings siblings) = AST.Siblings <$> mapM goNode siblings

    goNode ::
         AST.Node (AST.Descr, Info)
      -> Except FoldException (AST.Node AST.Descr)
    goNode (AST.Node (descr, info) children) =
        flip catchError catchAt $ do
          -- The order here matters for /which/ exception we might throw:
          -- first body, then children, and finally summarize
          forM_ (throwInBody info) $ throwError . FoldException
          children' <- goSiblings children
          forM_ (throwInSummarize info) $ throwError . FoldException
          return $ AST.Node descr children'
      where
        -- Model equivalent of 'handleAt'
        catchAt :: FoldException -> Except FoldException (AST.Node AST.Descr)
        catchAt ex
          | exceptionHandler info
          = return $ AST.Node (descrAt descr ex) $ AST.Siblings []

          | otherwise
          = throwError ex