code polymorphic in strictness (proof of concept)

PolymorphicStrictness.hs

-- in response to http://www.reddit.com/r/haskell/comments/2chb2h/fantasy_world_haskell/cjfobm5
-- 
-- Here is a demonstration that it is possible to write code which is "polymorphic in strictness",
-- that is, which can be executed strictly or lazily depending on the type at which it is instantiated.
-- 
-- Note that such a polymorphic function has to ask for a custom implementation of fmap and any other
-- standard function it is using, because those functions are not themselves polymorphic in strictness.

import Control.DeepSeq
import Debug.Trace
import Text.Printf


data Strict a = PrivateStrictCtor a

mkStrict :: NFData a => a -> Strict a
mkStrict x = x `deepseq` PrivateStrictCtor x

runStrict :: Strict a -> a
runStrict (PrivateStrictCtor x) = x


liftS1 :: NFData b => (a -> b) -> Strict a -> Strict b
liftS1 f = mkStrict . f . runStrict

strictCons :: NFData a => a -> Strict [a] -> Strict [a]
strictCons x = liftS1 (x:)

strictFMap :: (NFData (f b), Functor f)
           => (a -> b) -> Strict (f a) -> Strict (f b)
strictFMap f = liftS1 (fmap f)


newtype Lazy a = Lazy { runLazy :: a}

mkLazy = Lazy

lazyFMap :: Functor f
         => (a -> b) -> Lazy (f a) -> Lazy (f b)
lazyFMap f = mkLazy . fmap f . runLazy


-- traces calls, to make it clear whether the code is evaluated eagerly or lazily.
noisyPlus :: Int -> Int -> Int
noisyPlus x y = trace msg (x + y)
  where
    msg = printf "[adding %d + %d]" x y

polymorphicTest :: ((Int -> Int) -> p [Int] -> p [Int]) -> p [Int] -> p [Int]
polymorphicTest pmap = pmap (noisyPlus 10)
                     . pmap (noisyPlus 1)


-- |
-- >>> main
-- [[adding 1 + 0]
-- [adding 10 + 1]
-- 11,[adding 1 + 1]
-- [adding 10 + 2]
-- 12,[adding 1 + 2]
-- [adding 10 + 3]
-- 13,[adding 1 + 3]
-- [adding 10 + 4]
-- 14,[adding 1 + 4]
-- [adding 10 + 5]
-- 15]
-- [adding 1 + 0]
-- [adding 1 + 1]
-- [adding 1 + 2]
-- [adding 1 + 3]
-- [adding 1 + 4]
-- [adding 10 + 1]
-- [adding 10 + 2]
-- [adding 10 + 3]
-- [adding 10 + 4]
-- [adding 10 + 5]
-- [11,12,13,14,15]
main :: IO ()
main = do print $ runLazy   $ polymorphicTest   lazyFMap (mkLazy   [0..4])
          print $ runStrict $ polymorphicTest strictFMap (mkStrict [0..4])