-- Test for ticket #830, simplifier taking too long on large do expression

main = do
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()
  return ()


module T9233 where

import T9233a
import Data.Functor.Identity

upds :: (Monad m) => [String -> Options -> m Options]
upds = [
  \a o -> return o { flags = (flags o) { f1 = splitComma a ++ " " ++ f1 (flags o) } }
  ]

setAll :: Options -> Options
setAll _ = (getOpt upds :: Identity ()) `seq` undefined


module T9233a where

data X = X {
  f1 :: String,
  f2 :: !Bool,
  f3 :: !Bool,
  f4 :: !Bool,
  f5 :: !Bool,
  f6 :: !Bool,
  f7 :: !Bool,
  f8 :: !Bool,
  f9 :: !Bool,
  f10 :: !Bool,
  f11 :: !Bool,
  f12 :: !Bool,
  f13 :: !Bool,
  f14 :: !Bool,
  f15 :: !Bool,
  f16 :: !Bool,
  f17 :: !Bool,
  f18 :: !Bool,
  f19 :: !Bool,
  f20 :: !Bool,
  f21 :: !Bool,
  f22 :: !Bool,
  f23 :: !Bool,
  f24 :: !Bool,
  f25 :: !Bool,
  f26 :: !Bool,
  f27 :: !Bool,
  f28 :: !Bool,
  f29 :: !Bool,
  f30 :: !Bool,
  f31 :: !Bool,
  f32 :: !Bool,
  f33 :: !Bool,
  f34 :: !Bool,
  f35 :: !Bool,
  f36 :: !Bool,
  f37 :: !Bool,
  f38 :: !Bool,
  f39 :: !Bool,
  f40 :: !Bool,
  f41 :: !Bool,
  f42 :: !Bool,
  f43 :: !Bool,
  f44 :: !Bool,
  f45 :: !Bool,
  f46 :: !Bool,
  f47 :: !Bool,
  f48 :: !Bool,
  f49 :: !Bool,
  f50 :: !Bool,
  f51 :: !Bool,
  f52 :: !Bool,
  f53 :: !Bool,
  f54 :: !Bool,
  f55 :: !Bool,
  f56 :: !Bool,
  f57 :: !Bool,
  f58 :: !Bool,
  f59 :: !Bool,
  f60 :: !Bool,
  f61 :: !Bool,
  f62 :: !Bool,
  f63 :: !Bool,
  f64 :: !Bool,
  f65 :: !Bool,
  f66 :: !Bool,
  f67 :: !Bool,
  f68 :: !Bool,
  f69 :: !Bool,
  f70 :: !Bool,
  f71 :: !Bool,
  f72 :: !Bool,
  f73 :: !Bool,
  f74 :: !Bool,
  f75 :: !Bool,
  f76 :: !Bool,
  f77 :: !Bool,
  f78 :: !Bool,
  f79 :: !Bool,
  f80 :: !Bool,
  f81 :: !Bool,
  f82 :: !Bool,
  f83 :: !Bool,
  f84 :: !Bool,
  f85 :: !Bool,
  f86 :: !Bool,
  f87 :: !Bool,
  f88 :: !Bool,
  f89 :: !Bool,
  f90 :: !Bool,
  f91 :: !Bool,
  f92 :: !Bool,
  f93 :: !Bool,
  f94 :: !Bool,
  f95 :: !Bool,
  f96 :: !Bool,
  f97 :: !Bool,
  f98 :: !Bool,
  f99 :: !Bool,
  f100 :: !Bool
  }

data Options = Options {
  flags :: !X,
  o2 :: !Bool,
  o3 :: !Bool,
  o4 :: !Bool,
  o5 :: !Bool,
  o6 :: !Bool,
  o7 :: !Bool,
  o8 :: !Bool,
  o9 :: !Bool,
  o10 :: !Bool,
  o11 :: !Bool,
  o12 :: !Bool
  }

splitComma :: String -> String
splitComma _ = "a"
{-# NOINLINE splitComma #-}

getOpt :: Monad m => [String -> Options -> m Options] -> m ()
getOpt _ = return ()
{-# NOINLINE getOpt #-}


{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE RankNTypes #-}

-----------------------------------------------------------------------------
-- | Modified from cereal, which is
-- Copyright   : Lennart Kolmodin, Galois Inc. 2009
-- License     : BSD3-style

module T9630a (
      Serialize(..), GSerialize (..), Putter, Get
    ) where

import Data.ByteString.Builder (Builder)
import Data.ByteString as B
import GHC.Generics
import Control.Applicative (Applicative (..), (<$>))

class Serialize t where
    put :: Putter t
    get :: Get t

instance Serialize () where
    put ()  = pure ()
    get     = pure ()

-- Generics

class GSerialize f where
    gPut :: Putter (f a)
    gGet :: Get (f a)

instance (GSerialize a, GSerialize b) => GSerialize (a :*: b) where
    gPut (a :*: b) = gPut a *> gPut b
    gGet = (:*:) <$> gGet  <*> gGet

instance GSerialize a => GSerialize (M1 i c a) where
    gPut = gPut . unM1
    gGet = M1 <$> gGet

instance Serialize a => GSerialize (K1 i a) where
    gPut = put . unK1
    gGet = K1 <$> get

-- Put

data PairS a = PairS a !Builder

newtype PutM a = Put { unPut :: PairS a }

type Put = PutM ()

type Putter a = a -> Put

instance Functor PutM where
        fmap f m = Put $ let PairS a w = unPut m in PairS (f a) w

instance Applicative PutM where
        pure a = Put (PairS a mempty)

        m <*> k = Put $
            let PairS f w  = unPut m
                PairS x w' = unPut k
            in PairS (f x) (w `mappend` w')

-- Get

data Result r = Fail String B.ByteString
              | Partial (B.ByteString -> Result r)
              | Done r B.ByteString

newtype Get a = Get
  { unGet :: forall r. Input -> Buffer -> More
                    -> Failure r -> Success a r
                    -> Result r }

type Input  = B.ByteString
type Buffer = Maybe B.ByteString

type Failure   r = Input -> Buffer -> More -> [String] -> String -> Result r
type Success a r = Input -> Buffer -> More -> a                  -> Result r

data More
  = Complete
  | Incomplete (Maybe Int)
    deriving (Eq)

instance Functor Get where
    fmap p m =        Get $ \ s0 b0 m0 kf ks ->
      unGet m s0 b0 m0 kf $ \ s1 b1 m1 a     -> ks s1 b1 m1 (p a)

instance Applicative Get where
    pure a = Get $ \ s0 b0 m0 _ ks -> ks s0 b0 m0 a

    f <*> x =         Get $ \ s0 b0 m0 kf ks ->
      unGet f s0 b0 m0 kf $ \ s1 b1 m1 g     ->
      unGet x s1 b1 m1 kf $ \ s2 b2 m2 y     -> ks s2 b2 m2 (g y)


module T6975 where
data Foo = Foo
  { field1 :: Int -> Int
  , field2 :: Int -> Int
  , field3 :: Int -> Int
  , field4 :: Int -> Int
  , field5 :: Int -> Int
  , field6 :: Int -> Int
  , field7 :: Int -> Int
  , field8 :: Int -> Int
  , field9 :: Int -> Int
  , field10 :: Int -> Int
  , field11 :: Int -> Int
  , field12 :: Int -> Int
  , field13 :: Int -> Int
  , field14 :: Int -> Int
  , field15 :: Int -> Int
  , field16 :: Int -> Int
  , field17 :: Int -> Int
  , field18 :: Int -> Int
  , field19 :: Int -> Int
  , field20 :: Int -> Int
  , field21 :: Int -> Int
  , field22 :: Int -> Int
  , field23 :: Int -> Int
  , field24 :: Int -> Int
  , field25 :: Int -> Int
  , field26 :: Int -> Int
  , field27 :: Int -> Int
  , field28 :: Int -> Int
  , field29 :: Int -> Int
  , field30 :: Int -> Int
  , field31 :: Int -> Int
  , field32 :: Int -> Int
  , field33 :: Int -> Int
  , field34 :: Int -> Int
  , field35 :: Int -> Int
  , field36 :: Int -> Int
  , field37 :: Int -> Int
  , field38 :: Int -> Int
  , field39 :: Int -> Int
  , field40 :: Int -> Int
  , field41 :: Int -> Int
  , field42 :: Int -> Int
  , field43 :: Int -> Int
  , field44 :: Int -> Int
  , field45 :: Int -> Int
  , field46 :: Int -> Int
  , field47 :: Int -> Int
  , field48 :: Int -> Int
  , field49 :: Int -> Int
  , field50 :: Int -> Int
  , field51 :: Int -> Int
  , field52 :: Int -> Int
  , field53 :: Int -> Int
  , field54 :: Int -> Int
  , field55 :: Int -> Int
  , field56 :: Int -> Int
  , field57 :: Int -> Int
  , field58 :: Int -> Int
  , field59 :: Int -> Int
  , field60 :: Int -> Int
  , field61 :: Int -> Int
  , field62 :: Int -> Int
  , field63 :: Int -> Int
  , field64 :: Int -> Int
  , field65 :: Int -> Int
  , field66 :: Int -> Int
  , field67 :: Int -> Int
  , field68 :: Int -> Int
  , field69 :: Int -> Int
  , field70 :: Int -> Int
  , field71 :: Int -> Int
  , field72 :: Int -> Int
  , field73 :: Int -> Int
  , field74 :: Int -> Int
  , field75 :: Int -> Int
  , field76 :: Int -> Int
  , field77 :: Int -> Int
  , field78 :: Int -> Int
  , field79 :: Int -> Int
  , field80 :: Int -> Int
  , field81 :: Int -> Int
  , field82 :: Int -> Int
  , field83 :: Int -> Int
  , field84 :: Int -> Int
  , field85 :: Int -> Int
  , field86 :: Int -> Int
  , field87 :: Int -> Int
  , field88 :: Int -> Int
  , field89 :: Int -> Int
  , field90 :: Int -> Int
  , field91 :: Int -> Int
  , field92 :: Int -> Int
  , field93 :: Int -> Int
  , field94 :: Int -> Int
  , field95 :: Int -> Int
  , field96 :: Int -> Int
  , field97 :: Int -> Int
  , field98 :: Int -> Int
  , field99 :: Int -> Int
  , field100 :: Int -> Int
 }


{-
 - Instant Insanity using Type Families.
 -
 - See:  The Monad Read, Issue #8 - http://www.haskell.org/wikiupload/d/dd/TMR-Issue8.pdf
 -}

{-# OPTIONS_GHC -freduction-depth=400 #-}

{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}

import Prelude hiding (all, flip, map, filter )

data Proxy a = Proxy
main = print (Proxy :: Proxy (Solutions Cubes))

data R -- Red
data G -- Green
data B -- Blue
data W -- White

data Cube u f r b l d

data True
data False

type family And b1 b2 :: *
type instance And True True   = True
type instance And True False  = False
type instance And False False = False
type instance And False True  = False

type family NE x y :: *
type instance NE R R = False
type instance NE R G = True
type instance NE R B = True
type instance NE R W = True
type instance NE G R = True
type instance NE G G = False
type instance NE G B = True
type instance NE G W = True
type instance NE B R = True
type instance NE B G = True
type instance NE B B = False
type instance NE B W = True
type instance NE W R = True
type instance NE W G = True
type instance NE W B = True
type instance NE W W = False

type family EQ x y :: *

type instance EQ R R = True
type instance EQ R G = False
type instance EQ R B = False
type instance EQ R W = False
type instance EQ G R = False
type instance EQ G G = True
type instance EQ G B = False
type instance EQ G W = False
type instance EQ B R = False
type instance EQ B G = False
type instance EQ B B = True
type instance EQ B W = False
type instance EQ W R = False
type instance EQ W G = False
type instance EQ W B = False
type instance EQ W W = True

data Nil = Nil
data Cons x xs = Cons x xs

type family All l :: *
type instance All Nil = True
type instance All (Cons False xs) = False
type instance All (Cons True xs) = All xs

type family ListConcat xs ys :: *
type instance ListConcat Nil ys = ys
type instance ListConcat (Cons x xs) ys = Cons x (ListConcat xs ys)

type family AppendIf b a as :: *
type instance AppendIf False a as = as
type instance AppendIf True a as = Cons a as

data Rotate
data Twist
data Flip

type family Apply f a :: *
type instance Apply Rotate (Cube u f r b l d) = (Cube u r b l f d)
type instance Apply Twist  (Cube u f r b l d) = (Cube f r u l d b)
type instance Apply Flip   (Cube u f r b l d) = (Cube d l b r f u)

-- orientations c = [ z | x <- [ c, flip c ], y <- [ x, twist x, twist (twist x) ], z <- [y, rot y, rot(rot y), rot(rot(rot(y))) ] ]

type family Map f as :: *
type instance Map f Nil = Nil
type instance Map f (Cons a as) = Cons (Apply f a) (Map f as)

type family MapAppend f as :: *
type instance MapAppend f xs = ListConcat xs (Map f xs)

type family MapAppend2 f as :: *
type instance MapAppend2 f xs = ListConcat xs (MapAppend f (Map f xs))

type family MapAppend3 f as :: *
type instance MapAppend3 f xs = ListConcat xs (MapAppend2 f (Map f xs))

type family Iterate2 f as :: *
type instance Iterate2 f Nil = Nil
type instance Iterate2 f (Cons a as) = ListConcat (Cons (Apply f a) (Cons a Nil)) (Iterate2 f as)

type family Iterate3 f as :: *
type instance Iterate3 f (Cons a as) =
  ListConcat (Cons a
             (Cons (Apply f a)
             (Cons (Apply f (Apply f a))
              Nil)))
             (Iterate3 f as)

type family Iterate4 f as :: *
type instance Iterate4 f Nil = Nil
type instance Iterate4 f (Cons a as) =
   ListConcat (Cons a
              (Cons (Apply f a)
              (Cons (Apply f (Apply f a))
              (Cons (Apply f (Apply f (Apply f a)))
               Nil))))
              (Iterate4 f as)

type family Orientations c :: *
-- type instance Orientations c = Iterate4 Rotate (Iterate3 Twist (Iterate2 Flip (Cons c Nil)))
type instance Orientations c = MapAppend3 Rotate (MapAppend2 Twist (MapAppend Flip (Cons c Nil)))

type Cube1 = Cube B G W G B R
type Cube2 = Cube W G B W R R
type Cube3 = Cube G W R B R R
type Cube4 = Cube B R G G W W

type Cubes = Cons Cube1 (Cons Cube2 (Cons Cube3 (Cons Cube4 Nil)))

type family Compatible c d :: *
type instance Compatible (Cube u1 f1 r1 b1 l1 d1) (Cube u2 f2 r2 b2 l2 d2) =
  All (Cons (NE f1 f2) (Cons (NE r1 r2) (Cons (NE b1 b2) (Cons (NE l1 l2) Nil))))

type family Allowed c cs :: *
type instance Allowed c Nil = True
type instance Allowed c (Cons s ss) = And (Compatible c s) (Allowed c ss)

type family MatchingOrientations as sol :: *
type instance MatchingOrientations Nil sol = Nil
type instance MatchingOrientations (Cons o os) sol = AppendIf (Allowed o sol) (Cons o sol) (MatchingOrientations os sol)

type family AllowedCombinations os sols :: *
type instance AllowedCombinations os Nil = Nil
type instance AllowedCombinations os (Cons sol sols) = ListConcat (MatchingOrientations os sol) (AllowedCombinations os sols)

type family Solutions c :: *
type instance Solutions Nil = Cons Nil Nil
type instance Solutions (Cons c cs) = AllowedCombinations (Orientations c) (Solutions cs)

{-
 - solutions [] = [ [] ]
 - solutions (c:cs) = [ (o:sol) | sol <- solutions cs, o <- orientations c, allowed o
-}


{-
 - Instant Insanity using Closed Type Families and DataKinds.
 -
 - See:  http://stackoverflow.com/questions/26538595
 -}

{-# OPTIONS_GHC -freduction-depth=400 #-}

{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE DataKinds, KindSignatures, PolyKinds #-}
{-# LANGUAGE TypeOperators #-}

import Prelude hiding (all, flip, map, filter )

data Proxy (a :: k) = Proxy

main = print (Proxy :: Proxy (Solutions Cubes))

data Color = R | G | B | W

data Cube = Cube Color Color Color Color Color Color

type family And (b1 :: Bool) (b2 :: Bool) :: Bool where
    And True True = True
    And b1 b2 = False

type family NE (x :: Color) (y :: Color) :: Bool where
    NE x x = False
    NE x y = True

type family EQ (x :: Color) (y :: Color) :: Bool where
    EQ a a = True
    EQ a b = False

type family All (l :: [Bool]) :: Bool where
    All '[] = True
    All (False ': xs) = False
    All (True ': xs) = All xs

type family ListConcat (xs :: [k]) (ys :: [k]) :: [k] where
    ListConcat '[] ys = ys
    ListConcat (x ': xs) ys = x ': ListConcat xs ys

type family AppendIf (b :: Bool) (a :: [Cube]) (as :: [[Cube]]) :: [[Cube]] where
    AppendIf False a as = as
    AppendIf True a as = a ': as

data Transform = Rotate | Twist | Flip

type family Apply (f :: Transform) (a :: Cube) :: Cube where
    Apply Rotate ('Cube u f r b l d) = ('Cube u r b l f d)
    Apply Twist  ('Cube u f r b l d) = ('Cube f r u l d b)
    Apply Flip   ('Cube u f r b l d) = ('Cube d l b r f u)

type family Map (f :: Transform) (as :: [Cube]) :: [Cube] where
    Map f '[] = '[]
    Map f (a ': as) = (Apply f a) ': (Map f as)

type family MapAppend (f :: Transform) (as :: [Cube]) :: [Cube] where
    MapAppend f xs = ListConcat xs (Map f xs)

type family MapAppend2 (f :: Transform) (as :: [Cube]) :: [Cube] where
    MapAppend2 f xs = ListConcat xs (MapAppend f (Map f xs))

type family MapAppend3 (f :: Transform) (as :: [Cube]) :: [Cube] where
    MapAppend3 f xs = ListConcat xs (MapAppend2 f (Map f xs))

type family Iterate2 (f :: Transform) (as :: [Cube]) :: [Cube] where
    Iterate2 f '[] = '[]
    Iterate2 f (a ': as) = ListConcat [Apply f a, a] (Iterate2 f as)

type family Iterate3 (f :: Transform) (as :: [Cube]) :: [Cube] where
    Iterate3 f '[] = '[]
    Iterate3 f (a ': as) =
        ListConcat [a, Apply f a, Apply f (Apply f a)] (Iterate3 f as)

type family Iterate4 (f :: Transform) (as :: [Cube]) :: [Cube] where
    Iterate4 f '[] = '[]
    Iterate4 f (a ': as) =
        ListConcat [a, Apply f a, Apply f (Apply f a), Apply f (Apply f (Apply f a))]
                   (Iterate4 f as)

type family Orientations (c :: Cube) :: [Cube] where
    Orientations c = MapAppend3 Rotate (MapAppend2 Twist (MapAppend Flip '[c]))

type Cube1 = 'Cube B G W G B R
type Cube2 = 'Cube W G B W R R
type Cube3 = 'Cube G W R B R R
type Cube4 = 'Cube B R G G W W

type Cubes = [Cube1, Cube2, Cube3, Cube4]

type family Compatible (c :: Cube) (d :: Cube) :: Bool where
    Compatible ('Cube u1 f1 r1 b1 l1 d1) ('Cube u2 f2 r2 b2 l2 d2) =
        All [NE f1 f2, NE r1 r2, NE b1 b2, NE l1 l2]

type family Allowed (c :: Cube) (cs :: [Cube]) :: Bool where
    Allowed c '[] = True
    Allowed c (s ': ss) = And (Compatible c s) (Allowed c ss)

type family MatchingOrientations (as :: [Cube]) (sol :: [Cube]) :: [[Cube]] where
    MatchingOrientations '[] sol = '[]
    MatchingOrientations (o ': os) sol =
        AppendIf (Allowed o sol) (o ': sol) (MatchingOrientations os sol)

type family AllowedCombinations (os :: [Cube]) (sols :: [[Cube]]) where
    AllowedCombinations os '[] = '[]
    AllowedCombinations os (sol ': sols) =
        ListConcat (MatchingOrientations os sol) (AllowedCombinations os sols)

type family Solutions (cs :: [Cube]) :: [[Cube]] where
    Solutions '[] = '[ '[] ]
    Solutions (c ': cs) = AllowedCombinations (Orientations c) (Solutions cs)


{-
 - Instant Insanity using Closed Type Families, but no DataKinds
 -
 - See:  http://stackoverflow.com/questions/26538595
 -}

{-# OPTIONS_GHC -freduction-depth=400 #-}

{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}

import Prelude hiding (all, flip, map, filter )

data Proxy a = Proxy

main = print (Proxy :: Proxy (Solutions Cubes))

data R -- Red
data G -- Green
data B -- Blue
data W -- White

data Cube u f r b l d

data True
data False

type family And b1 b2 :: * where
    And True True = True
    And b1 b2 = False

type family NE x y :: * where
    NE x x = False
    NE x y = True

type family EQ x y :: * where
    EQ a a = True
    EQ a b = False

data Nil = Nil
data Cons x xs = Cons x xs

type family All l :: * where
    All Nil = True
    All (Cons False xs) = False
    All (Cons True xs) = All xs

type family ListConcat xs ys :: * where
    ListConcat Nil ys = ys
    ListConcat (Cons x xs) ys = Cons x (ListConcat xs ys)

type family AppendIf b a as :: * where
    AppendIf False a as = as
    AppendIf True a as = Cons a as

data Rotate
data Twist
data Flip

type family Apply f a :: * where
    Apply Rotate (Cube u f r b l d) = (Cube u r b l f d)
    Apply Twist  (Cube u f r b l d) = (Cube f r u l d b)
    Apply Flip   (Cube u f r b l d) = (Cube d l b r f u)

type family Map f as :: * where
    Map f Nil = Nil
    Map f (Cons a as) = Cons (Apply f a) (Map f as)

type family MapAppend f as :: * where
    MapAppend f xs = ListConcat xs (Map f xs)

type family MapAppend2 f as :: * where
    MapAppend2 f xs = ListConcat xs (MapAppend f (Map f xs))

type family MapAppend3 f as :: * where
    MapAppend3 f xs = ListConcat xs (MapAppend2 f (Map f xs))

type family Iterate2 f as :: * where
    Iterate2 f Nil = Nil
    Iterate2 f (Cons a as) = ListConcat (Cons (Apply f a) (Cons a Nil)) (Iterate2 f as)

type family Iterate3 f as :: * where
    Iterate3 f (Cons a as) =
        ListConcat (Cons a
                    (Cons (Apply f a)
                     (Cons (Apply f (Apply f a))
                      Nil)))
                   (Iterate3 f as)

type family Iterate4 f as :: * where
    Iterate4 f Nil = Nil
    Iterate4 f (Cons a as) =
        ListConcat (Cons a
                    (Cons (Apply f a)
                     (Cons (Apply f (Apply f a))
                      (Cons (Apply f (Apply f (Apply f a)))
                       Nil))))
                   (Iterate4 f as)

type family Orientations c :: * where
    Orientations c = MapAppend3 Rotate (MapAppend2 Twist (MapAppend Flip (Cons c Nil)))

type Cube1 = Cube B G W G B R
type Cube2 = Cube W G B W R R
type Cube3 = Cube G W R B R R
type Cube4 = Cube B R G G W W

type Cubes = Cons Cube1 (Cons Cube2 (Cons Cube3 (Cons Cube4 Nil)))

type family Compatible c d :: * where
    Compatible (Cube u1 f1 r1 b1 l1 d1) (Cube u2 f2 r2 b2 l2 d2) =
        All (Cons (NE f1 f2) (Cons (NE r1 r2) (Cons (NE b1 b2) (Cons (NE l1 l2) Nil))))

type family Allowed c cs :: * where
    Allowed c Nil = True
    Allowed c (Cons s ss) = And (Compatible c s) (Allowed c ss)

type family MatchingOrientations as sol :: * where
    MatchingOrientations Nil sol = Nil
    MatchingOrientations (Cons o os) sol =
        AppendIf (Allowed o sol) (Cons o sol) (MatchingOrientations os sol)

type family AllowedCombinations os sols :: * where
    AllowedCombinations os Nil = Nil
    AllowedCombinations os (Cons sol sols) =
        ListConcat (MatchingOrientations os sol) (AllowedCombinations os sols)

type family Solutions c :: * where
    Solutions Nil = Cons Nil Nil
    Solutions (Cons c cs) = AllowedCombinations (Orientations c) (Solutions cs)


{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -freduction-depth=0 #-}   -- this should terminate!

module T9872d where
-- Code from Jan Stolarek, labelled "exp-tyfams.hs" on Trac #9872,
-- generated by a Template Haskell program

-- This file demonstrates exponential compile times with type
-- families. Code in this file was extracted from encoding generated
-- automatically with Template Haskell by singletons library.

import Data.Kind
import GHC.TypeLits

-- encoding of type-level partially applied functions
data TyFun :: Type -> Type -> Type
type family Apply (f :: TyFun k1 k2 -> Type) (x :: k1) :: k2
type a @@ b = Apply a b

-- some boilerplate
type family Error (a :: k) :: k1
type ErrorSym1 a = Error a
data ErrorSym0 :: TyFun a b -> Type
type instance Apply ErrorSym0 e = Error e
data Proxy a = Proxy
data KProxy (a :: Type) = KProxy
type KindOf (a :: k) = ('KProxy :: KProxy k)

-- type-level addition
type (:+$$$) (t1 :: Nat) (t2 :: Nat) = t1 + t2

data (:+$$) (l :: Nat) (tf :: TyFun Nat Nat)
  = forall a. (KindOf (Apply ((:+$$) l) a)) ~ (KindOf ((:+$$$) l a)) =>
    (:+$$###)
type instance Apply ((:+$$) l1) l2 = (:+$$$) l1 l2

data (:+$) (l :: TyFun Nat (TyFun Nat Nat -> Type))
  = forall a. (KindOf (Apply (:+$) a)) ~ (KindOf ((:+$$) a)) => (:+$###)
type instance Apply (:+$) l = (:+$$) l

-- type-level lists
type NilSym0 = '[]

type ConsSym2 (x :: a) (xs :: [a]) = x ': xs

data ConsSym1 (x :: a) (l_a3t6 :: TyFun [a] [a])
  = forall b. (KindOf (Apply (ConsSym1 x) b)) ~ (KindOf (ConsSym2 x b)) =>
    (:$$###)
type instance Apply (ConsSym1 x) xs = ConsSym2 x xs

data ConsSym0 (l :: TyFun a (TyFun [a] [a] -> Type))
  = forall a. (KindOf (Apply ConsSym0 a)) ~ (KindOf (ConsSym1 a)) => (:$###)
type instance Apply ConsSym0 l = ConsSym1 l

type Let_1627403919Scrutinee_1627403894Sym4 t1 t2 t3 t4 =
    Let_1627403919Scrutinee_1627403894 t1 t2 t3 t4

data Let_1627403919Scrutinee_1627403894Sym3 l_a3Dx
                                            l_a3Dy
                                            l_a3Dz
                                            l_a3Dw
  = forall arg_a3DA. (KindOf (Apply (Let_1627403919Scrutinee_1627403894Sym3
                                     l_a3Dx l_a3Dy l_a3Dz) arg_a3DA)) ~
                     (KindOf (Let_1627403919Scrutinee_1627403894Sym4
                              l_a3Dx l_a3Dy l_a3Dz arg_a3DA)) =>
    Let_1627403919Scrutinee_1627403894Sym3KindInference
type instance Apply (Let_1627403919Scrutinee_1627403894Sym3
                     l_a3Dx l_a3Dy l_a3Dz) l_a3Dw =
  Let_1627403919Scrutinee_1627403894Sym4 l_a3Dx l_a3Dy l_a3Dz l_a3Dw

data Let_1627403919Scrutinee_1627403894Sym2 l_a3Dt l_a3Du l_a3Ds
  = forall arg_a3Dv. (KindOf (Apply (Let_1627403919Scrutinee_1627403894Sym2
                                     l_a3Dt l_a3Du) arg_a3Dv)) ~
                     (KindOf (Let_1627403919Scrutinee_1627403894Sym3
                              l_a3Dt l_a3Du arg_a3Dv)) =>
    Let_1627403919Scrutinee_1627403894Sym2KindInference
type instance Apply
    (Let_1627403919Scrutinee_1627403894Sym2 l_a3Dt l_a3Du) l_a3Ds =
  Let_1627403919Scrutinee_1627403894Sym3 l_a3Dt l_a3Du l_a3Ds
data Let_1627403919Scrutinee_1627403894Sym1 l_a3Dq l_a3Dp
  = forall arg_a3Dr. (KindOf (Apply (Let_1627403919Scrutinee_1627403894Sym1
                                     l_a3Dq) arg_a3Dr)) ~
                     (KindOf (Let_1627403919Scrutinee_1627403894Sym2
                              l_a3Dq arg_a3Dr)) =>
    Let_1627403919Scrutinee_1627403894Sym1KindInference
type instance Apply (Let_1627403919Scrutinee_1627403894Sym1 l_a3Dq)
                    l_a3Dp
  = Let_1627403919Scrutinee_1627403894Sym2 l_a3Dq l_a3Dp
data Let_1627403919Scrutinee_1627403894Sym0 l_a3Dn
  = forall arg_a3Do. (KindOf (Apply Let_1627403919Scrutinee_1627403894Sym0
                              arg_a3Do)) ~
                     (KindOf (Let_1627403919Scrutinee_1627403894Sym1
                              arg_a3Do)) =>
    Let_1627403919Scrutinee_1627403894Sym0KindInference
type instance Apply Let_1627403919Scrutinee_1627403894Sym0 l_a3Dn
  = Let_1627403919Scrutinee_1627403894Sym1 l_a3Dn
type Let_1627403919Scrutinee_1627403894 f_a3Dd
                                        q0_a3De
                                        x_a3Df
                                        xs_a3Dg =
    Apply (Apply (Apply ScanrSym0 f_a3Dd) q0_a3De) xs_a3Dg

type family Case f q0 x xs t :: [k] where
  Case f q0 x xs '[]       = ErrorSym0 @@ "empty list"
  Case f q0 x xs (q ': qs) = ConsSym0 @@ (f @@ x @@ q) @@ (ConsSym0 @@ q @@ qs)

-- type-level scanr
type ScanrSym3 (t1 :: TyFun a (TyFun b b -> Type) -> Type)
               (t2 :: b)
               (t3 :: [a]) =
    Scanr t1 t2 t3

data ScanrSym2 (l1 :: TyFun a (TyFun b b -> Type) -> Type)
               (l2 :: b)
               (l3 :: TyFun [a] [b])
  = forall a. (KindOf (Apply (ScanrSym2 l1 l2) a)) ~
              (KindOf (ScanrSym3 l1 l2 a)) =>
    ScanrSym2KindInference
type instance Apply (ScanrSym2 l1 l2) l3 = ScanrSym3 l1 l2 l3

data ScanrSym1 (l_a3D0 :: TyFun a_a3CJ (TyFun b_a3CK b_a3CK -> Type) -> Type)
               (l_a3CZ :: TyFun b_a3CK (TyFun ([a_a3CJ]) ([b_a3CK])
                                        -> Type))
  = forall arg_a3D1. (KindOf (Apply (ScanrSym1 l_a3D0) arg_a3D1)) ~
                     (KindOf (ScanrSym2 l_a3D0 arg_a3D1)) =>
    ScanrSym1KindInference
type instance Apply (ScanrSym1 l_a3D0) l_a3CZ = ScanrSym2 l_a3D0 l_a3CZ

data ScanrSym0 (l :: TyFun (TyFun a (TyFun  b   b  -> Type) -> Type)
                           (TyFun b (TyFun [a] [b] -> Type) -> Type))
  = forall a. (KindOf (Apply ScanrSym0 a)) ~ (KindOf (ScanrSym1 a)) =>
    ScanrSym0KindInference
type instance Apply ScanrSym0 l1 = ScanrSym1 l1

type family Scanr (a_a3D6 :: TyFun a_a3CJ (TyFun b_a3CK b_a3CK -> Type) -> Type)
                  (a_a3D7 :: b_a3CK)
                  (a_a3D8 :: [a_a3CJ]) :: [b_a3CK] where
  Scanr _z_1627403911_a3Db q0_a3Dc '[] = Apply (Apply ConsSym0 q0_a3Dc) NilSym0
  Scanr f_a3Dd q0_a3De (x_a3Df ': xs_a3Dg) =
    Case f_a3Dd q0_a3De x_a3Df xs_a3Dg (Let_1627403919Scrutinee_1627403894Sym4
                                        f_a3Dd q0_a3De x_a3Df xs_a3Dg)

{-
foo32 :: Proxy ('[528,527,525,522,518,513,507,500,492,483,473,462,450,437,423,
                  408,392,375,357,338,318,297,275,252,228,203,177,150,122,93,
                  63,32,0])
foo32 = Proxy

bar32 :: Proxy (ScanrSym0 @@ (:+$) @@ 0 @@ '[1,2,3,4,5,6,7,8,9,10,11,12,13,14,
                                             15,16,17,18,19,20,21,22,23,24,25,
                                             26,27,28,29,30,31,32])
bar32 = foo32

-}
{-
foo64 :: Proxy ('[2080,2079,2077,2074,2070,2065,2059,2052,2044,2035,2025,2014,
                  2002,1989,1975,1960,1944,1927,1909,1890,1870,1849,1827,1804,
                  1780,1755,1729,1702,1674,1645,1615,1584,1552,1519,1485,1450,
                  1414,1377,1339,1300,1260,1219,1177,1134,1090,1045,999,952,904,
                  855,805,754,702,649,595,540,484,427,369,310,250,189,127,64,0])
foo64 = Proxy

bar64 :: Proxy (ScanrSym0 @@ (:+$) @@ 0 @@ '[1,2,3,4,5,6,7,8,9,10,11,12,13,14,
                                             15,16,17,18,19,20,21,22,23,24,25,
                                             26,27,28,29,30,31,32,33,34,35,36,
                                             37,38,39,40,41,42,43,44,45,46,47,
                                             48,49,50,51,52,53,54,55,56,57,58,
                                             59,60,61,62,63,64])
bar64 = foo64

foo128 :: Proxy ('[8256,8255,8253,8250,8246,8241,8235,8228,8220,8211,8201,8190,
                   8178,8165,8151,8136,8120,8103,8085,8066,8046,8025,8003,7980,
                   7956,7931,7905,7878,7850,7821,7791,7760,7728,7695,7661,7626,
                   7590,7553,7515,7476,7436,7395,7353,7310,7266,7221,7175,7128,
                   7080,7031,6981,6930,6878,6825,6771,6716,6660,6603,6545,6486,
                   6426,6365,6303,6240,6176,6111,6045,5978,5910,5841,5771,5700,
                   5628,5555,5481,5406,5330,5253,5175,5096,5016,4935,4853,4770,
                   4686,4601,4515,4428,4340,4251,4161,4070,3978,3885,3791,3696,
                   3600,3503,3405,3306,3206,3105,3003,2900,2796,2691,2585,2478,
                   2370,2261,2151,2040,1928,1815,1701,1586,1470,1353,1235,1116,
                   996,875,753,630,506,381,255,128,0])
foo128 = Proxy

bar128 :: Proxy (ScanrSym0 @@ (:+$) @@ 0 @@ '[1,2,3,4,5,6,7,8,9,10,11,12,13,14,
                                              15,16,17,18,19,20,21,22,23,24,25,
                                              26,27,28,29,30,31,32,33,34,35,36,
                                              37,38,39,40,41,42,43,44,45,46,47,
                                              48,49,50,51,52,53,54,55,56,57,58,
                                              59,60,61,62,63,64,65,66,67,68,69,
                                              70,71,72,73,74,75,76,77,78,79,80,
                                              81,82,83,84,85,86,87,88,89,90,91,
                                              92,93,94,95,96,97,98,99,100,101,
                                              102,103,104,105,106,107,108,109,
                                              110,111,112,113,114,115,116,117,
                                              118,119,120,121,122,123,124,125,
                                              126,127,128])
bar128 = foo128
-}

foo256 :: Proxy ('[32896,32895,32893,32890,32886,32881,32875,32868,32860,32851,
                   32841,32830,32818,32805,32791,32776,32760,32743,32725,32706,
                   32686,32665,32643,32620,32596,32571,32545,32518,32490,32461,
                   32431,32400,32368,32335,32301,32266,32230,32193,32155,32116,
                   32076,32035,31993,31950,31906,31861,31815,31768,31720,31671,
                   31621,31570,31518,31465,31411,31356,31300,31243,31185,31126,
                   31066,31005,30943,30880,30816,30751,30685,30618,30550,30481,
                   30411,30340,30268,30195,30121,30046,29970,29893,29815,29736,
                   29656,29575,29493,29410,29326,29241,29155,29068,28980,28891,
                   28801,28710,28618,28525,28431,28336,28240,28143,28045,27946,
                   27846,27745,27643,27540,27436,27331,27225,27118,27010,26901,
                   26791,26680,26568,26455,26341,26226,26110,25993,25875,25756,
                   25636,25515,25393,25270,25146,25021,24895,24768,24640,24511,
                   24381,24250,24118,23985,23851,23716,23580,23443,23305,23166,
                   23026,22885,22743,22600,22456,22311,22165,22018,21870,21721,
                   21571,21420,21268,21115,20961,20806,20650,20493,20335,20176,
                   20016,19855,19693,19530,19366,19201,19035,18868,18700,18531,
                   18361,18190,18018,17845,17671,17496,17320,17143,16965,16786,
                   16606,16425,16243,16060,15876,15691,15505,15318,15130,14941,
                   14751,14560,14368,14175,13981,13786,13590,13393,13195,12996,
                   12796,12595,12393,12190,11986,11781,11575,11368,11160,10951,
                   10741,10530,10318,10105,9891,9676,9460,9243,9025,8806,
                   8586,8365,8143,7920,7696,7471,7245,7018,6790,6561,6331,6100,
                   5868,5635,5401,5166,4930,4693,4455,4216,3976,3735,3493,3250,
                   3006,2761,2515,2268,2020,1771,1521,1270,1018,765,511,256,0])
foo256 = Proxy

bar256 :: Proxy (ScanrSym0 @@ (:+$) @@ 0 @@ '[1,2,3,4,5,6,7,8,9,10,11,12,13,14,
                                              15,16,17,18,19,20,21,22,23,24,25,
                                              26,27,28,29,30,31,32,33,34,35,36,
                                              37,38,39,40,41,42,43,44,45,46,47,
                                              48,49,50,51,52,53,54,55,56,57,58,
                                              59,60,61,62,63,64,65,66,67,68,69,
                                              70,71,72,73,74,75,76,77,78,79,80,
                                              81,82,83,84,85,86,87,88,89,90,91,
                                              92,93,94,95,96,97,98,99,100,101,
                                              102,103,104,105,106,107,108,109,
                                              110,111,112,113,114,115,116,117,
                                              118,119,120,121,122,123,124,125,
                                              126,127,128,129,130,131,132,133,
                                              134,135,136,137,138,139,140,141,
                                              142,143,144,145,146,147,148,149,
                                              150,151,152,153,154,155,156,157,
                                              158,159,160,161,162,163,164,165,
                                              166,167,168,169,170,171,172,173,
                                              174,175,176,177,178,179,180,181,
                                              182,183,184,185,186,187,188,189,
                                              190,191,192,193,194,195,196,197,
                                              198,199,200,201,202,203,204,205,
                                              206,207,208,209,210,211,212,213,
                                              214,215,216,217,218,219,220,221,
                                              222,223,224,225,226,227,228,229,
                                              230,231,232,233,234,235,236,237,
                                              238,239,240,241,242,243,244,245,
                                              246,247,248,249,250,251,252,253,
                                              254,255,256])
bar256 = foo256


{-# LANGUAGE BangPatterns #-}

module Main where

findDivBy :: Int -> [Int] -> Maybe Int
findDivBy p ns
    -- go should be a join point and should get worker/wrappered; the worker
    -- must also be a join point (since it's mutually recursive with one).
  = let go !p ns = case ns of n:ns' -> case n `mod` p of 0 -> Just n
                                                         _ -> go p ns'
                              []    -> Nothing
    in case p of
         0 -> error "div by zero"
         _ -> go p ns

main = print $ findDivBy 7 [1..10]


module Main where

import Data.List

-- These four functions should all wind up the same; they represent successive
-- simplifications that should happen. (Actual details may vary, since find
-- isn't quite defined this way, but the differences disappear by the end.)

firstEvenIsPositive1 :: [Int] -> Bool
firstEvenIsPositive1 = maybe False (> 0) . find even

-- After inlining:

firstEvenIsPositive2 :: [Int] -> Bool
firstEvenIsPositive2 xs =
  let go xs = case xs of x:xs' -> if even x then Just x else go xs'
                         []    -> Nothing
  in case go xs of Just n  -> n > 0
                   Nothing -> False

-- Note that go *could* be a join point if it were declared inside the scrutinee
-- instead of outside. So it's now Float In's job to move the binding inward a
-- smidge. *But* if it goes too far inward (as it would until recently), it will
-- wrap only "go" instead of "go xs", which won't let us mark go as a join point
-- since join points can't be partially invoked.
--
-- After Float In:

firstEvenIsPositive3 :: [Int] -> Bool
firstEvenIsPositive3 xs =
  case let {-join-} go xs = case xs of x:xs' -> if even x then Just x
                                                          else go xs'
                                       []    -> Nothing
       in go xs of
    Just n  -> n > 0
    Nothing -> False

-- After the simplifier:

firstEvenIsPositive4 :: [Int] -> Bool
firstEvenIsPositive4 xs =
  let {-join-} go xs = case xs of x:xs' -> if even x then x > 0 else go xs'
                                  []    -> False
  in go xs

-- This only worked because go was a join point so that the case gets moved
-- inside.

{-# NOINLINE firstEvenIsPositive1 #-}

main = print $ or $ [firstEvenIsPositive1 [1,3..n] | n <- [1..10000]]


{-
 - A variation on join002.hs that avoids Float Out issues. The join points in
 - join002.hs may get floated to top level, which is necessary to allow in
 - general, but which makes them into functions rather than join points, thus
 - messing up the test.
 -}

module Main (
  firstMultIsPositive1, firstMultIsPositive2, firstMultIsPositive3,
  firstMultIsPositive4,

  main
) where

import Data.List

divides :: Int -> Int -> Bool
p `divides` n = n `mod` p == 0

infix 4 `divides`

-- These four functions should all wind up the same; they represent successive
-- simplifications that should happen. (Actual details may vary, since find
-- isn't quite defined this way, but the differences disappear by the end.)

firstMultIsPositive1 :: Int -> [Int] -> Bool
firstMultIsPositive1 p = maybe False (> 0) . find (p `divides`)

-- After inlining:

firstMultIsPositive2 :: Int -> [Int] -> Bool
firstMultIsPositive2 p xs =
  let go xs = case xs of x:xs' -> if p `divides` x then Just x else go xs'
                         []    -> Nothing
  in case go xs of Just n  -> n > 0
                   Nothing -> False

-- Note that go *could* be a join point if it were declared inside the scrutinee
-- instead of outside. So it's now Float In's job to move the binding inward a
-- smidge. *But* if it goes too far inward (as it would until recently), it will
-- wrap only "go" instead of "go xs", which won't let us mark go as a join point
-- since join points can't be partially invoked.
--
-- After Float In:

firstMultIsPositive3 :: Int -> [Int] -> Bool
firstMultIsPositive3 p xs =
  case let {-join-} go xs = case xs of x:xs' -> if p `divides` x then Just x
                                                                 else go xs'
                                       []    -> Nothing
       in go xs of
    Just n  -> n > 0
    Nothing -> False

-- After the simplifier:

firstMultIsPositive4 :: Int -> [Int] -> Bool
firstMultIsPositive4 p xs =
  let {-join-} go xs = case xs of x:xs' -> if p `divides` x then x > 0
                                                            else go xs'
                                  []    -> False
  in go xs

-- This only worked because go was a join point so that the case gets moved
-- inside.

{-# NOINLINE firstMultIsPositive1 #-}

main = print $ or $ [firstMultIsPositive1 2 [1,3..n] | n <- [1..10000]]


{-
 - A rather contrived example demonstrating the virtues of not floating join
 - points outward.
 -}

module Main (main) where

-- Calculate n `div` d `div` d by looping.

{-# NOINLINE slowDivDiv #-}
slowDivDiv :: Int -> Int -> Int
slowDivDiv n d
  = let {-# NOINLINE divPos #-}
        divPos :: Int -> Int
        divPos n0
          = -- This function is a join point (all calls are tail calls), so it
            -- never causes a closure allocation, so it doesn't help to float it
            -- out. Thus -fno-join-points causes a ~25% jump in allocations.
            let go n' i
                  = case n' >= d of True  -> go (n' - d) (i + 1)
                                    False -> i
            in go n0 0
    in case n >= 0 of True  -> divPos (divPos n)
                      False -> divPos (-(divPos (-n)))
                                 -- It's important that divPos be called twice
                                 -- because otherwise it'd be a one-shot lambda
                                 -- and so the join point would be floated
                                 -- back in again.

main = print $ sum [slowDivDiv n d | n <- [1..1000], d <- [1..1000]]


{- Test of Worker/Wrapper operating on join points -}

module Main where

sumOfMultiplesOf :: Int -> [Int] -> Int
sumOfMultiplesOf p ns
  = {- This is a join point (and it will stay that way---it won't get floated to
       top level because p occurs free). It should get worker/wrappered. -}
    let go ns acc
          = case ns of []    -> acc
                       n:ns' -> case n `mod` p of 0 -> go ns' (acc + n)
                                                  _ -> go ns'  acc
    in go ns 0

{-
It's hard to test for this, but what should happen is that go gets W/W'd and the
worker is a join point (else Core Lint will complain). Interestingly, go is
*not* CPR'd, because then the worker couldn't be a join point, but once the
simplifier runs, the worker ends up returning Int# anyway. See Note [Don't CPR
join points] in WorkWrap.hs.
-}

main = print $ sumOfMultiplesOf 2 [1..10]


module Main where

{-# NOINLINE foo #-}
foo :: Int -> Int
foo x = x

{-# RULES "foo/5" forall (f :: Int -> Int). foo (f 5) = foo (f 42) #-}
-- highly suspect, of course!

main = print $ foo (let {-# NOINLINE j #-}
                        j :: Int -> Int
                        j n = n + 1 in j 5)

{-
If we're not careful, this will get rewritten to

  main = print $ let <join> j n = n + 1 in foo (j 42)

which violates the join point invariant (can't invoke a join point from
non-tail context). Solution is to refuse to float join points when matching
RULES.
-}


-- Test of fusion in unfold/destroy style. Originally, unfold/destroy supported
-- filter, but the constructors (here Done and Yield) couldn't be compiled away.
-- Join points let us do this by pulling the case from sumS into the loop in
-- filterS.

{-# LANGUAGE GADTs #-}

module Main (main) where

data Stream a where Stream :: (s -> Step a s) -> s -> Stream a
data Step a s = Done | Yield a s

{-# INLINE sumS #-}
sumS :: Stream Int -> Int
sumS (Stream next s0) = go s0 0
  where
    go s acc = case next s of Done       -> acc
                              Yield a s' -> go s' (acc + a)

{-# INLINE filterS #-}
filterS :: (a -> Bool) -> Stream a -> Stream a
filterS p (Stream next s0) = Stream fnext s0
  where
    fnext s = seek s
      where
        -- should be a join point!
        seek s = case next s of Done                   -> Done
                                Yield a s' | p a       -> Yield a s'
                                           | otherwise -> seek s'

{-# INLINE enumFromToS #-}
enumFromToS :: Int -> Int -> Stream Int
enumFromToS lo hi = Stream next lo
  where
    next n | n > hi    = Done
           | otherwise = Yield n (n+1)

{-# NOINLINE test #-} -- for -ddump-simpl
test :: Int -> Int -> Int
test lo hi = sumS (filterS even (enumFromToS lo hi))

-- Note that this overflows on 32-bit machines and therefore we have two stdout
-- files
main = print $ test 1 10000000


{-# LANGUAGE BangPatterns #-}

-- | Tests that conversions between various primitive types (e.g.
-- Word, Double, etc) doesn't allocate.
module Main (main) where

import Data.Word

-- Repeatedly convert Words to Doubles
loop :: Floating a => Word -> a
loop n = go 0 0.0
  where
    go i !acc | i < n = go (i+1) (acc + fromIntegral i)
              | otherwise = acc
{-# SPECIALISE loop :: Word -> Float #-}
{-# SPECIALISE loop :: Word -> Double #-}

main :: IO ()
main = do
    print (loop 1000000 :: Float)
    print (loop 1000000 :: Double)


{-# LANGUAGE DeriveFoldable #-}

module Main where
import Data.Semigroup

-- Just a list without any special fusion rules.
data List a = Nil | Cons a (List a) deriving Foldable

instance Semigroup (List a) where
  Nil <> ys = ys
  Cons x xs <> ys = Cons x (xs <> ys)

replicateList :: Int -> a -> List a
replicateList 0 x = Nil
replicateList n x = Cons x (replicateList (n - 1) x)

newtype ListList a = ListList (List (List a)) deriving Foldable

long :: Int -> Bool
long n = null $ ListList $ replicateList n Nil <> Cons (Cons () Nil) Nil

main :: IO ()
main = print $ long (10^(6 :: Int))


{-# LANGUAGE DeriveFoldable #-}

module Main where

-- Trying to check if this is null from left to right or right to left
-- will produce an infinite loop.
data Ouch a = Ouch (Ouch a) a (Ouch a) deriving Foldable

ouch :: a -> Ouch a
ouch a = v where v = Ouch v a v

newtype Tuplouch a = Tuplouch (Ouch (a, Int)) deriving Foldable

main :: IO ()
main = do
  print $ null (ouch ())
  print $ null (Tuplouch (ouch ((), 3)))


{-# LANGUAGE BangPatterns, MagicHash, UnboxedTuples #-}
module Main where

import GHC.Exts
import GHC.IO

main :: IO ()
main = loop 10000000
  where
    loop :: Int -> IO ()
    loop 0 = return ()
    loop i = newArray >> loop (i-1)

newArray :: IO ()
newArray = IO $ \s -> case newArray# 16# () s of
    (# s', _ #) -> (# s', () #)


{-# LANGUAGE MagicHash, UnboxedTuples #-}
module Main where

import GHC.Exts
import GHC.IO

main :: IO ()
main = loop 10000000
  where
    loop :: Int -> IO ()
    loop 0 = return ()
    loop i = newByteArray >> loop (i-1)

newByteArray :: IO ()
newByteArray = IO $ \s -> case newByteArray# 128# s of
    (# s', _ #) -> (# s', () #)


{-# LANGUAGE MagicHash, UnboxedTuples #-}
module Main where

import GHC.Exts
import GHC.IO

main :: IO ()
main = do
    marr <- newArray
    loop 10000000 (unMArray marr)
  where
    loop :: Int -> MutableArray# RealWorld () -> IO ()
    loop 0 _    = return ()
    loop i marr = freezeArray marr >> loop (i-1) marr

data MArray = MArray { unMArray :: !(MutableArray# RealWorld ()) }

newArray :: IO MArray
newArray = IO $ \s -> case newArray# 16# () s of
    (# s', marr# #) -> (# s', MArray marr# #)

freezeArray :: MutableArray# RealWorld () -> IO ()
freezeArray marr# = IO $ \s -> case freezeArray# marr# 0# 16# s of
    (# s', _ #) -> (# s', () #)


module Main (main) where

import System.Environment (getArgs)
import qualified Data.ByteString.Lazy as L

main :: IO ()
main = do
    (file : _) <- getArgs
    L.readFile file >>= L.putStr


module Main where

-- This test works efficiently because the full laziness
-- pass now floats out applications
--      \x -> f y (x+1)
-- It'll float out the (f y) if that's a redex

loop :: Double -> [Int] -> Double
{-# NOINLINE loop #-}
loop x [] = x
loop x (n:ns) = x `seq` loop (x ^ n) ns

main = print $ loop 1 (replicate 10000000 5)

----------------------------------------------------
{-  Roman's message of May 2010

I tried running nofib with -fno-method-sharing (we discussed this at some point). These are the results:

--------------------------------------------------------------------------------
        Program           Size    Allocs   Runtime   Elapsed
--------------------------------------------------------------------------------

            Min          -0.3%    -25.0%    -12.5%     -9.9%
            Max          +0.2%   +159.1%    +90.0%    +84.7%
 Geometric Mean          -0.0%     +2.2%     +6.8%     +5.1%

This is the worst program:

         simple          +0.2%   +159.1%    +65.3%    +63.9%

I looked at it a bit and came up with this small example:

----
loop :: Double -> [Int] -> Double
{-# NOINLINE loop #-}
loop x [] = x
loop x (n:ns) = x `seq` loop (x ^ n) ns

main = print $ loop 1 (replicate 10000000 5)
----

This is over 2x slower with -fno-method-sharing. The culprit is, of
course, (^). Here is the difference:

Without -fno-method-sharing:

----
^_rVB :: GHC.Types.Double -> GHC.Types.Int -> GHC.Types.Double ^_rVB =
  GHC.Real.^
    @ GHC.Types.Double
    @ GHC.Types.Int
    GHC.Float.$fNumDouble
    GHC.Real.$fIntegralInt

Main.loop [InlPrag=NOINLINE (sat-args=2), Occ=LoopBreaker]
  :: GHC.Types.Double -> [GHC.Types.Int] -> GHC.Types.Double Main.loop =
  \ (x1_aat :: GHC.Types.Double) (ds_drG :: [GHC.Types.Int]) ->
    case ds_drG of _ {
      [] -> x1_aat;
      : n_aav ns_aaw ->
        case x1_aat of x2_aau { GHC.Types.D# ipv_srQ ->
        Main.loop (^_rVB x2_aau n_aav) ns_aaw
        }
    }
----

With:

----
Main.loop [InlPrag=NOINLINE (sat-args=2), Occ=LoopBreaker]
  :: GHC.Types.Double -> [GHC.Types.Int] -> GHC.Types.Double Main.loop =
  \ (x1_aat :: GHC.Types.Double) (ds_drD :: [GHC.Types.Int]) ->
    case ds_drD of _ {
      [] -> x1_aat;
      : n_aav ns_aaw ->
        case x1_aat of x2_aau { GHC.Types.D# ipv_srN ->
        Main.loop
          (GHC.Real.^
             @ GHC.Types.Double
             @ GHC.Types.Int
             GHC.Float.$fNumDouble
             GHC.Real.$fIntegralInt
             x2_aau
             n_aav)
          ns_aaw
        }
    }
----

This is a bit disappointing. I would have expected GHC to float out
the application of (^) to the two dictionaries during full laziness
(note that (^) has arity 2 so the application is oversaturated). Why
doesn't that happen? SetLevels (if this is the right place to look)
has this:

-}


{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ConstraintKinds #-}

module Main( main, boo ) where

import Prelude hiding (repeat)

boo xs f = (\x -> f x, xs)

repeat :: Int -> (a -> a) -> a -> a
repeat 1 f x = f x
repeat n f x = n `seq` x `seq` repeat (n-1) f $ f x

---- Buggy version
------------------

type Numerical a = (Fractional a, Real a)

data Box a = Box
    { func :: forall dum. (Numerical dum) => dum -> a -> a
    , obj :: !a }

do_step :: (Numerical num) => num -> Box a -> Box a
do_step number Box{..} = Box{ obj = func number obj, .. }

start :: Box Double
start = Box { func = \x y -> realToFrac x + y
            , obj = 0 }

test :: Int -> IO ()
test steps = putStrLn $ show $ obj $ repeat steps (do_step 1) start

---- Driver
-----------

main :: IO ()
main = test 2000 -- compare test2 10000000 or test3 10000000, but test4 20000

{-
---- No tuple constraint synonym is better
------------------------------------------

data Box2 a = Box2
    { func2 :: forall num. (Fractional num, Real num) => num -> a -> a
    , obj2 :: !a }

do_step2 :: (Fractional num, Real num) => num -> Box2 a -> Box2 a
do_step2 number Box2{..} = Box2{ obj2 = func2 number obj2, ..}

start2 :: Box2 Double
start2 = Box2 { func2 = \x y -> realToFrac x + y
              , obj2 = 0 }

test2 :: Int -> IO ()
test2 steps = putStrLn $ show $ obj2 $ repeat steps (do_step2 1) start2

---- Not copying the function field works too
---------------------------------------------

do_step3 :: (Numerical num) => num -> Box a -> Box a
do_step3 number b@Box{..} = b{ obj = func number obj }

test3 :: Int -> IO ()
test3 steps = putStrLn $ show $ obj $ repeat steps (do_step3 1) start

---- But record wildcards are not at fault
------------------------------------------

do_step4 :: (Numerical num) => num -> Box a -> Box a
do_step4 number Box{func = f, obj = x} = Box{ obj = f number x, func = f }

test4 :: Int -> IO ()
test4 steps = putStrLn $ show $ obj $ repeat steps (do_step4 1) start
-}

{-
First of all, very nice example. Thank you for making it so small and easy to work with.

I can see what's happening. The key part is what happens here:
{{{
do_step4 :: (Numerical num) => num -> Box a -> Box a
do_step4 number Box{ func = f, obj = x}
              = Box{ func = f, obj = f number x }
}}}
After elaboration (ie making dictionaries explicit) we get this:
{{{
do_step4 dn1 number (Box {func = f, obj = x })
  = Box { func = \dn2 -> f ( case dn2 of (f,r) -> f
                           , case dn2 of (f,r) -> r)
        , obj = f dn1 number x }
}}}
That's odd!  We expected this:
{{{
do_step4 dn1 number (Box {func = f, obj = x })
  = Box { func = f
        , obj = f dn1 number x }
}}}
And indeed, the allocation of all those `\dn2` closures is what is causing the problem.
So we are missing this optimisation:
{{{
   (case dn2 of (f,r) -> f, case dn2 of (f,r) -> r)
===>
   dn2
}}}
If we did this, then the lambda would look like `\dn2 -> f dn2` which could eta-reduce to `f`.
But there are at least three problems:
 * The tuple transformation above is hard to spot
 * The tuple transformation is not quite semantically right; if `dn2` was bottom, the LHS and RHS are different
 * The eta-reduction isn't quite semantically right: if `f` ws bottom, the LHS and RHS are different.

You might argue that the latter two can be ignored because dictionary arguments are special;
indeed we often toy with making them strict.

But perhaps a better way to avoid the tuple-transformation issue would be not to construct that strange expression in the first place. Where is it coming from?  It comes from the call to `f` (admittedly applied to no arguments) in `Box { ..., func = f }`.  GHC needs a dictionary for `(Numerical dum)` (I changed the name of the type variable in `func`'s type in the definition of `Box`).  Since it's just a pair GHC says "fine, I'll build a pair, out of `Fractional dum` and `Real dum`.  How does it get those dictionaries?  By selecting the components of the `Franctional dum` passed to `f`.

If GHC said instead "I need `Numerical dum` and behold I have one in hand, it'd be much better. It doesn't because tuple constraints are treated specially.  But if we adopted the idea in #10362, we would (automatically) get to re-use the `Numerical dum` constraint.  That would leave us with eta reduction, which is easier.

As to what will get you rolling, a good solution is `test3`, which saves instantiating and re-generalising `f`. The key thing is to update all the fields ''except'' the polymorphic `func` field. I'm surprised you say that it doesn't work.  Can you give a (presumably more complicated) example to demonstrate? Maybe there's a separate bug!

-}


{-# LANGUAGE MultiParamTypeClasses, FlexibleContexts #-}
module Main ( main ) where

class Foldable f => C f a where
  m :: f a -> a

instance C [] Int where
  m = foldr (+) 0

{-# NOINLINE go #-}
go :: C [] b => b -> Int -> Int
go _ i = foldr (+) 0 [1..i]

main :: IO ()
main = print $ go (0 :: Int) 20000


-- We used to inline constructor wrapper functions only when fully applied.
-- This led to unnecessary boxing when partially applying to unpacked fields.

module Main where
import Control.DeepSeq
import Data.Functor.Identity
import Control.Exception (evaluate)

data AList = Cons !Int !Int !Int !Int !Int !Int !Int !Int !Int AList | Nil

-- We need to write this instance manually because the Generic-derived
-- instance allocates a ton of intermediate junk, obscuring the interesting
-- differences.
instance NFData AList where
  rnf Nil = ()
  rnf (Cons _1 _2 _3 _4 _5 _6 _7 _8 _9 xs) = rnf xs

-- If GHC is allowed to specialize it to Identity, the partial application of
-- Cons will become a fully saturated one, defeating the test. So we NOINLINE
-- it.
buildalist :: Applicative f => Int -> f AList
buildalist n
  | n <= 0 = pure Nil
  | otherwise = Cons n (n+1) (n+2) (n+3) (n+4) (n+5) (n+6) (n+7) (n+8) <$>
                  buildalist (n - 1)
{-# NOINLINE buildalist #-}

main = evaluate . rnf . runIdentity $ buildalist 100000


{-# OPTIONS_GHC -fno-full-laziness #-}

module Main where

import Control.Monad (unless)
import Data.Time.Clock
import System.IO

data AppState = AppState [Int]

cycleState :: [Int] -> [Int]
cycleState w =  filter (check w) w

check :: [Int] -> Int -> Bool
check world pos = pos `elem` world

initialSet :: [Int]
initialSet = [1]

main :: IO ()
main = appLoop 24 (AppState initialSet)

appLoop :: Int -> AppState -> IO ()
appLoop n s
  | n == 0 = return ()
  | otherwise = do let AppState state = s
                   print state
                   appLoop (n-1) $ AppState (cycleState state)


import Data.IORef

main :: IO ()
main = do
  ref <- newIORef 10000
  n <- readIORef ref
  print $ length $ [0::Int, 2 .. n]


{-# LANGUAGE DeriveTraversable #-}

import Data.Monoid (Endo (..))
import Control.Exception (evaluate)

data Tree a = Bin !(Tree a) a !(Tree a) | Tip
  deriving (Functor, Foldable)

t1, t2, t3, t4, t5 :: Tree ()
t1 = Bin Tip () Tip
t2 = Bin t1 () t1
t3 = Bin t2 () t2
t4 = Bin t3 () t3
t5 = Bin t4 () t4
t6 = Bin t5 () t5
t7 = Bin t6 () t6

replaceManyTimes :: Functor f => f a -> f Int
replaceManyTimes xs = appEndo
  (foldMap (\x -> Endo (x <$)) [1..20000])
  (0 <$ xs)

main :: IO ()
main = do
  evaluate $ sum $ replaceManyTimes t7
  pure ()


{-# LANGUAGE BangPatterns, GADTs, ExistentialQuantification #-}
{-# OPTIONS_GHC -cpp #-}

module Main where

import Data.Int
import GHC.Types

foo :: Int -> Int -> IO Int
foo = \i j -> sfoldl' (+) 0 $ xs i j +++ ys i j
  where xs k l = senumFromStepN k l 200000
        ys k l = senumFromStepN k l 300000
        {-# Inline xs #-}
        {-# Inline ys #-}
{-# Inline foo #-}

-- We narrow the result to 32-bits to account for the fact that this overflows
-- on 32-bit machines.
main = do { n <- foo 1 1; print (fromIntegral n :: Int32) }

-------------------------------------------------------------------------------
-- vector junk
-------------------------------------------------------------------------------

#define PHASE_FUSED [1]
#define PHASE_INNER [0]

#define INLINE_FUSED INLINE PHASE_FUSED
#define INLINE_INNER INLINE PHASE_INNER

data Stream m a = forall s. Stream (s -> m (Step s a)) s

data Step s a where
  Yield :: a -> s -> Step s a
  Skip  :: s -> Step s a
  Done  :: Step s a

senumFromStepN :: (Num a, Monad m) => a -> a -> Int -> Stream m a
{-# INLINE_FUSED senumFromStepN #-}
senumFromStepN x y n = x `seq` y `seq` n `seq` Stream step (x,n)
  where
    {-# INLINE_INNER step #-}
    step (w,m) | m > 0     = return $ Yield w (w+y,m-1)
               | otherwise = return $ Done

sfoldl' :: Monad m => (a -> b -> a) -> a -> Stream m b -> m a
{-# INLINE sfoldl' #-}
sfoldl' f = sfoldlM' (\a b -> return (f a b))

sfoldlM' :: Monad m => (a -> b -> m a) -> a -> Stream m b -> m a
{-# INLINE_FUSED sfoldlM' #-}
sfoldlM' m w (Stream step t) = foldlM'_loop SPEC w t
  where
    foldlM'_loop !_ z s
      = z `seq`
        do
          r <- step s
          case r of
            Yield x s' -> do { z' <- m z x; foldlM'_loop SPEC z' s' }
            Skip    s' -> foldlM'_loop SPEC z s'
            Done       -> return z

infixr 5 +++
(+++) :: Monad m => Stream m a -> Stream m a -> Stream m a
{-# INLINE_FUSED (+++) #-}
Stream stepa ta +++ Stream stepb tb = Stream step (Left ta)
  where
    {-# INLINE_INNER step #-}
    step (Left  sa) = do
                        r <- stepa sa
                        case r of
                          Yield x sa' -> return $ Yield x (Left  sa')
                          Skip    sa' -> return $ Skip    (Left  sa')
                          Done        -> return $ Skip    (Right tb)
    step (Right sb) = do
                        r <- stepb sb
                        case r of
                          Yield x sb' -> return $ Yield x (Right sb')
                          Skip    sb' -> return $ Skip    (Right sb')
                          Done        -> return $ Done


module T14052 where

example :: Char
example = 'a'


{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE FlexibleContexts #-}

module Main where

import Prelude
import qualified Foreign.Storable as Storable
import qualified Control.Monad.State.Strict as S
import Control.Monad.IO.Class
import Foreign.Marshal.Alloc       (mallocBytes)

newtype Foo a = Foo a

intSize :: Int
intSize = Storable.sizeOf (undefined :: Int)

-- This 'go' loop should allocate nothing, because it specialises
-- for the shape of the state.  But in 8.4 it did (Trac #14936)

slow :: Int -> IO ()
slow i = do let go 0 = pure ()
                go j = do Foo (!a, !off) <- S.get
                          S.put (Foo (a+1, off))
                          go (j - 1)
            S.evalStateT (go i) (Foo ((0::Int),(intSize::Int)))

main = do { slow (10 ^ 7); print "Done" }


module Main where

import T14955a

--test1 :: [Bool] -> Bool
--test1 = ors

--test2 :: [Bool] -> Bool
--test2 = dors boolDict

--test2a :: [Bool] -> Bool
--test2a xs = dors boolDict xs

test3 :: [Bool] -> Bool
test3 xs = pors xs

--test4 :: [Bool] -> Bool
--test4 xs = porsProxy xs

main = print (test3 (replicate 1000000 False))


{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
module T14955a where

import Prelude (Bool(..), (||), (&&))

-- Implementation 1

class Prop r where
  or :: r -> r -> r
  and :: r -> r -> r
  true :: r
  false :: r

instance Prop Bool where
  or = (||)
  and = (&&)
  true = True
  false = False

-- Implementation 2

data PropDict r = PropDict {
  dor :: r -> r -> r
  , dand :: r -> r -> r
  , dtrue :: r
  , dfalse :: r
  }

boolDict = PropDict {
  dor = (||)
  , dand = (&&)
  , dtrue = True
  , dfalse = False }

-- Implementation 3

class PropProxy r where
  propDict :: PropDict r

instance PropProxy Bool where
  propDict = boolDict

-- Implementation 4

class PropProxy2 r where
  propDict2 :: PropDict r
  dummy :: ()

instance PropProxy2 Bool where
  propDict2 = boolDict
  dummy = ()

ors :: Prop r => [r] -> r
ors [] = true
ors (o:os) = o `or` ors os
{-# INLINABLE ors #-}

dors :: PropDict r -> [r] -> r
dors pd [] = dtrue pd
dors pd (o:os) = dor pd o (dors pd os)

pors :: PropProxy r => [r] -> r
pors [] = dtrue propDict
pors (o:os) = dor propDict o (pors os)
{-# INLINABLE pors #-}

porsProxy :: PropProxy2 r => [r] -> r
porsProxy [] = dtrue propDict2
porsProxy (o:os) = dor propDict2 o (porsProxy os)
{-# INLINABLE porsProxy #-}


module Main (main) where

-- See Trac #149

-- Currently (with GHC 7.0) the CSE works, just,
-- but it's delicate.

import System.CPUTime

main :: IO ()
main = print $ playerMostOccur1 [1..m]

m :: Int
m = 22

playerMostOccur1 :: [Int] -> Int
playerMostOccur1 [a] = a
playerMostOccur1 (x:xs)
 | numOccur x (x:xs) > numOccur (playerMostOccur1 xs) xs = x
 | otherwise = playerMostOccur1 xs

numOccur :: Int -> [Int] -> Int
numOccur i is = length is


module Main (main) where

-- See Trac #149

-- Currently (with GHC 7.0) the CSE works, just,
-- but it's delicate.

import System.CPUTime

main :: IO ()
main = print $ playerMostOccur2 [1..m]

m :: Int
m = 22

playerMostOccur2 :: [Int] -> Int
playerMostOccur2 [a] = a
playerMostOccur2 (x:xs)
 | numOccur x (x:xs) > numOccur pmo xs = x
 | otherwise = pmo
    where pmo = playerMostOccur2 xs

numOccur :: Int -> [Int] -> Int
numOccur i is = length is


-- T15226
import Control.Exception (evaluate)

-- Just in case Prelude.repeat changes for some reason.
import Prelude hiding (repeat)

-- We want to be sure that the compiler *doesn't* know that
-- all the elements of the list are in WHNF, because if it
-- does, PrelRules may erase the seq#'s altogether.
repeat :: a -> [a]
repeat a = res
  where res = a : res
{-# NOINLINE repeat #-}  -- Belt *and* suspenders

silly :: [Int] -> IO ()
silly = foldr go (pure ())
  where
    go x r = do
      x' <- evaluate x
      evaluate (x' + 3)  -- GHC should know that x' has been evaluated,
                         -- so this calculation will be erased entirely.
                         -- Otherwise, we'll create a thunk to pass to
                         -- evaluate.
      r

main :: IO ()
-- 10,000,000 repetitions take only a twentieth of a second,
-- but allocations go up dramatically if the result is not
-- known evaluated.
main = silly $ take 10000000 $ repeat 1


-- T15226
import Control.Exception (evaluate)

-- Just in case Prelude.repeat changes for some reason.
import Prelude hiding (repeat)
import Data.Coerce

-- We want to be sure that the compiler *doesn't* know that
-- all the elements of the list are in WHNF, because if it
-- does, PrelRules may erase the seq#'s altogether.
repeat :: a -> [a]
repeat a = res
  where res = a : res
{-# NOINLINE repeat #-}  -- Belt *and* suspenders

newtype Foo = Foo Int

silly :: [Int] -> IO ()
silly = foldr go (pure ())
  where
    go x r = do
      x' <- (coerce (evaluate :: Foo -> IO Foo) :: Int -> IO Int) x
      evaluate (x' + 3)  -- GHC should know that x' has been evaluated,
                         -- so this calculation will be erased entirely.
                         -- Otherwise, we'll create a thunk to pass to
                         -- evaluate.
      r

main :: IO ()
-- 10,000,000 repetitions take only a twentieth of a second,
-- but allocations go up dramatically if the result is not
-- known evaluated.
main = silly $ take 10000000 $ repeat 1


module Main where

import Data.List

expensive :: [Word]
expensive = [1 .. 10000]

cheap :: [Word]
cheap = repeat 2

test_zipWith :: IO ()
test_zipWith = do
    let zw3 = sum $ zipWith3 (\a b c -> a*b*c) expensive cheap cheap
        zw4 = sum $ zipWith4 (\a b c d -> a*b*c*d) expensive cheap cheap cheap
        zw5 = sum $ zipWith5 (\a b c d e ->
            a*b*c*d*e) expensive cheap cheap cheap cheap
        zw6 = sum $ zipWith6 (\a b c d e f ->
            a*b*c*d*e*f) expensive cheap cheap cheap cheap cheap
        zw7 = sum $ zipWith7 (\a b c d e f g ->
            a*b*c*d*e*f*g) expensive cheap cheap cheap cheap cheap cheap

    putStrLn ("zipWith3: " ++ show zw3)
    putStrLn ("zipWith4: " ++ show zw4)
    putStrLn ("zipWith5: " ++ show zw5)
    putStrLn ("zipWith6: " ++ show zw6)
    putStrLn ("zipWith7: " ++ show zw7)

test_zip3 :: IO ()
test_zip3 = do
    let z3 = foldr (\(x,y,z) acc -> x*y*z+acc) 0 (zip3 expensive cheap cheap)

    putStrLn ("zip3: " ++ show z3)

main :: IO ()
main = do
    test_zip3
    test_zipWith


import Control.Exception (evaluate)
import Data.List

-- The following will fuse with minimal heap usage provided
-- `findIndices` is marked `INLINABLE` instead of `INLINE`.

unsafeFindIndex p = head . findIndices p

main = do evaluate $ elemIndex 999999 [(1::Int)..1000000]
          evaluate $ elemIndices 999999 [(1::Int)..1000000]
          evaluate $ findIndex (>=999999) [(1::Int)..1000000]
          evaluate $ findIndices (>=999999) [(1::Int)..1000000]
          evaluate $ unsafeFindIndex (>=999999) [(1::Int)..1000000]


{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Strict            #-}
{-# LANGUAGE BangPatterns      #-}
{-# LANGUAGE DeriveGeneric     #-}

module Main where

import qualified Data.Set  as Set
import qualified Data.Text as Text

import Data.Set              (Set)
import Data.Text             (Text)
import System.IO             (BufferMode (NoBuffering), hSetBuffering, stdout)
import GHC.Generics          (Generic)
import Control.DeepSeq       (force, NFData)
import Control.Exception     (evaluate)

--------------------------------
-- === Running benchmarks === --
--------------------------------

iters :: Int
iters = 100000000

src1 :: Text
src1 = Text.replicate iters "tttt"

data Grammar a
    = Tokens !(Set a) !(a -> Bool)
    | Many   !(Grammar a)
    | X      !(Grammar a)

instance Ord a => Semigroup (Grammar a) where
    Tokens s f <> Tokens s' g = Tokens (s <> s') $ \c -> f c || g c
    {-# INLINE (<>) #-}

token :: Eq a => a -> Grammar a
token = \a -> Tokens (Set.singleton a) (a ==)
{-# INLINE token #-}

many :: Grammar a -> Grammar a
many = Many
{-# INLINE many #-}

data Result
    = Success Text Text
    | Fail
    deriving (Show, Generic)

instance NFData Result

runTokenParser :: Grammar Char -> Text -> Result
runTokenParser = \grammar stream -> case grammar of
    Tokens _ tst -> let
        head = Text.head stream
        in if tst head
            then Success (Text.tail stream) (Text.singleton head)
            else Fail
    Many (Tokens _ tst) -> let
        (!consumed, !rest) = Text.span tst stream
        in Success rest consumed
    X !grammar -> runTokenParser grammar stream

testGrammar1 :: Grammar Char
testGrammar1 = let
    s1 = token 't'
    in many s1
{-# INLINE testGrammar1 #-}

test3 :: Text -> Result
test3 src =
  runTokenParser testGrammar1 src
{-# NOINLINE test3 #-}

main :: IO ()
main = do
    srcx <- evaluate $ force src1
    evaluate $ force $ test3 srcx
    pure ()


{-# LANGUAGE UnicodeSyntax, FlexibleContexts #-}

module Main (main) where

import T2902_A_PairingSum

f :: Int -> PSum Int Int
f n = unions $ fmap g [1..n]
  where
    g m = unions $ fmap fromList
      [ zip [m..n] $ repeat 1
      , zip [m,2+m..n] $ repeat 2
      , zip [m,3+m..n] $ repeat 3
      ]

main âˆ· IO ()
main = print $ take 20 $ toList $ f 20


{-# LANGUAGE UnicodeSyntax, MultiParamTypeClasses, FlexibleInstances #-}

module T2902_A_PairingSum (Sum(..), PSum) where

import T2902_Sum

data PSum a b = Empty | Tree a b [(PSum a b)]

instance (Ord a, Eq b, Num b) â‡’ Sum PSum a b where
  insert     = insertX
  union      = unionX
  unions     = unionsX
  extractMin = extractMinX
  fromList   = fromListX
  toList     = toListX

insertX âˆ· (Ord a, Eq b, Num b) â‡’ a â†’ b â†’ PSum a b â†’ PSum a b
insertX v r = unionX $ Tree v r []

unionX âˆ· (Ord a, Eq b, Num b) â‡’ PSum a b â†’ PSum a b â†’ PSum a b
unionX x Empty = x
unionX Empty x = x
unionX x@(Tree v r xs) y@(Tree w s ys) =
  case compare v w of
    LT â†’ Tree v r (y:xs)
    GT â†’ Tree w s (x:ys)
    EQ â†’ case r + s of
      0 â†’ z
      t â†’ insertX v t z
  where z = unionX (unionsX xs) (unionsX ys)

unionsX âˆ· (Ord a, Eq b, Num b) â‡’ [PSum a b] â†’ PSum a b
unionsX [] = Empty
unionsX [x] = x
unionsX (x : y : zs) = unionX (unionX x y) (unionsX zs)

extractMinX âˆ· (Ord a, Eq b, Num b) â‡’ PSum a b â†’ ((a,b), PSum a b)
extractMinX Empty = undefined
extractMinX (Tree v r xs) = ((v,r), unionsX xs)

fromListX âˆ· (Ord a, Eq b, Num b) â‡’ [(a,b)] â†’ PSum a b
fromListX [] = Empty
fromListX ((v,r):xs) = insertX v r $ fromListX xs

toListX âˆ· (Ord a, Eq b, Num b) â‡’ PSum a b â†’ [(a,b)]
toListX Empty = []
toListX x = let (y, z) = extractMinX x in y : toListX z


{-# LANGUAGE UnicodeSyntax, FlexibleContexts #-}

module Main (main) where

import T2902_B_PairingSum

f :: Int -> PSum Int Int
f n = unions $ fmap g [1..n]
  where
    g m = unions $ fmap fromList
      [ zip [m..n] $ repeat 1
      , zip [m,2+m..n] $ repeat 2
      , zip [m,3+m..n] $ repeat 3
      ]

main âˆ· IO ()
main = print $ take 20 $ toList $ f 20


{-# LANGUAGE UnicodeSyntax, MultiParamTypeClasses, FlexibleInstances #-}

module T2902_B_PairingSum (Sum(..), PSum) where

import T2902_Sum

data PSum a b = Empty | Tree a b [PSum a b]

instance (Ord a, Eq b, Num b) â‡’ Sum PSum a b where

  insert v r = union $ Tree v r []

  union x Empty = x
  union Empty x = x
  union x@(Tree v r xs) y@(Tree w s ys) =
    case compare v w of
      LT â†’ Tree v r (y:xs)
      GT â†’ Tree w s (x:ys)
      EQ â†’ case r + s of
        0 â†’ z
        t â†’ insert v t z
    where z = union (unions xs) (unions ys)

  unions [] = Empty
  unions [x] = x
  unions (x : y : zs) = union (union x y) (unions zs)

  extractMin Empty = undefined
  extractMin (Tree v r xs) = ((v,r), unions xs)

  fromList [] = Empty
  fromList ((v,r):xs) = insert v r $ fromList xs

  toList Empty = []
  toList x = let (y, z) = extractMin x in y : toList z


{-# LANGUAGE UnicodeSyntax, MultiParamTypeClasses #-}

module T2902_Sum (Sum(..)) where

class Sum c a b where
  insert     âˆ· a â†’ b â†’ c a b â†’ c a b
  union      âˆ· c a b â†’ c a b â†’ c a b
  unions     âˆ· [c a b] â†’ c a b
  extractMin âˆ· c a b â†’ ((a,b), c a b)

  fromList   âˆ· [(a,b)] â†’ c a b
  toList     âˆ· c a b â†’ [(a,b)]


{-# LANGUAGE ExistentialQuantification, DeriveDataTypeable #-}

-- The second version (count2) took ages with GHC 6.12
-- because the typeOf function was not properly memoised

import Data.Typeable
import System.CPUTime

size :: Int
size = 40000    -- This was big enough to take 5 seconds in
                -- the bad case on my machine.

data Any = forall a. (Typeable a) => Any a

int_type, int_list_type :: TypeRep
int_type = typeOf (undefined :: Int)
int_list_type = typeOf (undefined :: [Int])

count1 :: [Any] -> Int
count1 [] = 0
count1 (Any x:xs) = count1 xs + (if typeOf x == int_type then 1 else 0)

doTime x = do
  start <- getCPUTime
  putStr "Result: "
  print x
  stop <- getCPUTime
  putStr "Time(sec): "
  print (round $ fromIntegral (stop - start) / 1e12)
    -- The 'round' rounds to an integral number of seconds
    -- Should be zero if things are working right!

main = do
  let list = [MkT | i <- [1..size  :: Int]]
  putStrLn "count1"
  let x = map Any list
  doTime $ count1 x
  doTime $ count1 x
  doTime $ count1 x
  putStrLn ""
  putStrLn "count2"
  let x = map (Any . (:[])) list
  doTime $ count1 x
  doTime $ count1 x
  doTime $ count1 x

data T = MkT deriving Typeable


{-# LANGUAGE BangPatterns #-}
{-# OPTIONS -fvia-C -optc-O3 -fexcess-precision -optc-msse3 #-}

import Control.Monad.ST
import Data.Array.ST
import Data.Array.Base

main = print $ runST
          (do arr <- newArray (1,2000000) 137.0 :: ST s (STUArray s Int Double)
              go arr 2000000 0.0 )

go :: STUArray s Int Double -> Int -> Double -> ST s Double
go !a i !acc
    | i < 1     = return acc
    | otherwise = do
         b <- unsafeRead a i
         unsafeWrite a i (b+3.0)
         c <- unsafeRead a i
         go a (i-1) (c+acc)


{-# OPTIONS_GHC -funbox-strict-fields -O #-}
{-# LANGUAGE ExistentialQuantification #-}

{- OPTIONS_GHC -ddump-simpl -ddump-asm -}

module Main (main) where

import GHC.Float (float2Int, int2Float)

import System.Environment

import Prelude hiding           (null
                                ,lines,unlines
                                ,writeFile
                                )

import Control.Exception        (assert, bracket, )

import Foreign.Marshal.Array    (advancePtr)
import Foreign.Ptr              (minusPtr)
import Foreign.Storable         (Storable(..))

import Control.Monad            (when)

import System.IO                (openBinaryFile, hClose,
                                 hPutBuf,
                                 Handle, IOMode(..))

import System.IO.Unsafe         (unsafePerformIO)

import Foreign.Ptr              (Ptr)
import Foreign.ForeignPtr       (ForeignPtr, withForeignPtr, )
import Foreign.Marshal.Array    (copyArray)

import qualified Foreign.ForeignPtr as F

main :: IO ()
main = do args <- getArgs
          case args of
              ["1"] -> mainMonolithic1Generator
              ["2"] -> mainMonolithic1Composed
              _ -> error "Huh?"

type Phase = (Float, Float, Float)

{-# INLINE saw #-}
saw :: Num a => a -> a
saw t = 1-2*t

{-# INLINE fraction #-}
fraction :: Float -> Float
fraction x = x - int2Float (float2Int x)

{-# INLINE generator0Freq #-}
generator0Freq :: Float -> Float -> Maybe (Float, Float)
generator0Freq freq =
   \p -> Just (saw p, fraction (p+freq))

infixl 6 `mix`, `mixGen`

{-# INLINE mix #-}
mix ::
   (Num y) =>
   (s -> Maybe (y, s)) ->
   (t -> Maybe (y, t)) ->
   ((s,t) -> Maybe (y, (s,t)))
mix f g (s0,t0) =
   do (a,s1) <- f s0
      (b,t1) <- g t0
      return ((a+b), (s1,t1))

data Generator a =
   forall s.
      Generator (s -> Maybe (a, s)) s

{-# INLINE runGeneratorMonolithic #-}
runGeneratorMonolithic :: Int -> Generator Float -> Vector Float
runGeneratorMonolithic size' (Generator f s) =
   fst $ unfoldrN size' f s

{- SPECIALISE INLINE generator0Gen :: Float -> Float -> Generator Float -}
{-# INLINE generator0Gen #-}
generator0Gen :: Float -> Float -> Generator Float
generator0Gen freq phase =
   Generator (\p -> Just (saw p, fraction (p+freq))) phase

{- SPECIALISE INLINE mixGen :: Generator Float -> Generator Float -> Generator Float -}
{-# INLINE mixGen #-}
mixGen ::
   (Num y) =>
   Generator y ->
   Generator y ->
   Generator y
mixGen (Generator f s) (Generator g t) =
   Generator (\(s0,t0) ->
      do (a,s1) <- f s0
         (b,t1) <- g t0
         return ((a+b), (s1,t1))) (s,t)

{-# INLINE dl #-}
dl :: Phase
dl = (0.01008, 0.01003, 0.00990)

{-# INLINE initPhase2 #-}
initPhase2 :: (Phase, Phase)
initPhase2 =
   ((0,0.7,0.1), (0.3,0.4,0.6))

size :: Int
size = 10000000

mainMonolithic1Composed :: IO ()
mainMonolithic1Composed =
   writeFile "T3736.speed.f32"
      (fst $ unfoldrN size
          (let (f0,f1,f2) = dl
           in  generator0Freq f0 `mix`
               generator0Freq f1 `mix`
               generator0Freq f2)
          (let (p0,p1,p2) = fst initPhase2
           in  ((p0,p1),p2)))

mainMonolithic1Generator :: IO ()
mainMonolithic1Generator =
   writeFile "T3736.speed.f32"
      (runGeneratorMonolithic size
          (let (f0,f1,f2) = dl
               (p0,p1,p2) = fst initPhase2
           in  generator0Gen f0 p0 `mixGen`
               generator0Gen f1 p1 `mixGen`
               generator0Gen f2 p2))

empty :: (Storable a) => Vector a
empty = unsafeCreate 0 $ const $ return ()
{-# NOINLINE empty #-}

null :: Vector a -> Bool
null (SV _ _ l) = assert (l >= 0) $ l <= 0
{-# INLINE null #-}

unfoldrN :: (Storable b) => Int -> (a -> Maybe (b, a)) -> a -> (Vector b, Maybe a)
unfoldrN n f x0 =
   if n <= 0
     then (empty, Just x0)
     else unsafePerformIO $ createAndTrim' n $ \p -> go p n x0
       where
          go = arguments2 $ \p i -> \x ->
             if i == 0
               then return (0, n-i, Just x)
               else
                 case f x of
                   Nothing     -> return (0, n-i, Nothing)
                   Just (w,x') -> do poke p w
                                     go (incPtr p) (i-1) x'
{-# INLINE unfoldrN #-}

hPut :: (Storable a) => Handle -> Vector a -> IO ()
hPut h v =
   when (not (null v)) $
      withStartPtr v $ \ ptrS l ->
         let ptrE = advancePtr ptrS l
         in  hPutBuf h ptrS (minusPtr ptrE ptrS)

writeFile :: (Storable a) => FilePath -> Vector a -> IO ()
writeFile f txt =
   bracket (openBinaryFile f WriteMode) hClose
      (\h -> hPut h txt)

data Vector a = SV {-# UNPACK #-} !(ForeignPtr a)
                   {-# UNPACK #-} !Int                -- offset
                   {-# UNPACK #-} !Int                -- length

withStartPtr :: Storable a => Vector a -> (Ptr a -> Int -> IO b) -> IO b
withStartPtr (SV x s l) f =
   withForeignPtr x $ \p -> f (p `advancePtr` s) l
{-# INLINE withStartPtr #-}

incPtr :: (Storable a) => Ptr a -> Ptr a
incPtr v = advancePtr v 1
{-# INLINE incPtr #-}

unsafeCreate :: (Storable a) => Int -> (Ptr a -> IO ()) -> Vector a
unsafeCreate l f = unsafePerformIO (create l f)
{-# INLINE unsafeCreate #-}

create :: (Storable a) => Int -> (Ptr a -> IO ()) -> IO (Vector a)
create l f = do
    fp <- mallocForeignPtrArray l
    withForeignPtr fp $ \p -> f p
    return $! SV fp 0 l

createAndTrim' :: (Storable a) => Int
                               -> (Ptr a -> IO (Int, Int, b))
                               -> IO (Vector a, b)
createAndTrim' l f = do
    fp <- mallocForeignPtrArray l
    withForeignPtr fp $ \p -> do
        (off, l', res) <- f p
        if assert (l' <= l) $ l' >= l
            then return $! (SV fp 0 l, res)
            else do ps <- create l' $ \p' -> copyArray p' (p `advancePtr` off) l'
                    return $! (ps, res)

{-# INLINE arguments2 #-}
arguments2 :: (a -> b -> x) -> a -> b -> x
arguments2 f = \a b -> (f $! a) $! b

{-# INLINE mallocForeignPtrArray #-}
mallocForeignPtrArray :: Storable a => Int -> IO (F.ForeignPtr a)
mallocForeignPtrArray = F.mallocForeignPtrArray


module Main where

import T3738a

{-# INLINE bar #-}
bar :: Int -> [Int]
bar x = map (+ 2) (foo x)

main = print (bar 2 !! 10000)


module T3738a where

{-# INLINE foo #-}
foo :: Num a => a -> [a]
foo x = map (+ 1) (repeat x)