{-# LANGUAGE BangPatterns, DoAndIfThenElse #-}

{-|
Module      :  GHC.AssertNF
Copyright   :  (c) 2013-2019 Joachim Breitner
License     :  BSD3
Maintainer  :  Joachim Breitner <mail@joachim-breitner.de>

To avoid space leaks and unwanted evaluation behaviour, the programmer might want his data to be fully evaluated at certain positions in the code. This can be enforced, for example, by ample use of "Control.DeepSeq", but this comes at a cost.

Experienced users hence use 'Control.DeepSeq.deepseq' only to find out about the existence of space leaks and optimize their code to not create the thunks in the first place, until the code no longer shows better performance with 'deepseq'.

This module provides an alternative approach: An explicit assertion about the evaluation state. If the programmer expect a certain value to be fully evaluated at a specific point of the program (e.g. before a call to 'writeIORef'), he can state that, and as long as assertions are enabled, this statement will be checked. In the production code the assertions can be disabled, to avoid the run-time cost.

-}


module GHC.AssertNF (
    assertNF,
    assertNFNamed,
    assertNFHere,
    disableAssertNF,
    isNF,
    )
where

import GHC.HeapView
import Debug.Trace
import Control.Monad
import Text.Printf
import Language.Haskell.TH (Q, Exp(AppE,VarE,LitE), Lit(StringL), Loc, location, loc_filename, loc_start, mkName)
import Data.IORef
import System.IO.Unsafe ( unsafePerformIO )

enabledRef :: IORef Bool
enabledRef :: IORef Bool
enabledRef = forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ forall a. a -> IO (IORef a)
newIORef Bool
True
{-# NOINLINE enabledRef #-}

-- Everything is in normal form, unless it is a
-- thunk explicitly marked as such.
-- Indirection are also considered to be in HNF
isHNF :: Closure -> IO Bool
isHNF :: Closure -> IO Bool
isHNF Closure
c = do
    case Closure
c of
        ThunkClosure {}    -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
        APClosure {}       -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
        SelectorClosure {} -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
        BCOClosure {}      -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
        Closure
_                  -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True

-- | The function 'assertNF' checks whether its argument is fully evaluated and
-- deeply evaluated. If this is not the case, a warning is printed to the standard output,
-- giving the number of thunks found and printing the shape of the unevaluated object:
--
-- >> let x = 1 + 2
-- >> let y = (x,x)
-- >> assertNF y
-- >Parameter not in normal form: 2 thunks found:
-- >let t1 = _bco
-- >in (t1,t1)
-- >> x
-- >3
-- >> assertNF y
-- >>
--
assertNF :: a -> IO ()
assertNF :: forall a. a -> IO ()
assertNF = forall a. String -> a -> IO ()
assertNF' String
"Parameter not in normal form"

-- | In order to better identify the source of error messages from 'assertNF', this variant allows you to include a name that is printed in the output:
--
-- >> assertNFNamed "y" y
-- >y not in normal form: 2 thunks found:
-- >let t1 = _bco
-- >in (t1,t1)
--
assertNFNamed :: String -> a -> IO ()
assertNFNamed :: forall a. String -> a -> IO ()
assertNFNamed String
valName = forall a. String -> a -> IO ()
assertNF' (String
valName forall a. [a] -> [a] -> [a]
++ String
" not in normal form")

-- | This function, when called as @$assertNFHere@ in a module with @-XTemplateHaskell@ enabled, will cause the current filename and position be included in the error message:
--
-- >Parameter at Test.hs:18:1 not in normal form: 2 thunks found:
-- >let t1 = _bco
-- >in (t1,t1)
--
assertNFHere :: Q Exp
assertNFHere :: Q Exp
assertNFHere = do
    String
locStr <- Loc -> String
formatLoc forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Q Loc
location
    -- We don't use ''assertNF here, so that this module can be used on a
    -- compiler that does not support TH.
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Exp -> Exp -> Exp
AppE (Name -> Exp
VarE (String -> Name
mkName String
"GHC.AssertNF.assertNFNamed"))
                  (Lit -> Exp
LitE (String -> Lit
StringL String
locStr))
  where formatLoc :: Loc -> String
        formatLoc :: Loc -> String
formatLoc Loc
loc = let file :: String
file = Loc -> String
loc_filename Loc
loc
                            (Int
line, Int
col) = Loc -> (Int, Int)
loc_start Loc
loc
                        in  forall r. PrintfType r => String -> r
printf String
"parameter at %s:%d:%d" String
file Int
line Int
col

assertNF' :: String ->  a -> IO ()
assertNF' :: forall a. String -> a -> IO ()
assertNF' String
str a
x = do
    Bool
en <- forall a. IORef a -> IO a
readIORef IORef Bool
enabledRef
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
en forall a b. (a -> b) -> a -> b
$ do
        [Int]
depths <- Int -> Box -> IO [Int]
assertNFBoxed Int
0 (forall a. a -> Box
asBox a
x)
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Int]
depths) forall a b. (a -> b) -> a -> b
$ do
            HeapGraph ()
g <- forall a. Monoid a => Int -> a -> Box -> IO (HeapGraph a)
buildHeapGraph (forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum [Int]
depths forall a. Num a => a -> a -> a
+ Int
3) () (forall a. a -> Box
asBox a
x)
                -- +3 for good mesure; applications don't look good otherwise
            String -> IO ()
traceIO forall a b. (a -> b) -> a -> b
$ String
str forall a. [a] -> [a] -> [a]
++ String
": " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
depths) forall a. [a] -> [a] -> [a]
++ String
" thunks found:\n" forall a. [a] -> [a] -> [a]
++
                forall a. HeapGraph a -> String
ppHeapGraph HeapGraph ()
g


assertNFBoxed :: Int -> Box -> IO [Int]
assertNFBoxed :: Int -> Box -> IO [Int]
assertNFBoxed !Int
d Box
b = do
    Closure
c <- Box -> IO Closure
getBoxedClosureData Box
b
    Bool
nf <- Closure -> IO Bool
isHNF Closure
c
    if Bool
nf
    then do
        Closure
c' <- Box -> IO Closure
getBoxedClosureData Box
b
        forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Int -> Box -> IO [Int]
assertNFBoxed (Int
dforall a. Num a => a -> a -> a
+Int
1)) (forall b. GenClosure b -> [b]
allClosures Closure
c')
    else forall (m :: * -> *) a. Monad m => a -> m a
return [Int
d]

-- | Invoke this function at the top of your 'main' method to turn every call
-- to 'assertNF' and its variants to noops.
disableAssertNF :: IO ()
disableAssertNF :: IO ()
disableAssertNF = forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
enabledRef Bool
False

-- | A variant of 'assertNF' that does not print anything and just returns
-- 'True' if the value is in normal form, or 'False' otherwise. This function
-- is not affected by 'disableAssertNF'.
isNF :: a -> IO Bool
isNF :: forall a. a -> IO Bool
isNF a
x = Box -> IO Bool
isNFBoxed (forall a. a -> Box
asBox a
x)

isNFBoxed :: Box -> IO Bool
isNFBoxed :: Box -> IO Bool
isNFBoxed Box
b = do
    Closure
c <- Box -> IO Closure
getBoxedClosureData Box
b
    Bool
nf <- Closure -> IO Bool
isHNF Closure
c
    if Bool
nf
    then do
        Closure
c' <- Box -> IO Closure
getBoxedClosureData Box
b
        forall (m :: * -> *) a. Monad m => (a -> m Bool) -> [a] -> m Bool
allM Box -> IO Bool
isNFBoxed (forall b. GenClosure b -> [b]
allClosures Closure
c')
    else forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

-- From Control.Monad.Loops in monad-loops, but I'd like to avoid too many
-- trivial dependencies
allM :: (Monad m) => (a -> m Bool) -> [a] -> m Bool
allM :: forall (m :: * -> *) a. Monad m => (a -> m Bool) -> [a] -> m Bool
allM a -> m Bool
_ []       = forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
allM a -> m Bool
p (a
x:[a]
xs)   = do
        Bool
q <- a -> m Bool
p a
x
        if Bool
q
                then forall (m :: * -> *) a. Monad m => (a -> m Bool) -> [a] -> m Bool
allM a -> m Bool
p [a]
xs
                else forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False