{-# LANGUAGE StandaloneDeriving #-} 
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ExistentialQuantification #-}

-- |
-- Module      : OAlg.Control.HNFData
-- Description : reducing a value to head normal form
-- Copyright   : (c) Erich Gut
-- License     : BSD3
-- Maintainer  : zerich.gut@gmail.com
--
-- reducing a value to head normal form. This is much weaker then "Control.DeepSeq".
module OAlg.Control.HNFData
  ( HNFValue(..), fromHNFValue

  , HNFData(..), hnfValue
  )
  where

import Control.Exception

--------------------------------------------------------------------------------
-- HNFValue -

-- | values in head normal form.
data HNFValue x = HNFValue x | forall e . Exception e => Failure e

deriving instance Show x => Show (HNFValue x)

instance Functor HNFValue where
  fmap :: forall a b. (a -> b) -> HNFValue a -> HNFValue b
fmap a -> b
f (HNFValue a
x) = forall x. x -> HNFValue x
HNFValue (a -> b
f a
x)
  fmap a -> b
_ (Failure e
e)  = forall x e. Exception e => e -> HNFValue x
Failure e
e

--------------------------------------------------------------------------------
-- fromHNFValue -

-- | from head normal form.
--
-- __Property__ Let @x'@ be in @'HNFValue' __x__@ then holds:
--
-- (1) If @x'@ matches @'HNFValue' x@ then the result of @'fromHNFValue' x'@ is @x@.
--
-- (2) If @x'@ matches @'Failure' e@ then evaluation @'fromHNFValue' x'@ will end up
-- in a throwing @e@.
fromHNFValue :: HNFValue x -> x
fromHNFValue :: forall x. HNFValue x -> x
fromHNFValue HNFValue x
hvx = case HNFValue x
hvx of
  HNFValue x
x -> x
x
  Failure e
e -> forall a e. Exception e => e -> a
throw e
e

--------------------------------------------------------------------------------
-- HNFData -

-- | data reducible to head normal form.
class HNFData x where
  -- | tries to reduce a value to its head normal form, throwing an 'Exception' for
  --   undefined values.
  rhnf :: x -> ()

--------------------------------------------------------------------------------
-- hnfValue -

-- | tries to reduce a value @x@ to its head normal form. If the reduction ends up in a 'SomeException'
-- @e@ then this will be catched and @'Failure' e@ will be returned, otherwise @'HNFValue' will be
-- returned.
hnfValue :: HNFData x => x -> IO (HNFValue x)
hnfValue :: forall x. HNFData x => x -> IO (HNFValue x)
hnfValue x
x = case forall x. HNFData x => x -> ()
rhnf x
x of
              () -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall x. x -> HNFValue x
HNFValue x
x)
            forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` (\(SomeException
e :: SomeException) -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall x e. Exception e => e -> HNFValue x
Failure SomeException
e))


instance HNFData () where
  rhnf :: () -> ()
rhnf () = ()

instance HNFData Bool where
  rhnf :: Bool -> ()
rhnf Bool
False = ()
  rhnf Bool
_     = ()
  
instance HNFData [x] where
  rhnf :: [x] -> ()
rhnf [x]
xs = case [x]
xs of
              [] -> ()
              [x]
_  -> ()