module T15445 where

import T15445a

foo :: IO ()
foo = do { print (plusTwoRec [1..10 :: Int])
         ; print (plusTwoRec' [1..20 :: Int]) }


module T15445a where

{-# SPECIALIZE plusTwoRec :: [Int] -> [Int] #-}
plusTwoRec :: Num a => [a] -> [a]
plusTwoRec [] = []
plusTwoRec (x:xs) = x+2:plusTwoRec xs

plusTwoRec' :: Num a => [a] -> [a]
plusTwoRec' [] = []
plusTwoRec' (x:xs) = x+2:plusTwoRec' xs


{-# LANGUAGE ImpredicativeTypes #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeInType #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module T15453 where

import Data.Kind
import Data.Proxy
import Data.Type.Equality

type family S :: Type where
  S = T
type family T :: Type where
  T = Int

f :: (forall (x :: S). Proxy x) :~: (forall (x :: T). Proxy x)
f = Refl

g :: (forall (x :: T). Proxy x) :~: (forall (x :: Int). Proxy x)
g = Refl

h :: (forall (x :: S). Proxy x) :~: (forall (x :: Int). Proxy x)
h = f `trans` g


{-# LANGUAGE PatternSynonyms #-}
module T15517 where

data Nat = Z | S Nat

pattern Zpat = Z

sfrom :: Nat -> () -> Bool
sfrom Zpat  = \_ -> False
sfrom (S Z) = \_ -> False


{-# LANGUAGE DataKinds               #-}
{-# LANGUAGE FlexibleInstances       #-}
{-# LANGUAGE FunctionalDependencies  #-}
{-# LANGUAGE GADTs                   #-}
{-# LANGUAGE LambdaCase              #-}
{-# LANGUAGE PatternSynonyms         #-}
{-# LANGUAGE PolyKinds               #-}
{-# LANGUAGE TypeFamilies            #-}
{-# LANGUAGE TypeOperators           #-}
module T15517a () where

import Data.Kind (Type)
import Data.Proxy

newtype Rep (ki :: kon -> Type) (phi :: Nat -> Type) (code :: [[Atom kon]])
  = Rep (NS (PoA ki phi) code)

data NA  :: (kon -> Type) -> (Nat -> Type) -> Atom kon -> Type where
  NA_I :: (IsNat k) => phi k -> NA ki phi (I k)
  NA_K ::              ki  k -> NA ki phi (K k)

data NP :: (k -> Type) -> [k] -> Type where
  NP0  :: NP p '[]
  (:*) :: p x -> NP p xs -> NP p (x : xs)

class IsNat (n :: Nat) where
  getSNat :: Proxy n -> SNat n
instance IsNat Z where
  getSNat _ = SZ
instance IsNat n => IsNat (S n) where
  getSNat p = SS (getSNat $ proxyUnsuc p)

proxyUnsuc :: Proxy (S n) -> Proxy n
proxyUnsuc _ = Proxy

type PoA (ki :: kon -> Type) (phi :: Nat -> Type) = NP (NA ki phi)

data Atom kon
  = K kon
  | I Nat

data Nat = S Nat | Z
data SNat :: Nat -> Type where
  SZ ::           SNat Z
  SS :: SNat n -> SNat (S n)

data Kon = KInt
data Singl (kon :: Kon) :: Type where
  SInt :: Int -> Singl KInt

type family Lkup (n :: Nat) (ks :: [k]) :: k where
  Lkup Z     (k : ks) = k
  Lkup (S n) (k : ks) = Lkup n ks

data El :: [Type] -> Nat -> Type where
  El :: IsNat ix => Lkup ix fam -> El fam ix

data NS :: (k -> Type) -> [k] -> Type where
  There :: NS p xs -> NS p (x : xs)
  Here  :: p x     -> NS p (x : xs)

class Family (ki :: kon -> Type) (fam :: [Type]) (codes :: [[[Atom kon]]])
      | fam -> ki codes , ki codes -> fam where
    sfrom' :: SNat ix -> El fam ix -> Rep ki (El fam) (Lkup ix codes)

data Rose a = a :>: [Rose a]
            | Leaf a

type FamRoseInt = '[Rose Int, [Rose Int]]

type CodesRoseInt =
    '[ '[ '[K KInt, I (S Z)], '[K KInt]], '[ '[], '[I Z, I (S Z)]]]

pattern IdxRoseInt = SZ
pattern IdxListRoseInt = SS SZ

pat1 :: PoA Singl (El FamRoseInt) '[I Z, I (S Z)]
     -> NS (PoA Singl (El FamRoseInt)) '[ '[], '[I Z, I (S Z)]]
pat1 d = There (Here d)

pat2 :: PoA Singl (El FamRoseInt) '[]
     -> NS (PoA Singl (El FamRoseInt)) '[ '[], '[I Z, I (S Z)]]
pat2 d = Here d

pat3 :: PoA Singl (El FamRoseInt) '[K KInt]
     -> NS (PoA Singl (El FamRoseInt)) '[ '[K KInt, I (S Z)], '[K KInt]]
pat3 d = There (Here d)

pat4 :: PoA Singl (El FamRoseInt) '[K KInt, I (S Z)]
     -> NS (PoA Singl (El FamRoseInt)) '[ '[K KInt, I (S Z)], '[K KInt]]
pat4 d = Here d

instance Family Singl FamRoseInt CodesRoseInt where
  sfrom' = \case IdxRoseInt     -> \case El (x :>: xs) -> Rep (pat4 (NA_K (SInt x) :* (NA_I (El xs) :* NP0)))
                                         El (Leaf x)   -> Rep (pat3 (NA_K (SInt x) :* NP0))
                 IdxListRoseInt -> \case El []     -> Rep (pat2 NP0)
                                         El (x:xs) -> Rep (pat1 (NA_I (El x) :* (NA_I (El xs) :* NP0)))


{-# Language PartialTypeSignatures, RankNTypes #-}

module Foo where

f xs = let ys = reverse xs
       in ys `seq`
          let w = length xs
          in w + length (reverse (case ys of { a:as -> as; [] -> [] }))


module T14573 where

import Data.Bits (shift)

badOne :: [Int] -> Integer     -- replace Integer by Int and all is good!
badOne is = sum $ zipWith (\n _->shift 1 n) [0..] is


-- variant of T5327, where we force the newtype to have a wrapper
{-# LANGUAGE GADTs, ExplicitForAll #-}
module T16254 where

newtype Size a b where
  Size :: forall b a. Int -> Size a b

{-# INLINABLE val2 #-}
val2 = Size 17

-- In the core, we should see a comparison against 34#, i.e. constant
-- folding should have happened. We actually see it twice: Once in f's
-- definition, and once in its unfolding.
f n = case val2 of Size s -> s + s > n


module T16288A where

import T16288C

data License

class Pretty a where
  pretty :: a -> Doc

instance Pretty License where
  pretty _  = pretV

bar :: (Pretty a) => a -> Doc
bar w = foo (pretty (u w w w w))

u :: a -> a -> a -> a -> a
u = u


module T16288B where

import T16288A
import T16288C

bar2 :: License -> Doc
bar2 = bar


module T16288C where

data Doc = Empty | Beside Doc

hcat :: Doc -> Doc
hcat Empty = Empty
hcat xs = hcat xs

pretV = hcat Empty

foo :: Doc -> Doc
foo Empty = hcat Empty
foo val = Beside val


module T16348 where

data V2 a = V2 !a !a

inv22 _ = case V2 (V2 1 2) (V2 3 4) of
             V2 _ (V2 _ z) -> z


module T1647 where

foo :: IO ()
foo = putStrLn "Foo"


{-# LANGUAGE GADTs #-}

-- Trac #2520: a bug in the specialiser when we tried to
-- quantify over an Internal Name

module Types where

data Prod a b = Prod a b

data Nil = Nil

class ProdSel f where
   nil :: f Nil
   prod :: f x -> f y -> f (Prod x y)

instance ProdSel SqlFields where
   nil = SFNil
   prod = SFProd

{-# SPECIALIZE reproject :: SqlFields a -> SqlFields a #-}

reproject :: ProdSel f => SqlFields a -> f a
reproject SFNil = nil
reproject (SFProd a b) = prod (reproject a) (reproject b)

data SqlFields a where
  SFNil :: SqlFields Nil
  SFProd :: SqlFields a -> SqlFields b -> SqlFields (Prod a b)


module Foo where

import Data.Bits

-- This should be simplified away to -28
int :: Int
int = negate ((((((15 + 18 - 11) * 3) `quot` 2) `rem` 19) `shiftL` 3) `shiftR` 2)


-- Test Trac #3118

-- The test is quite delicate.  It aims to get 'f' to look like
--   f y = case x of
--             Red -> (y, y)
--             _ -> let v = case x of
--                             Green -> 2
--                             Blue  -> 3
--                  in (v, 5)
--
-- And now float the inner case to top level
-- so that it's not so obvious that the Red case
-- cannot occur.  This crashed GHC 6.10.
--
-- It's delicate to make the bug show up
--  (a) because it relies on not "seeing" that
--      x = Red until later.
--  (b) because dropping the Red case must happen
--      before float-out, which itself happens v early

-- In the original report, the x=Red was concealed by profiling

module T3118 where

data Colour = Red | Green | Blue

{-# NOINLINE [0] f #-}
g x = Red

x = g True

f :: Int -> (Int,Int)
f y = case x of
         Red -> (y, y)
         xx -> let v = case xx of
                          Red -> 1
                          Green -> 2
                          Blue  -> 3
                 in (v, 5)


-- Trac #3234
-- Should give a use of foldr/single

module Foo where

x = ['x'] ++ "haskell"


-- This tests whether a supurious `seq` is eliminated

-- The test output is -ddump-simpl with uniques suppressed,
-- so it may wobble a bit and require updating

module T3717 where

foo :: Int -> Int
foo 0 = 0
foo n = (if n < 5 then 1 else 2) `seq` foo (n-1)


{-# OPTIONS_GHC -ddump-simpl #-}
module T3772 where

import T3772_A

foo :: Int -> ()
{-# NOINLINE foo #-}
foo n = apply n (id :: [Double] -> [Double])

-- = apply [Double] [Double] d1 d2 (id :: [Double] -> [Double]) =
-- deepSeq d2 (id (gen d1 n)) () = deepSeq d2 (gen d1 n) () = d2 |> co
-- (gen d1 n) () =

-- where d2 :: DeepSeq [Double]
--       d2 = df d3
--
--       d3 :: DeepSeq Double

--       d1 :: C [Double]
--       d1 = df' d3


module T3772_A where

class DeepSeq a => C a where
-- class C a where
  gen :: Int -> a

instance C Double where
  gen = fromIntegral

instance C a => C [a] where
  {-# INLINE gen #-}
  gen n = replicate n (gen n)

class DeepSeq a where
  deepSeq :: a -> b -> b

instance DeepSeq Double where
  deepSeq = seq

instance DeepSeq a => DeepSeq [a] where
  {-# INLINE deepSeq #-}
  deepSeq xs b = foldr deepSeq b xs

apply :: (C a, DeepSeq b) => Int -> (a -> b) -> ()
{-# INLINE apply #-}
apply n f = f (gen n) `deepSeq` ()

{-
$cdeepSeq :: DeepSeq a -> [a] -> b -> b
-- User INLINE( 3 args )!
$cdeepSeq a (d:DS a) b (x:[a]) (y:b) = ...

$fDeepSeq[] :: DeepSeq a -> DeepSeq [a]
-- DFun (with auto INLINE pragma)
$fDeepSeq[] a d = $cdeepSeq a d |> blah

$cp1 a d :: C a => DeepSep [a]
-- We don't want to eta-expand this, lest
-- $cdeepSeq gets inlined in it!
$cp1 a d = $fDeepSep[] a (scsel a d)

$fC[] :: C a => C [a]
-- DFun
$fC[] a d = MkC ($cp1 a d) ($cgen a d)
-}


{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
{-# LANGUAGE ScopedTypeVariables, FlexibleInstances  #-}

-- This test has a deep nest of join points, which led to
-- an exponential blow-up in SpecConstr

module T3831(setAttributes)  where

import Data.Monoid
import Control.Applicative (Applicative(..), Alternative(empty, (<|>)))
import Control.Monad

class (Monoid s, OutputCap s) => TermStr s

class OutputCap f where
    outputCap :: ([Int] -> String) -> [Int] -> f
    outputCap = error "urk"

instance OutputCap [Char] where
instance (Enum p, OutputCap f) => OutputCap (p -> f) where

instance Functor Capability where
    fmap = liftM

instance Applicative Capability where
    pure = return
    (<*>) = ap

instance Monad Capability where
    return = Capability . const . return . Just
    Capability f >>= g = Capability $ \t -> do
        mx <- f t
        case mx of
            Nothing -> return Nothing
            Just x -> let Capability g' = g x in g' t

instance Alternative Capability where
    empty = mzero
    (<|>) = mplus

instance MonadPlus Capability where
    mzero = Capability (const $ return Nothing)
    Capability f `mplus` Capability g = Capability $ \t -> do
        mx <- f t
        case mx of
            Nothing -> g t
            _ -> return mx

newtype Capability a = Capability (() -> IO (Maybe a))

tiGetOutput1 :: forall f . OutputCap f => String -> Capability f
{-# NOINLINE tiGetOutput1 #-}
tiGetOutput1 _ = return (outputCap (const "") [])

enterStandoutMode :: TermStr s => Capability s
enterStandoutMode = tiGetOutput1 "smso"

enterUnderlineMode :: TermStr s => Capability s
enterUnderlineMode = tiGetOutput1 "smul"

reverseOn :: TermStr s => Capability s
reverseOn = tiGetOutput1 "rev"

blinkOn:: TermStr s => Capability s
blinkOn = tiGetOutput1 "blink"

boldOn :: TermStr s => Capability s
boldOn = tiGetOutput1 "bold"

dimOn :: TermStr s => Capability s
dimOn = tiGetOutput1 "dim"

invisibleOn :: TermStr s => Capability s
invisibleOn = tiGetOutput1 "invis"

protectedOn :: TermStr s => Capability s
protectedOn = tiGetOutput1 "prot"

data Attributes = Attributes {
                    standoutAttr,
                    underlineAttr,
                    reverseAttr,
                    blinkAttr,
                    dimAttr,
                    boldAttr,
                    invisibleAttr,
                    protectedAttr :: Bool
                }

setAttributes :: TermStr s => Capability (Attributes -> s)
setAttributes = usingSGR0 `mplus` manualSets
    where
        usingSGR0 = do
            sgr <- tiGetOutput1 "sgr"
            return $ \a -> let mkAttr f = if f a then 1 else 0 :: Int
                           in sgr (mkAttr standoutAttr)
                                  (mkAttr underlineAttr)
                                  (mkAttr reverseAttr)
                                  (mkAttr blinkAttr)
                                  (mkAttr dimAttr)
                                  (mkAttr boldAttr)
                                  (mkAttr invisibleAttr)
                                  (mkAttr protectedAttr)
                                  (0::Int)
        attrCap :: TermStr s => (Attributes -> Bool) -> Capability s
                    -> Capability (Attributes -> s)
        attrCap f cap = do {to <- cap; return $ \a -> if f a then to else mempty}
                        `mplus` return (const mempty)
        manualSets = do
            cs <- sequence [attrCap standoutAttr enterStandoutMode
                            , attrCap underlineAttr enterUnderlineMode
                            , attrCap reverseAttr reverseOn
                            , attrCap blinkAttr blinkOn
                            , attrCap boldAttr boldOn
                            , attrCap dimAttr dimOn
                            , attrCap invisibleAttr invisibleOn
                            , attrCap protectedAttr protectedOn
                            ]
            return $ \a -> mconcat $ map ($ a) cs


{-# LANGUAGE TypeFamilies #-}
module T3990 where

data family Complex a
data instance Complex Double = CD {-# UNPACK #-} !Double
                                  {-# UNPACK #-} !Double

data T = T {-# UNPACK #-} !(Complex Double)
-- This shouuld actually get unpacked!

test_case :: T
test_case = T (CD 1 1)


module T4138 where

import T4138_A

-- We NOINLINE f because we want to count the number of F#s in the
-- -ddump-simpl output, so we don't want to be confused by F#s
-- appearing in the inlining
{-# NOINLINE f #-}
f :: (Float, Float) -> ()
f = rnf

{-
We're hoping that the output will include something like:

  \ (ds_afa :: (GHC.Types.Float, GHC.Types.Float)) ->
    case ds_afa of _ { (x_afd, y_afe) ->
    case x_afd of _ { GHC.Types.F# ipv_afm ->
    T4138_A.$fNFDataFloat_$crnf y_afe } }
-}


module T4138_A where

class NFData a where
    rnf :: a -> ()
    rnf a = a `seq` ()

instance NFData Float

instance (NFData a, NFData b) => NFData (a,b) where
    rnf (x,y) = rnf x `seq` rnf y


module Eta where

data T = MkT
newtype Foo = Foo T

lift :: Foo -> T
lift (Foo x) = bof x
  -- The point is that we expect
  --   lift = bof |> co
  -- not
  --   lift = \fx -> bof (fx |> co)

bof :: T -> T
{-# NOINLINE bof #-}
bof MkT = MkT


{-# LANGUAGE GeneralizedNewtypeDeriving #-}

-- Triggered a lint error due to the specialiser

module T4203 where

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

newtype NonNegative a = NonNegative a
 deriving (Eq, Num, Show)

instance (Eq a, Num a) => Arbitrary (NonNegative a) where
  arbitrary = return (rubble (rubble 0))
  coarbitrary = error "urk"

rubble :: (Eq a, Num a) => a -> a
rubble 0 = 1
rubble n = n * rubble (n-1)

newtype EmptyStackSet = EmptyStackSet (NonNegative Int)

instance Arbitrary EmptyStackSet where
  arbitrary = do
        x <- arbitrary :: Gen (NonNegative Int)
        return $ EmptyStackSet x
  coarbitrary = error "urk"

newtype Gen a = Gen a

instance Functor Gen where
    fmap = liftM

instance Applicative Gen where
    pure = return
    (<*>) = ap

instance Monad Gen where
  return a    = Gen a
  Gen m >>= k = Gen (let Gen m' = k m in m')

class Arbitrary a where
  arbitrary   :: Gen a
  coarbitrary :: a

data StackSet = StackSet


-- Trac #4306
-- Check that the worker for 'upd' has only one argument

module T4306 where

data D = D {-# UNPACK #-} !Double {-# UNPACK #-} !Double
data UPD = UPD {-# UNPACK #-} !Double D

upd (UPD _ (D x _)) = sqrt $! (x*x + x*x + sin x + x*x + x*x + cos x + x*x + x*x + tan x +
                               x*x + x*x + sin x + x*x + x*x + cos x + x*x + x*x + tan x +
                               x*x + x*x + sin x + x*x + x*x + cos x + x*x + x*x + tan x)
                               -- make the rhs large enough to be worker/wrapperred


-- This one elicited a bug in the simplifier
-- that produces a Lint out-of-scope error

module T4345 where

isNull :: IO Bool
isNull = error "urk"

wrapMatchAll :: IO (Maybe ())
wrapMatchAll = do
   nsub <- undefined
   let loop True = do atEnd <- isNull
                      return Nothing
       loop False = loop False
   result <- undefined
   loop undefined


{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
{-# LANGUAGE FlexibleContexts #-}

module T4398 where

{-# RULES "suspicious" forall (x :: a) y. f (x :: Ord a => a) y = g x y  #-}

{-# NOINLINE f #-}
f :: a -> a -> Bool
f x y = True

g :: Ord a => a -> a -> Bool
g = (<)


module T4903 where

import T4903a

{-# SPECIALIZE eq :: TreeF Tree -> Tree -> Bool #-}
-- The pragma is only problematic if it is in a separate module

f :: Bool
-- If we don't use eq, there is no problem
f = eq Tree tree


{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE RankNTypes            #-}
{-# LANGUAGE TypeOperators         #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE GADTs                 #-}
{-# LANGUAGE TypeFamilies          #-}

module T4903a where

import Data.Kind

class El phi ix where
  proof :: phi ix

class Fam phi where
  from :: phi ix -> ix -> PF phi I0 ix

type family PF (phi :: Type -> Type) :: (Type -> Type) -> Type -> Type

data I0 a = I0 a

data I xi      (r :: Type -> Type) ix = I (r xi)
data (f :*: g) (r :: Type -> Type) ix = f r ix :*: g r ix

class HEq phi f where
  heq :: (forall ix. phi ix -> r ix -> Bool)
      -> phi ix -> f r ix -> Bool

instance El phi xi => HEq phi (I xi) where
  -- Replacing proof by undefined solves the problem
  heq eq _ (I x)     = eq proof x

instance (HEq phi f, HEq phi g) => HEq phi (f :*: g) where
  -- The problem only arises when there are two calls to heq here
  heq eq p (x :*: y) = heq eq p x && heq eq p y

{-# INLINABLE eq #-}
eq :: (Fam phi, HEq phi (PF phi)) => phi ix -> ix -> Bool
eq p x = heq (\p (I0 x) -> eq p x) p (from p x)

data Tree = Bin Tree Tree

tree :: Tree
-- The problem only occurs on an inifite (or very large) structure
tree = Bin tree tree

data TreeF :: Type -> Type where Tree :: TreeF Tree

type instance PF TreeF = I Tree :*: I Tree
-- If the representation is only |I Tree| then there is no problem

instance Fam TreeF where
  from Tree (Bin l r) = I (I0 l) :*: I (I0 r)

instance El TreeF Tree where proof = Tree


{-# LANGUAGE MagicHash #-}

module T4908 where
import GHC.Base

f :: Int -> (Int,Int) -> Bool
f 0 x = True
f n x = case x of (a,b) -> case b of
                             I# 0# -> True
                             I# _  -> f (n-1) x


module T4918 where

import T4918a

f1 = map (\() -> 'p') [()]
f2 = map (\() -> 'q') myEnum


module T4918a where

class MyEnum a where
 myEnum :: [a]

instance MyEnum () where
 myEnum = [()]


module T4930 where

foo :: Int -> Int
foo n = (if n < 5 then foo n else n+2)
        `seq` n+5


module Main where

import Data.Int
import Data.Array.Base
import Data.Array.ST
import Control.Monad.ST
import System.Environment

main :: IO ()
main = do
  [_nr, _len] <- getArgs
  let nRounds = read _nr :: Int
      len = read _len :: Int
  stToIO $ do
    arr <- newArray (1, len) 0

    let spin :: STUArray s Int Int -> Int -> Int -> Int -> ST s ()
        spin _   r i n | i > n = return ()
        spin arr r i n = do x <- unsafeRead arr i
                            unsafeWrite arr i $ x + r
                            spin arr r (i + 1) n

        loop :: STUArray s Int Int -> Int -> ST s ()
        loop _   r | r > nRounds = return ()
        loop arr r = do
            k <- getNumElements arr
            spin arr r 0 (k - 1)
            loop arr (r + 1)

    loop arr 1


{-# LANGUAGE MagicHash #-}
module T4957 where

import GHC.Base

f :: Bool -> Int -> Int
f b 0 = 0
f b x = let y = case b of
                 True -> case f b (x-1) of
                            I# v -> I# (v -# 1#)
                 False -> case f b (x-1) of
                            I# v -> I# (v +# 1#)
      in
      case b of
         True -> case y of
                   I# w -> I# (w -# 1#)

         False -> case y of
                   I# w -> I# (w +# 1#)


-- In this test we do -ddump-simpl, and grep for 'patError.
-- We expect *not* to see patError in the output
-- because the branch is inaccessible.
-- In GHC 7.0 and earlier, we did get a patError in the output program.

{-# LANGUAGE TypeFamilies, GADTs #-}
module NoMatch where

data Tag
data TagExtra

--------

data Foo a where
  Foo :: String -> Foo a
  FooExtra :: Int -> Foo TagExtra

-- The cmm code for fooName does not match against 'FooExtra'
fooName :: Foo Tag -> String
fooName (Foo s) = s

--------

data Bar a where
  Bar :: String -> Bar a
  BarExtra :: a ~ TagExtra => Int -> Bar a

-- The cmm code for barName will try to pattern-match against 'BarExtra'
barName :: Bar Tag -> String
barName (Bar s) = s


{-# LANGUAGE KindSignatures, GADTs, TypeFamilies, MultiParamTypeClasses,  FlexibleContexts, ScopedTypeVariables, TypeSynonymInstances,  FlexibleInstances #-}
module T5303( showContextSeries ) where

import Control.Monad.State.Strict( StateT )
import Control.Monad.Trans ( lift )
import Data.Kind (Type)

data Tree (m :: Type -> Type) = Tree {}

data FL (a :: Type -> Type -> Type) x z where
    (:>:) :: a x y -> FL a y z -> FL a x z
    NilFL :: FL a x x

class (Functor m, Monad m) => ApplyMonad m (state :: (Type -> Type) -> Type)

class Apply (p :: Type -> Type -> Type) where
    type ApplyState p :: (Type -> Type) -> Type
    apply :: ApplyMonad m (ApplyState p) => p x y -> m ()

class (Functor m, Monad m, ApplyMonad (ApplyMonadOver m state) state)
      => ApplyMonadTrans m (state :: (Type -> Type) -> Type) where
  type ApplyMonadOver m state :: Type -> Type
  runApplyMonad :: (ApplyMonadOver m state) x -> state m -> m (x, state m)

instance (Functor m, Monad m) => ApplyMonadTrans m Tree where
  type ApplyMonadOver m Tree = TreeMonad m
  runApplyMonad = virtualTreeMonad

instance (Functor m, Monad m) => ApplyMonad (TreeMonad m) Tree

-- | Internal state of the 'TreeIO' monad. Keeps track of the current Tree
-- content, unsync'd changes and a current working directory (of the  monad).
data TreeState m = TreeState { tree :: !(Tree m) }
type TreeMonad m = StateT (TreeState m) m
type TreeIO = TreeMonad IO

virtualTreeMonad :: (Functor m, Monad m) => TreeMonad m a -> Tree m -> m  (a, Tree m)
virtualTreeMonad action t = undefined

applyToState :: forall p m x y. (Apply p, ApplyMonadTrans m (ApplyState p))
             => p x y -> (ApplyState p) m -> m ((ApplyState p) m)
applyToState _ _ = snd `fmap` runApplyMonad undefined undefined

showContextSeries :: (Apply p, ApplyState p ~ Tree) => FL p x y -> TreeIO ()
showContextSeries (p:>:_) = (undefined >>= lift . applyToState p) >>  return ()


module T5327 where

newtype Size = Size Int

{-# INLINABLE val2 #-}
val2 = Size 17

-- In the core, we should see a comparison against 34#, i.e. constant
-- folding should have happened. We actually see it twice: Once in f's
-- definition, and once in its unfolding.
f n = case val2 of Size s -> s + s > n


{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
{-# LANGUAGE UnicodeSyntax #-}
{-# LANGUAGE EmptyDataDecls #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}

module T5329 where

data PZero
data PSucc p

data Peano n where
  PZero âˆ· Peano PZero
  PSucc âˆ· IsPeano p â‡’ Peano p â†’ Peano (PSucc p)

class IsPeano n where
  peano âˆ· Peano n

instance IsPeano PZero where
  peano = PZero

instance IsPeano p â‡’ IsPeano (PSucc p) where
  peano = PSucc peano

class (n ~ PSucc (PPred n)) â‡’ PHasPred n where
  type PPred n

instance PHasPred (PSucc p) where
  type PPred (PSucc p) = p

pPred âˆ· Peano (PSucc p) â†’ Peano p
pPred (PSucc p) = p

infixl 6 :+:

class (IsPeano n, IsPeano m, IsPeano (n :+: m), (n :+: m) ~ (m :+: n))
      â‡’ PAdd n m where
  type n :+: m

instance PAdd PZero PZero where
  type PZero :+: PZero = PZero

instance IsPeano p â‡’ PAdd PZero (PSucc p) where
  type PZero :+: (PSucc p) = PSucc p

instance IsPeano p â‡’ PAdd (PSucc p) PZero where
  type (PSucc p) :+: PZero = PSucc p

instance (IsPeano n, IsPeano m, PAdd n m) â‡’ PAdd (PSucc n) (PSucc m) where
  type (PSucc n) :+: (PSucc m) = PSucc (PSucc (n :+: m))

data PAddResult n m r where
  PAddResult âˆ· (PAdd n m, PAdd m n, (n :+: m) ~ r)
             â‡’ PAddResult n m r

pAddLeftZero âˆ· âˆ€ n . IsPeano n â‡’ PAddResult PZero n n
pAddLeftZero = case peano âˆ· Peano n of
  PZero   â†’ PAddResult
  PSucc _ â†’ PAddResult

pAddRightZero âˆ· âˆ€ n . IsPeano n â‡’ PAddResult n PZero n
pAddRightZero = case peano âˆ· Peano n of
  PZero   â†’ PAddResult
  PSucc _ â†’ PAddResult

data PAddSucc n m where
  PAddSucc âˆ· (PAdd n m, PAdd m n,
              PAdd (PSucc n) m, PAdd m (PSucc n),
              PAdd n (PSucc m), PAdd (PSucc m) n,
              (PSucc n :+: m) ~ PSucc (n :+: m),
              (n :+: PSucc m) ~ PSucc (n :+: m))
           â‡’ PAddSucc n m

pAddSucc âˆ· âˆ€ n m . (IsPeano n, IsPeano m) â‡’ PAddSucc n m
pAddSucc = case (peano âˆ· Peano n, peano âˆ· Peano m) of
  (PZero,   PZero)   â†’ PAddSucc
  (PZero,   PSucc _) â†’ case pAddLeftZero âˆ· PAddResult n (PPred m) (PPred m) of
    PAddResult â†’ PAddSucc
  (PSucc _, PZero)   â†’ case pAddRightZero âˆ· PAddResult (PPred n) m (PPred n) of
    PAddResult â†’ PAddSucc
  (PSucc _, PSucc _) â†’ case pAddSucc âˆ· PAddSucc (PPred n) (PPred m) of
    PAddSucc â†’ PAddSucc

data PAdd2 n m where
  PAdd2 âˆ· (PAdd n m, PAdd m n) â‡’ PAdd2 n m

pAdd2 âˆ· âˆ€ n m . (IsPeano n, IsPeano m) â‡’ PAdd2 n m
pAdd2 = case (peano âˆ· Peano n, peano âˆ· Peano m) of
  (PZero,   PZero)   â†’ PAdd2
  (PZero,   PSucc _) â†’ PAdd2
  (PSucc _, PZero)   â†’ PAdd2
  (PSucc _, PSucc _) â†’ case pAdd2 âˆ· PAdd2 (PPred n) (PPred m) of
    PAdd2 â†’ PAdd2

data PAdd3 n m k where
  PAdd3 âˆ· (PAdd n m, PAdd m k, PAdd m n, PAdd k m, PAdd n k, PAdd k n,
           PAdd (n :+: m) k, PAdd k (m :+: n),
           PAdd n (m :+: k), PAdd (m :+: k) n,
           PAdd (n :+: k) m, PAdd m (n :+: k),
           ((n :+: m) :+: k) ~ (n :+: (m :+: k)),
           (m :+: (n :+: k)) ~ ((m :+: n) :+: k))
        â‡’ PAdd3 n m k

pAdd3 âˆ· âˆ€ n m k . (IsPeano n, IsPeano m, IsPeano k) â‡’ PAdd3 n m k
pAdd3 = case (peano âˆ· Peano n, peano âˆ· Peano m, peano âˆ· Peano k) of
  (PZero,   PZero,   PZero)   â†’ PAdd3
  (PZero,   PZero,   PSucc _) â†’ PAdd3
  (PZero,   PSucc _, PZero)   â†’ PAdd3
  (PSucc _, PZero,   PZero)   â†’ PAdd3
  (PZero,   PSucc _, PSucc _) â†’
    case pAdd2 âˆ· PAdd2 (PPred m) (PPred k) of
      PAdd2 â†’ PAdd3
  (PSucc _, PZero,   PSucc _) â†’
    case pAdd2 âˆ· PAdd2 (PPred n) (PPred k) of
      PAdd2 â†’ PAdd3
  (PSucc _, PSucc _, PZero)   â†’
    case pAdd2 âˆ· PAdd2 (PPred n) (PPred m) of
      PAdd2 â†’ PAdd3
  (PSucc _, PSucc _, PSucc _) â†’
    case pAdd3 âˆ· PAdd3 (PPred n) (PPred m) (PPred k) of
      PAdd3 â†’ case pAddSucc âˆ· PAddSucc (PPred n :+: PPred m) (PPred k) of
        PAddSucc â†’ case pAddSucc âˆ· PAddSucc (PPred n :+: PPred k) (PPred m) of
          PAddSucc â†’ case pAddSucc âˆ· PAddSucc (PPred m :+: PPred k) (PPred n) of
            PAddSucc â†’ PAdd3


{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
module T5342 (increaseAreas) where

import Control.Monad
import Data.List

nubSorted :: Eq a => [a] -> [a]
nubSorted = undefined

cellsAround :: (Num a, Num b, Ord a, Ord b) => [(a, b)] -> [(a, b)]
cellsAround = undefined

increaseAreas :: (Num a, Num b, Ord a, Ord b) => [[(a, b)]] -> [[(a, b)]]
increaseAreas areas
 = nubSorted $ sort $
     do
         area <- areas
         cell2 <- cellsAround area
         return $ sort $ cell2 : area


{-# LANGUAGE BangPatterns, RankNTypes, MagicHash, UnboxedTuples #-}

module T5359a (linesT) where

import GHC.Base hiding (empty)
import GHC.Word
import GHC.ST (ST(..), runST)

nullT :: Text -> Bool
nullT (Text _ _ len) = len <= 0
{-# INLINE [1] nullT #-}

spanT :: (Char -> Bool) -> Text -> (Text, Text)
spanT p t@(Text arr off len) = (textP arr off k, textP arr (off+k) (len-k))
  where k = loop 0
        loop !i | i >= len || not (p c) = i
                | otherwise             = loop (i+d)
            where Iter c d              = iter t i
{-# INLINE spanT #-}

linesT :: Text -> [Text]
linesT ps | nullT ps  = []
          | otherwise = h : if nullT t
                            then []
                            else linesT (unsafeTail t)
    where (h,t) = spanT (/= '\n') ps
{-# INLINE linesT #-}

unsafeTail :: Text -> Text
unsafeTail t@(Text arr off len) = Text arr (off+d) (len-d)
  where d = iter_ t 0
{-# INLINE unsafeTail #-}

data Iter = Iter {-# UNPACK #-} !Char {-# UNPACK #-} !Int

iter :: Text -> Int -> Iter
iter (Text arr _ _) i = Iter (unsafeChrT m) 1
  where m = unsafeIndex arr i
{-# INLINE iter #-}

iter_ :: Text -> Int -> Int
iter_ (Text arr off _) i | m < 0xD800 || m > 0xDBFF = 1
                         | otherwise                = 2
  where m = unsafeIndex arr (off+i)
{-# INLINE iter_ #-}

data Text = Text {-# UNPACK #-}!Array {-# UNPACK #-}!Int {-# UNPACK #-}!Int

text :: Array -> Int -> Int -> Text
text arr off len = Text arr off len
{-# INLINE text #-}

emptyT :: Text
emptyT = Text empty 0 0
{-# INLINE [1] emptyT #-}

textP :: Array -> Int -> Int -> Text
textP arr off len | len == 0  = emptyT
                  | otherwise = text arr off len
{-# INLINE textP #-}

unsafeChrT :: Word16 -> Char
unsafeChrT (W16# w#) = C# (chr# (word2Int# w#))
{-# INLINE unsafeChrT #-}

data Array = Array ByteArray#

data MArray s = MArray (MutableByteArray# s)

new :: forall s. Int -> ST s (MArray s)
new n@(I# len#)
  | n < 0 || n /= 0 = error $ "Data.Text.Array.new: size overflow"
  | otherwise = ST $ \s1# ->
       case newByteArray# len# s1# of
         (# s2#, marr# #) -> (# s2#, MArray marr# #)
{-# INLINE new #-}

unsafeFreeze :: MArray s -> ST s Array
unsafeFreeze (MArray maBA) = ST $ \s# -> (# s#, Array (unsafeCoerce# maBA) #)
{-# INLINE unsafeFreeze #-}

unsafeIndex :: Array -> Int -> Word16
unsafeIndex (Array aBA) (I# i#) =
    case indexWord16Array# aBA i# of r# -> (W16# r#)
{-# INLINE unsafeIndex #-}

empty :: Array
empty = runST (new 0 >>= unsafeFreeze)


{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeOperators #-}

module T5359b where

-----------------------------------------------------------------------------
-- Base
-----------------------------------------------------------------------------
infixr 5 :+:
infixr 6 :*:

data U       = U
data a :+: b = L a | R b
data a :*: b = a :*: b
newtype Rec a   = Rec a

class Representable a where
  type Rep a
  to   :: Rep a -> a
  from :: a -> Rep a

data Tree = Leaf | Bin Int Tree Tree

instance Representable Tree where
  type Rep Tree =     U
                      :+: (Rec Int :*: Rec Tree :*: Rec Tree)

  from (Bin x l r) = R ((Rec x :*: Rec l :*: Rec r))
  from Leaf        = L (U)

  to (R ((Rec x :*: (Rec l) :*: (Rec r)))) = Bin x l r
  to (L (U))                               = Leaf

--------------------------------------------------------------------------------
-- Generic enum
--------------------------------------------------------------------------------

class Enum' a where
  enum' :: [a]

instance Enum' U where enum' = undefined
instance (Enum' a) => Enum' (Rec a) where enum' = undefined
instance (Enum' f, Enum' g) => Enum' (f :+: g) where enum' = undefined
instance (Enum' f, Enum' g) => Enum' (f :*: g) where enum' = undefined

-- This INLINE pragma is essential for the bug
{-# INLINE genum #-}
genum :: (Representable a, Enum' (Rep a)) => [a]
-- The definition of genum is essential for the bug
genum = map to enum'

instance Enum' Tree where enum' = genum
instance Enum' Int  where enum' = []

-- This SPECIALISE pragma is essential for the bug
{-# SPECIALISE genum :: [Tree] #-}


module T5366 where

newtype Id a = Id Int
data Foo = Foo {-# UNPACK #-} !(Id Foo) String
data Bar = Bar {-# UNPACK #-} !Foo

f :: Bar -> Int
f (Bar (Foo (Id x) _)) = x


module Foo where

type T a = Int

f :: T a -> Bool -> [Int]
f x b = case b of
               True  -> f x b
               False -> x : f x (x > 19)


module T5550 where

import GHC.Exts ( SpecConstrAnnotation(..) )

data SPEC = SPEC | SPEC2
{-# ANN type SPEC ForceSpecConstr #-}

loop :: SPEC -> [Int] -> [Int] -> [Int]
loop SPEC z [] = z
loop SPEC z (x:xs) = loop SPEC (x:z) xs


main :: IO ()
main = do
  printInt $ 9999 `div` 5
  printInt $ 9999 `mod` 5
  n <- readLn
  printInt $ n `div` 4
  printInt $ n `mod` 4

printInt :: Int -> IO ()
printInt = print


module T5623 where

import Foreign.Storable
import Control.Monad
import GHC.Ptr

foo :: Ptr Float -> IO Float
foo p = liftM2 (+) (peekElemOff q 0) (peekElemOff q 1)
  where
    q = p `plusPtr` 4


{-# LANGUAGE MagicHash, BangPatterns #-}
module T5658b where
import GHC.Prim
import GHC.Exts ( isTrue# )

foo :: ByteArray# -> ByteArray# -> Int# -> Int# -> Bool
foo xs ys m n = go 0# 0#
  where
    go i j = case isTrue# (i >=# m) of
      False -> let !x = indexIntArray# xs i in
        case isTrue# (j >=# n) of
          False -> case isTrue# (x ==# indexIntArray# ys j) of
            False -> False
            True  -> go (i +# 1#) (j +# 1#)
          True -> False
      True -> case isTrue# (j >=# n) of
        False -> let !y = indexIntArray# ys i in False
        True -> True


module T5776 where

-- The point about this test is that we should get a rule like this:
-- "foo" [ALWAYS]
--    forall (@ a)
--           ($dEq  :: Eq a)
--           ($dEq1 :: Eq a)
--           (x :: a)
--           (y :: a)
--           (z :: a).
--      T5776.f (g @ a $dEq1 x y)
--              (g @ a $dEq  y z)
--      = GHC.Types.True
--
-- Note the *two* forall'd dEq parameters. This is important.
-- See Note [Simplifying RULE lhs constraints] in TcSimplify

{-# RULES "foo" forall x y z.
      f (g x y) (g y z) = True
 #-}

g :: Eq a => a -> a -> Bool
{-# NOINLINE g #-}
g = (==)

f :: Bool -> Bool -> Bool
{-# NOINLINE f #-}
f a b = False

blah :: Int -> Int -> Bool
blah x y = f (g x y) (g x y)


{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
module T5821 where

type family T a
type instance T Int = Bool

foo :: Num a => a -> T a
foo = undefined

{-# SPECIALISE foo :: Int -> Bool #-}


module T5996 where

data C a b = C a b
a = undefined
{-# NOINLINE a #-}
b = undefined
{-# NOINLINE b #-}

x1 = C a b
x2 = C x1 b
y1 = C a b
y2 = C y1 b


module T6056 where
import T6056a

foo :: Int -> (Maybe Int, [Int])
foo x = smallerAndRest x [x]


module T6056a where

smallerAndRest :: Ord a => a -> [a] -> (Maybe a, [a])
smallerAndRest x [] = (Nothing, [])
smallerAndRest x (y:ys) | y < x = (Just y, ys)
                        | otherwise = smallerAndRest x ys

{-# INLINABLE smallerAndRest #-}


module T6082_RULE where

-- Should warn
foo1 x = x
{-# RULES "foo1" forall x. foo1 x = x #-}

-- Should warn
foo2 x = x
{-# INLINE foo2 #-}
{-# RULES "foo2" forall x. foo2 x = x #-}

-- Should not warn
foo3 x = x
{-# NOINLINE foo3 #-}
{-# RULES "foo3" forall x. foo3 x = x #-}


{-# LANGUAGE MagicHash, UnboxedTuples #-}

module Float where

import GHC.Prim

foo vs
  = let w = if length (reverse vs) > 10 then Just (length vs) else Nothing

        f :: State# RealWorld -> Int -> (# Int, State# RealWorld #)
        f s x | Just 0 <- w = case f s (x+1) of
                        (# r, s' #) -> (# r, s' #)
              | otherwise = (# x, s #)

    in f realWorld# 1


import Data.Char

{-# RULES "map-loop" [~] forall f . map' f = map' (id . f) #-}

{-# NOINLINE map' #-}
map' f [] = []
map' f (x:xs) = f x : map' f xs

main = print (map' toUpper "Hello, World")


module T7165 where

import T7165a

meh = blah (0,0)


{-# LANGUAGE GADTs #-}

module T7165a where

blah :: (dd ~ (Double, Double)) => dd -> dd
blah (ax, bx)
    | ax < bx = blah (bx, ax)
    | otherwise = (0,0)


{-# LANGUAGE MagicHash #-}
module T7287 where

import GHC.Prim

{-# RULES
  "int2Word#/word2Int#" forall x. int2Word# (word2Int# x) = x
  #-}

{- We get a legitimate

   T7287.hs:7:3: warning:
       Rule int2Word#/word2Int# may never fire because
         rule "word2Int#" for â€˜word2Int#â€™ might fire first
       Probable fix: add phase [n] or [~n] to the competing rule

because rule "word2Int#" is the constant folding rule that converts
a sufficiently-narrow Word# literal to an Int#.  There is a similar
one for int2Word#, so the whole lot is confluent. -}


-- Both these functions should successfully simplify
-- using the combine-identical-alternatives optimisation

module T7360 where

import GHC.List as L

data Foo = Foo1 | Foo2 | Foo3 !Int

fun1 :: Foo -> ()
{-# NOINLINE fun1 #-}
fun1 x = case x of
               Foo1 -> ()
               Foo2 -> ()
               Foo3 {} -> ()

fun2 x = (fun1 Foo1,  -- Keep -ddump-simpl output
                      -- in a predicatable order
         case x of
          [] -> L.length x
          (_:_) -> L.length x)


-- The contents of this file are irrelevant. It is merely
-- the target for compilation by the T7702Plugin, which
-- exhibits the space leak in Trac #7702
module Main where

main :: IO ()
main = return ()


{-# LANGUAGE TypeFamilies, ConstraintKinds #-}

module Foo( shared, foo, bar) where
-- module Foo where

import Data.Kind

{-
foo :: [Int] -> [Int]
foo = let f = map negate
      in   f.  f.  f.  f.  f.  f.  f.  f.  f.  f.  f.  f.  f.  f.  f.  f.  f.  f.  f.  f.  f.  f.  f.
           f.  f.  f.  f.  f.  f.  f.  f.  f.  f.  f.  f.  f.  f.  f.  f.  f.  f.  f.  f.  f.  f.  f.
           f.  f.  f.  f.  f.  f.  f.  f.  f.  f.  f.  f.  f.  f.  f.  f.  f.  f.  f.  f.  f.  f.  f.
           f.  f.  f.  f.  f.  f.  f.  f.  f.  f.  f.  f.  f.  f.  f.  f.  f.  f.  f.  f.  f.  f.  f.
           f . f . f . f . f . f . f . f . f . f . f . f . f

-}

type family Domain (f :: Type -> Type) a :: Constraint

type instance Domain [] a = ()

instance MyFunctor [] where
  myfmap = map

class MyFunctor f where
  myfmap :: (Domain f a, Domain f b) => (a -> b) -> f a -> f b

shared :: (MyFunctor f, Domain f Int) => f Int -> f Int
shared = let
  f = myfmap negate
  in
  f.  f.  f.  f.  f.  f.  f.  f.  f.  f.  f.  f.  f.  f.  f.  f.  f.  f.  f.  f.  f.  f.  f.
  f.  f.  f.  f.  f.  f.  f.  f.  f.  f.  f.  f.  f.  f.  f.  f.  f.  f.  f.  f.  f.  f.  f.
  f.  f.  f.  f.  f.  f.  f.  f.  f.  f.  f.  f.  f.  f.  f.  f.  f.  f.  f.  f.  f.  f.  f.
  f.  f.  f.  f.  f.  f.  f.  f.  f.  f.  f.  f.  f.  f.  f.  f.  f.  f.  f.  f.  f.  f.  f.
  f . f . f . f . f . f . f . f . f . f . f . f . f

foo xs = shared $ 0:xs
bar xs = 0:shared xs


{-# LANGUAGE MagicHash #-}

module T7796 where

import GHC.Prim

--
-- test for #7796
--
-- created by nicolas.frisby@gmail.com, feel free to email me!
--
-- a delicate interaction between specialisation and w/w creates a
-- binding that is dead but is allocated at run-time
--

--
-- we grep the -ddump-prep for $s$go, and the actual test expects a
-- particular number of hits
--
-- thus the test will fail in two scenarios:
--
--   * the actually interesting case where the zombie $s$go binding
--     survives, or
--
--   * the naming convention for specialised things changes, in which
--     case the Makefile rule for this test needs to be updated to
--     scrape the -ddump-prep output differently
--

--
-- the zombie binding is $sgo; here's how we reproduce it:
--
--   1. specialise go such that the RHS of $sgo uses both $sgo and go
--
--   2. worker-wrapper $sgo but *not* go
--
-- thus: $sgo uses $w$sgo uses go uses $sgo
--
-- the key point: the last "use" is only via a RULE; see the ticket
-- #7796 for more discussion and related tickets
--

data L = C Int# L | N Int# -- I'm using unboxed elements to avoid ww'd
                           -- unrelated to the bug

host :: Eq b => b -> L -> Bool
host b x =
  let go :: Eq a =>  -- must be used (to trigger specialise), but not
                     -- strict (else we ww the unspecialised version)

            a ->     -- must be strict, so that we ww the
                     -- specialisation

            L ->     -- not sure what this needs... but strict is
                     -- doing the trick

            Bool

      go d (N i) = d `seq` case i of
        0# -> True
        o  -> go b (N (i -# 1#)) -- NB must at (a ~ b)

      go d (C x xs) = (d == d) `seq` go d (C (x -# 1#) xs)
  in go (3 :: Int) x


module T7865 where

-- Our very expensive operation that we don't want to perform more than once
-- Don't inline it so we can see exactly where it's called in the core
{-# NOINLINE expensive #-}
expensive :: Int -> Int
expensive x = x * 100000

-- SpecConstr this function:
recursive :: [Int] -> (Int,Int) -> (Int,Int)
recursive list acc
 = case list of
   []     -> acc
   (x:xs) ->
     -- Our expensive tuple:
     -- The case is here mainly so that the expensive let isn't floated out before SpecConstr.
     let a'    = case xs of
                 [] -> acc
                 (_:_) -> (let b = expensive x in (b * 2), x)
         -- Use the expensive value once and recurse.
         -- We recurse with (_:_:_) so that a specialisation is made for that pattern,
         -- which simplifies the case xs above. This exposes the expensive let.
         (p,q) = case a' of (p',q') -> recursive (x:x:xs) (q',p')

         -- Use the expensive value again.
         -- Our problem is that this shows up as a separate let-binding for expensive, instead of reusing
         -- the already computed value from above.
     in  (p + fst a', q + snd a')


module T7944 where

import GHC.Exts

-- Force specialisation of "go"
data SPEC = SPEC | SPEC2
{-# ANN type SPEC ForceSpecConstr #-}

-- This is more or less just an ordinary fold
go :: SPEC -> [a] -> IntMap a -> IntMap a
go SPEC [] m = m
go SPEC (_:xs) m
 = go SPEC xs
 -- This would be the "worker function" of the fold
 $ Unary m

-- Both constructors are necessary, despite only one being used
data IntMap a = Nil | Unary (IntMap a)


-- We import Pretty from package ghc
module T7995 where
import Pretty

foo = text "test"


{-# LANGUAGE PolyKinds #-}
{-# OPTIONS_GHC -dcore-lint -O #-}
module T8196 where

data T a b = MkT (a b)
   deriving Show

foo = print (MkT (Just True))


module T8221 where

import T8221a

data Located e = L () e deriving Eq


module T8221a where

import Data.IORef

data Link a = Link !(IORef (Link a)) | X

instance Eq (Link a) where
 (==) (Link x) (Link y) = x==y


module T8221b where

data Link a = Link a !(Link a)


{-# LANGUAGE MagicHash #-}
module T8274 where

import GHC.Prim

data P = Positives Int# Float# Double# Char# Word#
data N = Negatives Int# Float# Double#

p = Positives 42# 4.23# 4.23## '4'# 4##
n = Negatives -4# -4.0# -4.0##


module T8329 where

import T8329_Parse
import T8329_Com


module T8329_Com where

import Data.String (fromString)

encodingName :: String
encodingName = fromString ""


{-# OPTIONS_GHC -O0 #-}

module T8329_Meta where

import Data.String


module T8329_Parse where

import T8329_Meta


{-# LANGUAGE FlexibleInstances, RankNTypes #-}

module Main ( main, useAbstractMonad ) where

import Control.Monad
import Control.Monad.ST
import Control.Applicative

newtype ReaderT r m a = ReaderT {
        -- | The underlying computation, as a function of the environment.
        runReaderT :: r -> m a
    }

instance (Applicative m) => Applicative (ReaderT r m) where
    pure    = liftReaderT . pure
    f <*> v = ReaderT $ \ r -> runReaderT f r <*> runReaderT v r

instance (Functor m) => Functor (ReaderT r m) where
    fmap f  = mapReaderT (fmap f)

instance (Monad m) => Monad (ReaderT r m) where
    return x  = ReaderT (\_ -> return x)
    m >>= k  = ReaderT $ \ r -> do
        a <- runReaderT m r
        runReaderT (k a) r
    fail msg = ReaderT (\_ -> fail msg)

mapReaderT :: (m a -> n b) -> ReaderT r m a -> ReaderT r n b
mapReaderT f m = ReaderT $ f . runReaderT m

liftReaderT :: m a -> ReaderT r m a
liftReaderT m = ReaderT (const m)

ask :: (Monad m) => ReaderT r m r
ask = ReaderT return

class (Applicative m, Functor m , Monad m) => MonadAbstractIOST m where
    addstuff :: Int -> m Int

type ReaderST s = ReaderT (Int) (ST s)

instance MonadAbstractIOST (ReaderST s) where
    addstuff a = return . (a +) =<< ask

runAbstractST :: (forall s. ReaderST s a) -> a
runAbstractST f = runST $ runReaderT f 99

{-# SPECIALIZE useAbstractMonad :: Int -> ReaderST s Int #-}
-- Note the polymorphism
useAbstractMonad :: MonadAbstractIOST m => Int -> m Int
useAbstractMonad n = foldM (\a b -> a `seq` return . (a +) =<< (addstuff b)) 0 [1..n]

-- useConcreteMonad :: Int -> ReaderST s Int
-- useConcreteMonad = foldM (\a b -> a `seq` return . (a +) =<< (addstuff b)) 0 [1..n]

main :: IO ()
main = do
    let st = runAbstractST (useAbstractMonad 5000000)
    putStrLn . show $ st


{-# LANGUAGE GADTs, DataKinds, KindSignatures, FlexibleInstances #-}

module T8537 where

import Data.Functor

data Nat = S !Nat  | Z

infixr 3 :*

data Shape (rank :: Nat) a where
    Nil  :: Shape Z a
    (:*) ::  !(a) -> !(Shape r a ) -> Shape  (S r) a

instance Functor (Shape Z) where

    fmap  = \ f Nil -> Nil
    {-# INLINABLE fmap #-}

    {-# SPECIALIZE fmap :: (Int ->Int )-> (Shape Z Int)-> (Shape Z Int) #-}


{-# LANGUAGE ExistentialQuantification #-}
module T8714 where

data HLState = forall a. HLState (a -> a) !a

data BufferImpl = FBufferData !HLState

focusAst :: BufferImpl -> HLState
focusAst (FBufferData (HLState f x)) = HLState f (f x)


{-# LANGUAGE CPP #-}

-- I'm concerned that the -ddump-simpl output may differ on 32 and 64-bit
-- platforms.  So far I've only put in output for 64-bit platforms.

module T8832 where

import Data.Bits
import Data.Int
import Data.Word

#define T(s,T) \
s :: T ; \
s = clearBit (bit 0) 0 ; \

T(i,Int)
T(i8,Int8)
T(i16,Int16)
T(i32,Int32)
#ifdef T8832_WORDSIZE_64
T(i64,Int64)
#endif

T(w,Word)
T(w8,Word8)
T(w16,Word16)
T(w32,Word32)
#ifdef T8832_WORDSIZE_64
T(w64,Word64)
#endif

T(z,Integer)


{-# OPTIONS_GHC -fno-warn-missing-methods #-}
{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
{-# LANGUAGE KindSignatures, GADTs, DataKinds, FlexibleInstances, FlexibleContexts #-}

module T8848 where

import qualified Control.Applicative as A
import qualified Data.Functor as Fun

data Nat = S Nat  | Z

data Shape (rank :: Nat) a where
    Nil  :: Shape Z a
    (:*) ::  a -> Shape r a -> Shape  (S r) a

instance A.Applicative (Shape Z) where
instance A.Applicative (Shape r)=> A.Applicative (Shape (S r)) where
instance Fun.Functor (Shape Z) where
instance (Fun.Functor (Shape r)) => Fun.Functor (Shape (S r)) where

map2 :: (A.Applicative (Shape r))=> (a->b ->c) -> (Shape r a) -> (Shape r b) -> [Shape r c]
-- Artificially made recursive so that it won't inline,
-- so we can see if the specialisation happens
map2 = \f l r -> (A.pure f A.<*>  l  A.<*> r) : map2 f l r

{-# SPECIALIZE map2 :: (a->b->c)
                    -> (Shape (S (S Z)) a )
                    -> Shape (S (S Z)) b
                    -> [Shape (S (S Z)) c] #-}

map3 :: (a->b->c)-> (Shape (S (S Z)) a )-> Shape (S (S Z)) b -> [Shape (S (S Z)) c]
map3 x y z = map2 x y z


{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
module T8848a where

f :: Ord a => b -> a -> a
f y x = x

{-# SPECIALISE f :: b -> [Int] -> [Int] #-}

{- Specialised badly:

"SPEC Spec.f" [ALWAYS]
    forall (@ b_aX7).
      Spec.f @ b_aX7
             @ [GHC.Types.Int]
             (GHC.Classes.$fOrd[]
                @ GHC.Types.Int
                (GHC.Classes.$fEq[] @ GHC.Types.Int GHC.Classes.$fEqInt)
                GHC.Classes.$fOrdInt)
      = Spec.f_$sf @ b_aX7
-}


module T9400 (main) where
import GHC.Base

str = "defg"

main :: IO ()
main = do
    case "abc" of
        (x:y:xs) -> putStrLn xs
    case "" of
        [] -> putStrLn "x"
    case "ab" of
        [] -> putStrLn "y"
        (x:y:[]) -> putStrLn "z"
    case str of
        (x:xs) -> putStrLn xs
    case "ab" of
        "" -> putStrLn "fail"


module T9441a where

f1 :: Integer -> Integer
f1 1 = 1
f1 n = n * f1 (n - 1)

f2 :: Integer -> Integer
f2 1 = 1
f2 m = m * f2 (m - 1)


module T9441b where

f1 :: Integer -> Integer
f1 n
    | n <= 1 = 1
    | otherwise = go n 1
  where
    go 0 r = r
    go m r = go (m - 1) (r * m)

f2 :: Integer -> Integer
f2 n = go n 1
  where
    go 0 s = s
    go p s = go (p - 1) (s * p)


module T9441 where
-- Core output should show only one recursive Bind Rec { .. }
import GHC.Exts (build)

{-# INLINE reverse' #-}
reverse' :: [a] -> [a]
reverse' xs = build $ \c n -> foldl (\a x -> x `c` a) n xs

appRev :: [a] -> [a] -> [a]
appRev xs ys = xs ++ reverse' ys

revAppRev :: [a] -> [a] -> [a]
revAppRev xs ys = reverse' xs ++ reverse' ys


module T9509 (main) where

import T9509a

main = foo (5 :: Int) >>= print


module T9509a (foo) where

import Data.IORef

foo :: Ord a => a -> IO a
{-# INLINABLE foo #-}
foo x = newIORef x >>= readIORef >>= \y ->
        case compare x y of
           LT ->  return x
           _  ->  foo x   -- Recursive so it won't inline


{-# LANGUAGE TypeFamilies, FlexibleContexts, UndecidableInstances #-}

-- This is a copy of typecheck/should_run/T3500b, but it's here for
-- a different reason: at one time, it sent the compiler into a loop.
-- ANd T3500b isn't tested 'fast' mode

module T9565 where

newtype Mu f = Mu (f (Mu f))

type family Id m
type instance Id m = m

instance Show (Id (f (Mu f))) => Show (Mu f) where
    show (Mu f) = show f

showMu :: Mu (Either ()) -> String
showMu = show

item :: Mu (Either ())
item = Mu (Right (Mu (Left ())))

main = print (showMu item)


{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# OPTIONS_GHC -O #-}

module T9583 where

import Data.Binary      ( Binary(..) )
import Data.Data        ( Data )
import Data.Typeable    ( Typeable )
import GHC.Generics     ( Generic )

data T = A
       | B
       | C T
       | D T T
       | E T T
  deriving (Data, Generic, Typeable)

instance Binary T


module A where

import B

data HsExpr id
  = HsOverLit (HsOverLit id)
  | HsBracketOut (HsExpr id)
  deriving Eq


module B where

import {-# SOURCE #-} A (HsExpr)

data HsOverLit id
  = OverLit (HsExpr id)
  deriving Eq


import Distribution.Simple

main = defaultMain


module T7702Plugin ( plugin )  where

import GhcPlugins

-- A plugin that does nothing but tickle CoreM's writer.
plugin :: Plugin
plugin = defaultPlugin { installCoreToDos = install }
    where
        install :: [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo]
        install _ todos = do

            putMsgS "T7702Plugin"

            -- 1 million times, so the allocation in this plugin dominates allocation due
            -- to other compiler flags and the test framework can easily catch the difference
            -- can't use replicateM_ because it causes its own problems
            nothingX100000 ; nothingX100000 ; nothingX100000 ; nothingX100000 ; nothingX100000
            nothingX100000 ; nothingX100000 ; nothingX100000 ; nothingX100000 ; nothingX100000

            return todos

-- this will result in a call to plusWriter in CoreM's
-- >>= implementation, which was causing the space leak
nothing :: CoreM ()
nothing = liftIO (return ())

nothingX10 :: CoreM ()
nothingX10 = do
    nothing ; nothing ; nothing ; nothing ; nothing
    nothing ; nothing ; nothing ; nothing ; nothing

nothingX100 :: CoreM ()
nothingX100 = do
    nothingX10 ; nothingX10 ; nothingX10 ; nothingX10 ; nothingX10
    nothingX10 ; nothingX10 ; nothingX10 ; nothingX10 ; nothingX10

nothingX1000 :: CoreM ()
nothingX1000 = do
    nothingX100 ; nothingX100 ; nothingX100 ; nothingX100 ; nothingX100
    nothingX100 ; nothingX100 ; nothingX100 ; nothingX100 ; nothingX100

nothingX10000 :: CoreM ()
nothingX10000 = do
    nothingX1000 ; nothingX1000 ; nothingX1000 ; nothingX1000 ; nothingX1000
    nothingX1000 ; nothingX1000 ; nothingX1000 ; nothingX1000 ; nothingX1000

nothingX100000 :: CoreM ()
nothingX100000 = do
    nothingX10000 ; nothingX10000 ; nothingX10000 ; nothingX10000 ; nothingX10000
    nothingX10000 ; nothingX10000 ; nothingX10000 ; nothingX10000 ; nothingX10000


import Control.Exception
import Control.DeepSeq
main = evaluate (('a' : undefined) `deepseq` return () :: IO ())


{-# LANGUAGE MagicHash #-}

import GHC.Exts
import Unsafe.Coerce
import Data.Array

newtype Age = Age Int

fooAge :: Array Int Int -> Array Int Age
fooAge = fmap Age
fooCoerce :: Array Int Int -> Array Int Age
fooCoerce = fmap coerce
fooUnsafeCoerce :: Array Int Int -> Array Int Age
fooUnsafeCoerce = fmap unsafeCoerce

same :: a -> b -> IO ()
same x y = case reallyUnsafePtrEquality# (unsafeCoerce x) y of
    1# -> putStrLn "yes"
    _  -> putStrLn "no"

main = do
    let l = listArray (1,3) [1,2,3]
    same (fooAge l) l
    same (fooCoerce l) l
    same (fooUnsafeCoerce l) l


import Control.Monad.ST
import Data.STRef

-- Make sure that the realWord# token used by runST (actually by runSTRep) is
-- not inlined, which would share the call to `newMutVar#`, and suddenly there
-- would be only one MutVar

main =
    let f () = runST $ do
        ref <- newSTRef 0
        modifySTRef ref (+1)
        readSTRef ref
    in print (f () + f ())


-- This test checks that the magic treatment of RULES
-- for 'seq' works right.
--
-- See Note [RULES for seq] in MkId for more details

module Main where

{-# NOINLINE f #-}
f x = not x

{-# RULES
     "f/seq" forall n.  seq (f n) = const True
 #-}

main = print (seq (f True) False)


-- !!! Test filter fusion

-- In GHC 4.06, the filterFB rule was back to front, which
-- made this program hit the "error foo" case instead of
-- working fine.

module Main where

main :: IO ()
main = print (length (filter (not . foo)
                             (filter (const False) [Nothing])))
  where foo (Just x) = x
        foo _        = error "foo"


-- !!! A rules test
-- At one time the rule got too specialised a type:
--
--  _R "ffoo" forall {@ a1 v :: (a1, ((), ()))}
--            fst @ a1 @ () (sndSnd @ a1 @ () @ () v) = fst @ a1 @ ((), ()) v

module Main where

import System.IO
import System.IO.Unsafe ( unsafePerformIO )

{-# NOINLINE [0] sndSnd #-}
-- Don't inline till last, to give the rule a chance
sndSnd (a,(b,c)) = (a,c)

{-# NOINLINE [2] myFst #-}
-- Don't inline till last, to give the rule a chance
myFst (a,b) = a

trace x y = unsafePerformIO (hPutStr stderr x >> hPutStr stderr "\n" >> return y)

{-# RULES "foo" forall v .  myFst (sndSnd v) = trace "Yes" (fst v) #-}

main :: IO ()
main = print (myFst (sndSnd (True, (False,True))))


{-# LANGUAGE UnboxedTuples #-}

-- O2 to get CSE

module Main where

f :: Int -> (# Int, Int #)
f 0 = (# 1,2 #)
f n = f (n-1)

{-# NOINLINE g #-}
g x = case f x of
        (# a,b #) -> if a>0
                     then f x   -- CSE opportunity
                     else (# b,a #)

-- GHC 6.2 wrongly optimised g to:
--      case f x of t
--        (# a,b #) -> if a>0 then
--                        t     -- WRONG
--                      else (# b,a #)

main = case g 2 of (# a,b #) -> print a


module Main where

-- A test for loss of sharing.  GHC 6.4.1 did a bogus preInlineUnconditionally

import Control.Monad ( guard )

expensive 0 = True
expensive 1 = False
expensive n = expensive (n-2)

f g = if expensive (1000000*(fst g)) then odd else even

---------------------------------------------------------
-- The key point is that the (c g) call should not get pushed inside the \x,
-- as happened in 6.4.1.  Doing so loses laziness, and this test shows up
-- the difference in performance
gen_sucW grow c g
  = \ x -> grow g x >>= \ y -> do guard $ check y; return y
  where
    check = c g

sucW = gen_sucW (\ g x -> map (+x) [fst g..snd g]) f (11,500000)

main = print (sum $ sucW 11,sum $ sucW 12)

-- Because this version uses a case expression, the bug
-- doesn't happen and execution is much faster
gen_sucC grow c g = case c g of
           check -> \ x -> grow g x >>= \ y -> do guard $ check y; return y

sucC = gen_sucC (\ g x -> map (+x) [fst g..snd g]) f (11,500000)

mainC = print (sum $ sucC 11,sum $ sucC 12)


module Main where

main = print (fib' 100)
        -- This will time out unless memoing works properly

data Nat = Z | S Nat
           deriving (Show, Eq)

memo f = g
  where
    fz = f Z
    fs = memo (f . S)
    g  Z    = fz
    g (S n) = fs n
        -- It is a BAD BUG to inline 'fs' inside g
        -- and that happened in 6.4.1, resulting in exponential behaviour

-- memo f = g (f Z) (memo (f . S))
--        = g (f Z) (g (f (S Z)) (memo (f . S . S)))
--        = g (f Z) (g (f (S Z)) (g (f (S (S Z))) (memo (f . S . S . S))))

fib' :: Nat -> Integer
fib'             =  memo fib
  where
  fib Z          =  0
  fib (S Z)      =  1
  fib (S (S n))  =  fib' (S n) + fib' n

instance Num Nat where
  fromInteger 0        =  Z
  fromInteger n        =  S (fromInteger (n - 1))
  Z + n                =  n
  S m + n              =  S (m + n)
  Z * n                =  Z
  S m * n              =  (m * n) + n
  Z - n                =  Z
  S m - Z              =  S m
  S m - S n            =  m - n

instance Enum Nat where
  succ                 =  S
  pred Z               =  Z
  pred (S n)           =  n
  toEnum               =  fromInteger . toInteger
  fromEnum Z           =  0
  fromEnum (S n)       =  fromEnum n + 1


{-# LANGUAGE MagicHash #-}

-- Actually, this exercises prelude/PrelRules, but this is the closest
-- place I could find to put it...

import GHC.Exts
import Numeric
import Data.Bits

main = do phex (I# (uncheckedIShiftL#  (negateInt# 5#) 2#))
          phex (I# (uncheckedIShiftRA# (negateInt# 5#) 1#))
          phex (I# (uncheckedIShiftRL# (negateInt# 5#) 1#))
          phex (W# (uncheckedShiftL#   (int2Word# (negateInt# 5#)) 2#))
          phex (W# (uncheckedShiftRL#  (int2Word# (negateInt# 5#)) 1#))

phex x = putStrLn (showSigned (\x -> ("0x"++) . showHex x) 0 x "")

{- Too wordsize-dependent
phex x = putStrLn (hex x)
hex x = "0x" ++ [onedigit (fromIntegral ((x `shiftR` (i*4)) .&. 0xF))
                 | i <- [digits-1,digits-2..0]]
    where
    digits = bitSize x `div` 4
    onedigit n = "0123456789abcdef" !! n
-}


module Main where
import Data.Char

{-# NOINLINE f #-}
f :: Int -> String
f x = "NOT FIRED"

{-# NOINLINE neg #-}
neg :: Int -> Int
neg = negate

{-# NOINLINE myord #-}
myord :: Char -> Int
myord = ord

{-# RULES
     "f" forall (c::Char->Int) (x::Char). f (c x) = "RULE FIRED"
 #-}

main = do { print (f (myord 'a'))       -- Rule should fire
          ; print (f (neg 1)) }         -- Rule should not fire


{-# LANGUAGE ExistentialQuantification #-}

-- This test is really meant for human looking; do a -ddump-simpl.

-- The definition that you want to look at is for foo.
-- It produces a nested unfold that should look something
-- like the code below.  Note the 'lvl1_shW'.  It is BAD
-- if this is a lambda instead; you get a lot more allocation
-- See Note [Escaping a value lambda] in SetLevels

{-
      $wunfold_shU =
        \ (ww_she :: [[a_abm]]) (ww1_shf :: Data.Maybe.Maybe (Stream.Stream a_abm)) ->
          case ww1_shf of wild2_afo {
            Data.Maybe.Nothing ->
              case ww_she of wild_ad6 {
                [] -> GHC.Base.[] @ a_abm;
                : x_ado xs1_adp ->
                  $wunfold_shU
                    xs1_adp
                    (Data.Maybe.Just
                       @ (Stream.Stream a_abm) (Stream.Stream @ a_abm @ [a_abm]
                                                                *** lvl1_shW ***
                                                                x_ado))
              };
            Data.Maybe.Just ds3_afJ ->
              case ds3_afJ of wild3_afL { Stream.Stream @ s1_afN stepb_afO sb_afP ->
              case stepb_afO sb_afP of wild4_afR {
                Stream.Done -> $wunfold_shU ww_she (Data.Maybe.Nothing @ (Stream.Stream a_abm));
                Stream.Yield x_afV sb'_afW ->
                  GHC.Base.:
                    @ a_abm
                    x_afV
                    ($wunfold_shU
                       ww_she
                       (Data.Maybe.Just
                          @ (Stream.Stream a_abm) (Stream.Stream @ a_abm @ s1_afN stepb_afO sb'_afW)));
                Stream.Skip sb'_afZ ->
                  $wunfold_shU
                    ww_she
                    (Data.Maybe.Just
                       @ (Stream.Stream a_abm) (Stream.Stream @ a_abm @ s1_afN stepb_afO sb'_afZ))
              }
              }
-}

module Main( main, foo ) where
-- Must export foo to make the issue show up

import Prelude hiding ( concatMap, map)

main = print (sum (foo [[1,2], [3,4,5]]))

foo :: Num a => [[a]] -> [a]
foo xss = Main.concatMap (\xs -> Main.map (+1) xs) xss

instance StreamableSequence [] where
  stream = listToStream
  unstream = streamToList
  -- These inline pragmas are useless (see #5084)
{-
  {-# INLINE stream #-}
  {-# INLINE unstream #-}
-}

listToStream :: [a] -> Stream a
listToStream xs = Stream next xs
  where next []     = Done
        next (x:xs) = Yield x xs
{-# INLINE [0] listToStream #-}

streamToList :: Stream a -> [a]
streamToList (Stream next s) = unfold s
  where unfold s =
          case next s of
            Done       -> []
            Skip    s' ->     unfold s'
            Yield x s' -> x : unfold s'
{-# INLINE [0] streamToList #-}

{-# RULES
"stream/unstream"
  forall s. listToStream (streamToList s) = s
  #-}

map :: (a -> b) -> [a] -> [b]
map f = unstream . mapS f . stream
{-# INLINE map #-}

concatMap :: (a -> [b]) -> [a] -> [b]
concatMap f = unstream . concatMapS (stream . f) . stream
{-# INLINE concatMap #-}

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

data Step a s = Done
              | Yield a s
              | Skip    s

class StreamableSequence seq where
  stream   :: seq a -> Stream a
  unstream :: Stream a -> seq a

  -- axiom: stream . unstream = id
  -- These inline pragmas are useless (see #5084)
{-
  {-# INLINE stream #-}
  {-# INLINE unstream #-}
-}

{-
--version that does not require the sequence type
--to be polymorphic in its elements:

class StreamableSequence seq a | seq -> a where
  stream   :: seq -> Stream a
  unstream :: Stream a -> seq
-}

mapS :: (a -> b) -> Stream a -> Stream b
mapS f (Stream next s0) = Stream next' s0
  where next' s = case next s of
          Done       -> Done
          Skip    s' -> Skip        s'
          Yield x s' -> Yield (f x) s'
{-# INLINE [0] mapS #-}

concatMapS :: (a -> Stream b) -> Stream a -> Stream b
concatMapS f (Stream step s) = Stream step' (s, Nothing)
  where step' (s, Nothing) =
          case step s of
            Yield x s' -> Skip (s', Just (f x))
            Skip    s' -> Skip (s', Nothing)
            Done       -> Done

        step' (s, Just (Stream stepb sb)) =
          case stepb sb of
            Yield x sb' -> Yield x (s, Just (Stream stepb sb'))
            Skip    sb' -> Skip (s, Just (Stream stepb sb'))
            Done        -> Skip (s, Nothing)
{-# INLINE [0] concatMapS #-}


{-# LANGUAGE ForeignFunctionInterface, MagicHash, UnboxedTuples #-}

-- From trac #1947
-- Should fail with heap exhaustion
-- See notes below with "Infinite loop here".

module Main(main) where

import System.IO.Unsafe
import System.IO
import System.Environment
import System.Exit
import Foreign.C.Types
import Data.Char(ord,chr)

-- low level imports
import GHC.Base                 (realWorld#)
import GHC.IO                   (IO(IO), unIO, unsafePerformIO)
import GHC.Prim                 (State#,RealWorld)

-- FFI replacements for Haskell stuff
foreign import ccall unsafe "stdio.h getchar" getchar :: IO CInt
foreign import ccall unsafe "ctype.h iswspace" isspace :: CInt -> CInt

skipCAF :: State# RealWorld -> a -> a
skipCAF _ x = x

-- IO Subsystem
-- Unboxed IO is more efficient, but requires a certain level of
-- optimisation, so provide a BOXED_IO fallback

data RW_Box = RW_Box (State# RealWorld)
type RW_Pair a = (RW_Box, a)

fromIO :: IO a -> (RW_Box -> RW_Pair a)
fromIO a (RW_Box r) = case unIO a r of (# r, x #) -> (RW_Box r, x)

toIO :: (RW_Box -> RW_Pair a) -> IO a
toIO f = IO $ \r -> case f (RW_Box r) of (RW_Box r, x) -> (# r, x #)

-- IO functions not dependent on the IO primitives
main :: IO ()
main = toIO main_generated

typeRealWorld :: RW_Box -> RW_Box
typeRealWorld x = x

overlay_get_char :: RW_Box -> RW_Pair Int
overlay_get_char = fromIO $ do
    c <- getchar
    return $ fromIntegral c

system_IO_hPutChar :: Handle -> Int -> RW_Box -> RW_Pair ()
system_IO_hPutChar h c = fromIO $ hPutChar h (chr c)

overlay_errorIO :: [Int] -> RW_Box -> RW_Pair a
overlay_errorIO x r = case fromIO (putStrLn ("ERROR: " ++ map chr x)) r of
                           (r, _) -> fromIO exitFailure r

system_Environment_getArgs :: RW_Box -> RW_Pair [[Int]]
system_Environment_getArgs r = case (fromIO getArgs) r of
                                    (r, s) -> (r, map str_ s)

overlay_supero_wrap x = x

-- Primitives
prelude_seq = seq

prelude_error x = error (map chr x)

aDD_W = (+) :: Int -> Int -> Int
mUL_W = (*) :: Int -> Int -> Int
sUB_W = (-) :: Int -> Int -> Int
eQ_W = (==) :: Int -> Int -> Bool
nE_W = (/=) :: Int -> Int -> Bool
gT_W = (>) :: Int -> Int -> Bool
gE_W = (>=) :: Int -> Int -> Bool
lT_W = (<) :: Int -> Int -> Bool
lE_W = (<=) :: Int -> Int -> Bool
qUOT = quot :: Int -> Int -> Int
rEM = rem :: Int -> Int -> Int
nEG_W = negate :: Int -> Int
yHC_Primitive_primIntAbs = abs :: Int -> Int
yHC_Primitive_primIntSignum = signum :: Int -> Int
yHC_Primitive_primIntegerAdd = (+) :: Integer -> Integer -> Integer
yHC_Primitive_primIntegerEq = (==) :: Integer -> Integer -> Bool
yHC_Primitive_primIntegerFromInt = toInteger :: Int -> Integer
yHC_Primitive_primIntegerGe = (>=) :: Integer -> Integer -> Bool
yHC_Primitive_primIntegerGt = (>) :: Integer -> Integer -> Bool
yHC_Primitive_primIntegerLe = (<=) :: Integer -> Integer -> Bool
yHC_Primitive_primIntegerMul = (*) :: Integer -> Integer -> Integer
yHC_Primitive_primIntegerNe = (/=) :: Integer -> Integer -> Bool
yHC_Primitive_primIntegerNeg = negate :: Integer -> Integer
yHC_Primitive_primIntegerQuot = quot :: Integer -> Integer -> Integer
yHC_Primitive_primIntegerQuotRem = quotRem :: Integer -> Integer -> (Integer, Integer)
yHC_Primitive_primIntegerRem = rem :: Integer -> Integer -> Integer
yHC_Primitive_primIntFromInteger = fromInteger :: Integer -> Int
yHC_Primitive_primIntegerLt = (<) :: Integer -> Integer -> Bool
yHC_Primitive_primIntegerSub = (-) :: Integer -> Integer -> Integer

aDD_D = (+) :: Double -> Double -> Double
sUB_D = (-) :: Double -> Double -> Double
lT_D = (<) :: Double -> Double -> Bool
lE_D = (<=) :: Double -> Double -> Bool
gT_D = (>) :: Double -> Double -> Bool
gE_D = (>=) :: Double -> Double -> Bool
eQ_D = (==) :: Double -> Double -> Bool
mUL_D = (*) :: Double -> Double -> Double
nEG_D = (negate) :: Double -> Double
nE_D = (/=) :: Double -> Double -> Bool
sLASH_D = (/) :: Double -> Double -> Double
yHC_Primitive_primDecodeDouble = decodeFloat :: Double -> (Integer,Int)
yHC_Primitive_primDoubleACos = acos :: Double -> Double
yHC_Primitive_primDoubleASin = asin :: Double -> Double
yHC_Primitive_primDoubleATan = atan :: Double -> Double
yHC_Primitive_primDoubleAbs = abs :: Double -> Double
yHC_Primitive_primDoubleCos = cos :: Double -> Double
yHC_Primitive_primDoubleExp = exp :: Double -> Double
yHC_Primitive_primDoubleFromInteger = fromInteger :: Integer -> Double
yHC_Primitive_primDoubleLog = log :: Double -> Double
yHC_Primitive_primDoublePow = (**) :: Double -> Double -> Double
yHC_Primitive_primDoubleSignum = signum :: Double -> Double
yHC_Primitive_primDoubleSin = sin :: Double -> Double
yHC_Primitive_primDoubleSqrt = sqrt :: Double -> Double
yHC_Primitive_primDoubleTan = tan :: Double -> Double
yHC_Primitive_primEncodeDouble = encodeFloat :: Integer -> Int -> Double

-- things which Yhc decides should be hopelessly slow
prelude_Int_Integral_mod = mod :: Int -> Int -> Int
prelude_Integer_Integral_div = div :: Integer -> Integer -> Integer
prelude_Integer_Integral_mod = mod :: Integer -> Integer -> Integer
prelude_Integer_Num_signum = signum :: Integer -> Integer
prelude_Integer_Num_abs = abs :: Integer -> Integer

int_ x = x :: Int
chr_ x = ord x
str_ x = map chr_ x

system_IO_stdin = stdin
system_IO_stdout = stdout

data_Char_isSpace :: Int -> Bool
data_Char_isSpace c = isspace (toEnum c) /= 0

type ReadsPrec a = Int -> [Int] -> [(a,[Int])]

prelude_Int_Read_readsPrec :: ReadsPrec Int
prelude_Int_Read_readsPrec p s = [(a, str_ b) | (a,b) <- readsPrec p (map chr s)]
prelude_Int_Read_readList = undefined

prelude_Integer_Read_readsPrec :: ReadsPrec Integer
prelude_Integer_Read_readsPrec p s = [(a, str_ b) | (a,b) <- readsPrec p (map chr s)]
prelude_Integer_Read_readList = undefined

prelude_Double_Read_readsPrec :: ReadsPrec Double
prelude_Double_Read_readsPrec p s = [(a, str_ b) | (a,b) <- readsPrec p (map chr s)]
prelude_Double_Read_readList = undefined

prelude_Char_Read_readsPrec :: ReadsPrec Int
prelude_Char_Read_readsPrec p s = [(chr_ (a :: Char), str_ b) | (a,b) <- readsPrec p (map chr s)]

prelude_Char_Show_showList :: [Int] -> [Int] -> [Int]
prelude_Char_Show_showList value rest = str_ (show (map chr value)) ++ rest

prelude_Char_Show_showsPrec :: Int -> Int -> [Int] -> [Int]
prelude_Char_Show_showsPrec prec i rest = str_ (showsPrec prec (chr i) []) ++ rest

prelude_Int_Show_showsPrec :: Int -> Int -> [Int] -> [Int]
prelude_Int_Show_showsPrec prec i rest = str_ (showsPrec prec i []) ++ rest

prelude_Integer_Show_showsPrec :: Int -> Integer -> [Int] -> [Int]
prelude_Integer_Show_showsPrec prec i rest = str_ (showsPrec prec i []) ++ rest

prelude_Double_Show_showsPrec :: Int -> Double -> [Int] -> [Int]
prelude_Double_Show_showsPrec prec i rest = str_ (showsPrec prec i []) ++ rest

prelude_'amp'amp27 v1 v2 =
    case (data_Char_isSpace v1) of
        True ->
            case v2 of
                [] -> True
                (:) v4 v5 -> prelude_'amp'amp27 v4 v5
        False -> False

prelude_LAMBDA22 v1 v2 =
    case v1 of
        (,) v267 v268 ->
            case v268 of
                [] -> prelude_LAMBDA24 v267 v2
                (:) v7 v8 ->
                    let v11 = prelude_'amp'amp27 v7 v8
                    in case v11 of
                           True -> prelude_LAMBDA24 v267 v2
                           False -> prelude__foldr25 v2

prelude_LAMBDA24 v1 v2 = (:) v1 (prelude__foldr25 v2)

prelude_IO_Monad_fail41 v1 =
    overlay_errorIO
      (skipCAF realWorld# (str_ "pattern-match failure in do expression"))
      v1

prelude__foldr25 v1 =
    case v1 of
        [] -> []
        (:) v296 v297 -> prelude_LAMBDA22 v296 v297

f17 uncaf = skipCAF uncaf (str_ "Prelude.read: no parse")

f18 v1 v2 =
    case v1 of
        (,) v176 v177 ->
            case v177 of
                [] -> f20 v176 v2
                (:) v7 v8 ->
                    let v11 = prelude_'amp'amp27 v7 v8
                    in case v11 of
                           True -> f20 v176 v2
                           False ->
                               case v2 of
                                   [] -> prelude_error (f17 realWorld#)
                                   (:) v4 v5 -> f18 v4 v5

f20 v1 v2 =
    case v2 of
        [] -> v1
        (:) v257 v258 ->
            let v9 = prelude_LAMBDA22 v257 v258
            in case v9 of
                   [] -> v1
                   (:) v10 v11 ->
                       prelude_error
                         (skipCAF realWorld# (str_ "Prelude.read: ambiguous parse"))

-- Infinite loop here.  It was originally:
-- f34 v1 v2 v3 =
--    let v336 = f34 v1 v2 v3
--    in v336
--
-- But that now (correctly) just makes a non-allocating infinite loop
-- instead of (incorrectly) eta-reducing to f34 = f34.
-- So I've changed to an infinite, allocating loop, which makes
-- the heap get exhausted.
f34 v1 v2 v3 =
  if abs v2 < 1000 then
    let v336 = f34 (v1+1) (-v2) v3
    in v336
  else if v2 == 2000 then 0 else v1

f38 v1 v2 =
    case v1 of
        [] -> system_IO_hPutChar system_IO_stdout (chr_ '\n') v2
        (:) v350 v351 ->
            case (system_IO_hPutChar
                    system_IO_stdout
                    v350
                    (typeRealWorld v2)) of
                ( v7  , v8  ) -> f38 v351 v7

main_generated v1 =
    case (system_Environment_getArgs (typeRealWorld v1)) of
        ( v3  , v4  ) ->
            case v4 of
                (:) v7 v8 ->
                    case v8 of
                        (:) v9 v12 ->
                            case v12 of
                                (:) v13 v14 ->
                                    case v14 of
                                        [] ->
                                            case (prelude_Int_Show_showsPrec
                                                    (int_ 0)
                                                    (let v8 =
                                                             case (prelude_Int_Read_readsPrec
                                                                     (int_ 0)
                                                                     v7) of
                                                                 [] -> prelude_error (f17 realWorld#)
                                                                 (:) v12 v14 -> f18 v12 v14
                                                         v10 =
                                                             case (prelude_Int_Read_readsPrec
                                                                     (int_ 0)
                                                                     v9) of
                                                                 [] -> prelude_error (f17 realWorld#)
                                                                 (:) v15 v16 -> f18 v15 v16
                                                         v11 =
                                                             case (prelude_Int_Read_readsPrec
                                                                     (int_ 0)
                                                                     v13) of
                                                                 [] -> prelude_error (f17 realWorld#)
                                                                 (:) v17 v18 -> f18 v17 v18
                                                     in case (lT_W v10 v8) of
                                                            True ->
                                                                let v7 = f34 v8 v10 v11
                                                                in v7
                                                            False -> v11)
                                                    (skipCAF realWorld# (str_ ""))) of
                                                [] ->
                                                    system_IO_hPutChar
                                                      system_IO_stdout
                                                      (chr_ '\n')
                                                      (typeRealWorld v3)
                                                (:) v11 v12 ->
                                                    case (system_IO_hPutChar
                                                            system_IO_stdout
                                                            v11
                                                            (typeRealWorld (typeRealWorld v3))) of
                                                        ( v7  , v8  ) -> f38 v12 v7
                                        (:) v15 v16 -> prelude_IO_Monad_fail41 v3
                                [] -> prelude_IO_Monad_fail41 v3
                        [] -> prelude_IO_Monad_fail41 v3
                [] -> prelude_IO_Monad_fail41 v3


module Main where

import GHC.Exts

-- This checks that rules look through unfoldings when matching
-- lambdas, but only in the right phase

foo :: (Int -> IO ()) -> IO ()
foo f = putStr "not fired: " >> f 0
{-# NOINLINE foo #-}

f1 :: Int -> IO ()
f1 _ = putStrLn "f1"
{-# NOINLINE[0] f1 #-}

f2 :: Int -> IO ()
f2 _ = putStrLn "f2"
{-# NOINLINE f2 #-}

newtype Age = MkAge Int

-- It also checks that this can look through casted lambdas

f3 :: Age -> IO ()
f3 _ = putStrLn "f3"
{-# NOINLINE[0] f3 #-}

{-# RULES "foo" [0] forall g . foo (\x -> g) = putStr "fired: " >> g #-}

main = do
    foo f1
    foo f1
    foo f2
    foo f2
    foo (coerce f3)
    foo (coerce f3)


import GHC.OldList
main :: IO ()
main = maximumBy compare [1..10000] `seq` return ()


{-# LANGUAGE UnboxedTuples #-}
{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}
module Main where

data JSONState = JSONState [()] () () deriving Show

weta_s6yD :: Either a (b, c) -> (# (Either a b, JSONState) #)
weta_s6yD ww_s6ys = case ww_s6ys of
    Left l -> (# (Left l, JSONState [] () ()) #)
    Right (x, _) -> (# (Right x, JSONState [] () ()) #)

eta_B1 :: (Either a (b, c), t) -> Either a1 (Either a b, JSONState)
eta_B1 (ww_s6ys, _) = case weta_s6yD ww_s6ys of
    (# ww_s6zb #) -> Right ww_s6zb

wks_s6yS :: Either a b -> (# (Either a b, JSONState) #)
wks_s6yS ww_s6yH =
    case case ww_s6yH of
        Left l_a4ay -> eta_B1 (Left l_a4ay, ())
        Right r_a4aB -> eta_B1 (Right (r_a4aB, ()), ())
    of
        Right ww_s6ze -> (# ww_s6ze #)

ks_a49u :: (Either a b, t) -> Either a1 (Either a b, JSONState)
ks_a49u (ww_s6yH, _) = case wks_s6yS ww_s6yH of
    (# ww_s6ze #) -> Right ww_s6ze

wks_s6z7 :: Either a b -> (# (Either a b, JSONState) #)
wks_s6z7 ww_s6yW = case (
    case ww_s6yW of
        Left _ -> ks_a49u (ww_s6yW, JSONState [()] () ())
        Right _ -> ks_a49u (ww_s6yW, JSONState [] () ())
    ) of
        Right ww_s6zh -> (# ww_s6zh #)

ks_X3Sb :: Either () Int -> Either String (Either () Int, JSONState)
ks_X3Sb ww_s6yW = case wks_s6z7 ww_s6yW of
    (# ww_s6zh #) -> Right ww_s6zh

main :: IO ()
main = print $ ks_X3Sb (Left ())


module Main (main ) where

import Debug.Trace

foo :: (a,b) -> a
foo (x,y) = x
{-# NOINLINE foo #-}

wwMe :: Int -> (Int,Int) -> (Int, Int)
wwMe 0 p =
    let a = fst p
        b = snd p
        -- This ensures sharing of b, as seen by the demand analyzer

    in foo p `seq`
       -- This ensures that wwMe is strict in the tuple, but that the tuple
       -- is preserved.
       (b + a, a + b)

wwMe n p = wwMe (n-1) (0,0)
    -- ^ Make it recursive, so that it is attractive to worker-wrapper

go :: Int -> IO ()
go seed = do
    let shareMeThunk = trace "Evaluated (should only happen once)" (seed + 1)
        {-# NOINLINE shareMeThunk #-}
        -- ^ This is the thunk that is wrongly evaluated twice.

    let (x,y) = wwMe 0 (seed,shareMeThunk)

    (x + y) `seq` return ()
    -- ^ Use both components
{-# NOINLINE go #-}

main :: IO ()
main = go 42


data T1 = MkT1Bad                     | MkT1Good                     deriving Show
data T2 = MkT2Bad Int                 | MkT2Good Int                 deriving Show
data T3 = MkT3Bad {-# UNPACK #-} !Int | MkT3Good {-# UNPACK #-} !Int deriving Show
data T4 = MkT4Bad Int                 | MkT4Good Int                 deriving Show
data T5 = MkT5Bad {-# UNPACK #-} !Int | MkT5Good {-# UNPACK #-} !Int deriving Show

{-# RULES

"T1"           app MkT1Bad     = MkT1Good
"T2" forall x. app (MkT2Bad x) = MkT2Good x
"T3" forall x. app (MkT3Bad x) = MkT3Good x
"T4"           app MkT4Bad     = MkT4Good
"T5"           app MkT5Bad     = MkT5Good
  #-}

app = id
{-# NOINLINE app #-}

main = do
  print (app MkT1Bad)
  print (app (MkT2Bad 42))
  print (app (MkT3Bad 42))
  print (app MkT4Bad 42)
  print (app MkT5Bad 42)


data T6 = MkT6Bad {-# UNPACK #-} !Int | MkT6Good {-# UNPACK #-} !Int deriving Show

{-# RULES

"T6" [1] forall x. MkT6Bad x = MkT6Good x
  #-}

main = do
  print (MkT6Bad 42) -- late rule


module Main where

f :: Word -> Bool
f n = case n+1 of
       0 -> True
       _ -> False
{-# NOINLINE f #-}

main = do
   putStrLn "Word: wrap (0-1)"
   print (f (-1))


import Debug.Trace

g x expensive ys = let h = \y -> y + expensive x
                   in map h ys
{-# NOINLINE g #-}

foo x = trace "Evaluate me only once!" x

main = sum (g 1 foo [1,2,3]) `seq` return ()


{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Main (main) where

import T13429a

import Data.Foldable (Foldable(..))
import Data.Monoid (Monoid(..))

main :: IO ()
main = print $ prop_mappend z z
  where
    z :: Seq Integer
    z = deep (Four 1 2 3 4) Empty (Four 1 2 3 4)

infix 4 ~=

(~=) :: Eq a => Maybe a -> a -> Bool
(~=) = maybe (const False) (==)

-- Partial conversion of an output sequence to a list.
toList' :: (Eq a, Measured [a] a, Valid a) => Seq a -> Maybe [a]
toList' xs
  | valid xs = Just (toList xs)
  | otherwise = Nothing

prop_mappend :: Seq Integer -> Seq Integer -> Bool
prop_mappend xs ys =
    toList' (mappend xs ys) ~= toList xs ++ toList ys

------------------------------------------------------------------------
-- Valid trees
------------------------------------------------------------------------

class Valid a where
    valid :: a -> Bool

instance (Measured v a, Eq v, Valid a) => Valid (FingerTree v a) where
    valid Empty = True
    valid (Single x) = valid x
    valid (Deep s pr m sf) =
        s == measure pr `mappend` measure m `mappend` measure sf &&
        valid pr && valid m && valid sf

instance (Measured v a, Eq v, Valid a) => Valid (Node v a) where
    valid node = measure node == foldMap measure node && all valid node

instance Valid a => Valid (Digit a) where
    valid = all valid

instance Valid Integer where
    valid = const True

------------------------------------------------------------------------
-- Use list of elements as the measure
------------------------------------------------------------------------

type Seq a = FingerTree [a] a

instance Measured [Integer] Integer where
    measure x = [x]


{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE UndecidableInstances #-}
module T13429a where -- Originally FingerTree.hs from the ticket

import Data.Semigroup (Semigroup(..))

class (Monoid v) => Measured v a | a -> v where
    measure :: a -> v

instance (Measured v a) => Measured v (Digit a) where
    measure = foldMap measure

instance (Monoid v) => Measured v (Node v a) where
    measure (Node2 v _ _)    =  v
    measure (Node3 v _ _ _)  =  v

instance (Measured v a) => Measured v (FingerTree v a) where
    measure Empty           =  mempty
    measure (Single x)      =  measure x
    measure (Deep v _ _ _)  =  v

data FingerTree v a
    = Empty
    | Single a
    | Deep !v !(Digit a) (FingerTree v (Node v a)) !(Digit a)
  deriving Show

instance Foldable (FingerTree v) where
    foldMap _ Empty = mempty
    foldMap f (Single x) = f x
    foldMap f (Deep _ pr m sf) =
        foldMap f pr `mappend` foldMap (foldMap f) m `mappend` foldMap f sf

instance Measured v a => Semigroup (FingerTree v a) where
    (<>) = (><)

instance Measured v a => Monoid (FingerTree v a) where
    mempty = empty

empty :: Measured v a => FingerTree v a
empty = Empty

infixr 5 ><
infixr 5 <|
infixl 5 |>

(<|) :: (Measured v a) => a -> FingerTree v a -> FingerTree v a
a <| Empty              =  Single a
a <| Single b           =  deep (One a) Empty (One b)
a <| Deep v (Four b c d e) m sf = m `seq`
    Deep (measure a `mappend` v) (Two a b) (node3 c d e <| m) sf
a <| Deep v pr m sf     =
    Deep (measure a `mappend` v) (consDigit a pr) m sf

consDigit :: a -> Digit a -> Digit a
consDigit a (One b) = Two a b
consDigit a (Two b c) = Three a b c
consDigit a (Three b c d) = Four a b c d
consDigit _ (Four _ _ _ _) = illegal_argument "consDigit"

(|>) :: (Measured v a) => FingerTree v a -> a -> FingerTree v a
Empty |> a              =  Single a
Single a |> b           =  deep (One a) Empty (One b)
Deep v pr m (Four a b c d) |> e = m `seq`
    Deep (v `mappend` measure e) pr (m |> node3 a b c) (Two d e)
Deep v pr m sf |> x     =
    Deep (v `mappend` measure x) pr m (snocDigit sf x)

snocDigit :: Digit a -> a -> Digit a
snocDigit (One a) b = Two a b
snocDigit (Two a b) c = Three a b c
snocDigit (Three a b c) d = Four a b c d
snocDigit (Four _ _ _ _) _ = illegal_argument "snocDigit"

(><) :: (Measured v a) => FingerTree v a -> FingerTree v a -> FingerTree v a
(><) =  appendTree0

appendTree0 :: (Measured v a) => FingerTree v a -> FingerTree v a -> FingerTree v a
appendTree0 Empty xs =
    xs
appendTree0 xs Empty =
    xs
appendTree0 (Single x) xs =
    x <| xs
appendTree0 xs (Single x) =
    xs |> x
appendTree0 (Deep _ pr1 m1 sf1) (Deep _ pr2 m2 sf2) =
    deep pr1 (addDigits0 m1 sf1 pr2 m2) sf2

addDigits0 :: (Measured v a) => FingerTree v (Node v a) -> Digit a -> Digit a -> FingerTree v (Node v a) -> FingerTree v (Node v a)
addDigits0 m1 (One a) (One b) m2 =
    appendTree1 m1 (node2 a b) m2
addDigits0 m1 (One a) (Two b c) m2 =
    appendTree1 m1 (node3 a b c) m2
addDigits0 m1 (One a) (Three b c d) m2 =
    appendTree2 m1 (node2 a b) (node2 c d) m2
addDigits0 m1 (One a) (Four b c d e) m2 =
    appendTree2 m1 (node3 a b c) (node2 d e) m2
addDigits0 m1 (Two a b) (One c) m2 =
    appendTree1 m1 (node3 a b c) m2
addDigits0 m1 (Two a b) (Two c d) m2 =
    appendTree2 m1 (node2 a b) (node2 c d) m2
addDigits0 m1 (Two a b) (Three c d e) m2 =
    appendTree2 m1 (node3 a b c) (node2 d e) m2
addDigits0 m1 (Two a b) (Four c d e f) m2 =
    appendTree2 m1 (node3 a b c) (node3 d e f) m2
addDigits0 m1 (Three a b c) (One d) m2 =
    appendTree2 m1 (node2 a b) (node2 c d) m2
addDigits0 m1 (Three a b c) (Two d e) m2 =
    appendTree2 m1 (node3 a b c) (node2 d e) m2
addDigits0 m1 (Three a b c) (Three d e f) m2 =
    appendTree2 m1 (node3 a b c) (node3 d e f) m2
addDigits0 m1 (Three a b c) (Four d e f g) m2 =
    appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
addDigits0 m1 (Four a b c d) (One e) m2 =
    appendTree2 m1 (node3 a b c) (node2 d e) m2
addDigits0 m1 (Four a b c d) (Two e f) m2 =
    appendTree2 m1 (node3 a b c) (node3 d e f) m2
addDigits0 m1 (Four a b c d) (Three e f g) m2 =
    appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
addDigits0 m1 (Four a b c d) (Four e f g h) m2 =
    appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2

appendTree1 :: (Measured v a) => FingerTree v a -> a -> FingerTree v a -> FingerTree v a
appendTree1 Empty a xs =
    a <| xs
appendTree1 xs a Empty =
    xs |> a
appendTree1 (Single x) a xs =
    x <| a <| xs
appendTree1 xs a (Single x) =
    xs |> a |> x
appendTree1 (Deep _ pr1 m1 sf1) a (Deep _ pr2 m2 sf2) =
    deep pr1 (addDigits1 m1 sf1 a pr2 m2) sf2

addDigits1 :: (Measured v a) => FingerTree v (Node v a) -> Digit a -> a -> Digit a -> FingerTree v (Node v a) -> FingerTree v (Node v a)
addDigits1 m1 (One a) b (One c) m2 =
    appendTree1 m1 (node3 a b c) m2
addDigits1 m1 (One a) b (Two c d) m2 =
    appendTree2 m1 (node2 a b) (node2 c d) m2
addDigits1 m1 (One a) b (Three c d e) m2 =
    appendTree2 m1 (node3 a b c) (node2 d e) m2
addDigits1 m1 (One a) b (Four c d e f) m2 =
    appendTree2 m1 (node3 a b c) (node3 d e f) m2
addDigits1 m1 (Two a b) c (One d) m2 =
    appendTree2 m1 (node2 a b) (node2 c d) m2
addDigits1 m1 (Two a b) c (Two d e) m2 =
    appendTree2 m1 (node3 a b c) (node2 d e) m2
addDigits1 m1 (Two a b) c (Three d e f) m2 =
    appendTree2 m1 (node3 a b c) (node3 d e f) m2
addDigits1 m1 (Two a b) c (Four d e f g) m2 =
    appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
addDigits1 m1 (Three a b c) d (One e) m2 =
    appendTree2 m1 (node3 a b c) (node2 d e) m2
addDigits1 m1 (Three a b c) d (Two e f) m2 =
    appendTree2 m1 (node3 a b c) (node3 d e f) m2
addDigits1 m1 (Three a b c) d (Three e f g) m2 =
    appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
addDigits1 m1 (Three a b c) d (Four e f g h) m2 =
    appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
addDigits1 m1 (Four a b c d) e (One f) m2 =
    appendTree2 m1 (node3 a b c) (node3 d e f) m2
addDigits1 m1 (Four a b c d) e (Two f g) m2 =
    appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
addDigits1 m1 (Four a b c d) e (Three f g h) m2 =
    appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
addDigits1 m1 (Four a b c d) e (Four f g h i) m2 =
    appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2

appendTree2 :: (Measured v a) => FingerTree v a -> a -> a -> FingerTree v a -> FingerTree v a
appendTree2 Empty a b xs =
    a <| b <| xs
appendTree2 xs a b Empty =
    xs |> a |> b
appendTree2 (Single x) a b xs =
    x <| a <| b <| xs
appendTree2 xs a b (Single x) =
    xs |> a |> b |> x
appendTree2 (Deep _ pr1 m1 sf1) a b (Deep _ pr2 m2 sf2) =
    deep pr1 (addDigits2 m1 sf1 a b pr2 m2) sf2

addDigits2 :: (Measured v a) => FingerTree v (Node v a) -> Digit a -> a -> a -> Digit a -> FingerTree v (Node v a) -> FingerTree v (Node v a)
addDigits2 m1 (One a) b c (One d) m2 =
    appendTree2 m1 (node2 a b) (node2 c d) m2
addDigits2 m1 (One a) b c (Two d e) m2 =
    appendTree2 m1 (node3 a b c) (node2 d e) m2
addDigits2 m1 (One a) b c (Three d e f) m2 =
    appendTree2 m1 (node3 a b c) (node3 d e f) m2
addDigits2 m1 (One a) b c (Four d e f g) m2 =
    appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
addDigits2 m1 (Two a b) c d (One e) m2 =
    appendTree2 m1 (node3 a b c) (node2 d e) m2
addDigits2 m1 (Two a b) c d (Two e f) m2 =
    appendTree2 m1 (node3 a b c) (node3 d e f) m2
addDigits2 m1 (Two a b) c d (Three e f g) m2 =
    appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
addDigits2 m1 (Two a b) c d (Four e f g h) m2 =
    appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
addDigits2 m1 (Three a b c) d e (One f) m2 =
    appendTree2 m1 (node3 a b c) (node3 d e f) m2
addDigits2 m1 (Three a b c) d e (Two f g) m2 =
    appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
addDigits2 m1 (Three a b c) d e (Three f g h) m2 =
    appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
addDigits2 m1 (Three a b c) d e (Four f g h i) m2 =
    appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
addDigits2 m1 (Four a b c d) e f (One g) m2 =
    appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
addDigits2 m1 (Four a b c d) e f (Two g h) m2 =
    appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
addDigits2 m1 (Four a b c d) e f (Three g h i) m2 =
    appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
addDigits2 m1 (Four a b c d) e f (Four g h i j) m2 =
    appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2

appendTree3 :: (Measured v a) => FingerTree v a -> a -> a -> a -> FingerTree v a -> FingerTree v a
appendTree3 Empty a b c xs =
    a <| b <| c <| xs
appendTree3 xs a b c Empty =
    xs |> a |> b |> c
appendTree3 (Single x) a b c xs =
    x <| a <| b <| c <| xs
appendTree3 xs a b c (Single x) =
    xs |> a |> b |> c |> x
appendTree3 (Deep _ pr1 m1 sf1) a b c (Deep _ pr2 m2 sf2) =
    deep pr1 (addDigits3 m1 sf1 a b c pr2 m2) sf2

addDigits3 :: (Measured v a) => FingerTree v (Node v a) -> Digit a -> a -> a -> a -> Digit a -> FingerTree v (Node v a) -> FingerTree v (Node v a)
addDigits3 m1 (One a) b c d (One e) m2 =
    appendTree2 m1 (node3 a b c) (node2 d e) m2
addDigits3 m1 (One a) b c d (Two e f) m2 =
    appendTree2 m1 (node3 a b c) (node3 d e f) m2
addDigits3 m1 (One a) b c d (Three e f g) m2 =
    appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
addDigits3 m1 (One a) b c d (Four e f g h) m2 =
    appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
addDigits3 m1 (Two a b) c d e (One f) m2 =
    appendTree2 m1 (node3 a b c) (node3 d e f) m2
addDigits3 m1 (Two a b) c d e (Two f g) m2 =
    appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
addDigits3 m1 (Two a b) c d e (Three f g h) m2 =
    appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
addDigits3 m1 (Two a b) c d e (Four f g h i) m2 =
    appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
addDigits3 m1 (Three a b c) d e f (One g) m2 =
    appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
addDigits3 m1 (Three a b c) d e f (Two g h) m2 =
    appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
addDigits3 m1 (Three a b c) d e f (Three g h i) m2 =
    appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
addDigits3 m1 (Three a b c) d e f (Four g h i j) m2 =
    appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2
addDigits3 m1 (Four a b c d) e f g (One h) m2 =
    appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
addDigits3 m1 (Four a b c d) e f g (Two h i) m2 =
    appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
addDigits3 m1 (Four a b c d) e f g (Three h i j) m2 =
    appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2
addDigits3 m1 (Four a b c d) e f g (Four h i j k) m2 =
    appendTree4 m1 (node3 a b c) (node3 d e f) (node3 g h i) (node2 j k) m2

appendTree4 :: (Measured v a) => FingerTree v a -> a -> a -> a -> a -> FingerTree v a -> FingerTree v a
appendTree4 Empty a b c d xs =
    a <| b <| c <| d <| xs
appendTree4 xs a b c d Empty =
    xs |> a |> b |> c |> d
appendTree4 (Single x) a b c d xs =
    x <| a <| b <| c <| d <| xs
appendTree4 xs a b c d (Single x) =
    xs |> a |> b |> c |> d |> x
appendTree4 (Deep _ pr1 m1 sf1) a b c d (Deep _ pr2 m2 sf2) =
    deep pr1 (addDigits4 m1 sf1 a b c d pr2 m2) sf2

addDigits4 :: (Measured v a) => FingerTree v (Node v a) -> Digit a -> a -> a -> a -> a -> Digit a -> FingerTree v (Node v a) -> FingerTree v (Node v a)
addDigits4 m1 (One a) b c d e (One f) m2 =
    appendTree2 m1 (node3 a b c) (node3 d e f) m2
addDigits4 m1 (One a) b c d e (Two f g) m2 =
    appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
addDigits4 m1 (One a) b c d e (Three f g h) m2 =
    appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
addDigits4 m1 (One a) b c d e (Four f g h i) m2 =
    appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
addDigits4 m1 (Two a b) c d e f (One g) m2 =
    appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
addDigits4 m1 (Two a b) c d e f (Two g h) m2 =
    appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
addDigits4 m1 (Two a b) c d e f (Three g h i) m2 =
    appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
addDigits4 m1 (Two a b) c d e f (Four g h i j) m2 =
    appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2
addDigits4 m1 (Three a b c) d e f g (One h) m2 =
    appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
addDigits4 m1 (Three a b c) d e f g (Two h i) m2 =
    appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
addDigits4 m1 (Three a b c) d e f g (Three h i j) m2 =
    appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2
addDigits4 m1 (Three a b c) d e f g (Four h i j k) m2 =
    appendTree4 m1 (node3 a b c) (node3 d e f) (node3 g h i) (node2 j k) m2
addDigits4 m1 (Four a b c d) e f g h (One i) m2 =
    appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
addDigits4 m1 (Four a b c d) e f g h (Two i j) m2 =
    appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2
addDigits4 m1 (Four a b c d) e f g h (Three i j k) m2 =
    appendTree4 m1 (node3 a b c) (node3 d e f) (node3 g h i) (node2 j k) m2
addDigits4 m1 (Four a b c d) e f g h (Four i j k l) m2 =
    appendTree4 m1 (node3 a b c) (node3 d e f) (node3 g h i) (node3 j k l) m2

deep ::  (Measured v a) =>
     Digit a -> FingerTree v (Node v a) -> Digit a -> FingerTree v a
deep pr m sf = Deep ((measure pr `mappendVal` m) `mappend` measure sf) pr m sf

data Digit a
    = One a
    | Two a a
    | Three a a a
    | Four a a a a
    deriving Show

instance Foldable Digit where
    foldMap f (One a) = f a
    foldMap f (Two a b) = f a `mappend` f b
    foldMap f (Three a b c) = f a `mappend` f b `mappend` f c
    foldMap f (Four a b c d) = f a `mappend` f b `mappend` f c `mappend` f d

data Node v a = Node2 !v a a | Node3 !v a a a
    deriving Show

instance Foldable (Node v) where
    foldMap f (Node2 _ a b) = f a `mappend` f b
    foldMap f (Node3 _ a b c) = f a `mappend` f b `mappend` f c

node2        ::  (Measured v a) => a -> a -> Node v a
node2 a b    =   Node2 (measure a `mappend` measure b) a b

node3        ::  (Measured v a) => a -> a -> a -> Node v a
node3 a b c  =   Node3 (measure a `mappend` measure b `mappend` measure c) a b c

mappendVal :: (Measured v a) => v -> FingerTree v a -> v
mappendVal v Empty = v
mappendVal v t = v `mappend` measure t

illegal_argument :: String -> a
illegal_argument name =
    error $ "Logic error: " ++ name ++ " called with illegal argument"


-- This one come from lehins, between comment:22 and 23 of Trac #13429
module Main where

import T13429_2a as Array

arr2 :: Array D Int Int -> Array D Int Int
arr2 arr = Array.map (*2) arr

main :: IO ()
main = print $ arr2 $ makeArray 1600 id


{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE MultiParamTypeClasses #-}
module T13429_2a where

data D

data Array r ix e = Array { _size :: ix
                          , _index :: ix -> e }

class Show ix => Index ix

instance Index Int

class Index ix => Massiv r ix e where
  size :: Array r ix e -> ix
  makeArray :: ix -> (ix -> e) -> Array r ix e
  index :: Array r ix e -> ix -> e

instance Massiv r ix e => Show (Array r ix e) where
  show arr = "<Array " ++ show (size arr) ++ ">"

instance Index ix => Massiv D ix e where
  size = _size
  makeArray = Array
  index = _index

-- | Map a function over an array (restricted return type)
map :: Massiv r' ix e' => (e' -> e) -> Array r' ix e' -> Array D ix e
map = mapG
{-# INLINE map #-}

-- | Map a function over an array (general)
mapG :: (Massiv r' ix e', Massiv r ix e) => (e' -> e) -> Array r' ix e' -> Array r ix e
mapG f arr = makeArray (size arr) (f . index arr)


module Main where

delayedId :: a -> a
delayedId x = x
{-# INLINE [0] delayedId #-}

alwaysTrue :: [Integer]-> Bool
alwaysTrue xs = xs == delayedId xs
{-# NOINLINE alwaysTrue #-}

{-# RULES
    "[Integer] Eq Refl" forall (xs :: [Integer]). xs == xs = True
#-}

main = putStrLn $ if alwaysTrue undefined then "ok" else "not ok"


{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE UndecidableSuperClasses #-}
{-# LANGUAGE PolyKinds #-}
module Main where

import T13750a

import GHC.Exts (Constraint)
import Unsafe.Coerce
import Data.Proxy

class MyShow a where
  myShow :: a -> String

instance MyShow Char where
  myShow a = [a]

gshowS :: (All2 MyShow xss) => NS xss -> String
gshowS (Z xs)  = gshowP xs
gshowS (S xss) = gshowS xss

gshowP :: (All MyShow xs) => NP xs -> String
gshowP (x :* Nil) = myShow x

class (AllF c xs) => All (c :: k -> Constraint) (xs :: [k])
  -- where foo :: Proxy c     -- This makes it not seg-fault

instance All c '[]
instance (c x, All c xs) => All c (x ': xs)

type family AllF (c :: k -> Constraint) (xs :: [k]) :: Constraint
type instance AllF _c '[]       = ()
type instance AllF  c (x ': xs) = (c x, All c xs)

type All2 f = All (All f)

main :: IO ()
main = do
  let t = 'x' :* Nil
  print (gshowS (Z ('x' :* Nil) :: NS '[ '[ Char ] ]))