{-# LANGUAGE Arrows, NoMonomorphismRestriction #-}
module T5333 where

import Prelude hiding ( id, (.) )
import Control.Arrow

cc1 :: a e b -> a e b -> a e b
cc1 = undefined

-- With GHC < 7.10.1, the following compile failures occured:
--
-- ghc: panic! (the 'impossible' happened)
--  (GHC version 7.8.4 for x86_64-unknown-linux):
--  mkCmdEnv Not found: base:GHC.Desugar.>>>{v 02V}

-- 'g' fails to compile.
g = proc (x, y, z) ->
   ((returnA -< x) &&& (returnA -< y) &&& (returnA -< z))

-- 'f' compiles:
--   - without an infix declaration
--   - with the infixl declaration
-- and fails with the infixr declaration
infixr 6 `cc1`
-- infixl 6 `cc1`

f = proc (x, y, z) ->
  ((returnA -< x) `cc1` (returnA -< y) `cc1` (returnA -< z))


{-# LANGUAGE Arrows, ExistentialQuantification #-}

-- Crashed GHC 6.4 with a lint error
-- because of the existential

-- Esa Pulkkinen <esa.pulkkinen@kotiposti.net>
-- Thomas JÃ¤ger <ThJaeger@gmail.com>

module ShouldFail where

class Foo a where foo :: a -> ()
data Bar = forall a. Foo a => Bar a

get :: Bar -> ()
get = proc x -> case x of Bar a -> foo -< a

-- This should be rejected because the left side of -< (here foo)
-- should be treated as being outside the scope of the proc: it can't
-- refer to the local variables x and a (this is enforced), nor the
-- existentially quantified type variable introduced by unwrapping x.


{-# LANGUAGE Arrows #-}

module ShouldFail where

g :: Int -> Int
g = proc x -> f x -< x+1
  where f = (*)


{-# LANGUAGE Arrows #-}
-- Arrow commands where an expression is expected

module ShouldFail where

import Control.Arrow

foo = returnA -< []
bar = (|zeroArrow|)


{-# LANGUAGE Arrows, ExistentialQuantification #-}

-- Trac #1662

module ShouldFail where

import Control.Arrow

data T = forall a. T a

panic :: (Arrow arrow) => arrow T T
panic = proc (T x) -> do returnA -< T x


{-# OPTIONS_GHC -XArrows -XRecursiveDo#-}
-- Test Trac #2111

module Foo where

foo = do { rec { x <- undefined -< x }; undefined -< x }

bar1 = do { rec { x <- return ('a':x); }; putStrLn (take 20 x) }

bar2 = mdo { rec { x <- return ('a':x); }; putStrLn (take 20 x) }


{-# LANGUAGE Arrows #-}

module T5380 where

testB :: not_bool -> (() -> ()) -> () -> not_unit
testB b f = proc () -> if b then f -< () else f -< ()


{-# LANGUAGE Arrows #-}

-- Toy lambda-calculus interpreter from John Hughes's arrows paper (s5)

module Main(main) where

import Data.Maybe(fromJust)
import Control.Arrow

type Id = String
data Val a = Num Int | Bl Bool | Fun (a (Val a) (Val a))
data Exp = Var Id | Add Exp Exp | If Exp Exp Exp | Lam Id Exp | App Exp Exp

eval :: (ArrowChoice a, ArrowApply a) => Exp -> a [(Id, Val a)] (Val a)
eval (Var s) = proc env ->
                returnA -< fromJust (lookup s env)
eval (Add e1 e2) = proc env -> do
                ~(Num u) <- eval e1 -< env
                ~(Num v) <- eval e2 -< env
                returnA -< Num (u + v)
eval (If e1 e2 e3) = proc env -> do
                ~(Bl b) <- eval e1 -< env
                if b    then eval e2 -< env
                        else eval e3 -< env
eval (Lam x e) = proc env ->
                returnA -< Fun (proc v -> eval e -< (x,v):env)
eval (App e1 e2) = proc env -> do
                ~(Fun f) <- eval e1 -< env
                v <- eval e2 -< env
                f -<< v

-- some tests

i = Lam "x" (Var "x")
k = Lam "x" (Lam "y" (Var "x"))
double = Lam "x" (Add (Var "x") (Var "x"))

-- if b then k (double x) x else x + x + x

text_exp = If (Var "b")
                (App (App k (App double (Var "x"))) (Var "x"))
                (Add (Var "x") (Add (Var "x") (Var "x")))

unNum (Num n) = n

main = do
        print (unNum (eval text_exp [("b", Bl True), ("x", Num 5)]))
        print (unNum (eval text_exp [("b", Bl False), ("x", Num 5)]))


{-# LANGUAGE Arrows #-}

-- Homogeneous (or depth-preserving) functions over perfectly balanced trees.

module Main where

import Control.Arrow
import Control.Category
import Data.Complex
import Prelude hiding (id, (.))

infixr 4 :&:

-- Consider the following non-regular type of perfectly balanced trees,
-- or `powertrees' (cf Jayadev Misra's powerlists):

data Pow a = Zero a | Succ (Pow (Pair a))
        deriving Show

type Pair a = (a, a)

-- Here are some example elements:

tree0 = Zero 1
tree1 = Succ (Zero (1, 2))
tree2 = Succ (Succ (Zero ((1, 2), (3, 4))))
tree3 = Succ (Succ (Succ (Zero (((1, 2), (3, 4)), ((5, 6), (7, 8))))))

-- The elements of this type have a string of constructors expressing
-- a depth n as a Peano numeral, enclosing a nested pair tree of 2^n
-- elements.  The type definition ensures that all elements of this type
-- are perfectly balanced binary trees of this form.  (Such things arise
-- in circuit design, eg Ruby, and descriptions of parallel algorithms.)
-- And the type system will ensure that all legal programs preserve
-- this structural invariant.
--
-- The only problem is that the type constraint is too restrictive, rejecting
-- many of the standard operations on these trees.  Typically you want to
-- split a tree into two subtrees, do some processing on the subtrees and
-- combine the results.  But the type system cannot discover that the two
-- results are of the same depth (and thus combinable).  We need a type
-- that says a function preserves depth.  Here it is:

data Hom a b = (a -> b) :&: Hom (Pair a) (Pair b)

-- A homogeneous (or depth-preserving) function is an infinite sequence of
-- functions of type Pair^n a -> Pair^n b, one for each depth n.  We can
-- apply a homogeneous function to a powertree by selecting the function
-- for the required depth:

apply :: Hom a b -> Pow a -> Pow b
apply (f :&: fs) (Zero x) = Zero (f x)
apply (f :&: fs) (Succ t) = Succ (apply fs t)

-- Having defined apply, we can forget about powertrees and do all our
-- programming with Hom's.  Firstly, Hom is an arrow:

instance Category Hom where
        id = id :&: id
        (f :&: fs) . (g :&: gs) = (f . g) :&: (fs . gs)

instance Arrow Hom where
        arr f = f :&: arr (f *** f)
        first (f :&: fs) =
                first f :&: (arr transpose >>> first fs >>> arr transpose)

transpose :: ((a,b), (c,d)) -> ((a,c), (b,d))
transpose ((a,b), (c,d)) = ((a,c), (b,d))

-- arr maps f over the leaves of a powertree.

-- The composition >>> composes sequences of functions pairwise.
--
-- The *** operator unriffles a powertree of pairs into a pair of powertrees,
-- applies the appropriate function to each and riffles the results.
-- It defines a categorical product for this arrow category.

-- When describing algorithms, one often provides a pure function for the
-- base case (trees of one element) and a (usually recursive) expression
-- for trees of pairs.

-- For example, a common divide-and-conquer pattern is the butterfly, where
-- one recursive call processes the odd-numbered elements and the other
-- processes the even ones (cf Geraint Jones and Mary Sheeran's Ruby papers):

butterfly :: (Pair a -> Pair a) -> Hom a a
butterfly f = id :&: proc (x, y) -> do
                x' <- butterfly f -< x
                y' <- butterfly f -< y
                returnA -< f (x', y')

-- The recursive calls operate on halves of the original tree, so the
-- recursion is well-defined.

-- Some examples of butterflies:

rev :: Hom a a
rev = butterfly swap
        where   swap (x, y) = (y, x)

unriffle :: Hom (Pair a) (Pair a)
unriffle = butterfly transpose

-- Batcher's sorter for bitonic sequences:

bisort :: Ord a => Hom a a
bisort = butterfly cmp
        where   cmp (x, y) = (min x y, max x y)

-- This can be used (with rev) as the merge phase of a merge sort.
--
sort :: Ord a => Hom a a
sort = id :&: proc (x, y) -> do
                x' <- sort -< x
                y' <- sort -< y
                yr <- rev -< y'
                p <- unriffle -< (x', yr)
                bisort2 -< p
        where _ :&: bisort2 = bisort

-- Here is the scan operation, using the algorithm of Ladner and Fischer:

scan :: (a -> a -> a) -> a -> Hom a a
scan op b = id :&: proc (x, y) -> do
                y' <- scan op b -< op x y
                l <- rsh b -< y'
                returnA -< (op l x, y')

-- The auxiliary function rsh b shifts each element in the tree one place to
-- the right, placing b in the now-vacant leftmost position, and discarding
-- the old rightmost element:

rsh :: a -> Hom a a
rsh b = const b :&: proc (x, y) -> do
                w <- rsh b -< y
                returnA -< (w, x)

-- Finally, here is the Fast Fourier Transform:

type C = Complex Double

fft :: Hom C C
fft = id :&: proc (x, y) -> do
                x' <- fft -< x
                y' <- fft -< y
                r <- roots (-1) -< ()
                let z = r*y'
                unriffle -< (x' + z, x' - z)

-- The auxiliary function roots r (where r is typically a root of unity)
-- populates a tree of size n (necessarily a power of 2) with the values
-- 1, w, w^2, ..., w^(n-1), where w^n = r.

roots :: C -> Hom () C
roots r = const 1 :&: proc _ -> do
                x <- roots r' -< ()
                unriffle -< (x, x*r')
        where   r' = if imagPart s >= 0 then -s else s
                s = sqrt r

-- Miscellaneous functions:

rrot :: Hom a a
rrot = id :&: proc (x, y) -> do
                w <- rrot -< y
                returnA -< (w, x)

ilv :: Hom a a -> Hom (Pair a) (Pair a)
ilv f = proc (x, y) -> do
                x' <- f -< x
                y' <- f -< y
                returnA -< (x', y')

scan' :: (a -> a -> a) -> a -> Hom a a
scan' op b = proc x -> do
                l <- rsh b -< x
                (id :&: ilv (scan' op b)) -< op l x

riffle :: Hom (Pair a) (Pair a)
riffle = id :&: proc ((x1, y1), (x2, y2)) -> do
                x <- riffle -< (x1, x2)
                y <- riffle -< (y1, y2)
                returnA -< (x, y)

invert :: Hom a a
invert = id :&: proc (x, y) -> do
                x' <- invert -< x
                y' <- invert -< y
                unriffle -< (x', y')

carryLookaheadAdder :: Hom (Bool, Bool) Bool
carryLookaheadAdder = proc (x, y) -> do
                carryOut <- rsh (Just False) -<
                        if x == y then Just x else Nothing
                Just carryIn <- scan plusMaybe Nothing -< carryOut
                returnA -< x `xor` y `xor` carryIn
        where   plusMaybe x Nothing = x
                plusMaybe x (Just y) = Just y
                False `xor` b = b
                True `xor` b = not b

-- Global conditional for SIMD

ifAll :: Hom a b -> Hom a b -> Hom (a, Bool) b
ifAll fs gs = ifAllAux snd (arr fst >>> fs) (arr fst >>> gs)
        where   ifAllAux :: (a -> Bool) -> Hom a b -> Hom a b -> Hom a b
                ifAllAux p (f :&: fs) (g :&: gs) =
                        liftIf p f g :&: ifAllAux (liftAnd p) fs gs
                liftIf p f g x = if p x then f x else g x
                liftAnd p (x, y) = p x && p y

maybeAll :: Hom a c -> Hom (a, b) c -> Hom (a, Maybe b) c
maybeAll (n :&: ns) (j :&: js) =
        choose :&: (arr dist >>> maybeAll ns (arr transpose >>> js))
        where   choose (a, Nothing) = n a
                choose (a, Just b) = j (a, b)
                dist ((a1, b1), (a2, b2)) = ((a1, a2), zipMaybe b1 b2)
                zipMaybe (Just x) (Just y) = Just (x, y)
                zipMaybe _ _ = Nothing

main = do
        print (apply rev tree3)
        print (apply invert tree3)
        print (apply (invert >>> sort) tree3)
        print (apply (scan (+) 0) tree3)


{-# LANGUAGE Arrows #-}

module Main(main) where

import Control.Arrow
import Control.Category
import Prelude hiding (id, (.))

class ArrowLoop a => ArrowCircuit a where
        delay :: b -> a b b

-- stream map instance

data Stream a = Cons a (Stream a)

instance Functor Stream where
        fmap f ~(Cons a as) = Cons (f a) (fmap f as)

zipStream :: Stream a -> Stream b -> Stream (a,b)
zipStream ~(Cons a as) ~(Cons b bs) = Cons (a,b) (zipStream as bs)

unzipStream :: Stream (a,b) -> (Stream a, Stream b)
unzipStream abs = (fmap fst abs, fmap snd abs)

newtype StreamMap a b = StreamMap (Stream a -> Stream b)
unStreamMap (StreamMap f) = f

instance Category StreamMap where
        id = StreamMap id
        StreamMap f . StreamMap g = StreamMap (f . g)

instance Arrow StreamMap where
        arr f = StreamMap (fmap f)
        first (StreamMap f) =
                StreamMap (uncurry zipStream . first f . unzipStream)

instance ArrowLoop StreamMap where
        loop (StreamMap f) =
                StreamMap (loop (unzipStream . f . uncurry zipStream))

instance ArrowCircuit StreamMap where
        delay a = StreamMap (Cons a)

listToStream :: [a] -> Stream a
listToStream = foldr Cons undefined

streamToList :: Stream a -> [a]
streamToList (Cons a as) = a:streamToList as

runStreamMap :: StreamMap a b -> [a] -> [b]
runStreamMap (StreamMap f) as =
        take (length as) (streamToList (f (listToStream as)))

-- simple automaton instance

data Auto a b = Auto (a -> (b, Auto a b))

instance Category Auto where
        id = Auto $ \a -> (a, id)
        Auto f . Auto g = Auto $ \b ->
                                let     (c, g') = g b
                                        (d, f') = f c
                                in      (d, f' . g')

instance Arrow Auto where
        arr f = Auto $ \a -> (f a, arr f)
        first (Auto f) = Auto $ \(b,d) -> let (c,f') = f b in ((c,d), first f')

instance ArrowLoop Auto where
        loop (Auto f) = Auto $ \b ->
                let     (~(c,d), f') = f (b,d)
                in      (c, loop f')

instance ArrowCircuit Auto where
        delay a = Auto $ \a' -> (a, delay a')

runAuto :: Auto a b -> [a] -> [b]
runAuto (Auto f) [] = []
runAuto (Auto f) (a:as) = let (b, f') = f a in b:runAuto f' as

-- Some simple example circuits

-- A resettable counter (first example in several Hawk papers):

counter :: ArrowCircuit a => a Bool Int
counter = proc reset -> do
        rec     output <- returnA -< if reset then 0 else next
                next <- delay 0 -< output+1
        returnA -< output

-- Some other basic circuits from the Hawk library.

-- flush: when reset is True, return d for n ticks, otherwise copy value.
-- (a variation on the resettable counter)

flush :: ArrowCircuit a => Int -> b -> a (b, Bool) b
flush n d = proc (value, reset) -> do
        rec     count <- returnA -< if reset then n else max (next-1) 0
                next <- delay 0 -< count
        returnA -< if count > 0 then d else value

-- latch: on each tick, return the last value for which reset was True,
-- or init if there was none.
--
latch :: ArrowCircuit a => b -> a (b, Bool) b
latch init = proc (value, reset) -> do
        rec     out <- returnA -< if reset then value else last
                last <- delay init -< out
        returnA -< out

-- Some tests using the counter

test_input = [True, False, True, False, False, True, False, True]
test_input2 = zip [1..] test_input

-- A test of the resettable counter.

main = do
        print (runStreamMap counter test_input)
        print (runAuto counter test_input)
        print (runStreamMap (flush 2 0) test_input2)
        print (runAuto (flush 2 0) test_input2)
        print (runStreamMap (latch 0) test_input2)
        print (runAuto (latch 0) test_input2)

-- A step function (cf current in Lustre)

step :: ArrowCircuit a => b -> a (Either b c) b
step b = proc x -> do
                rec     last_b <- delay b -< getLeft last_b x
                returnA -< last_b
        where   getLeft _ (Left b) = b
                getLeft b (Right _) = b


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

-- Simple expression parser
-- (uses do-notation and operators)

module Main(main) where

import Control.Arrow
import Control.Category
import Data.Char
import Prelude hiding (id, (.))

-- Parsers

class (Eq s, Show s, ArrowPlus a) => ArrowParser s a where
        symbol :: s -> a b String

data Sym s = Sym { token :: s, value :: String }

-- Simple backtracking instance

newtype BTParser s a b = BTParser (a -> [Sym s] -> [(b, [Sym s])])

instance Category (BTParser s) where
        id = BTParser $ \a ss -> [(a, ss)]
        BTParser f . BTParser g = BTParser $ \b ss ->
                [(d, ss'') | (c, ss') <- g b ss, (d, ss'') <- f c ss']

instance Arrow (BTParser s) where
        arr f = BTParser $ \a ss -> [(f a, ss)]
        first (BTParser f) = BTParser $ \(b,d) ss ->
                [((c,d), ss') | (c,ss') <- f b ss]

instance ArrowZero (BTParser s) where
        zeroArrow = BTParser $ \b ss -> []

instance ArrowPlus (BTParser s) where
        BTParser f <+> BTParser g = BTParser $ \b ss -> f b ss ++ g b ss

instance (Eq s, Show s) => ArrowParser s (BTParser s) where
        symbol s = BTParser $ \b ss ->
                case ss of
                Sym s' v:ss' | s' == s -> [(v, ss')]
                _ -> []

runBTParser :: BTParser s () c -> [Sym s] -> c
runBTParser (BTParser parser) syms =
        head [c | (c, []) <- parser () syms]

-- Expressions

data ESym = LPar | RPar | Plus | Minus | Mult | Div | Number | Unknown
        deriving (Show, Eq, Ord)

type ExprParser = BTParser ESym
type ExprSym = Sym ESym

-- The grammar

expr :: ExprParser () Int
expr = proc () -> do
                x <- term -< ()
                expr' -< x

expr' :: ExprParser Int Int
expr' = proc x -> do
                returnA -< x
        <+> do
                (|(symbol Plus)|)
                y <- term -< ()
                expr' -< x + y
        <+> do
                (|(symbol Minus)|)
                y <- term -< ()
                expr' -< x - y

term :: ExprParser () Int
term = proc () -> do
                x <- factor -< ()
                term' -< x

term' :: ExprParser Int Int
term' = proc x -> do
                returnA -< x
        <+> do
                (|(symbol Mult)|)
                y <- factor -< ()
                term' -< x * y
        <+> do
                (|(symbol Div)|)
                y <- factor -< ()
                term' -< x `div` y

factor :: ExprParser () Int
factor = proc () -> do
                v <- (|(symbol Number)|)
                returnA -< read v::Int
        <+> do
                (|(symbol Minus)|)
                v <- factor -< ()
                returnA -< -v
        <+> do
                (|(symbol LPar)|)
                v <- expr -< ()
                (|(symbol RPar)|)
                returnA -< v

-- Lexical analysis

lexer :: String -> [ExprSym]
lexer [] = []
lexer ('(':cs) = Sym LPar "(":lexer cs
lexer (')':cs) = Sym RPar ")":lexer cs
lexer ('+':cs) = Sym Plus "+":lexer cs
lexer ('-':cs) = Sym Minus "-":lexer cs
lexer ('*':cs) = Sym Mult "*":lexer cs
lexer ('/':cs) = Sym Div "/":lexer cs
lexer (c:cs)
        | isSpace c = lexer cs
        | isDigit c = Sym Number (c:w):lexer cs'
        | otherwise = Sym Unknown [c]:lexer cs
                where (w,cs') = span isDigit cs

parse = runBTParser expr . lexer

main = do
        print (parse "1+2*(3+4)")
        print (parse "3*5-17/3+4")


{-# LANGUAGE Arrows #-}

import Control.Arrow
import qualified Control.Category as Cat

test :: Int -> Int
test = proc x -> do
    let neg = x < 0
    case x of
        x | neg -> returnA -< 0           -- GHC panics
        --x | x < 0 -> returnA -< 0       -- GHC doesn't panic
        _       -> returnA -< 10

main = do
    print $ test (-1)
    print $ test 1


import Distribution.Simple
main = defaultMain


module Mod where
import A
h :: Int
h = g


module M where
import A
f :: T -> String
f = show


module Indef where
import Sig
data T = MkT B


module P where
type B = Foo
newtype Foo = Foo Double


{-# LANGUAGE TemplateHaskell #-}
module TH where
$( return [] )


{-# LANGUAGE TypeFamilies #-}
module Stuff where

data family T a

data instance T Int = T Int

test :: String
test =
  "test"


module Lib where

import Stuff

doSomeStuff :: String
doSomeStuff =
  test


module B where

import A.Sig

exclaimA :: A -> String
exclaimA = (++ "!") . showA


module A where

newtype A = A { unA :: Int }

showA :: A -> String
showA = show . unA


{-# language TemplateHaskell #-}
module C where

import Data.Char (toUpper)

import A.Sig
import B

veryExclaimA :: A -> String
veryExclaimA = fmap toUpper . exclaimA


{-# OPTIONS_GHC -XImpredicativeTypes -fno-warn-deprecated-flags #-}

-- Sept 16: now failing, beause I've furter reduced the scop
--          of impredicative types

module Base1 where
-- basic examples of impredicative instantiation of variables

data MEither a b = MLeft a
                 | MRight b
                 | MEmpty

type Sid = forall a. a -> a

-- no need for impredicativity
test0 = MRight id

-- requires impredicativity
test1 :: Sid -> MEither Sid b
test1 fid = MLeft fid

test2 :: MEither b Sid -> Maybe (Sid,Sid)
test2 m = case (test1 id) of
             MLeft x -> case m of
                          MRight y -> Just (x,y)
                          _ -> Nothing
             _ -> Nothing

test3 :: MEither a b -> b
test3 (MRight x) = x

test4 = test3 (test1 id)


{-# OPTIONS_GHC -XImpredicativeTypes -fno-warn-deprecated-flags -XScopedTypeVariables #-}

module ShouldCompile where

{-------- Examples from the paper ---------}

f :: (forall a. [a] -> a) -> (Int, Char)
f get = (get [1,2], get ['a', 'b', 'c'])

g :: Maybe (forall a. [a] -> a) -> (Int, Char)
g Nothing = (0, '0')
g (Just get) = (get [1,2], get ['a','b','c'])

sing x = [x]

id1 :: forall a. a -> a
id1 = id

{-
ids :: [forall a. a -> a]
ids = [id1,id1]

t1 :: [forall a. a -> a]
t1 = tail ids

t2 :: [forall a. a -> a]
t2 = sing id

t3 :: forall a. a -> a
t3 = head ids
-}

{--------------- Examples from QMLF paper -------------------}

qF :: (forall a. a -> a -> a) -> (Bool, Char)
qF choose = (choose True False, choose 'a' 'b')

qG :: (forall a. a -> a -> a) -> (forall a. a -> a) -> (forall g. (g -> g) -> (g -> g))
qG choose id = choose id

qH :: (forall a. a -> a -> a) -> (forall a. a -> a) -> (forall b. b -> b) -> (forall b. b -> b)
qH choose id = choose id

choose :: forall a. a -> a -> a
choose x y = x

{-
impred1 :: (Bool, Char)
impred1 = qF $ choose  --- impredicative instantiation for $

impred2 :: (forall a. a -> a -> a) -> (Bool, Char)
impred2 = id qF
-}

{------ Examples for Garrique/Remy paper -------}

--- all of these currently work in GHC with higher-rank types

self1 :: (forall a. a -> a) -> (forall a. a -> a)
self1 f = f f

self2 :: (forall a. a -> a) -> b -> b
self2 f = f f

gr1 = self1 id

gr2 = self2 id

gr3 = (\(u :: (forall a. a -> a) -> (forall a. a -> a)) -> u id) self1

{------------ Church numerals ----------}

type Church = forall a. a -> (a -> a) -> a

z :: Church
z = \z -> \f -> z

s :: Church -> Church
s = \n -> \z -> \f -> f (n z f)

fold :: Church -> a -> (a -> a) -> a
fold n f z = n f z

{-
mul :: Church -> Church -> Church
mul m n = \f -> \a -> m (n f) a

exp :: Church -> Church -> Church
exp m n = n (mul m) (s z)

idC :: Church -> Church
idC x = fold x s z

inc :: Church -> Church
inc x = fold x s (s z)
-}

{------- fix for higher rank types ---------}

data Tree a = Branch a (Tree (a,a)) | Leaf

type MapTree = forall a b. (a -> b) -> Tree a -> Tree b
cross f (a,b) = (f a,f b)

-- I think this should work in GHC now, but it doesn't
-- fix specialized to higher-rank type
fixMT :: (MapTree -> MapTree) -> MapTree
fixMT f = f (fixMT f)

mapTree' = fixMT (\ (mapTree :: MapTree) -> \f tree -> case tree of
                            Branch a t -> Branch (f a) (mapTree (cross f) t)
                            Leaf -> Leaf)

-- polymorphic fix
fix :: (a -> a) -> a
fix f = f (fix f)

-- mapTree'' :: MapTree
mapTree'' = (fix :: (MapTree -> MapTree) -> MapTree)
               (\ mapTree -> \f tree -> case tree of
                            Branch a t -> Branch (f a) (mapTree (cross f) t)
                            Leaf -> Leaf)


{-# LANGUAGE RankNTypes #-}

module Church1 where
-- Church numerals w/o extra type constructors

type CNat = forall a. (a->a) -> a -> a

n0 :: CNat
n0 = \f z -> z

n1 :: CNat
n1 = \f z -> f z

nsucc :: CNat -> CNat
nsucc n = \f z -> f (n f z)

add, mul :: CNat -> CNat -> CNat
add m n = \f -> \a -> m f (n f a)
mul m n = \f -> \a -> m (n f) a

-- already works with GHC 6.4
exp0 :: CNat -> CNat -> CNat
exp0 m n = n m

exp1 :: CNat -> CNat -> CNat
exp1 m n = (n::((CNat -> CNat) -> CNat -> CNat)) (mul m) n1  -- checks with app rule


{-# LANGUAGE RankNTypes #-}

module Church2 where
-- Church numerals w/o extra type constructors: Should fail

type CNat = forall a. (a->a) -> a -> a

n0 :: CNat
n0 = \f z -> z

n1 :: CNat
n1 = \f z -> f z

nsucc :: CNat -> CNat
nsucc n = \f z -> f (n f z)

add, mul :: CNat -> CNat -> CNat
add m n = \f -> \a -> m f (n f a)
mul m n = \f -> \a -> m (n f) a

-- already works with GHC 6.4
exp0 :: CNat -> CNat -> CNat
exp0 m n = n m

-- should fail!
exp2 :: CNat -> CNat -> CNat
exp2 m n = n (mul m) n1


{-# OPTIONS_GHC -XImpredicativeTypes -fno-warn-deprecated-flags -XEmptyDataDecls -XGADTs #-}

-- Trac #1118

module Compose where

data Z
data S n

data List n a where
    Nil :: List Z a
    (:-) :: a -> List n a -> List (S n) a

data Hold a = Hold (forall m . a m -> a (S m))

compose' :: List n (Hold a) -> a (S Z) -> a (S n)
compose' Nil x = x
compose' ((Hold f) :- fs) x = f (compose' fs x)

compose :: List n (forall m . a m -> a (S m)) -> a (S Z) -> a (S n)
compose Nil x = x
compose (f :- fs) x = f (compose fs x)

composeS :: [forall m . a m -> a m] -> a n -> a n
composeS [] x = x
composeS (f:fs) x = f (composeS fs x)


{-# OPTIONS_GHC -XImpredicativeTypes -fno-warn-deprecated-flags #-}

module PList1 where
-- Polymorphic lists 1: requires smart-app-res

type Sid = forall a . a -> a

ids :: [Sid]
ids = []

-- requires smart-app-res
test0 :: [Sid]
test0 = (\x->x) : ids

test1 :: [Sid]  -- SLPJ added
test1 = ids ++ test0

test2 :: [Sid]
test2 = tail test1

test3 :: [Sid]  -- SLPJ added
test3 = reverse test2
test4 = (tail::([Sid]->[Sid])) test2

test5 = (head::([Sid]->Sid)) test2


{-# OPTIONS_GHC -XImpredicativeTypes -fno-warn-deprecated-flags #-}

module PList2 where
-- Polymorphic lists 2: require smart-app-arg & smart-app-res: Should fail w/o smart-app-arg

type Sid = forall a. a -> a

ids :: [Sid]
ids = []

test0 :: [Sid]
test0 = (\x -> x):ids  -- requires smart-app-res

test1 :: [Sid]  -- Added SLPJ
test1 = ids ++ test0

test2 :: [Sid]
test2 = tail test1 -- requires smart-app-arg

test3 :: [Sid]  -- Added SLPJ
test3 = reverse test2

test4 :: Sid
test4 = head ids  --requires smart-app-arg

test5 :: Sid
test5 = head ids  -- still requires smart-app-arg


{-# LANGUAGE Rank2Types #-}

module SystemF where
-- System-F examples

type Sid = forall a. a -> a

apply :: forall a b . (a -> b) -> a -> b
apply f g = f g

hr :: (forall a. a -> a) -> (Int,Bool)
hr f = (f 3,f True)

test0 = apply hr id   -- requires smart-app-arg

selfApp :: Sid -> Sid
selfApp x = (x::(Sid -> Sid)) x


{-# OPTIONS_GHC -XImpredicativeTypes -fno-warn-deprecated-flags #-}

-- Sept 16: now scraping through with -XImpredicateTypes

module Main where

data Foo x y = Foo {foo1 :: x, foo2 :: y}
instance Functor (Foo x) where
    fmap f (Foo x y) = Foo x (f y)

bar :: a -> Foo (forall s. s) a
bar a = Foo undefined a

main = print (foo2 (fmap (*2) (bar 2)))


module Data.Map where
-- conflicts with module from containers package
import Data.Set


module A where
a = 42 :: Int

main2 = print a


module Main where

import A

main = print a


> import Distribution.Simple
> main = defaultMain


module B.A where
a = 42 :: Int

main = print a


 {-# LANGUAGE TemplateHaskell #-}
 module Library where

import TH

main = print ($(spliceMe) [1, 2])


{-# LANGUAGE TemplateHaskell #-}
module TH where

import Language.Haskell.TH

spliceMe = [| (\xs -> tail xs ++ init xs) |]


import Distribution.Simple
main = defaultMain


module Q where
import P
data Q = Q
q = not p


module R where
import P  -- p (exposed), q (reexport p:P)
import P2 -- q (reexport p:P)
import Q  -- q (exposed)
import qualified QP -- q (reexport p:P)
import qualified QQ -- q (reexport q:Q)
import qualified PMerge -- q (reexport p:P)
import qualified PMerge2 -- q (reexport p:P2)
import qualified QMerge -- q (reexport q:Q)
data R = R
r = p && q


module S where
-- NB: package p is hidden!
import qualified QP     -- q (reexport p:P)
import qualified RP     -- r (reexport p:P)
import qualified Q      -- q (exposed), r (reexport q:Q)
import qualified R      -- r (exposed)
import qualified RR     -- r (reexport r:R)
import qualified RP     -- r (reexport p:P)
import qualified RQP    -- r (reexport p:P)
import qualified RQP2   -- r (reexport p:P)
import qualified PMerge  -- q (reexport p:P), r (reexport p:P)
import qualified PMerge2 -- q (reexport p:P2), r (reexport p:P2)
import qualified QMerge  -- q (reexport q:Q), r (reexport q:Q)

x :: QP.P
x = RP.P

s = QP.p || Q.q || R.r


module T where

import Conflict -- should be ambiguous


module Q where
import P
q :: Int
q = p + 10


module Main where
import Q
main = print q


import Data.List.NonEmpty
main = return ()


module A where
import Foreign -- a local module
import Foreign.C -- a package module

y = Foreign.x


import qualified P.Lazy
import qualified P.Strict
main = P.Lazy.foo >> P.Strict.foo


module P where

import Map

foo = do
    let x = insert 0 "foo"
          . delete 1
          . insert 1 undefined
          . insert (6 :: Int) "foo"
          $ empty
    print (member 1 x)
    print (toList x)
    print x


module Q2 where
import Q
instance Show (IO a) where
    show = undefined


f2 :: Int -> Int -> Int
f2 x1 = if x1 == 0 then (\x0 -> x0) else let
     y = x1 - 1
     in f3 y y
f3 :: Int -> Int -> Int -> Int
f3 x2 = if x2 == 0 then f2 else let
     y = x2 - 1
     in f4 y y
f4 :: Int -> Int -> Int -> Int -> Int
f4 x3 = if x3 == 0 then f3 else let
     y = x3 - 1
     in \x2 x1 x0 -> f4 y x2 x1 (y + x0)
main = print (f2 100 0)


{-# LANGUAGE MagicHash #-}

{-
If the (unboxed, hence strict) "let thunk =" would survive to the CallArity
stage, it might yield wrong results (eta-expanding thunk and hence "cond" would
be called multiple times).

It does not actually happen (CallArity sees a "case"), so this test just
safe-guards against future changes here.
-}

import Debug.Trace
import GHC.Exts
import System.Environment

cond :: Int# -> Bool
cond x = trace ("cond called with " ++ show (I# x)) True
{-# NOINLINE cond #-}

bar (I# x) =
    let go n = let x = thunk n
               in case n of
                    100# -> I# x
                    _    -> go (n +# 1#)
    in go x
  where thunk = if cond x then \x -> (x +# 1#) else \x -> (x -# 1#)

main = do
    args <- getArgs
    bar (length args) `seq` return ()


{-# LANGUAGE TupleSections #-}
import CoreSyn
import CoreUtils
import Id
import Type
import MkCore
import CallArity (callArityRHS)
import MkId
import SysTools
import DynFlags
import ErrUtils
import Outputable
import TysWiredIn
import Literal
import GHC
import Control.Monad
import Control.Monad.IO.Class
import System.Environment( getArgs )
import VarSet
import PprCore
import Unique
import UniqSet
import CoreLint
import FastString

-- Build IDs. use mkTemplateLocal, more predictable than proper uniques
go, go2, x, d, n, y, z, scrutf, scruta :: Id
[go, go2, x,d, n, y, z, scrutf, scruta, f] = mkTestIds
    (words "go go2 x d n y z scrutf scruta f")
    [ mkVisFunTys [intTy, intTy] intTy
    , mkVisFunTys [intTy, intTy] intTy
    , intTy
    , mkVisFunTys [intTy] intTy
    , mkVisFunTys [intTy] intTy
    , intTy
    , intTy
    , mkVisFunTys [boolTy] boolTy
    , boolTy
    , mkVisFunTys [intTy, intTy] intTy -- protoypical external function
    ]

exprs :: [(String, CoreExpr)]
exprs =
  [ ("go2",) $
     mkRFun go [x]
        (mkLetNonRec d (mkACase (Var go `mkVarApps` [x])
                          (mkLams [y] $ Var y)
                  ) $ mkLams [z] $ Var d `mkVarApps` [x]) $
        go `mkLApps` [0, 0]
  , ("nested_go2",) $
     mkRFun go [x]
        (mkLetNonRec n (mkACase (Var go `mkVarApps` [x])
                          (mkLams [y] $ Var y))  $
            mkACase (Var n) $
                mkFun go2 [y]
                    (mkLetNonRec d
                        (mkACase (Var go `mkVarApps` [x])
                                 (mkLams [y] $ Var y) ) $
                        mkLams [z] $ Var d `mkVarApps` [x] )$
                    Var go2 `mkApps` [mkLit 1] ) $
        go `mkLApps` [0, 0]
  , ("d0 (go 2 would be bad)",) $
     mkRFun go [x]
        (mkLetNonRec d (mkACase (Var go `mkVarApps` [x])
                          (mkLams [y] $ Var y)
                  ) $
            mkLams [z] $ Var f `mkApps` [ Var d `mkVarApps` [x],  Var d `mkVarApps` [x] ]) $
        go `mkLApps` [0, 0]
  , ("go2 (in case crut)",) $
     mkRFun go [x]
        (mkLetNonRec d (mkACase (Var go `mkVarApps` [x])
                          (mkLams [y] $ Var y)
                  ) $ mkLams [z] $ Var d `mkVarApps` [x]) $
        Case (go `mkLApps` [0, 0]) z intTy
            [(DEFAULT, [], Var f `mkVarApps` [z,z])]
  , ("go2 (in function call)",) $
     mkRFun go [x]
        (mkLetNonRec d (mkACase (Var go `mkVarApps` [x])
                          (mkLams [y] $ Var y)
                  ) $ mkLams [z] $ Var d `mkVarApps` [x]) $
        f `mkLApps` [0] `mkApps` [go `mkLApps` [0, 0]]
  , ("go2 (using surrounding interesting let)",) $
     mkLetNonRec n (f `mkLApps` [0]) $
         mkRFun go [x]
            (mkLetNonRec d (mkACase (Var go `mkVarApps` [x])
                              (mkLams [y] $ Var y)
                      ) $ mkLams [z] $ Var d `mkVarApps` [x]) $
            Var f `mkApps` [n `mkLApps` [0],  go `mkLApps` [0, 0]]
  , ("go2 (using surrounding boring let)",) $
     mkLetNonRec z (mkLit 0) $
         mkRFun go [x]
            (mkLetNonRec d (mkACase (Var go `mkVarApps` [x])
                              (mkLams [y] $ Var y)
                      ) $ mkLams [z] $ Var d `mkVarApps` [x]) $
            Var f `mkApps` [Var z,  go `mkLApps` [0, 0]]
  , ("two calls, one from let and from body (d 1 would be bad)",) $
     mkLetNonRec  d (mkACase (mkLams [y] $ mkLit 0) (mkLams [y] $ mkLit 0)) $
     mkFun go [x,y] (mkVarApps (Var d) [x]) $
     mkApps (Var d) [mkLApps go [1,2]]
  , ("a thunk in a recursion (d 1 would be bad)",) $
     mkRLet n (mkACase (mkLams [y] $ mkLit 0) (Var n)) $
     mkRLet d (mkACase (mkLams [y] $ mkLit 0) (Var d)) $
         Var n `mkApps` [d `mkLApps` [0]]
  , ("two thunks, one called multiple times (both arity 1 would be bad!)",) $
     mkLetNonRec n (mkACase (mkLams [y] $ mkLit 0) (f `mkLApps` [0])) $
     mkLetNonRec d (mkACase (mkLams [y] $ mkLit 0) (f `mkLApps` [0])) $
         Var n `mkApps` [Var d `mkApps` [Var d `mkApps` [mkLit 0]]]
  , ("two functions, not thunks",) $
     mkLetNonRec go  (mkLams [x] (mkACase (mkLams [y] $ mkLit 0) (Var f `mkVarApps` [x]))) $
     mkLetNonRec go2 (mkLams [x] (mkACase (mkLams [y] $ mkLit 0) (Var f `mkVarApps` [x]))) $
         Var go `mkApps` [go2 `mkLApps` [0,1], mkLit 0]
  , ("a thunk, called multiple times via a forking recursion (d 1 would be bad!)",) $
     mkLetNonRec  d   (mkACase (mkLams [y] $ mkLit 0) (f `mkLApps` [0])) $
     mkRLet go2 (mkLams [x] (mkACase (Var go2 `mkApps` [Var go2 `mkApps` [mkLit 0, mkLit 0]]) (Var d))) $
         go2 `mkLApps` [0,1]
  , ("a function, one called multiple times via a forking recursion",) $
     mkLetNonRec go   (mkLams [x] (mkACase (mkLams [y] $ mkLit 0) (Var f `mkVarApps` [x]))) $
     mkRLet go2 (mkLams [x] (mkACase (Var go2 `mkApps` [Var go2 `mkApps` [mkLit 0, mkLit 0]]) (go `mkLApps` [0]))) $
         go2 `mkLApps` [0,1]
  , ("two functions (recursive)",) $
     mkRLet go  (mkLams [x] (mkACase (mkLams [y] $ mkLit 0) (Var go `mkVarApps` [x]))) $
     mkRLet go2 (mkLams [x] (mkACase (mkLams [y] $ mkLit 0) (Var go2 `mkVarApps` [x]))) $
         Var go `mkApps` [go2 `mkLApps` [0,1], mkLit 0]
  , ("mutual recursion (thunks), called mutiple times (both arity 1 would be bad!)",) $
     Let (Rec [ (n, mkACase (mkLams [y] $ mkLit 0) (Var d))
              , (d, mkACase (mkLams [y] $ mkLit 0) (Var n))]) $
         Var n `mkApps` [Var d `mkApps` [Var d `mkApps` [mkLit 0]]]
  , ("mutual recursion (functions), but no thunks",) $
     Let (Rec [ (go,  mkLams [x] (mkACase (mkLams [y] $ mkLit 0) (Var go2 `mkVarApps` [x])))
              , (go2, mkLams [x] (mkACase (mkLams [y] $ mkLit 0) (Var go `mkVarApps` [x])))]) $
         Var go `mkApps` [go2 `mkLApps` [0,1], mkLit 0]
  , ("mutual recursion (functions), one boring (d 1 would be bad)",) $
     mkLetNonRec d (f `mkLApps` [0]) $
         Let (Rec [ (go,  mkLams [x, y] (Var d `mkApps` [go2 `mkLApps` [1,2]]))
                  , (go2, mkLams [x] (mkACase (mkLams [y] $ mkLit 0) (Var go `mkVarApps` [x])))]) $
             Var d `mkApps` [go2 `mkLApps` [0,1]]
  , ("a thunk (non-function-type), called twice, still calls once",) $
    mkLetNonRec d (f `mkLApps` [0]) $
        mkLetNonRec x (d `mkLApps` [1]) $
            Var f `mkVarApps` [x, x]
  , ("a thunk (function type), called multiple times, still calls once",) $
    mkLetNonRec d (f `mkLApps` [0]) $
        mkLetNonRec n (Var f `mkApps` [d `mkLApps` [1]]) $
            mkLams [x] $ Var n `mkVarApps` [x]
  , ("a thunk (non-function-type), in mutual recursion, still calls once (d 1 would be good)",) $
    mkLetNonRec d (f `mkLApps` [0]) $
        Let (Rec [ (x, Var d `mkApps` [go `mkLApps` [1,2]])
                 , (go, mkLams [x] $ mkACase (mkLams [z] $ Var x) (Var go `mkVarApps` [x]) ) ]) $
            Var go `mkApps` [mkLit 0, go `mkLApps` [0,1]]
  , ("a thunk (non-function-type), in mutual recursion, causes many calls (d 1 would be bad)",) $
    mkLetNonRec d (f `mkLApps` [0]) $
        Let (Rec [ (x, Var go `mkApps` [go `mkLApps` [1,2], go `mkLApps` [1,2]])
                 , (go, mkLams [x] $ mkACase (Var d) (Var go `mkVarApps` [x]) ) ]) $
            Var go `mkApps` [mkLit 0, go `mkLApps` [0,1]]
  , ("a thunk (function type), in mutual recursion, still calls once (d 1 would be good)",) $
    mkLetNonRec d (f `mkLApps` [0]) $
        Let (Rec [ (n, Var go `mkApps` [d `mkLApps` [1]])
                 , (go, mkLams [x] $ mkACase (Var n) (Var go `mkApps` [Var n `mkVarApps` [x]]) ) ]) $
            Var go `mkApps` [mkLit 0, go `mkLApps` [0,1]]
  , ("a thunk (non-function-type) co-calls with the body (d 1 would be bad)",) $
    mkLetNonRec d (f `mkLApps` [0]) $
        mkLetNonRec x (d `mkLApps` [1]) $
            Var d `mkVarApps` [x]
  ]

main = do
    [libdir] <- getArgs
    runGhc (Just libdir) $ do
        getSessionDynFlags >>= setSessionDynFlags . flip gopt_set Opt_SuppressUniques
        dflags <- getSessionDynFlags
        liftIO $ forM_ exprs $ \(n,e) -> do
            case lintExpr dflags [f,scrutf,scruta] e of
                Just msg -> putMsg dflags (msg $$ text "in" <+> text n)
                Nothing -> return ()
            putMsg dflags (text n Outputable.<> char ':')
            -- liftIO $ putMsg dflags (ppr e)
            let e' = callArityRHS e
            let bndrs = nonDetEltsUniqSet (allBoundIds e')
              -- It should be OK to use nonDetEltsUniqSet here, if it becomes a
              -- problem we should use DVarSet
            -- liftIO $ putMsg dflags (ppr e')
            forM_ bndrs $ \v -> putMsg dflags $ nest 4 $ ppr v <+> ppr (idCallArity v)

-- Utilities
mkLApps :: Id -> [Integer] -> CoreExpr
mkLApps v = mkApps (Var v) . map mkLit

mkACase = mkIfThenElse (mkVarApps (Var scrutf) [scruta])

mkTestId :: Int -> String -> Type -> Id
mkTestId i s ty = mkSysLocal (mkFastString s) (mkBuiltinUnique i) ty

mkTestIds :: [String] -> [Type] -> [Id]
mkTestIds ns tys = zipWith3 mkTestId [0..] ns tys

mkRLet :: Id -> CoreExpr -> CoreExpr -> CoreExpr
mkRLet v rhs body = mkLetRec [(v, rhs)] body

mkFun :: Id -> [Id] -> CoreExpr -> CoreExpr -> CoreExpr
mkFun v xs rhs body = mkLetNonRec v (mkLams xs rhs) body

mkRFun :: Id -> [Id] -> CoreExpr -> CoreExpr -> CoreExpr
mkRFun v xs rhs body = mkRLet v (mkLams xs rhs) body

mkLit :: Integer -> CoreExpr
mkLit i = Lit (mkLitInteger i intTy)

-- Collects all let-bound IDs
allBoundIds :: CoreExpr -> VarSet
allBoundIds (Let (NonRec v rhs) body) = allBoundIds rhs `unionVarSet` allBoundIds body `extendVarSet` v
allBoundIds (Let (Rec binds) body) =
    allBoundIds body `unionVarSet` unionVarSets
        [ allBoundIds rhs `extendVarSet` v | (v, rhs) <- binds ]
allBoundIds (App e1 e2) = allBoundIds e1 `unionVarSet` allBoundIds e2
allBoundIds (Case scrut _ _ alts) =
    allBoundIds scrut `unionVarSet` unionVarSets
        [ allBoundIds e | (_, _ , e) <- alts ]
allBoundIds (Lam _ e)  = allBoundIds e
allBoundIds (Tick _ e) = allBoundIds e
allBoundIds (Cast e _) = allBoundIds e
allBoundIds _ = emptyVarSet


module Main where

import Hoopl.Block
import Hoopl.Collections
import Hoopl.Graph
import Hoopl.Label

import Data.Maybe

data TestBlock e x = TB { label_ :: Label, successors_ :: [Label] }
    deriving (Eq, Show)

instance NonLocal TestBlock where
  entryLabel = label_
  successors = successors_

-- Test the classical diamond shape graph.
test_diamond :: LabelMap (TestBlock C C)
test_diamond = mapFromList $ map (\b -> (label_ b, b)) blocks
  where
    blocks =
        [ TB (mkHooplLabel 1) [mkHooplLabel 2, mkHooplLabel 3]
        , TB (mkHooplLabel 2) [mkHooplLabel 4]
        , TB (mkHooplLabel 3) [mkHooplLabel 4]
        , TB (mkHooplLabel 4) []
        ]

-- Test that the backedge doesn't change anything.
test_diamond_backedge :: LabelMap (TestBlock C C)
test_diamond_backedge = mapFromList $ map (\b -> (label_ b, b)) blocks
  where
    blocks =
        [ TB (mkHooplLabel 1) [mkHooplLabel 2, mkHooplLabel 3]
        , TB (mkHooplLabel 2) [mkHooplLabel 4]
        , TB (mkHooplLabel 3) [mkHooplLabel 4]
        , TB (mkHooplLabel 4) [mkHooplLabel 1]
        ]

-- Test that the "bypass" edge from 1 to 4 doesn't change anything.
test_3 :: LabelMap (TestBlock C C)
test_3 = mapFromList $ map (\b -> (label_ b, b)) blocks
  where
    blocks =
        [ TB (mkHooplLabel 1) [mkHooplLabel 2, mkHooplLabel 4]
        , TB (mkHooplLabel 2) [mkHooplLabel 4]
        , TB (mkHooplLabel 4) []
        ]

-- Like test_3 but with different order of successors for the entry point.
test_4 :: LabelMap (TestBlock C C)
test_4 = mapFromList $ map (\b -> (label_ b, b)) blocks
  where
    blocks =
        [ TB (mkHooplLabel 1) [mkHooplLabel 4, mkHooplLabel 2]
        , TB (mkHooplLabel 2) [mkHooplLabel 4]
        , TB (mkHooplLabel 4) []
        ]

main :: IO ()
main = do
    let result = revPostorderFrom test_diamond (mkHooplLabel 1)
    putStrLn (show $ map label_ result)
    let result = revPostorderFrom test_diamond_backedge (mkHooplLabel 1)
    putStrLn (show $ map label_ result)
    let result = revPostorderFrom test_3 (mkHooplLabel 1)
    putStrLn (show $ map label_ result)
    let result = revPostorderFrom test_4 (mkHooplLabel 1)
    putStrLn (show $ map label_ result)


{-# LANGUAGE MagicHash #-}

module ShouldCompile where

import GHC.Exts

data STRef s a = STRef (MutVar# s a)

-- ghc 4.08 had a problem with returning a MutVar#.

from :: STRef s a -> MutVar# s a
from (STRef x) = x

to :: MutVar# s a -> STRef s a
to x = STRef x


module M where
import Data.Char
{-# INLINE f #-}
f = map ord . map chr


module Test where

-- !!! caused compiler to generate bogus HC code, fixed in
-- basicTypes/Literal.lhs rev. 1.36.

f :: Double -> Int
f x = round (x - (-5.0))


module ShouldCompile where

--              Killed GHC 6.0 in isCrossDllArg
--
-- ghc-6.0: panic! (the `impossible' happened, GHC version 6.0):
--      coreSyn/CoreUtils.lhs:1188: Non-exhaustive patterns in function isCrossDllArg
--
-- The reason was that newST had the form
--   newST = \ @ v -> GHC.Base.:
--                      @ (Environment.Scope v)
--                      (case $fScopeOpersScope @ v
--                       of tpl_B1 { Environment.:DScopeOpers tpl_B2 tpl_B3 ->
--                       tpl_B2
--                       })
--                      (GHC.Base.[] @ (Environment.Scope v))

class ScopeOpers s where
      emptyScope :: s
      op :: s -> s

data Scope v = NewScope

instance ScopeOpers (Scope v) where
      emptyScope = error "emptyScope"
      op = error "op"

newtype SymbolTable v = SymbolTable [Scope v]

newST :: SymbolTable v
newST = SymbolTable [emptyScope]


module Bug where

import Foreign hiding ( unsafePerformIO )
import Foreign.ForeignPtr
import Data.Char
import System.IO.Unsafe

data PackedString = PS !(ForeignPtr Word8) !Int !Int

(!) :: PackedString -> Int -> Word8
(PS x s _l) ! i
    = unsafePerformIO $ withForeignPtr x $ \p -> peekElemOff p (s+i)

w2c :: Word8 -> Char
w2c = chr . fromIntegral

indexPS :: PackedString -> Int -> Char
indexPS theps i | i < 0 = error "Negative index in indexPS"
                | otherwise = w2c $ theps ! i


{-# LANGUAGE MagicHash #-}
module ShouldCompile where

-- exposed a bug in the NCG in 6.4.2
import GHC.Base
class Unboxable a where
    writeUnboxable :: MutableByteArray# RealWorld -> a -> State# RealWorld -> State# RealWorld
    writeUnboxable arr a s  =  writeInt8Array# arr 0# (getTag 0) s


{-# LANGUAGE ForeignFunctionInterface #-}
module ShouldCompile where

import Foreign.C.Types

{-
During 6.11, this was failing like this:

In file included from /ghc/includes/Stg.h:207,

                 from /tmp/ghc2904_0/ghc2904_0.hc:3:0:
/tmp/ghc2904_0/ghc2904_0.hc: In function `swM_ret':

/tmp/ghc2904_0/ghc2904_0.hc:22:0:
     error: `gamma' undeclared (first use in this function)

/tmp/ghc2904_0/ghc2904_0.hc:22:0:
     error: (Each undeclared identifier is reported only once

/tmp/ghc2904_0/ghc2904_0.hc:22:0:
     error: for each function it appears in.)
-}

foreign import ccall unsafe "math.h gamma"
    gamma :: CDouble -> CDouble


{-# LANGUAGE MagicHash, BangPatterns #-}
{-# OPTIONS_GHC -O0 #-}

-- Variant of cgrun066; compilation as a module is different.

module Cg008 (hashStr) where

import Foreign.C
import Data.Word
import Foreign.Ptr
import GHC.Exts

import Control.Exception

hashStr  :: Ptr Word8 -> Int -> Int
hashStr (Ptr a#) (I# len#) = loop 0# 0#
   where
    loop h n | isTrue# (n GHC.Exts.==# len#) = I# h
             | otherwise  = loop h2 (n GHC.Exts.+# 1#)
          where !c = ord# (indexCharOffAddr# a# n)
                !h2 = (c GHC.Exts.+# (h GHC.Exts.*# 128#)) `remInt#` 4091#


module Main where
fib :: Int -> Int
fib 0 = 1 -- GHC should merge the blocks
fib 1 = 1 -- of these two alternatives
fib n = fib (n-1) + fib (n-2)
main = print $ fib 10


{-# LANGUAGE NamedFieldPuns #-}

{-
This funny module was reduced from a failing build of stage2 using
the new code generator and the linear register allocator, with this bug:

"inplace/bin/ghc-stage1" -fPIC -dynamic  -H32m -O -Wall -H64m -O0    -package-name ghc-7.1.20110414 -hide-all-packages -i -icompiler/basicTypes -icompiler/cmm -icompiler/codeGen -icompiler/coreSyn -icompiler/deSugar -icompiler/ghci -icompiler/hsSyn -icompiler/iface -icompiler/llvmGen -icompiler/main -icompiler/nativeGen -icompiler/parser -icompiler/prelude -icompiler/profiling -icompiler/rename -icompiler/simplCore -icompiler/simplStg -icompiler/specialise -icompiler/stgSyn -icompiler/stranal -icompiler/typecheck -icompiler/types -icompiler/utils -icompiler/vectorise -icompiler/stage2/build -icompiler/stage2/build/autogen -Icompiler/stage2/build -Icompiler/stage2/build/autogen -Icompiler/../libffi/build/include -Icompiler/stage2 -Icompiler/../libraries/base/cbits -Icompiler/../libraries/base/include -Icompiler/. -Icompiler/parser -Icompiler/utils   -optP-DGHCI -optP-include -optPcompiler/stage2/build/autogen/cabal_macros.h -package Cabal-1.11.0 -package array-0.3.0.2 -package base-4.3.1.0 -package ghc-boot-0.0.0.0 -package bytestring-0.9.1.10 -package containers-0.4.0.0 -package directory-1.1.0.0 -package filepath-1.2.0.0 -package hoopl-3.8.7.0 -package hpc-0.5.0.6 -package old-time-1.0.0.6 -package process-1.0.1.4 -package template-haskell-2.5.0.0 -package unix-2.4.1.0  -Wall -fno-warn-name-shadowing -fno-warn-orphans -XHaskell98 -XNondecreasingIndentation -XCPP -XMagicHash -XUnboxedTuples -XPatternGuards -XForeignFunctionInterface -XEmptyDataDecls -XTypeSynonymInstances -XMultiParamTypeClasses -XFlexibleInstances -XRank2Types -XScopedTypeVariables -XDeriveDataTypeable -DGHCI_TABLES_NEXT_TO_CODE -DSTAGE=2 -O2 -O -DGHC_DEFAULT_NEW_CODEGEN -no-user-package-db -rtsopts     -odir compiler/stage2/build -hidir compiler/stage2/build -stubdir compiler/stage2/build -hisuf dyn_hi -osuf  dyn_o -hcsuf dyn_hc -c compiler/main/DriverPipeline.hs -o compiler/stage2/build/DriverPipeline.dyn_o  -fforce-recomp -dno-debug-output -fno-warn-unused-binds

ghc-stage1: panic! (the 'impossible' happened)
  (GHC version 7.1.20110414 for x86_64-unknown-linux):
        Cannot patch JMP_TBL

This panic only appears to show up on x86-64 and with -fPIC.  I wasn't
able to get the produced optimized C-- to crash the linear register
allocator.  To see the bug, you need some extra patches for the new code
generator, in particular, this set (which can be acquired from the
jmp_tbl_bug tag at <https://github.com/ezyang/ghc>):

    commit 7b275c93df7944f0a9b51034cf1f64e3e70582a5
    Author: Edward Z. Yang <ezyang@mit.edu>
    Date:   Thu Apr 14 21:20:21 2011 +0100

        Give manifestSP better information about the actual SP location.

        This patch fixes silliness where the SP pointer is continually
        bumped up and down.

        Signed-off-by: Edward Z. Yang <ezyang@mit.edu>

    commit 5b5add4246d3997670ae995f7d2a028db92fff95
    Author: Edward Z. Yang <ezyang@mit.edu>
    Date:   Wed Apr 13 11:16:36 2011 +0100

        Generalized assignment rewriting pass.

        This assignment rewriting pass subsumes the previous reload
        sinking pass, and also performs basic inlining.

        Signed-off-by: Edward Z. Yang <ezyang@mit.edu>

The ostensible cause is that the linear register allocator is getting
really unlucky and needs to insert a fixup block after precisely one
jump in a jump table, because the block it jumps to was processed
already.  As you can see, actually getting the linear register allocator
into this funk is /very/ difficult.

-}

module DriverPipeline (compileFile) where

import Control.Exception

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

data Phase
        = Unlit ()
        | Ccpp
        | Cc
        | Cobjc
        | HCc
        | SplitAs
        | As
        | LlvmOpt
        | LlvmLlc
        | LlvmMangle
        | MergeStub
        | StopLn
  deriving (Show)

data PipeState = PipeState {
       stop_phase   :: Phase,
       src_basename :: String,
       output_spec  :: (),
       hsc_env      :: Maybe String,
       maybe_loc    :: Maybe String
  }

newtype CompPipeline a = P { unP :: PipeState -> IO (PipeState, a) }

instance Functor CompPipeline where
    fmap = liftM

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

instance Monad CompPipeline where
  return a = P $ \state -> return (state, a)
  P m >>= k = P $ \state -> do (state',a) <- m state
                               unP (k a) state'

eqPhase :: Phase -> Phase -> Bool
eqPhase (Unlit _)   (Unlit _)   = True
eqPhase Ccpp        Ccpp        = True
eqPhase Cc          Cc          = True
eqPhase HCc         HCc         = True
eqPhase SplitAs     SplitAs     = True
eqPhase As          As          = True
eqPhase LlvmOpt     LlvmOpt     = True
eqPhase LlvmLlc     LlvmLlc     = True
eqPhase LlvmMangle  LlvmMangle  = True
eqPhase MergeStub   MergeStub   = True
eqPhase StopLn      StopLn      = True
eqPhase _           _           = False

compileFile start_phase state = do
  unP (pipeLoop start_phase) state
  getOutputFilename undefined undefined undefined undefined undefined undefined

pipeLoop phase = do
  dflags@PipeState{stop_phase} <- getPipeState
  io $ evaluate (phase `eqPhase` stop_phase)
  runPhase phase dflags
  pipeLoop phase

getOutputFilename :: Phase -> () -> String -> Maybe String -> Phase -> Maybe String -> IO String
getOutputFilename p o b md p' ml
   | p' `eqPhase` p, () <- o = undefined
   | Just l <- ml = return l
   | Just d <- md = return $ d ++ b
   | otherwise    = undefined

runPhase p _ | p `eqPhase` Cc || p `eqPhase` Ccpp || p `eqPhase` HCc || p `eqPhase` Cobjc = undefined
runPhase LlvmMangle _ = undefined
runPhase SplitAs _ = undefined
runPhase LlvmOpt _ = undefined
runPhase LlvmLlc dflags = phaseOutputFilename >> io (evaluate dflags) >> return undefined
runPhase MergeStub _ = phaseOutputFilename >> undefined
runPhase other _ = io (evaluate (show other)) >> undefined

phaseOutputFilename :: CompPipeline ()
phaseOutputFilename = do
  PipeState{stop_phase, src_basename, output_spec, maybe_loc, hsc_env} <- getPipeState
  io $ getOutputFilename stop_phase output_spec src_basename hsc_env StopLn maybe_loc

getPipeState = P $ \state -> return (state, state)
io m = P $ \state -> do a <- m; return (state, ())


module A where

-- when used with '-g' debug generation option
-- '*/*' leaked into a /* comment */ and broke
-- GNU as.
x */* y = 42


{-# LANGUAGE MagicHash, UnboxedTuples #-}

module T12115 where

import GHC.Prim
import GHC.Types

f :: (# Void#, (# #) #) -> String
f = f


{-# LANGUAGE GHCForeignImportPrim, UnliftedFFITypes, MagicHash #-}

module Lib where

import GHC.Prim

foreign import prim f1 :: Int# -> Int#


module M where

f :: Double -> Double -> Bool
f x y = if x < y then True else False


module T15723A where

{-# INLINE foo #-}
foo :: Int -> Int
foo x = {-# SCC foo1 #-} bar x

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


module T15723B where

import T15723A

test :: Int -> Int
test x = {-# SCC test1 #-} foo $ foo x


module Bug (tst) where
tst :: Float -> Bool
tst x = truncate x > (0::Int)


module Q where

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

test1 :: Word32 -> Char
test1 w | w .&. 0x80000000 /= 0 = 'a'
test1 _ = 'b'

-- this should use a testq instruction on x86_64
test2 :: Int64 -> Char
test2 w | w .&. (-3) /= 0 = 'a'
test2 _ = 'b'


{-# LANGUAGE EmptyDataDecls #-}

-- This used to give warnings:
--     ld: atom sorting error for _Main_MyType_closure_tbl and _Main_MyType2_closure_tbl in q.o
--     ld: atom sorting error for _Main_MyType_closure_tbl and _Main_MyType2_closure_tbl in q.o
--     ld: atom sorting error for _Main_MyType_closure_tbl and _Main_MyType2_closure_tbl in q.o
-- when compiling on OS X (trac #2578).

module Main (main) where

data MyType
data MyType2

main :: IO ()
main = print ()


module Spring where

import Data.Array.Unboxed

step :: UArray Int Double -> [Double]
step y = [y!1 + y!0]


{-# OPTIONS -fno-warn-redundant-constraints #-}

module T3286 (train) where

import qualified Data.Map as M
import Data.List (groupBy, foldl')
import Data.Maybe (fromMaybe, fromJust)
import Data.Function (on)
import T3286b

type Prob = LogFloat

learn_states :: (Ord state) => [(observation, state)] -> M.Map state Prob
learn_states xs = histogram $ map snd xs

learn_observations ::  (Ord state, Ord observation) =>
                       M.Map state Prob
                    -> [(observation, state)]
                    -> M.Map (observation, state) Prob
learn_observations state_prob = M.mapWithKey f . histogram
    where f (_, state) prob = prob / (fromJust $ M.lookup state state_prob)

histogram :: (Ord a) => [a] -> M.Map a Prob
histogram xs = let hist = foldl' undefined M.empty xs in
                M.map (/ M.foldrWithKey (\_ a b -> a + b) 0 hist) hist

train :: (Ord observation, Ord state) =>
            [(observation, state)]
         -> (observation -> [Prob])
train sample = model
    where
        states = learn_states sample
        state_list = M.keys states

        observations = learn_observations states sample
        observation_probs = fromMaybe (fill state_list []) . (flip M.lookup $
                            M.fromList $ map (\ (e, xs) -> (e, fill state_list xs)) $
                                map (\ xs -> (fst $ head xs, map snd xs)) $
                                groupBy     ((==) `on` fst)
                                            [(observation, (state, prob))
                                                | ((observation, state), prob) <- M.toAscList observations])

        model = observation_probs

        fill :: Eq state => [state] -> [(state, Prob)] -> [Prob]
        fill = undefined


{-# LANGUAGE GeneralizedNewtypeDeriving #-}

module T3286b (LogFloat) where

newtype LogFloat = LogFloat Double
    deriving (Eq, Ord, Num, Show)

instance Fractional LogFloat where
    (/) (LogFloat x) (LogFloat y)
        |    x == 1
          && y == 1 = error "(/)"
        | otherwise                = LogFloat (x-y)
    fromRational = LogFloat . fromRational


module Bug where

compose :: [a -> a] -> a -> a
compose =  foldr (.) id

class Compose a where
    compose1 :: a -> a -> a


module T7237 where

import Data.List (foldl')

data SPair = SPair { pX, pY :: Double } deriving (Eq,Show)

data AList = AList { pairs :: [SPair] } deriving Show

rnf' :: AList -> ()
rnf' aList = foldl' (flip seq) () (pairs aList) `seq` ()


{-# LANGUAGE MagicHash #-}
module T8205 where

import GHC.Exts

data Stack a = Stack a (Stack a)

dropFromStack :: Int# -> Stack a -> Stack a
dropFromStack 0# l = l
dropFromStack n  (x `Stack` xs) = dropFromStack (n -# 1#) xs


{-# LANGUAGE ScopedTypeVariables #-}
module M () where

import Data.Bits ((.&.))

bitsSet :: Int -> Int -> Bool
bitsSet mask i
  = (i .&. mask == mask)

class Eq b => BitMask b where
  assocBitMask :: [(b,Int)]

  fromBitMask  :: Int -> b
  fromBitMask i
    = walk assocBitMask
    where
      walk []         = error "Graphics.UI.WX.Types.fromBitMask: empty list"
      walk [(x,0)]    = x
      walk ((x,m):xs) | bitsSet m i = x
                      | otherwise   = walk xs

data Align   = AlignLeft
             | AlignCentre
             deriving Eq

instance BitMask Align where
  assocBitMask
    = [(AlignCentre,512)
      ,(AlignLeft,  256)
      ]


module M (f) where

f :: Int -> Int
f i = go [ 1, 0 ]
    where
      go :: [Int] -> Int
      go []     = undefined
      go [1]    = undefined
      go (x:xs) | x == i    = 2
                | otherwise = go xs


{-# LANGUAGE UnboxedTuples #-}
module T9964 where

import GHC.Base

crash :: IO ()
crash = IO (\s ->
  let
    {-# NOINLINE s' #-}
    s' = s
  in (# s', () #))


{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE UnboxedTuples #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE MagicHash #-}
module Bug where

import GHC.Exts (TYPE, RuntimeRep, Weak#, State#, RealWorld, mkWeak# )

class Foo (a :: TYPE rep) where
  bar :: forall rep2 (b :: TYPE rep2). (a -> a -> b) -> a -> a -> b

baz :: forall rep (a :: TYPE rep). Foo a => a -> a -> (# a, a #)
baz = bar (#,#)

obscure :: (forall (rep1 :: RuntimeRep) (rep2 :: RuntimeRep)
                   (a :: TYPE rep1) (b :: TYPE rep2).
                   a -> b -> (# a, b #)) -> ()
obscure _ = ()

quux :: ()
quux = obscure (#,#)

primop :: forall (rep :: RuntimeRep) (a :: TYPE rep) b c.
          a -> b -> (State# RealWorld -> (# State# RealWorld, c #))
       -> State# RealWorld -> (# State# RealWorld, Weak# b #)
primop = mkWeak#


import Data.Bits
import GHC.Float
import GHC.Word
import Numeric

main :: IO ()
main = do
    putStrLn "Float"
    mapM_ print floats
    putStrLn "\nDouble"
    mapM_ print doubles
    putStrLn "\nWord32"
    mapM_ (printHex32 . castFloatToWord32) floats
    putStrLn "\nWord64"
    mapM_ (printHex64 . castDoubleToWord64) doubles
    putStrLn "Done!"

floats :: [Float]
floats = map castWord32ToFloat $ 0 : map (2^) [ 0 .. 31 ]

doubles :: [Double]
doubles = map castWord64ToDouble $ 0 : map (2^) [ 0 .. 63 ]

printHex32 :: Word32 -> IO ()
printHex32 w = putStrLn $ "0x" ++ showHex (0xffffffff .&. w) ""

printHex64 :: Word64 -> IO ()
printHex64 w = putStrLn $ "0x" ++ showHex w ""


-- !! cg001: main = -42 -- take 1

main = print ( f () )
     where
       f :: a -> Int
       f x = -42


main = print ((f id2) (10 + thirty_two))
  where
    f x = g x
      where
        g x = h x
          where
            h x = x

    thirty_two :: Int
    thirty_two = 32

id2 x = x


main = print (id2 (id2 id2) (42::Int))
--      where
--      id2 = s k k

-- id2 x = s k k x

id2 = s k k

s x y z = x z (y z)

k x y = x


main = print (length thirteen_ones)
     where
        thirteen_ones   = take (13::Int) ones

        ones :: [Int]
        ones            = 1 : ones


data Tree a = Leaf a | Branch (Tree a) (Tree a)

main = print (height our_tree)
    where
      our_tree :: Tree Int
      our_tree =
        Branch (Branch (Leaf 1) (Branch (Branch (Leaf 1) (Leaf 1)) (Leaf 1)))
               (Branch (Leaf 1) (Leaf 1))

height :: Tree a -> Int

height (Leaf _)         = 1
height (Branch t1 t2)   = 1 + max (height t1) (height t2)


main = print (length comp_list)
 where
    comp_list :: [(Int,Int)]
    comp_list = [ (elem1,elem2)
                | elem1 <- given_list,
                  elem2 <- given_list,
                  elem1 >= (4::Int),
                  elem2 <  (3::Int)
                ]

    given_list :: [Int]
    given_list = [1,2,3,4,5,6,7,8,9]


main = print (length take_list)
 where
    take_list :: [Int]
    take_list = takeWhile (\ x -> x < 6) given_list

    given_list :: [Int]
    given_list = [1,2,3,4,5,6,7,8,9]


main = print a
  where
    a :: Int
    b :: Int
    (a, b) = (3 + 4, 5 + 6)


-- !!! simple overloading example

class Foo a where
    foo :: a -> a -> Bool

class (Foo a) => Bar a where
    bar :: a -> a -> Bool

instance Foo Int where
    foo a b = a /= b

instance Foo Bool where
    foo a b = a /= b

instance Bar Int where
    bar a b = a < b

instance Bar Bool where
    bar a b = a < b

foO = if bar (2::Int) (3::Int) then
            if bar False True then
                (42::Int)
            else
                (888::Int)
       else
          (999::Int)

main = print foO


{-# LANGUAGE MagicHash #-}
-- !!! move arguments around on the stacks, mainly the B stack

import GHC.Base ( Float#, Double#, Int#, Int(..) )

main = print foo

foo = I#
        ( f 1.1##
            2.1#
            True
            3.1##
            4.1#
            5.1##
            6.1##
            42# -- the answer!
            7.1#
            8.1# )
    where
      f :: Double# -> Float# -> Bool -> Double# -> Float#
        -> Double# -> Double# -> Int# -> Float# -> Float#
        -> Int#
      f b1 s2 t b3 s4 b5 b6 i42 s7 s8
        -- evens, then odds
        = g s2 b3 b5 i42 s8 b1 t s4 b6 s7

      g :: Float# -> Double# -> Double# -> Int# -> Float#
        -> Double# -> Bool -> Float# -> Double# -> Float#
        -> Int#
      g s2 b3 b5 i42 s8 b1 t s4 b6 s7
        -- powers of 2 backwards, then others forwards
        = h s7 b6 t b5 s2 b3 i42 s8 b1 s4

      h :: Float# -> Double# -> Bool -> Double# -> Float#
        -> Double# -> Int# -> Float# -> Double# -> Float#
        -> Int#
      h s7 b6 t b5 s2 b3 i42 s8 b1 s4
        = i42


{-
From: Kevin Hammond <kh>
To: partain
Subject: Nasty Overloading
Date: Wed, 23 Oct 91 16:19:46 BST
-}
module Main where

class Foo a where
        o1 :: a -> a -> Bool
        o2 :: a -> Int

--      o2 :: Int
    -- Lennart: The type of method o2 does not contain the variable a
    -- (and it must according to line 1 page 29 of the manual).

class Foo tyvar => Bar tyvar where
        o3 :: a -> tyvar -> tyvar

-- class (Eq a, Foo a) => Baz a where
class (Ord a, Foo a) => Baz a where
        o4 :: a -> a -> (String,String,String,a)

instance (Ord a, Foo a) =>  Foo [a] where
        o2 x = 100
        o1 a b = a < b || o1 (head a) (head b)

-- instance Bar [a] where
instance (Ord a, Foo a) => Bar [a] where
        o3 x l = []
    --
    -- Lennart: I guess the instance declaration
    --  instance Bar [w] where
    --          o3 x l = []
    -- is wrong because to be a Bar you have to be a Foo.  For [w] to
    -- be a Foo, w has to be Ord and Foo.  But w is not Ord or Foo in
    -- this instance declaration so it must be wrong.  (Page 31, line
    -- 7: The context c' must imply ...)

instance Baz a => Baz [a] where
        o4 [] [] = ("Nil", "Nil", "Nil", [])
        o4 l1 l2 =
                (if o1 l1 l2 then "Y" else "N",
                 if l1 == l2 then "Y" else "N",
--               if o4 (head l1) (head l2) then "Y" else "N",
                 case o4 (head l1) (head l2) of
                        (_,_,_,l3) -> if (o1 (head l1) l3) then "Y" else "N",
                 l1 ++ l2 )

instance Foo Int where
        o2 x = x
        o1 i j = i == j

instance Bar Int where
        o3 _ j = j + 1

instance Baz Int where
--      o4 i j = i > j
        o4 i j = (if i>j then "Y" else "Z", "p", "q", i+j)
--simpl:o4 i j = ("Z", "p", "q", i+j)

{- also works w/ glhc! -}

main =  if o4 [1,2,3] [1,3,2::Int] /= ("Y","N","Y",[1,2,3,1,3,2]) then
                (print "43\n")
        else    (print "144\n")

{- works: glhc
main =  case o4 [1,2,3] [1,3,2::Int] of
                (s1,s2,s3,x) -> print s1

main =  case o4 ([]::[Int]) ([]::[Int]) of
                (s1,s2,s3,x) -> print s1
-}

{- simple main: breaks nhc, works w/ glhc
main = case o4 (3::Int) (4::Int) of (s1,s2,s3,x) -> print s1
-}


-- !! cg014: main = -42 -- twice: in Float and Double

main = print ((show ( (-42) :: Float )) ++ " " ++ (show ( (-42) :: Double )) ++ "\n")


{-# LANGUAGE MagicHash #-}
module Main ( main ) where

import Foreign
import Foreign.C
import GHC.Exts

data CList = CNil | CCons Int# CList

mk :: Int# -> CList
mk n  = if isTrue# (n ==# 0#)
        then CNil
        else CCons 1# (mk (n -# 1#))

clen :: CList -> Int#
clen CNil = 0#
clen (CCons _ cl) = 1# +# (clen cl)

main = case (clen list4) of
                len4 ->
                  case (len4 +# len4) of
                    8# -> finish 65#    -- 'A'
                    _  -> finish 66#    -- 'B'
      where
      list4     = mk 4#

finish :: Int# -> IO ()
finish n = c_putchar (castCharToCChar (C# (chr# n))) >> return ()

foreign import ccall unsafe "putchar"
  c_putchar :: CChar -> IO CInt


-- !!! tests calls of `error' (that make calls of `error'...)
--
main = error ("1st call to error\n"++(
       error ("2nd call to error\n"++(
       error ("3rd call to error\n"++(
       error ("4th call to error\n"++(
       error ("5th call to error\n"++(
       error ("6th call to error"
       )))))))))))


-- !!! test of cyclic default methods
--
class Foo a where
    op1 :: Fractional b => a -> b -> Bool
    op2 :: Fractional b => a -> b -> Bool
    op3 :: Fractional b => a -> b -> Bool
    op4 :: Fractional b => a -> b -> Bool
    op5 :: Fractional b => a -> b -> Bool
    op6 :: Fractional b => a -> b -> Bool

    -- each depends on the next:
    op1 a b = not (op2 a b)
    op2 a b = not (op3 a b)
    op3 a b = not (op4 a b)
    op4 a b = not (op5 a b)
    op5 a b = not (op6 a b)
    op6 a b = not (op1 a b)

-- now some instance decls to break the cycle:
instance Foo Int where
    op1 a b = a == 42

instance Foo Char where
    op1 a b = a == 'c'

instance Foo a => Foo [a] where
    op1 a b = null a

-- try it:
main = do
    putStr (show (op2 (3::Int)    3.14159))
    putStr (show (op2 'X'         3.14159))
    putStr (show (op2 ([]::[Char])3.14159))


-- !!! printing of floating-pt numbers
--
main = print (1.234e5 :: Float)


-- !!! reading/showing of Ints/Integers
--
main = print ((read "-1") :: Integer)


-- !!! Tests garbage collection in the branch of a case
-- !!!  alternative where the constructor is returned in the heap.

{- This is also a rather stressful test for another reason.
   The mutual recursion between munch and f causes lots of
   closures to be built, of the form (munch n s), for some n and s.
   Now, all of these closures are entered and each has as its value
   the result delivere by the next; so the result is that there is
   a massive chain of identical updates.

   As it turns out, they are mostly garbage, so the GC could eliminate
   them (though this isn't implemented at present), but that isn't
   necessarily the case.

   The only correct solution is to spot that the updates are all
   updating with the same value (update frames stacked on top of each
   other), and update all but one with indirections to the last
   remaining one.  This could be done by GC, or at the moment the
   frame is pushed.

   Incidentally, hbc won't have this particular problem, because it
   updates immediately.

   NOTE: [March 97]  Now that stack squeezing happens when GC happens,
   the stack is squished at GC.  So this program uses a small stack
   in a small heap (eg 4m heap 2m stack), but in a big heap (no GC)
   it needs a much bigger stack (10m)!  It would be better to try GC/stack
   squeezing on stack oflo.
-}

module Main where

main = munch 100000 (inf 3)

data Stream a
  = MkStream a a a a a a a a a (Stream a)
  | Empty

inf :: Int -> Stream Int
inf n = MkStream n n n n n n n n n (inf n)

munch :: Int -> Stream a -> IO ()

munch n Empty = return () -- error "this never happens!\n"
    -- this first equation mks it non-strict in "n"
    -- (NB: call the "error" makes it strict)

munch 0 _ = putStr "I succeeded!\n"
munch n s = case (f n s) of
              (True, rest) -> rest
              (False, _)   -> error "this never happens either\n"

--f :: Int -> Stream a -> (Bool, [Request])

f n (MkStream _ _ _ _ _ _ _ _ _ rest)
  = -- garbage collection *HERE*, please!
    -- (forced by the closure for n-1)
    (True, munch (n - 1) rest)

-- munch and f are mutually recursive, just to be nasty


-- !!! tests stack stubbing: if "f" doesn't stub "ns",
-- !!! the program has a space leak.

module Main where

main = f (putStr "a")
         (take 1000000 (repeat True))
         (putStr "b")

f a ns b = if last ns then a else b


-- !!! test super-dictionary grabification
--

main = putStr (show (is_one (1.2::Double)))

is_one :: RealFloat a => a -> Bool

is_one x = x == 1.0


{-# LANGUAGE ScopedTypeVariables #-}
-- !!! test various I/O Requests
--
--
import Control.Exception
import System.Environment
import System.IO
import Debug.Trace (trace)
import Text.Regex
import Data.Maybe

main = do
    prog <- getProgName
    let Just (name:_) = matchRegex (mkRegex ".*(cgrun025)") prog
    hPutStr stderr (shows name "\n")
    args <- getArgs
    hPutStr stderr (shows args "\n")
    path <- getEnv "PATH"
    hPutStr stderr ("GOT PATH\n")
    stdin_txt <- getContents
    putStr stdin_txt
    file_cts <- readFile (head args)
    hPutStr  stderr file_cts
    trace "hello, trace" $
      catch (getEnv "__WURBLE__" >> return ()) (\ (e :: SomeException) -> error "hello, error")


{-# LANGUAGE MagicHash #-}

-- !!! simple tests of primitive arrays
--
module Main ( main ) where

import GHC.Exts
import Data.Char        ( chr )

import Control.Monad.ST
import Data.Array.ST
import Data.Array.Unboxed

import Data.Ratio

main = putStr
         (test_chars    ++ "\n"  ++
          test_ints     ++ "\n"  ++
          test_addrs    ++ "\n"  ++
          test_floats   ++ "\n"  ++
          test_doubles  ++ "\n"  ++
          test_ptrs     ++ "\n")

-- Arr# Char# -------------------------------------------
-- (main effort is in packString#)

test_chars :: String
test_chars
  = let arr# = f 1000
    in
        shows (lookup_range arr# 42# 416#) "\n"
  where
    f :: Int -> UArray Int Char

    f size@(I# size#)
      = runST (
            -- allocate an array of the specified size
          newArray_ (0, (size-1))       >>= \ arr# ->

            -- fill in all elements; elem i has "i" put in it
          fill_in arr# 0# (size# -# 1#) >>

            -- freeze the puppy:
          freeze arr#
        )

    fill_in :: STUArray s Int Char -> Int# -> Int# -> ST s ()

    fill_in arr_in# first# last#
      = if isTrue# (first# ># last#)
        then return ()
        else writeArray arr_in# (I# first#) ((chr (I# first#))) >>
             fill_in arr_in# (first# +# 1#) last#

    lookup_range :: UArray Int Char -> Int# -> Int# -> [Char]
    lookup_range arr from# to#
      = if isTrue# (from# ># to#)
        then []
        else (arr ! (I# from#))
             : (lookup_range arr (from# +# 1#) to#)

-- Arr# Int# -------------------------------------------

test_ints :: String
test_ints
  = let arr# = f 1000
    in
        shows (lookup_range arr# 42# 416#) "\n"
  where
    f :: Int -> UArray Int Int

    f size@(I# size#)
      = runST (
            -- allocate an array of the specified size
          newArray_ (0, (size-1))       >>= \ arr# ->

            -- fill in all elements; elem i has i^2 put in it
          fill_in arr# 0# (size# -# 1#) >>

            -- freeze the puppy:
          freeze arr#
        )

    fill_in :: STUArray s Int Int -> Int# -> Int# -> ST s ()

    fill_in arr_in# first# last#
      = if isTrue# (first# ># last#)
        then return ()
        else writeArray arr_in# (I# first#) (I# (first# *# first#)) >>
             fill_in arr_in# (first# +# 1#) last#

    lookup_range :: UArray Int Int -> Int# -> Int# -> [Int]
    lookup_range arr from# to#
      = if isTrue# (from# ># to#)
        then []
        else (arr ! (I# from#))
             : (lookup_range arr (from# +# 1#) to#)

-- Arr# Addr# -------------------------------------------

test_addrs :: String
test_addrs
  = let arr# = f 1000
    in
        shows (lookup_range arr# 42# 416#) "\n"
  where
    f :: Int -> UArray Int (Ptr ())

    f size@(I# size#)
      = runST (
            -- allocate an array of the specified size
          newArray_ (0, (size-1))       >>= \ arr# ->

            -- fill in all elements; elem i has i^2 put in it
          fill_in arr# 0# (size# -# 1#) >>

            -- freeze the puppy:
          freeze arr#
        )

    fill_in :: STUArray s Int (Ptr ()) -> Int# -> Int# -> ST s ()

    fill_in arr_in# first# last#
      = if isTrue# (first# ># last#)
        then return ()
        else writeArray arr_in# (I# first#)
                            (Ptr (int2Addr# (first# *# first#))) >>
             fill_in arr_in# (first# +# 1#) last#

    lookup_range :: UArray Int (Ptr ()) -> Int# -> Int# -> [ Int ]
    lookup_range arr from# to#
      = let
            a2i (Ptr a#) = I# (addr2Int# a#)
        in
        if isTrue# (from# ># to#)
        then []
        else (a2i (arr ! (I# from#)))
             : (lookup_range arr (from# +# 1#) to#)

-- Arr# Float# -------------------------------------------

test_floats :: String
test_floats
  = let arr# = f 1000
    in
        shows (lookup_range arr# 42# 416#) "\n"
  where
    f :: Int -> UArray Int Float

    f size@(I# size#)
      = runST (
            -- allocate an array of the specified size
          newArray_ (0, (size-1))       >>= \ arr# ->

            -- fill in all elements; elem i has "i * pi" put in it
          fill_in arr# 0# (size# -# 1#) >>

            -- freeze the puppy:
          freeze arr#
        )

    fill_in :: STUArray s Int Float -> Int# -> Int# -> ST s ()

    fill_in arr_in# first# last#
      = if isTrue# (first# ># last#)
        then return ()
{-      else let e = ((fromIntegral (I# first#)) * pi)
             in trace (show e) $ writeFloatArray arr_in# (I# first#) e >>
             fill_in arr_in# (first# +# 1#) last#
-}
        else writeArray arr_in# (I# first#) ((fromIntegral (I# first#)) * pi) >>
             fill_in arr_in# (first# +# 1#) last#

    lookup_range :: UArray Int Float -> Int# -> Int# -> [Float]
    lookup_range arr from# to#
      = if isTrue# (from# ># to#)
        then []
        else (arr ! (I# from#))
             : (lookup_range arr (from# +# 1#) to#)

-- Arr# Double# -------------------------------------------

test_doubles :: String
test_doubles
  = let arr# = f 1000
    in
        shows (lookup_range arr# 42# 416#) "\n"
  where
    f :: Int -> UArray Int Double

    f size@(I# size#)
      = runST (
            -- allocate an array of the specified size
          newArray_ (0, (size-1))       >>= \ arr# ->

            -- fill in all elements; elem i has "i * pi" put in it
          fill_in arr# 0# (size# -# 1#) >>

            -- freeze the puppy:
          freeze arr#
        )

    fill_in :: STUArray s Int Double -> Int# -> Int# -> ST s ()

    fill_in arr_in# first# last#
      = if isTrue# (first# ># last#)
        then return ()
        else writeArray arr_in# (I# first#) ((fromIntegral (I# first#)) * pi) >>
             fill_in arr_in# (first# +# 1#) last#

    lookup_range :: UArray Int Double -> Int# -> Int# -> [Double]
    lookup_range arr from# to#
      = if isTrue# (from# ># to#)
        then []
        else (arr ! (I# from#))
             : (lookup_range arr (from# +# 1#) to#)

-- Arr# (Ratio Int) (ptrs) ---------------------------------
-- just like Int# test

test_ptrs :: String
test_ptrs
  = let arr# = f 1000
    in
        shows (lookup_range arr# 42 416) "\n"
  where
    f :: Int -> Array Int (Ratio Int)

    f size
      = runST (
          newArray (1, size) (3 % 5)    >>= \ arr# ->
          -- don't fill in the whole thing
          fill_in arr# 1 400            >>
          freeze arr#
        )

    fill_in :: STArray s Int (Ratio Int) -> Int -> Int -> ST s ()

    fill_in arr_in# first last
      = if (first > last)
        then return ()
        else writeArray arr_in# first (fromIntegral (first * first)) >>
             fill_in  arr_in# (first + 1) last

    lookup_range :: Array Int (Ratio Int) -> Int -> Int -> [Ratio Int]
    lookup_range array from too
      = if (from > too)
        then []
        else (array ! from) : (lookup_range array (from + 1) too)


-- !!! simple test of 0-method classes
--

class (Num a, Integral a) => Foo a

main = putStr (shows (f ((fromInteger 21)::Int)
                        ((fromInteger 37))) "\n")

instance Foo Int

f :: Foo a => a -> a -> Integer

f a b = toInteger (a + b)


main = putStr (shows (f (read "42.0")) "\n")

-- f compiled to bogus code with ghc 0.18 and earlier
-- switch() on a DoubleReg

f :: Double -> Int
f 1.0 = 1
f 2.0 = 2
f 3.0 = 3
f x = round x


{-# LANGUAGE MagicHash #-}
-- !! test GEN reps w/ unboxed values in them
-- !! NB: it was the static ones that were hosed...
--
module Main ( main ) where

--import PrelBase
import GHC.Base

main = do
    putStr (shows (sum ([1..1{-30-}]++[1..1{-40-}]++[11,22])) "\n")
    putStr (shows (prog 1{-30-} 1{-40-}) "\n")

data Foo a
  = MkFoo [a] Int# [Int] Int# [(a,Int)] Int#
  -- The above will cause a *horrible* GEN rep'n.

prog :: Int -> Int -> Int

prog size_1 size_2
  = let
        list1 = static1 : (map mk_foo [1 .. size_1])
        list2 = static2 : (map mk_foo [1 .. size_2])
    in
    I# (add_up 0# list1 (reverse list2))

static1 = MkFoo (error "static11") 11# [] 11# (error "static12") 11#
static2 = MkFoo (error "static21") 22# [] 22# (error "static22") 22#

one, two :: Int
one = 1; two = 2

mk_foo i@(I# i#)
  = MkFoo (error "list1") i# [i,i] i# (error "list2") i#

add_up :: Int# -> [Foo a] -> [Foo a] -> Int#

add_up acc [] [] = acc
add_up acc [] ys  = add_up acc ys []
add_up acc (x:xs) (y:ys) = add_up (acc +# add x y) xs ys
add_up acc (x:xs) [] = add_up acc xs []

add :: Foo a -> Foo a -> Int#
add (MkFoo _ _ _ _ _ x) (MkFoo _ _ _ _ _ y)
  = x +# y


{-# LANGUAGE MagicHash #-}
-- !! pattern-matching failure on functions that return Int#

--import PrelBase --ghc1.3
import GHC.Base

main = putStr (shows (I# (foo bar1 bar2)) "\n")
  where
    bar1 = Bar1 40 (39,38) resps
    bar2 = Bar1  2 ( 1, 0) resps
    resps = error "1.2 responses"

data Response = Response -- stub

data Bar
  = Bar1 Int (Int,Int) [Response]
  | Bar2 Int Int#
  | Bar3 Int

foo :: Bar -> Bar -> Int#

foo (Bar1 (I# i) _ _) (Bar1 (I# j) _ _) = i +# j


{-# LANGUAGE MagicHash #-}
-- !! worker/wrapper turns ( \ <absent> -> Int# ) function
-- !! into Int# -- WRONG

--import PrelBase --ghc1.3
import GHC.Base

main = putStr (shows true_or_false "\n")
  where
    true_or_false
      = case (cmp_name True imp1 imp2) of
          -1# -> False
          0#  -> True
          1#  -> False

    imp1 = Imp s "Imp1" s s
    imp2 = Imp s "Imp2" s s

    s = "String!"

-- taken from compiler: basicTypes/ProtoName.lhs

cmp_name :: Bool -> ProtoName -> ProtoName -> Int#

cmp_name by_local (Unk n1) (Unk n2)        = cmpString n1 n2
cmp_name by_local (Unk n1) (Imp m n2 _ o2) = cmpString n1 (if by_local then o2 else n2)
cmp_name by_local (Unk n1) (Prel nm)
  =  let  (_, n2) = getOrigName nm  in
     cmpString n1 n2

cmp_name by_local (Prel n1) (Prel n2) = cmpName n1 n2

cmp_name True  (Imp _ _ _ o1) (Imp _ _ _ o2) = cmpString o1 o2

cmp_name False (Imp m1 n1 _ _) (Imp m2 n2 _ _)
  = case cmpString n1 n2 of {
      -1# -> -1#;
      0# -> case cmpString m1 m2 of {
               0# -> 0#;
               xxx -> if null m1 || null m2
                      then 0#
                      else xxx
             };
      _ -> 1#
    }

cmp_name True (Imp _ _ _ o1) (Prel nm)
  = let
        (_, n2) = getOrigName nm
    in
    cmpString o1 n2

cmp_name False (Imp m1 n1 _ _) (Prel nm)
  = case getOrigName nm   of { (m2, n2) ->
    case cmpString n1 n2 of { -1# -> -1#; 0# -> cmpString m1 m2; _ -> 1# }}

cmp_name by_local other_p1 other_p2
  = case cmp_name by_local other_p2 other_p1 of -- compare the other way around
      -1#  -> 1#
      0#  -> 0#
      _ -> -1#

data ProtoName
  = Unk         String  -- local name in module

  | Imp         String  -- name of defining module
                String  -- name used in defining name
                String  -- name of the module whose interface told me
                        -- about this thing
                String  -- occurrence name

  | Prel        String{-Name-}

cmpString, cmpName :: String -> String -> Int#
cmpString a b = 0#
cmpName = cmpString

getOrigName :: String -> (String, String)
getOrigName x = ("MODULE", x)


-- !! fromRational woes
import Data.Ratio -- 1.3

main = putStr (
   shows tinyFloat  ( '\n'
 : shows t_f        ( '\n'
 : shows hugeFloat  ( '\n'
 : shows h_f        ( '\n'
 : shows tinyDouble ( '\n'
 : shows t_d        ( '\n'
 : shows hugeDouble ( '\n'
 : shows h_d        ( '\n'
 : shows x_f        ( '\n'
 : shows x_d        ( '\n'
 : shows y_f        ( '\n'
 : shows y_d        ( "\n"
 )))))))))))))
  where
    t_f :: Float
    t_d :: Double
    h_f :: Float
    h_d :: Double
    x_f :: Float
    x_d :: Double
    y_f :: Float
    y_d :: Double
    t_f = fromRationalX (toRational tinyFloat)
    t_d = fromRationalX (toRational tinyDouble)
    h_f = fromRationalX (toRational hugeFloat)
    h_d = fromRationalX (toRational hugeDouble)
    x_f = fromRationalX (1.82173691287639817263897126389712638972163e-300 :: Rational)
    x_d = fromRationalX (1.82173691287639817263897126389712638972163e-300 :: Rational)
    y_f = 1.82173691287639817263897126389712638972163e-300
    y_d = 1.82173691287639817263897126389712638972163e-300

fromRationalX :: (RealFloat a) => Rational -> a
fromRationalX r =
        let
            h = ceiling (huge `asTypeOf` x)
            b = toInteger (floatRadix x)
            x = fromRat 0 r
            fromRat e0 r' =
                let d = denominator r'
                    n = numerator r'
                in  if d > h then
                       let e = integerLogBase b (d `div` h) + 1
                       in  fromRat (e0-e) (n % (d `div` (b^e)))
                    else if abs n > h then
                       let e = integerLogBase b (abs n `div` h) + 1
                       in  fromRat (e0+e) ((n `div` (b^e)) % d)
                    else
                       scaleFloat e0 (rationalToRealFloat {-fromRational-} r')
        in  x

{-
fromRationalX r =
  rationalToRealFloat r
{- Hmmm...
        let
            h = ceiling (huge `asTypeOf` x)
            b = toInteger (floatRadix x)
            x = fromRat 0 r

            fromRat e0 r' =
{--}            trace (shows e0 ('/' : shows r' ('/' : shows h "\n"))) (
                let d = denominator r'
                    n = numerator r'
                in  if d > h then
                       let e = integerLogBase b (d `div` h) + 1
                       in  fromRat (e0-e) (n % (d `div` (b^e)))
                    else if abs n > h then
                       let e = integerLogBase b (abs n `div` h) + 1
                       in  fromRat (e0+e) ((n `div` (b^e)) % d)
                    else
                       scaleFloat e0 (rationalToRealFloat r')
                       -- now that we know things are in-bounds,
                       -- we use the "old" Prelude code.
{--}            )
        in  x
-}
-}

-- Compute the discrete log of i in base b.
-- Simplest way would be just divide i by b until it's smaller then b, but that would
-- be very slow!  We are just slightly more clever.
integerLogBase :: Integer -> Integer -> Int
integerLogBase b i =
     if i < b then
        0
     else
        -- Try squaring the base first to cut down the number of divisions.
        let l = 2 * integerLogBase (b*b) i
            doDiv :: Integer -> Int -> Int
            doDiv i l = if i < b then l else doDiv (i `div` b) (l+1)
        in  doDiv (i `div` (b^l)) l

------------

-- Compute smallest and largest floating point values.
tiny :: (RealFloat a) => a
tiny =
        let (l, _) = floatRange x
            x = encodeFloat 1 (l-1)
        in  x

huge :: (RealFloat a) => a
huge =
        let (_, u) = floatRange x
            d = floatDigits x
            x = encodeFloat (floatRadix x ^ d - 1) (u - d)
        in  x

tinyDouble = tiny :: Double
tinyFloat  = tiny :: Float
hugeDouble = huge :: Double
hugeFloat  = huge :: Float

{-
[In response to a request by simonpj, Joe Fasel writes:]

A quite reasonable request!  This code was added to the Prelude just
before the 1.2 release, when Lennart, working with an early version
of hbi, noticed that (read . show) was not the identity for
floating-point numbers.  (There was a one-bit error about half the time.)
The original version of the conversion function was in fact simply
a floating-point divide, as you suggest above.  The new version is,
I grant you, somewhat denser.

How's this?

--Joe
-}

rationalToRealFloat :: (RealFloat a) => Rational -> a

rationalToRealFloat x   =  x'
        where x'    = f e

--              If the exponent of the nearest floating-point number to x
--              is e, then the significand is the integer nearest xb^(-e),
--              where b is the floating-point radix.  We start with a good
--              guess for e, and if it is correct, the exponent of the
--              floating-point number we construct will again be e.  If
--              not, one more iteration is needed.

              f e   = if e' == e then y else f e'
                      where y      = encodeFloat (round (x * (1%b)^^e)) e
                            (_,e') = decodeFloat y
              b     = floatRadix x'

--              We obtain a trial exponent by doing a floating-point
--              division of x's numerator by its denominator.  The
--              result of this division may not itself be the ultimate
--              result, because of an accumulation of three rounding
--              errors.

              (s,e) = decodeFloat (fromInteger (numerator x) `asTypeOf` x'
                                        / fromInteger (denominator x))


module Main (main) where

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

c :: Double -> Double
c x = cos x
  where
    cos :: Double -> Double
    cos x = realToFrac (unsafePerformIO (c_cos (realToFrac x)))

foreign import ccall unsafe "cos"
  c_cos :: CDouble -> IO CDouble

main = putStr (shows (c 0.0) "\n")


-- !! Won't compile unless the compile succeeds on
-- !! the "single occurrence of big thing in a duplicated small thing"
-- !! inlining old-chestnut.  WDP 95/03
--
module Main ( main, g ) where

main = putStr (shows (g 42 45 45) "\n")

g :: Int -> Int -> Int -> [Int]

g x y z
  = let
        f a b = a + b * a * b - a + a + b + b * a * b - a + a + b + b * a * b - a + a + b + b * a * b - a + a + b + b * a * b - a + a + b + b * a * b - a + a + b + b * a * b - a + a + b + b * a * b - a + a + b + b * a * b - a + a + b + b * a * b - a + a + b + b * a * b - a + a + b + b * a * b - a + a + b + b * a * b - a + a + b + b * a * b - a + a + b
        g c = f c c
    in
    [g x, g y, g z, g x, g y, g z, g x, g y, g z, g x, g y, g z, g x, g y, g z, g x, g y, g z, g x, g y, g z, g x, g y, g z, g x, g y, g z, g x, g y, g z, g x, g y]


-- Andy Gill bug report 95/08:
-- Constant strings with '\0' in them don't work :-
--
main = putStrLn "hello\0 world"
--main = putStrLn "hello0 world"


{-
From: Rajiv Mirani <mirani>
Date: Sat, 26 Aug 95 21:14:47 -0400
Subject: GHC bug

GHC can't parse the following program when there is no newline at the
end of the last line:
-}

module Main where
main :: IO ()
main = return ()
-- random comment


-- !!! From a Rick Morgan bug report:
-- !!! Single-method class with a locally-polymorphic
-- !!! method.

module Main where

class Poly a where
   poly :: a -> b -> b

instance Poly [a] where
   poly [] y = y
   poly x  y = y

main = print ("hurrah" `poly` "Hello, world!\n")


module Main(main) where

data Burble a = B1 { op1 :: a -> Int, op2 :: Int -> a, op3 :: Int}
              | B2 { op2 :: Int -> a, op4 :: Int -> Int }

f1 :: Int -> Burble Int
f1 n = B1 { op1 = \x->x+n, op2 = \x -> x, op3 = n }

f2 :: Burble a -> Int -> Int
f2 r@(B1 {op1 = op1 , op2 = op2 }) n = op1 (op2 n) + op3 r

f3 :: Burble a -> Burble a
f3 x@(B1 {op3=op3}) = x {op3 = op3+1}

main = print (f2 (f3 (f1 3)) 4)


-- !!! Tickled a bug in core2stg
-- !!! (CoreSyn.Coerce constructors were not peeled off
-- !!! when converting CoreSyn.App)

module Main where

getData :: String -> IO ()
getData filename = case leng filename of {0 -> return ()}
leng :: String -> Int
leng [] = 0 --case ls of {[] -> 0 ; (_:xs) -> 1 + leng xs }
leng ls = leng ls

f [] [] = []
f xs ys = f xs ys

main =
     return ()  >>= \ _ ->
     case f [] [] of { [] -> getData [] }


{-# OPTIONS -cpp #-}
-- !!! Testing IEEE Float and Double extremity predicates.
module Main(main) where

import Data.Char
import Control.Monad.ST
import Data.Word
import Data.Array.Unsafe ( castSTUArray )
import Data.Array.ST

#include "ghcconfig.h"

reverse_if_bigendian :: [a] -> [a]
#ifdef WORDS_BIGENDIAN
reverse_if_bigendian = reverse
#else
reverse_if_bigendian = id
#endif

main :: IO ()
main = do
 sequence_ (map putStrLn double_tests)
 sequence_ (map putStrLn float_tests)
  where
   double_tests = run_tests double_numbers
   float_tests  = run_tests float_numbers

   run_tests nums =
    map ($ nums)
        [ denorm
        , pos_inf
        , neg_inf
        , nan
        , neg_zero
        , pos_zero
        ]

-------------
double_numbers :: [Double]
double_numbers =
      [ 0
      , encodeFloat 0 0     -- 0 using encodeFloat method
      , mkDouble (reverse_if_bigendian [0,0,0,0,0,0, 0xf0, 0x7f])  -- +inf
      , encodeFloat 1 2047  -- +Inf
      , encodeFloat 1 2048
      , encodeFloat 1  2047               -- signalling NaN
      , encodeFloat 0xf000000000000 2047  -- quiet NaN
      , 0/(0::Double)
        -- misc
      , 1.82173691287639817263897126389712638972163e-300
      , 1.82173691287639817263897126389712638972163e+300
      , 4.9406564558412465e-324  -- smallest possible denorm number
                                 -- (as reported by enquire running
                                 --  on a i686-pc-linux.)
      , 2.2250738585072014e-308
      , 0.11
      , 0.100
      , -3.4
        -- smallest
      , let (l, _) = floatRange x
            x = encodeFloat 1 (l-1)
        in x
        -- largest
      , let (_, u) = floatRange x
            d = floatDigits x
            x = encodeFloat (floatRadix x ^ d - 1) (u - d)
        in x
      ]

float_numbers :: [Float]
float_numbers =
      [ 0
      , encodeFloat 0 0     -- 0 using encodeFloat method
      , encodeFloat 1 255  -- +Inf
      , encodeFloat 1 256
      , encodeFloat 11 255        -- signalling NaN
      , encodeFloat 0xf00000 255  -- quiet NaN
      , 0/(0::Float)
        -- misc
      , 1.82173691287639817263897126389712638972163e-300
      , 1.82173691287639817263897126389712638972163e+300
      , 1.40129846e-45
      , 1.17549435e-38
      , 2.98023259e-08
      , 0.11
      , 0.100
      , -3.4
        -- smallest
      , let (l, _) = floatRange x
            x = encodeFloat 1 (l-1)
        in x
        -- largest
      , let (_, u) = floatRange x
            d = floatDigits x
            x = encodeFloat (floatRadix x ^ d - 1) (u - d)
        in x
      ]

-------------

denorm :: (Show a, RealFloat a) => [a] -> String
denorm numbers =
  unlines
     ( ""
     : "*********************************"
     : ("Denormalised numbers: " ++ doubleOrFloat numbers)
     : ""
     : map showPerform numbers)
 where
   showPerform = showAndPerform (isDenormalized) "isDenormalised"

pos_inf :: (Show a, RealFloat a) => [a] -> String
pos_inf numbers =
  unlines
     ( ""
     : "*********************************"
     : ("Positive Infinity: " ++ doubleOrFloat numbers)
     : ""
     : map showPerform numbers)
 where
   showPerform = showAndPerform (isInfinite) "isInfinite"

neg_inf :: (Show a, RealFloat a) => [a] -> String
neg_inf numbers =
  unlines
     ( ""
     : "*********************************"
     : ("Negative Infinity: " ++ doubleOrFloat numbers)
     : ""
     : map showPerform numbers)
 where
   showPerform = showAndPerform (\ x -> isInfinite x && x < 0) "isNegInfinite"

nan :: (Show a, RealFloat a) => [a] -> String
nan numbers =
  unlines
     ( ""
     : "*********************************"
     : ("NaN: " ++ doubleOrFloat numbers)
     : ""
     : map showPerform numbers)
 where
   showPerform = showAndPerform (isNaN) "isNaN"

pos_zero :: (Show a, RealFloat a) => [a] -> String
pos_zero numbers =
  unlines
     ( ""
     : "*********************************"
     : ("Positive zero: " ++ doubleOrFloat numbers)
     : ""
     : map showPerform numbers)
 where
   showPerform = showAndPerform (==0) "isPosZero"

neg_zero :: (Show a, RealFloat a) => [a] -> String
neg_zero numbers =
  unlines
     ( ""
     : "*********************************"
     : ("Negative zero: " ++ doubleOrFloat numbers)
     : ""
     : map showPerform numbers)
 where
   showPerform = showAndPerform (isNegativeZero) "isNegativeZero"

-- what a hack.
doubleOrFloat :: RealFloat a => [a] -> String
doubleOrFloat ls
 | (floatDigits atType) == (floatDigits (0::Double)) = "Double"
 | (floatDigits atType) == (floatDigits (0::Float))  = "Float"
 | otherwise = "unknown RealFloat type"
 where
   atType = undefined `asTypeOf` (head ls)

-- make a double from a list of 8 bytes
-- (caller deals with byte ordering.)
mkDouble :: [Word8] -> Double
mkDouble ls =
 runST (( do
   arr <- newArray_ (0,7)
   sequence (zipWith (writeArray arr) [(0::Int)..] (take 8 ls))
   arr' <- castSTUArray arr
   readArray arr' 0
 ) :: ST s Double )

showAndPerform :: (Show a, Show b)
               => (a -> b)
               -> String
               -> a
               -> String
showAndPerform fun name_fun val =
  name_fun ++ ' ':show val ++ " = " ++ show (fun val)


module Main( main ) where

main :: IO ()
main = seq (error "hello world!" :: Int) (return ())


module Main where

import System.IO

-- !!! CAF space leaks

main = lots_of_xs 10000

lots_of_xs 0 = return ()
lots_of_xs n = putChar 'x' >> lots_of_xs (n-1)


module Main where

--              GHC 4.04
-- I've been having problems getting GHC to compile some code I'm working
-- on with optimisation (-O) turned on.  Compilation is fine without -O
-- specified.  Through a process of elimination I've managed to reproduce
-- the problemin the following (much simpler) piece of code:

import Data.List

test es =
  concat (groupBy eq (zip [0..(length es) - 1] es))
  where
  eq a b = (fst a) == (fst b)

main = putStr (show (test [1,2,3,4]))


-- The new register allocator in 4.08 had a bug wherein
-- flow edges away from an insn which does a jump through
-- a switch table were not being added to the flow graph,
-- which causes computation of live ranges and thus register
-- assignment to be wrong in the alternatives and default.
-- This was fixed properly in the head branch (pre 4.09)
-- and avoided in 4.08.1 by disabling jump table generation
-- in the NCG -- it generates trees of ifs instead.

module Main ( main ) where

main = print (map f [1 .. 7])

{-# NOINLINE f #-}
f :: Int -> Bool
f 7 = False
f 1 = False
f 4 = False
f 6 = False
f 5 = False
f x = if x * 10 == 20 then True else False


-- !! Data constructors with strict fields
-- This test should use -funbox-strict-fields

module Main ( main ) where

main = print (g (f t))

t = MkT 1 2 (3,4) (MkS 5 6)

g (MkT x _ _ _) = x

data T = MkT Int !Int !(Int,Int) !(S Int)

data S a = MkS a a

{-# NOINLINE f #-}
f :: T -> T     -- Takes apart the thing and puts it
                -- back together differently
f (MkT x y (a,b) (MkS p q)) = MkT a b (p,q) (MkS x y)


-- !! Test strict, recursive newtypes
-- This test made a pre-5.02 fall over
-- Reason: the seq arising from the !F didn't see that
-- the represtation of F is a function.

-- NB It's crucial to compile this test *without* -O
-- The $ then prevents the 'F' from seeing the '\x'
-- and hence makes the evaluation happen at runtime

module Main ( main ) where

newtype F = F (Int -> Val)      -- NB: F and Val are
data Val = VFn !F |  VInt !Int  -- mutually recursive

f :: Val -> Val
f (VFn (F f)) = f 4

main = print (f (VFn (F $ (\x -> VInt (x+3)))))

instance Show Val where
  show (VInt n) = show n


module Main where

data T1         -- No constructors
data T2 = T2 !T1 Int

main = print (case (T2 (error "OK") 1) of { T2 x y -> y })

-- We should hit the (error "OK") case


-- !!! Caused a crash in GHC 5.04.2, fixed in CoreToStg.lhs rev. 1.98

data T1 = T1
data T2 = C1 !T1 | C2
data T3 = C3 !T2 Int

{-# NOINLINE f #-}
f 0 = C3 (C1 T1) 42
f n = C3 (C1 T1) n

main = case f 23 of
          C3 y z -> case y of
                        C1 T1 -> putStrLn "ok"


-- should run successfully and exit, i.e. without evaluating the
-- argument to return.
main = return undefined


module Main where

data Y = X1 | X2 | X3 | X4 | X5 | X6 | X7 | X8
        deriving( Show )

data X = WithY Y
         | A1 | A2 | A3 | A4 | A5 | A6 | A7 | A8

foo :: X -> Y
foo A1 = X1
foo A2 = X2
foo A3 = X3
foo A4 = X4
foo A5 = X5
foo A6 = X6
foo A7 = X7
foo A8 = X8
foo (WithY _) = X1

bar :: X -> Y
bar (WithY x) = x
bar y = foobar (foo y)  -- The WithY case can't occur, and in an
                        -- earlier version that confused the code generator

{-# NOINLINE foobar #-}
foobar x = x

main = print (map bar [WithY X2, A4, A5])


-- This program broke GHC 6.3, because dataToTag was called with
-- an unevaluated argument

module Main where

import System.Environment (getArgs)

-- NOTE: When if you remove Eight (or any other constructor) everything works
-- Having at least 9 constructors has something to do with the bug
data Digit = Zero | One | Two | Three | Four | Five | Six | Seven | Eight
    deriving (Eq,Enum)

instance Show Digit where
    show Five = "Five"
    show Six = "Six"
    show _ = undefined

-- Use either of these instances (instead of derived) and everything works
{-instance Enum Digit where
    fromEnum Five = 5
    fromEnum _ = undefined
    toEnum 6 = Six
    toEnum _ = undefined-}

{-instance Eq Digit where
    Five == Five = True
    Six == Six = True
    _ == _ = undefined-}

isFive :: Digit -> Bool
isFive a = succ a == Six

main :: IO()
main = do
    putStrLn ("======")
    -- These next two lines are just here to keep ghc from optimizing away stuff
    args <- getArgs
    let x = if length args == -1 then undefined else Five
    putStrLn ("x: " ++ show x)
    let y = succ x
    putStrLn ("let y = succ x")
    putStrLn ("y: " ++ show y)
    putStrLn ("y == Six: " ++ show (y == Six))
    putStrLn ("succ x == Six: " ++ show (succ x == Six))
    putStrLn ("isFive x: " ++ show (isFive x))