-- There was a bug in 6.12 that meant that the binding
-- for 'rght' was initially determined (correctly) to be
-- strictly demanded, but the FloatOut pass made it lazy
--
-- The test compiles the program and greps for the
-- binding of 'rght' to check that it is marked strict
-- something like this:
--         rght [Dmd=Just S] :: EvalTest.AList a

module EvalTest where

import GHC.Conc

import Control.Applicative (Applicative(..))
import Control.Monad (liftM, ap)

data Eval a = Done a

instance Functor Eval where
    fmap = liftM

instance Applicative Eval where
    pure = Done
    (<*>) = ap

instance Monad Eval where
  Done x >>= k = k x   -- Note: pattern 'Done x' makes '>>=' strict

rpar :: a -> Eval a
rpar x = x `par` return x

rseq :: a -> Eval a
rseq x = x `pseq` return x

runEval :: Eval a -> a
runEval (Done x) = x

data AList a = ANil | ASing a | Append (AList a) (AList a) | AList [a]

append ANil r = r
append l ANil = l -- **
append l r    = Append l r

parListTreeLike :: Integer -> Integer -> (Integer -> a) -> AList a
parListTreeLike min max fn
 | max - min <= threshold = ASing (fn max)
 | otherwise  =
      runEval $ do
        rpar rght
        rseq left
        return (left `append` rght)
    where
      mid  = min + ((max - min) `quot` 2)
      left = parListTreeLike min mid fn
      rght = parListTreeLike (mid+1) max fn

threshold = 1