{-# LANGUAGE KindSignatures, TypeFamilies, PolyKinds, FlexibleInstances #-}

module T7341 where

data Proxy a = Proxy

class C a where
  type F (a :: *) :: *
  op :: Proxy a -> Int

instance C [] where
  op _ = 5


{-# LANGUAGE DataKinds                 #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE GADTs                     #-}
{-# LANGUAGE KindSignatures            #-}

module T7347 where

import Data.Kind (Type)

data K = forall a. T a  -- Existential: promotion gives 'T :: forall k. k -> K

data G :: K -> Type where
  D :: G (T [])         -- Uses existential


{-# LANGUAGE TypeFamilies, PolyKinds, ScopedTypeVariables #-}
module T7404 where

import Data.Kind (Type)

type family Foo (x :: Type) (y :: x)


{-# LANGUAGE StandaloneDeriving, DataKinds, KindSignatures, DeriveGeneric, GADTs#-}

module T7422 where

import GHC.Generics

type CellId = Int
type Ident = String
type LabelName = String

data ExprTag = TagAst | TagEval

data Expr (tag :: ExprTag) where
  Var :: Ident -> Expr tag
  Label :: LabelName -> Expr tag -> Expr tag

deriving instance Generic (Expr a)


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

module T7438 where
import T7438a

go Nil acc = acc


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

module T7438a where

import Data.Kind (Type)

data Thrist :: k -> k -> Type where
  Nil :: Thrist a a


 {-# LANGUAGE DataKinds, PolyKinds, RankNTypes, GADTs #-}

module T7481 where

import Data.Kind (Type)
import Data.Proxy

data D a where
  D1 :: a -> D a
  D2 :: (a~Int) => D a
  D3 :: forall k (a::k) b. Proxy a -> D b

data Foo :: D Type -> Type


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

module T7488 where

newtype A = A Bool
data B (x :: A)


{-# LANGUAGE DataKinds #-}
module T7502 where

type S = [1,2]


{-# LANGUAGE TypeFamilies, PolyKinds #-}
module T7524 where

type family F (a :: k1) (b :: k2)
type instance F a a = Int
type instance F a b = Bool


{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE UndecidableInstances  #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE UndecidableSuperClasses #-}
{-# LANGUAGE KindSignatures        #-}
{-# LANGUAGE TypeOperators         #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE GADTs           #-}
{-# LANGUAGE Rank2Types      #-}

module T7594 where

import Data.Kind (Constraint, Type)

class    (c1 t, c2 t) => (:&:) (c1 :: Type -> Constraint)
                               (c2 :: Type -> Constraint)
                               (t :: Type)
instance (c1 t, c2 t) => (:&:) c1 c2 t

data ColD c where
  ColD :: (c a) => a -> ColD c

app :: (forall a. (c a) => a -> b) -> ColD c -> b
app f (ColD x) = f x

q :: ColD (Show :&: Real)
q = ColD (1.2 :: Double)

bar = app print q
-- This one works, as a result of fixing Trac #8644,
-- because the given constraint is
--   (Show :&: Real) a, which has no equality superclasses

q2 :: ColD (c :&: Real)
q2 = error "urk"

bar2 = app print q2
-- This one fail, because the given constraint is
--   (c :&: Real) a, which might have equality superclasses


{-# LANGUAGE PolyKinds              #-}
{-# LANGUAGE TypeFamilies           #-}

module T7601 where

import Data.Kind

class C (a :: k) where
   type F (a :: k)

class Category (c :: k -> k -> Type) where
   type Ob c :: k -> Constraint


{-# LANGUAGE DataKinds, RankNTypes, TypeFamilies #-}
module T7805 where

data HigherRank = HR (forall a. a -> a)

type family F (x :: HigherRank)
type instance F (HR x) = Bool


{-# LANGUAGE GADTs, InstanceSigs, DataKinds, PolyKinds, RankNTypes, LambdaCase #-}

module T7908 where

import Data.Kind (Type)

class Monad' (m :: (k -> Type) -> Type) where
  return' :: c a -> m c
  (>>>=) :: m c -> (forall a . c a -> m d) -> m d
  (>>-) :: m c -> (forall a . c a -> d) -> d

data Nat = Z' | S' Nat

data Nat' (n :: Nat) where
  Z :: Nat' Z'
  S :: Nat' n -> Nat' (S' n)

data Hidden :: (k -> Type) -> Type where
  Hide :: m a -> Hidden m

instance Monad' Hidden where
  return' :: forall k (c :: k -> Type) (a :: k) . c a -> Hidden c
  return' = Hide
  (>>>=) :: forall k (c :: k -> Type) (d :: k -> Type) .
            Hidden c -> (forall (a :: k) . c a -> Hidden d) -> Hidden d
  Hide a >>>= f = f a
  (>>-) :: forall k (c :: k -> Type) d .
           Hidden c -> (forall (a :: k) . c a -> d) -> d
  Hide a >>- f = f a

int2nat' 0 = return' Z
int2nat' i = (int2nat' $ i - 1) >>>= (\n -> return' $ S n)

data Fin (m :: Nat)  (n :: Nat) where
  Fz :: Fin (S' m) Z'
  Fs :: Fin m n -> Fin (S' m) (S' n)

-- N.B. not total!
nat2fin :: Nat' f -> Hidden Nat' -> Hidden (Fin f)
nat2fin (S _) (Hide Z) = return' Fz
nat2fin (S f) n = n >>>= (\case S n -> (nat2fin f (return' n) >>>= (\fn -> return' $ Fs fn)))

fin2int :: Hidden (Fin f) -> Int
fin2int f = f >>- go
  where go :: Fin f n -> Int
        go Fz = 0
        go (Fs f) = 1 + go f

test = fin2int (nat2fin (S $ S Z) $ return' (S Z))


{-# LANGUAGE PolyKinds, ExplicitForAll #-}
module T7916 where

import Data.Kind (Type)

f :: forall k (m :: k -> Type) (a :: k). m a -> m a
f = id

-- g :: forall (m :: k -> Type) (a :: k). m a -> m a
g x = f x

data M f = M (f Int)

-- Test that g :: forall (m :: k -> Type) (a :: k). m a -> m a
g1 = g :: [Int] -> [Int]
g2 = g :: M [] -> M []


{-# LANGUAGE TypeFamilies, PolyKinds #-}

module T7939a where

type family F a where
  F Int = Bool
  F Maybe = Char


{-# LANGUAGE DataKinds, PolyKinds, KindSignatures #-}
{-# LANGUAGE ExistentialQuantification, UndecidableInstances, TypeFamilies #-}

module Test where

import Data.Kind (Type)

-- Kind-level proxies.
data {-kind-} K (a :: Type) = KP

-- A type with 1 kind-polymorphic type argument.
data T (n :: k)

-- A type with 1 kind argument.
data F (kp :: K k)

-- A class with 1 kind argument.
class (kp ~ KP) => C (kp :: K k) where
  f :: T (a :: k) -> F kp

-- A type with 1 kind argument.
-- Contains an existentially quantified type-variable of this kind.
data SomeT (kp :: K k) = forall (n :: k). Mk (T n)

-- Show `SomeT` by converting it to `F`, using `C`.
instance (C kp, Show (F kp)) => Show (SomeT kp) where
  show (Mk x) = show (f x)


{-# LANGUAGE MagicHash #-}
import Data.Typeable

data K = K

-- This used to have a RHS but now we hide typeRep#
instance Typeable K -- where typeRep# _ = undefined


{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
{-# LANGUAGE ConstraintKinds, MultiParamTypeClasses #-}

module T8359 where

class DifferentTypes a b

type DifferentTypes3 a b c = (DifferentTypes a b, DifferentTypes b c, DifferentTypes a c)

class Foo a

class Bar a

-- Buggy instance requires UndecidableInstances to compile

instance (DifferentTypes3 a b c, Bar a, Bar b, Bar c) => Foo (a, b, c)

-- Equivalent instance compiles when manually expanding constraint type
-- instance (DifferentTypes a b, DifferentTypes b c, DifferentTypes a c, Bar a, Bar b, Bar c) => Foo (a, b, c)


{-# LANGUAGE FunctionalDependencies, FlexibleInstances,
             TypeFamilies,
             PolyKinds #-}

module T8391 where

type  Foo a = a

class Bar a b | a -> b

instance Bar a (Foo a)


 {-# LANGUAGE GADTs, PolyKinds, DataKinds, TypeFamilies #-}

module T8449 where

import T8449a

foo = SNil


{-# LANGUAGE GADTs, TypeFamilies, DataKinds, PolyKinds #-}

module T8449a where

data Lst a = Nil | Cons a (Lst a)

data family SList (a :: k)
data instance SList (a :: Lst k) where
   SNil :: SList 'Nil


{-# LANGUAGE DeriveFunctor, PolyKinds #-}
module T8534 where
data A a = A deriving Functor


{-# LANGUAGE DataKinds #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE AllowAmbiguousTypes #-}  -- 'c' is ambiguous

module T8566 where

import Data.Kind (Type)

data U (s :: Type) = forall v. AA v [U s]
-- AA :: forall (s:*) (v:*). v -> [U s] -> U s

data I (u :: U Type) (r :: [Type]) :: Type where
   A :: I (AA t as) r                  -- Existential k

-- A :: forall (u:U *) (r:[*])                  Universal
--             (k:BOX) (t:k) (as:[U *]).        Existential
--             (u ~ AA * k t as) =>
--             I u r

-- fs unused, but needs to be present for the bug
class C (u :: U Type) (r :: [Type]) (fs :: [Type]) where
   c :: I u r -> I u r

-- c :: forall (u :: U *) (r :: [*]) (fs :: [*]). C u r fs => I u r -> I u r

instance (C (AA (t (I a ps)) as) ps fs) => C (AA t (a ': as)) ps fs where
-- instance C (AA t (a ': as)) ps fs where
  c A = c undefined


{-# LANGUAGE DataKinds                  #-}
{-# LANGUAGE PolyKinds                  #-}
{-# LANGUAGE TypeFamilies               #-}
{-# LANGUAGE GADTs                      #-}
{-# LANGUAGE ScopedTypeVariables        #-}
{-# LANGUAGE TypeOperators              #-}
module T8566a where

import Data.Kind (Type)

data Field = forall k. APP k [Field]

data InField (u :: Field) :: Type where
  A :: AppVars t (ExpandField args) -> InField (APP t args)

type family ExpandField (args :: [Field]) :: [Type]
type family AppVars (t :: k) (vs :: [Type]) :: Type

-- This function fails to compile, because we discard
-- 'given' kind equalities.  See comment 7 in Trac #8566
-- This is really a bug, I claim
unA :: InField (APP t args) -> AppVars t (ExpandField args)
unA (A x) = x


{-# LANGUAGE PolyKinds, RankNTypes, ScopedTypeVariables #-}
module T8616 where

import Data.Proxy
import GHC.Exts

withSomeSing :: forall k (kproxy :: k). Proxy kproxy
withSomeSing = undefined :: (Any :: k)
  -- The 'k' is bought into scope by the type signature
  -- This is a type error, but should not crash GHC

foo = (undefined :: Proxy (a :: k)) :: forall k (a :: k). Proxy a
  -- Again, the 'k' is bought into scope by the type signature
  -- No type error though


{-# LANGUAGE TypeOperators, DataKinds, PolyKinds,
             MultiParamTypeClasses, GADTs, ConstraintKinds, TypeFamilies #-}
module T8705 where

data family Sing (a :: k)
data Proxy a = Proxy

data instance Sing (a :: Maybe k) where
  SJust :: Sing h -> Sing (Just h)

data Dict c where
  Dict :: c => Dict c

-- A less-than-or-equal relation among naturals
class a :<=: b

sLeq :: Sing n -> Sing n2 -> Dict (n :<=: n2)
sLeq = undefined

insert_ascending :: (lst ~ Just n1) => Proxy n1 -> Sing n -> Sing lst -> Dict (n :<=: n1)
insert_ascending _ n (SJust h)
  = case sLeq n h of
      Dict -> Dict


{-# LANGUAGE DataKinds, PolyKinds, TypeFamilies, GADTs, TypeOperators #-}

module T8985 where

import Data.Kind (Type)

data X (xs :: [k]) = MkX
data Y :: (k -> Type) -> [k] -> Type where
  MkY :: f x -> Y f (x ': xs)

type family F (a :: [[Type]]) :: Type
type instance F xss = Y X xss

works :: Y X '[ '[ ] ] -> ()
works (MkY MkX) = ()

fails :: F '[ '[ ] ] -> ()
fails (MkY MkX) = ()


{-# LANGUAGE PolyKinds #-}

module T9017 where

import Control.Arrow

foo :: a b (m b)
foo = arr return


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

module T9063 where

import Data.Type.Equality
import Data.Proxy

class kproxy ~ 'KProxy => PEq (kproxy :: KProxy a) where
  type (:==) (x :: a) (y :: a) :: Bool
  type x :== y = x == y

instance PEq ('KProxy :: KProxy Bool)

foo :: Proxy (True :== True) -> Proxy (True == True)
foo = id


{-# LANGUAGE MultiParamTypeClasses, DataKinds, FunctionalDependencies,
   KindSignatures, PolyKinds, FlexibleInstances, FlexibleContexts,
   UndecidableInstances #-}

module T9106 where

import GHC.TypeLits

class FunctorN (n :: Nat) f (a :: *) (fa :: *) | n f a -> fa where

instance FunctorN 0 f a a where

instance FunctorN n f a (f fa)


{-# LANGUAGE PolyKinds, DataKinds, TypeFamilies, GADTs, RankNTypes #-}

module T9144 where

import Data.Proxy
import GHC.TypeLits

data family Sing (a :: k)

data SomeSing :: KProxy k -> * where
  SomeSing :: forall k (a :: k). Sing a -> SomeSing ('KProxy :: KProxy k)

class kproxy ~ 'KProxy => SingKind (kproxy :: KProxy k) where
  fromSing :: forall (a :: k). Sing a -> DemoteRep ('KProxy :: KProxy k)
  toSing :: DemoteRep ('KProxy :: KProxy k) -> SomeSing ('KProxy :: KProxy k)

type family DemoteRep (kproxy :: KProxy k) :: *

data Foo = Bar Nat
data FooTerm = BarTerm Integer

data instance Sing (x :: Foo) where
  SBar :: Sing n -> Sing (Bar n)

type instance DemoteRep ('KProxy :: KProxy Nat) = Integer
type instance DemoteRep ('KProxy :: KProxy Foo) = FooTerm

instance SingKind ('KProxy :: KProxy Nat) where
  fromSing = undefined
  toSing = undefined

instance SingKind ('KProxy :: KProxy Foo) where
  fromSing (SBar n) = BarTerm (fromSing n)
  toSing n = case toSing n of SomeSing n' -> SomeSing (SBar n')


{-# LANGUAGE PolyKinds, MultiParamTypeClasses, FlexibleContexts, DataKinds,
             TypeFamilies #-}

module T9200 where

import Data.Kind (Type)
import Data.Proxy

------
-- test CUSK on classes

class C (f :: k) (a :: k2) where
  c_meth :: D a => Proxy f -> Proxy a -> ()

class C () a => D a

---------
--- test CUSK on type synonyms
data T1 a b c = MkT1 (S True b c)
data T2 p q r = MkT2 (S p 5 r)
data T3 x y q = MkT3 (S x y '())
type S (f :: k1) (g :: k2) (h :: k3) = ((T1 f g h, T2 f g h, T3 f g h) :: Type)

----------
-- test CUSK on closed type families
type family F (a :: k) :: k where
  F True = False
  F False = True
  F x = x


{-# LANGUAGE TypeFamilies, PolyKinds, DataKinds #-}

module T9200b where

---------
--- test CUSK on closed type families
type family F (a :: k) where
  F True = False
  F False = True
  F x = x


{-# LANGUAGE RankNTypes, GADTs, DataKinds, PolyKinds, TypeOperators, TypeFamilies #-}
module T9222 where

import Data.Kind
import Data.Proxy

-- Nov 2014: actually the type of Want is ambiguous if we
--           do the full co/contra thing for subtyping,
--           which we now do
-- So this program is erroneous.  (But the original ticket was
-- a crash, and that's still fixed!)

data Want :: (i,j) -> Type where
  Want :: (a ~ '(b,c) => Proxy b) -> Want a


{-# LANGUAGE DataKinds, KindSignatures, TypeFamilies #-}
module T9263a where

import T9263b
import Data.Proxy

data Void

instance PEq ('KProxy :: KProxy Void)


{-# LANGUAGE DataKinds, PolyKinds, TypeFamilies #-}
module T9263b where

import Data.Proxy

class kproxy ~ 'KProxy => PEq (kproxy :: KProxy a) where
   type F (x :: a) :: Bool
   type F (x :: a) = False


{-# LANGUAGE PolyKinds, TypeFamilies, ScopedTypeVariables #-}
module T9264 where

class C (a :: k) where
   type F (a :: k)
   type F (a :: k) = Int


{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
{-# LANGUAGE RankNTypes, ConstraintKinds, KindSignatures, DataKinds, TypeFamilies #-}
module T9569 where

import GHC.Exts

data Proxy (c :: Constraint)

class Deferrable (c :: Constraint) where
  defer :: Proxy c -> (c => a) -> a

deferPair :: (Deferrable c1, Deferrable c2) =>
                  Proxy (c1,c2) -> ((c1,c2) => a) -> a
deferPair = undefined

instance (Deferrable c1, Deferrable c2) => Deferrable (c1,c2) where
    -- defer p f = deferPair p f     -- Succeeds
    defer = deferPair                -- Fails

{-
  [G] Deferrable c1, Deferrable c2

  [W] Proxy (c1,c2) -> ((c1,c2) => a) -> a ~ Proxy (c1x,c2x) -> ((c1x,c2x) => ax) -> ax
  [w] Deferrable c1x
  [w] Deferrable c2x
-}


{-# LANGUAGE PolyKinds, DataKinds, TypeFamilies, ScopedTypeVariables, GADTs, RankNTypes #-}
module T9574 where

import Data.Kind (Type)

data KProxy (t :: Type) = KProxy
data Proxy p

class Funct f where
    type Codomain f :: Type

instance Funct ('KProxy :: KProxy o) where
    type Codomain 'KProxy = NatTr (Proxy :: o -> Type)

data NatTr (c :: o -> Type) where
    M :: (forall (a :: o). Proxy a) -> NatTr (c :: o -> Type)

p :: forall o (c :: o -> Type). NatTr c
p = M t where
    M t = undefined :: Codomain ('KProxy :: KProxy o)


{-# LANGUAGE GADTs, DataKinds, KindSignatures, PolyKinds, FlexibleContexts, RankNTypes, ScopedTypeVariables #-}
module T9725 where

import Data.Kind (Type)

data En = M Bool
class Kn (l :: En)

instance Kn (M b)

data Fac :: En -> Type where
  Mo :: Kn (M b) => Fac (M b)

data Fm :: Type -> Type where
  HiF :: Kn (ent b) => Fm (Fac (ent b)) -> Fm (O ent)
  MoF :: Kn (M b) => Fm (Fac (M b))

data O :: (k -> En) -> Type where
  Hi :: Fac (ent k) -> O ent

data Co :: (Type -> Type) -> Type -> Type where
  Ab :: (t -> f t) -> Co f t

-- Restricted kind signature:
--test :: forall (ent :: Bool -> En) . (forall i . Kn (ent i) => Fm (Fac (ent i))) -> Co Fm (O ent)

test :: forall ent . (forall i . Kn (ent i) => Fm (Fac (ent i))) -> Co Fm (O ent)
test de = Ab h
    where h :: O ent -> Fm (O ent)
          h (Hi m@Mo) = HiF (d m)
          d :: Kn (ent i) => Fac (ent i) -> Fm (Fac (ent i))
          d _ = de

{-
9725.hs:27:25:
    Could not deduce (Kn (ent k1)) arising from a use of â€˜HiFâ€™
    from the context (ent k1 ~ 'M b, Kn ('M b))
      bound by a pattern with constructor
                 Mo :: forall (b :: Bool). Kn ('M b) => Fac ('M b),
               in an equation for â€˜hâ€™
      at 9725.hs:27:19-20
    In the expression: HiF (d m)
    In an equation for â€˜hâ€™: h (Hi m@Mo) = HiF (d m)
    In an equation for â€˜testâ€™:
        test de
          = Ab h
          where
              h :: O ent -> Fm (O ent)
              h (Hi m@Mo) = HiF (d m)
              d :: Kn (ent i) => Fac (ent i) -> Fm (Fac (ent i))
              d _ = de
Failed, modules loaded: none.
-}


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

module T9750 where

import Data.Kind (Type)
import GHC.TypeLits ( Symbol, KnownSymbol )

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

data Meta = MetaCons Symbol
data M1 (c :: Meta) = M1

class Generic a where
  type Rep a :: Type
  from  :: a -> Rep a

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

data A = A1

instance Generic A where
  type Rep A = M1 ('MetaCons "test")
  from A1 = M1

class GShow' f where
  gshowsPrec' :: f -> ShowS

instance (KnownSymbol c) => GShow' (M1 ('MetaCons c)) where
  gshowsPrec' = error "urk"

instance GShow' A where
  gshowsPrec' = gshowsPrec' . from


{-# LANGUAGE InstanceSigs, PolyKinds #-}

module T9833 where

import Control.Applicative

data NullableInterp a = NullI Bool

instance Functor     NullableInterp where
  fmap = undefined
instance Applicative NullableInterp where
  pure  = undefined
  (<*>) = undefined

instance Alternative NullableInterp where
  empty :: NullableInterp a
  empty = undefined
  (<|>) = undefined


module T9838 where

import T9838a

foo :: EqShow a => a -> String
foo x = show x ++ show (x == x)

bar :: F Int -> Bool
bar x = x


{-# LANGUAGE TypeFamilies, ConstraintKinds #-}

module T9838a where

type EqShow a = (Eq a, Show a)

type family F a
type instance F Int = Bool


{-# LANGUAGE MultiParamTypeClasses, PolyKinds #-}
{-# OPTIONS_GHC -fprint-explicit-kinds #-}

module TidyClassKinds where

import Data.Proxy

class Poly a b

type ProxySyn = Proxy

instance Poly ProxySyn ProxySyn
  -- output should really talk about k1 and k2, not about k and k!


{-# LANGUAGE PolyKinds #-}

module TyVarTvKinds where

data T (a :: k1) x = MkT (S a ())
data S (b :: k2) y = MkS (T b ())
  -- tests TcTyClsDecls.no_sig_tv


{-# LANGUAGE PolyKinds #-}

module TyVarTvKinds2 where

data SameKind :: k -> k -> *

data Q (a :: k1) (b :: k2) c = MkQ (SameKind a b)


{-# LANGUAGE GADTs, ExplicitForAll, PolyKinds #-}

module TyVarTvKinds3 where

import Data.Kind

data SameKind :: k -> k -> Type
data Bad a where
  MkBad :: forall k1 k2 (a :: k1) (b :: k2). Bad (SameKind a b)


{-# LANGUAGE MagicHash #-}
{-# LANGUAGE TypeApplications #-}
module T16293a where

import Data.Coerce
import Data.Proxy
import GHC.Exts

test1a :: () -> Proxy Int
test1a _ = Proxy @Int

test1b :: () -> Proxy# Int
test1b _ = proxy# @Int

test2a :: (() -> Proxy a) -> (() -> Proxy b)
test2a = coerce

test2b :: (() -> Proxy# a) -> (() -> Proxy# b)
test2b = coerce


-- Tests created by Jan Stolarek <jan.stolarek@p.lodz.pl>

{-# LANGUAGE MagicHash #-}
module Main where

import GHC.Exts

main :: IO ()
main = do
  print (h 3.0##)
  print g
  print 3.14159

h :: Double# -> String
h n = if tagToEnum# (n ==## 3.0##) || tagToEnum# (n ==## 4.0##)
      then "First branch"
      else "Second branch"

g :: String
g = if ((fromInteger 1 :: Integer) == 1)
    then "First branch"
    else "Second branch"


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

module Main where

import Data.Int
import Data.List
import GHC.Prim
import GHC.Exts

main :: IO ()
main = do

    --
    -- Check if passing Int16# on the stack works (16 parameter function will
    -- need to use stack for some of the them)
    --
    let input =
            [ ( (a + 0), (a + 1), (a + 2), (a + 3),
                (a + 4), (a + 5), (a + 6), (a + 7),
                (a + 8), (a + 9), (a + 10), (a + 11),
                (a + 12), (a + 13), (a + 14), (a + 15) )
            | a <- allInt16
            ]
        expected =
            [ toInt16
                  (a + b + c + d + e + f + g + h +
                   i + j + k + l + m + n + o + p)
            | (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p) <- input
            ]
        actual =
            [ addMany a b c d e f g h i j k l m n o p
            | (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p) <- input
            ]
    checkResults "passing Int16# on the stack" input expected actual

    --
    -- negateInt16#
    --
    let input = allInt16
        expected = [ toInt16 (negate a) | a <- input ]
        actual = [ apply1 negateInt16# a | a <- input ]
    checkResults "negateInt16#" input expected actual

    --
    -- plusInt16#
    --
    let input = [ (a, b) | a <- allInt16, b <- allInt16 ]
        expected = [ toInt16 (a + b) | (a, b) <- input ]
        actual = [ apply2 plusInt16# a b | (a, b) <- input ]
    checkResults "plusInt16#" input expected actual

    -- --
    -- -- subInt16#
    -- --
    let input = [ (a, b) | a <- allInt16, b <- allInt16 ]
        expected = [ toInt16 (a - b) | (a, b) <- input ]
        actual = [ apply2 subInt16# a b | (a, b) <- input ]
    checkResults "subInt16#" input expected actual

    --
    -- timesInt16#
    --
    let input = [ (a, b) | a <- allInt16, b <- allInt16 ]
        expected = [ toInt16 (a * b) | (a, b) <- input ]
        actual = [ apply2 timesInt16# a b | (a, b) <- input ]
    checkResults "timesInt16#" input expected actual

    --
    -- remInt16#
    --
    let input =
            [ (a, b) | a <- allInt16, b <- allInt16
            -- Don't divide by 0 or cause overflow
            , b /= 0, not (a == -32768 && b == -1)
            ]
        expected = [ toInt16 (a `rem` b) | (a, b) <- input ]
        actual = [ apply2 remInt16# a b | (a, b) <- input ]
    checkResults "remInt16#" input expected actual

    --
    -- quotInt16#
    --
    let input =
            [ (a, b) | a <- allInt16, b <- allInt16
            , b /= 0, not (a == -32768 && b == -1)
            ]
        expected = [ toInt16 (a `quot` b) | (a, b) <- input ]
        actual = [ apply2 quotInt16# a b | (a, b) <- input ]
    checkResults "quotInt16#" input expected actual

    --
    -- quotRemInt16#
    --
    let input =
            [ (a, b) | a <- allInt16, b <- allInt16
            , b /= 0, not (a == -32768 && b == -1)
            ]
        expected =
            [ (toInt16 q, toInt16 r)  | (a, b) <- input
            , let (q, r) = a `quotRem` b
            ]
        actual = [ apply3 quotRemInt16# a b | (a, b) <- input ]
    checkResults "quotRemInt16#" input expected actual

checkResults
    :: (Eq a, Eq b, Show a, Show b) => String -> [a] -> [b] -> [b] -> IO ()
checkResults test inputs expected actual =
    case findIndex (\(e, a) -> e /= a) (zip expected actual) of
        Nothing -> putStrLn $ "Pass: " ++ test
        Just i -> error $
            "FAILED: " ++ test ++ " for input: " ++ show (inputs !! i)
              ++ " expected: " ++ show (expected !! i)
              ++ " but got: " ++ show (actual !! i)

-- testing across the entire Int16 range blows the memory,
-- hence choosing a smaller range
allInt16 :: [Int]
allInt16 = [ -50 .. 50 ]

toInt16 :: Int -> Int
toInt16 a = fromIntegral (fromIntegral a :: Int16)

addMany#
    :: Int16# -> Int16# -> Int16# -> Int16#
    -> Int16# -> Int16# -> Int16# -> Int16#
    -> Int16# -> Int16# -> Int16# -> Int16#
    -> Int16# -> Int16# -> Int16# -> Int16#
    -> Int16#
addMany# a b c d e f g h i j k l m n o p =
    a `plusInt16#` b `plusInt16#` c `plusInt16#` d `plusInt16#`
    e `plusInt16#` f `plusInt16#` g `plusInt16#` h `plusInt16#`
    i `plusInt16#` j `plusInt16#` k `plusInt16#` l `plusInt16#`
    m `plusInt16#` n `plusInt16#` o `plusInt16#` p
{-# NOINLINE addMany# #-}

addMany
    :: Int -> Int -> Int -> Int
    -> Int -> Int -> Int -> Int
    -> Int -> Int -> Int -> Int
    -> Int -> Int -> Int -> Int
    -> Int
addMany (I# a) (I# b) (I# c) (I# d)
        (I# e) (I# f) (I# g) (I# h)
        (I# i) (I# j) (I# k) (I# l)
        (I# m) (I# n) (I# o) (I# p)
            = I# (extendInt16# int16)
  where
    !int16 = addMany#
                (narrowInt16# a) (narrowInt16# b) (narrowInt16# c) (narrowInt16# d)
                (narrowInt16# e) (narrowInt16# f) (narrowInt16# g) (narrowInt16# h)
                (narrowInt16# i) (narrowInt16# j) (narrowInt16# k) (narrowInt16# l)
                (narrowInt16# m) (narrowInt16# n) (narrowInt16# o) (narrowInt16# p)
{-# NOINLINE addMany #-}

-- Convenient and also tests higher order functions on Int16#
apply1 :: (Int16# -> Int16#) -> Int -> Int
apply1 opToTest (I# a) = I# (extendInt16# (opToTest (narrowInt16# a)))
{-# NOINLINE apply1 #-}

apply2 :: (Int16# -> Int16# -> Int16#) -> Int -> Int -> Int
apply2 opToTest (I# a) (I# b) =
    let (# sa, sb #) = (# narrowInt16# a, narrowInt16# b #)
        r = opToTest sa sb
    in I# (extendInt16# r)
{-# NOINLINE apply2 #-}

apply3 :: (Int16# -> Int16# -> (# Int16#, Int16# #)) -> Int -> Int -> (Int, Int)
apply3 opToTest (I# a) (I# b) =
    let (# sa, sb #) = (# narrowInt16# a, narrowInt16# b #)
        (# ra, rb #) = opToTest sa sb
    in (I# (extendInt16# ra), I# (extendInt16# rb))
{-# NOINLINE apply3 #-}

instance
        (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g, Eq h,
         Eq i, Eq j, Eq k, Eq l, Eq m, Eq n, Eq o, Eq p)
      => Eq (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p) where
    (a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1) ==
        (a2, b2, c2, d2, e2, f2, g2, h2, i2, j2, k2, l2, m2, n2, o2, p2) =
            a1 == a2 && b1 == b2 && c1 == c2 && d1 == d2 &&
            e1 == e2 && f1 == f2 && g1 == g2 && h1 == h2 &&
            i1 == i2 && j1 == j2 && k1 == k2 && l1 == l2 &&
            m1 == m2 && n1 == n2 && o1 == o2 && p1 == p2

instance
        (Show a, Show b, Show c, Show d, Show e, Show f, Show g, Show h,
         Show i, Show j, Show k, Show l, Show m, Show n, Show o, Show p)
      => Show (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p) where
    show (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p) =
        "(" ++ show a ++ "," ++ show b ++ "," ++ show c ++ "," ++ show d ++
        "," ++ show e ++ "," ++ show f ++ "," ++ show g ++ "," ++ show h ++
        "," ++ show i ++ "," ++ show j ++ "," ++ show k ++ "," ++ show l ++
        "," ++ show m ++ "," ++ show n ++ "," ++ show o ++ "," ++ show p ++
        ")"


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

module Main where

import Data.Int
import Data.List
import GHC.Prim
import GHC.Exts

main :: IO ()
main = do

    --
    -- Check if passing Int8# on the stack works (16 parameter function will
    -- need to use stack for some of the them)
    --
    let input =
            [ ( (a + 0), (a + 1), (a + 2), (a + 3),
                (a + 4), (a + 5), (a + 6), (a + 7),
                (a + 8), (a + 9), (a + 10), (a + 11),
                (a + 12), (a + 13), (a + 14), (a + 15) )
            | a <- allInt8
            ]
        expected =
            [ toInt8
                  (a + b + c + d + e + f + g + h +
                   i + j + k + l + m + n + o + p)
            | (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p) <- input
            ]
        actual =
            [ addMany a b c d e f g h i j k l m n o p
            | (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p) <- input
            ]
    checkResults "passing Int8# on the stack" input expected actual

    --
    -- negateInt8#
    --
    let input = allInt8
        expected = [ toInt8 (negate a) | a <- input ]
        actual = [ apply1 negateInt8# a | a <- input ]
    checkResults "negateInt8#" input expected actual

    --
    -- plusInt8#
    --
    let input = [ (a, b) | a <- allInt8, b <- allInt8 ]
        expected = [ toInt8 (a + b) | (a, b) <- input ]
        actual = [ apply2 plusInt8# a b | (a, b) <- input ]
    checkResults "plusInt8#" input expected actual

    --
    -- subInt8#
    --
    let input = [ (a, b) | a <- allInt8, b <- allInt8 ]
        expected = [ toInt8 (a - b) | (a, b) <- input ]
        actual = [ apply2 subInt8# a b | (a, b) <- input ]
    checkResults "subInt8#" input expected actual

    --
    -- timesInt8#
    --
    let input = [ (a, b) | a <- allInt8, b <- allInt8 ]
        expected = [ toInt8 (a * b) | (a, b) <- input ]
        actual = [ apply2 timesInt8# a b | (a, b) <- input ]
    checkResults "timesInt8#" input expected actual

    --
    -- remInt8#
    --
    let input =
            [ (a, b) | a <- allInt8, b <- allInt8
            -- Don't divide by 0 or cause overflow
            , b /= 0, not (a == -128 && b == -1)
            ]
        expected = [ toInt8 (a `rem` b) | (a, b) <- input ]
        actual = [ apply2 remInt8# a b | (a, b) <- input ]
    checkResults "remInt8#" input expected actual

    --
    -- quotInt8#
    --
    let input =
            [ (a, b) | a <- allInt8, b <- allInt8
            , b /= 0, not (a == -128 && b == -1)
            ]
        expected = [ toInt8 (a `quot` b) | (a, b) <- input ]
        actual = [ apply2 quotInt8# a b | (a, b) <- input ]
    checkResults "quotInt8#" input expected actual

    --
    -- quotRemInt8#
    --
    let input =
            [ (a, b) | a <- allInt8, b <- allInt8
            , b /= 0, not (a == -128 && b == -1)
            ]
        expected =
            [ (toInt8 q, toInt8 r)  | (a, b) <- input
            , let (q, r) = a `quotRem` b
            ]
        actual = [ apply3 quotRemInt8# a b | (a, b) <- input ]
    checkResults "quotRemInt8#" input expected actual

checkResults
    :: (Eq a, Eq b, Show a, Show b) => String -> [a] -> [b] -> [b] -> IO ()
checkResults test inputs expected actual =
    case findIndex (\(e, a) -> e /= a) (zip expected actual) of
        Nothing -> putStrLn $ "Pass: " ++ test
        Just i -> error $
            "FAILED: " ++ test ++ " for input: " ++ show (inputs !! i)
              ++ " expected: " ++ show (expected !! i)
              ++ " but got: " ++ show (actual !! i)

allInt8 :: [Int]
allInt8 = [ minInt8 .. maxInt8 ]

minInt8 :: Int
minInt8 = fromIntegral (minBound :: Int8)

maxInt8 :: Int
maxInt8 = fromIntegral (maxBound :: Int8)

toInt8 :: Int -> Int
toInt8 a = fromIntegral (fromIntegral a :: Int8)

addMany#
    :: Int8# -> Int8# -> Int8# -> Int8#
    -> Int8# -> Int8# -> Int8# -> Int8#
    -> Int8# -> Int8# -> Int8# -> Int8#
    -> Int8# -> Int8# -> Int8# -> Int8#
    -> Int8#
addMany# a b c d e f g h i j k l m n o p =
    a `plusInt8#` b `plusInt8#` c `plusInt8#` d `plusInt8#`
    e `plusInt8#` f `plusInt8#` g `plusInt8#` h `plusInt8#`
    i `plusInt8#` j `plusInt8#` k `plusInt8#` l `plusInt8#`
    m `plusInt8#` n `plusInt8#` o `plusInt8#` p
{-# NOINLINE addMany# #-}

addMany
    :: Int -> Int -> Int -> Int
    -> Int -> Int -> Int -> Int
    -> Int -> Int -> Int -> Int
    -> Int -> Int -> Int -> Int
    -> Int
addMany (I# a) (I# b) (I# c) (I# d)
        (I# e) (I# f) (I# g) (I# h)
        (I# i) (I# j) (I# k) (I# l)
        (I# m) (I# n) (I# o) (I# p)
            = I# (extendInt8# int8)
  where
    !int8 = addMany#
                (narrowInt8# a) (narrowInt8# b) (narrowInt8# c) (narrowInt8# d)
                (narrowInt8# e) (narrowInt8# f) (narrowInt8# g) (narrowInt8# h)
                (narrowInt8# i) (narrowInt8# j) (narrowInt8# k) (narrowInt8# l)
                (narrowInt8# m) (narrowInt8# n) (narrowInt8# o) (narrowInt8# p)
{-# NOINLINE addMany #-}

-- Convenient and also tests higher order functions on Int8#
apply1 :: (Int8# -> Int8#) -> Int -> Int
apply1 opToTest (I# a) = I# (extendInt8# (opToTest (narrowInt8# a)))
{-# NOINLINE apply1 #-}

apply2 :: (Int8# -> Int8# -> Int8#) -> Int -> Int -> Int
apply2 opToTest (I# a) (I# b) =
    let (# sa, sb #) = (# narrowInt8# a, narrowInt8# b #)
        r = opToTest sa sb
    in I# (extendInt8# r)
{-# NOINLINE apply2 #-}

apply3 :: (Int8# -> Int8# -> (# Int8#, Int8# #)) -> Int -> Int -> (Int, Int)
apply3 opToTest (I# a) (I# b) =
    let (# sa, sb #) = (# narrowInt8# a, narrowInt8# b #)
        (# ra, rb #) = opToTest sa sb
    in (I# (extendInt8# ra), I# (extendInt8# rb))
{-# NOINLINE apply3 #-}

instance
        (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g, Eq h,
         Eq i, Eq j, Eq k, Eq l, Eq m, Eq n, Eq o, Eq p)
      => Eq (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p) where
    (a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1) ==
        (a2, b2, c2, d2, e2, f2, g2, h2, i2, j2, k2, l2, m2, n2, o2, p2) =
            a1 == a2 && b1 == b2 && c1 == c2 && d1 == d2 &&
            e1 == e2 && f1 == f2 && g1 == g2 && h1 == h2 &&
            i1 == i2 && j1 == j2 && k1 == k2 && l1 == l2 &&
            m1 == m2 && n1 == n2 && o1 == o2 && p1 == p2

instance
        (Show a, Show b, Show c, Show d, Show e, Show f, Show g, Show h,
         Show i, Show j, Show k, Show l, Show m, Show n, Show o, Show p)
      => Show (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p) where
    show (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p) =
        "(" ++ show a ++ "," ++ show b ++ "," ++ show c ++ "," ++ show d ++
        "," ++ show e ++ "," ++ show f ++ "," ++ show g ++ "," ++ show h ++
        "," ++ show i ++ "," ++ show j ++ "," ++ show k ++ "," ++ show l ++
        "," ++ show m ++ "," ++ show n ++ "," ++ show o ++ "," ++ show p ++
        ")"


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

module Main where

import Data.Word
import Data.Bits
import Data.List
import GHC.Prim
import GHC.Exts

main :: IO ()
main = do

    --
    -- Check if passing Word16# on the stack works (16 parameter function will
    -- need to use stack for some of the them)
    --
    let input =
            [ ( (a + 0), (a + 1), (a + 2), (a + 3),
                (a + 4), (a + 5), (a + 6), (a + 7),
                (a + 8), (a + 9), (a + 10), (a + 11),
                (a + 12), (a + 13), (a + 14), (a + 15) )
            | a <- allWord16
            ]
        expected =
            [ toWord16
                  (a + b + c + d + e + f + g + h +
                   i + j + k + l + m + n + o + p)
            | (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p) <- input
            ]
        actual =
            [ addMany a b c d e f g h i j k l m n o p
            | (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p) <- input
            ]
    checkResults "passing Word16# on the stack" input expected actual

    --
    -- notWord16#
    --
    let input = allWord16
        expected = [ toWord16 (complement a) | a <- input ]
        actual = [ apply1 notWord16# a | a <- input ]
    checkResults "notWord16#" input expected actual

    --
    -- plusWord16#
    --
    let input = [ (a, b) | a <- allWord16, b <- allWord16 ]
        expected = [ toWord16 (a + b) | (a, b) <- input ]
        actual = [ apply2 plusWord16# a b | (a, b) <- input ]
    checkResults "plusWord16#" input expected actual

    --
    -- subWord16#
    --
    let input = [ (a, b) | a <- allWord16, b <- allWord16 ]
        expected = [ toWord16 (a - b) | (a, b) <- input ]
        actual = [ apply2 subWord16# a b | (a, b) <- input ]
    checkResults "subWord16#" input expected actual

    --
    -- timesWord16#
    --
    let input = [ (a, b) | a <- allWord16, b <- allWord16 ]
        expected = [ toWord16 (a * b) | (a, b) <- input ]
        actual = [ apply2 timesWord16# a b | (a, b) <- input ]
    checkResults "timesWord16#" input expected actual

    --
    -- remWord16#
    --
    let input =
            -- Don't divide by 0.
            [ (a, b) | a <- allWord16, b <- allWord16 , b /= 0 ]
        expected = [ toWord16 (a `rem` b) | (a, b) <- input ]
        actual = [ apply2 remWord16# a b | (a, b) <- input ]
    checkResults "remWord16#" input expected actual

    --
    -- quotWord16#
    --
    let input =
            [ (a, b) | a <- allWord16, b <- allWord16, b /= 0 ]
        expected = [ toWord16 (a `quot` b) | (a, b) <- input ]
        actual = [ apply2 quotWord16# a b | (a, b) <- input ]
    checkResults "quotWord16#" input expected actual

    --
    -- quotRemWord16#
    --
    let input =
            [ (a, b) | a <- allWord16, b <- allWord16, b /= 0 ]
        expected =
            [ (toWord16 q, toWord16 r)  | (a, b) <- input
            , let (q, r) = a `quotRem` b
            ]
        actual = [ apply3 quotRemWord16# a b | (a, b) <- input ]
    checkResults "quotRemWord16#" input expected actual

checkResults
    :: (Eq a, Eq b, Show a, Show b) => String -> [a] -> [b] -> [b] -> IO ()
checkResults test inputs expected actual =
    case findIndex (\(e, a) -> e /= a) (zip expected actual) of
        Nothing -> putStrLn $ "Pass: " ++ test
        Just i -> error $
            "FAILED: " ++ test ++ " for input: " ++ show (inputs !! i)
              ++ " expected: " ++ show (expected !! i)
              ++ " but got: " ++ show (actual !! i)

-- testing across the entire Word16 range blows the memory,
-- hence choosing a smaller range
allWord16 :: [Word]
allWord16 = [ 0 .. 100 ]

toWord16 :: Word -> Word
toWord16 a = fromIntegral (fromIntegral a :: Word16)

addMany#
    :: Word16# -> Word16# -> Word16# -> Word16#
    -> Word16# -> Word16# -> Word16# -> Word16#
    -> Word16# -> Word16# -> Word16# -> Word16#
    -> Word16# -> Word16# -> Word16# -> Word16#
    -> Word16#
addMany# a b c d e f g h i j k l m n o p =
    a `plusWord16#` b `plusWord16#` c `plusWord16#` d `plusWord16#`
    e `plusWord16#` f `plusWord16#` g `plusWord16#` h `plusWord16#`
    i `plusWord16#` j `plusWord16#` k `plusWord16#` l `plusWord16#`
    m `plusWord16#` n `plusWord16#` o `plusWord16#` p
{-# NOINLINE addMany# #-}

addMany
    :: Word -> Word -> Word -> Word
    -> Word -> Word -> Word -> Word
    -> Word -> Word -> Word -> Word
    -> Word -> Word -> Word -> Word
    -> Word
addMany (W# a) (W# b) (W# c) (W# d)
        (W# e) (W# f) (W# g) (W# h)
        (W# i) (W# j) (W# k) (W# l)
        (W# m) (W# n) (W# o) (W# p)
            = W# (extendWord16# word16)
  where
    !word16 =
        addMany#
            (narrowWord16# a) (narrowWord16# b) (narrowWord16# c) (narrowWord16# d)
            (narrowWord16# e) (narrowWord16# f) (narrowWord16# g) (narrowWord16# h)
            (narrowWord16# i) (narrowWord16# j) (narrowWord16# k) (narrowWord16# l)
            (narrowWord16# m) (narrowWord16# n) (narrowWord16# o) (narrowWord16# p)
{-# NOINLINE addMany #-}

-- Convenient and also tests higher order functions on Word16#
apply1 :: (Word16# -> Word16#) -> Word -> Word
apply1 opToTest (W# a) = W# (extendWord16# (opToTest (narrowWord16# a)))
{-# NOINLINE apply1 #-}

apply2 :: (Word16# -> Word16# -> Word16#) -> Word -> Word -> Word
apply2 opToTest (W# a) (W# b) =
    let (# sa, sb #) = (# narrowWord16# a, narrowWord16# b #)
        r = opToTest sa sb
    in W# (extendWord16# r)
{-# NOINLINE apply2 #-}

apply3
  :: (Word16# -> Word16# -> (# Word16#, Word16# #)) -> Word -> Word -> (Word, Word)
apply3 opToTest (W# a) (W# b) =
    let (# sa, sb #) = (# narrowWord16# a, narrowWord16# b #)
        (# ra, rb #) = opToTest sa sb
    in (W# (extendWord16# ra), W# (extendWord16# rb))
{-# NOINLINE apply3 #-}

instance
        (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g, Eq h,
         Eq i, Eq j, Eq k, Eq l, Eq m, Eq n, Eq o, Eq p)
      => Eq (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p) where
    (a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1) ==
        (a2, b2, c2, d2, e2, f2, g2, h2, i2, j2, k2, l2, m2, n2, o2, p2) =
            a1 == a2 && b1 == b2 && c1 == c2 && d1 == d2 &&
            e1 == e2 && f1 == f2 && g1 == g2 && h1 == h2 &&
            i1 == i2 && j1 == j2 && k1 == k2 && l1 == l2 &&
            m1 == m2 && n1 == n2 && o1 == o2 && p1 == p2

instance
        (Show a, Show b, Show c, Show d, Show e, Show f, Show g, Show h,
         Show i, Show j, Show k, Show l, Show m, Show n, Show o, Show p)
      => Show (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p) where
    show (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p) =
        "(" ++ show a ++ "," ++ show b ++ "," ++ show c ++ "," ++ show d ++
        "," ++ show e ++ "," ++ show f ++ "," ++ show g ++ "," ++ show h ++
        "," ++ show i ++ "," ++ show j ++ "," ++ show k ++ "," ++ show l ++
        "," ++ show m ++ "," ++ show n ++ "," ++ show o ++ "," ++ show p ++
        ")"


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

module Main where

import Data.Word
import Data.Bits
import Data.List
import GHC.Prim
import GHC.Exts

main :: IO ()
main = do

    --
    -- Check if passing Word8# on the stack works (16 parameter function will
    -- need to use stack for some of the them)
    --
    let input =
            [ ( (a + 0), (a + 1), (a + 2), (a + 3),
                (a + 4), (a + 5), (a + 6), (a + 7),
                (a + 8), (a + 9), (a + 10), (a + 11),
                (a + 12), (a + 13), (a + 14), (a + 15) )
            | a <- allWord8
            ]
        expected =
            [ toWord8
                  (a + b + c + d + e + f + g + h +
                   i + j + k + l + m + n + o + p)
            | (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p) <- input
            ]
        actual =
            [ addMany a b c d e f g h i j k l m n o p
            | (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p) <- input
            ]
    checkResults "passing Word8# on the stack" input expected actual

    --
    -- notWord8#
    --
    let input = allWord8
        expected = [ toWord8 (complement a) | a <- input ]
        actual = [ apply1 notWord8# a | a <- input ]
    checkResults "notWord8#" input expected actual

    --
    -- plusWord8#
    --
    let input = [ (a, b) | a <- allWord8, b <- allWord8 ]
        expected = [ toWord8 (a + b) | (a, b) <- input ]
        actual = [ apply2 plusWord8# a b | (a, b) <- input ]
    checkResults "plusWord8#" input expected actual

    --
    -- subWord8#
    --
    let input = [ (a, b) | a <- allWord8, b <- allWord8 ]
        expected = [ toWord8 (a - b) | (a, b) <- input ]
        actual = [ apply2 subWord8# a b | (a, b) <- input ]
    checkResults "subWord8#" input expected actual

    --
    -- timesWord8#
    --
    let input = [ (a, b) | a <- allWord8, b <- allWord8 ]
        expected = [ toWord8 (a * b) | (a, b) <- input ]
        actual = [ apply2 timesWord8# a b | (a, b) <- input ]
    checkResults "timesWord8#" input expected actual

    --
    -- remWord8#
    --
    let input =
            -- Don't divide by 0.
            [ (a, b) | a <- allWord8, b <- allWord8 , b /= 0 ]
        expected = [ toWord8 (a `rem` b) | (a, b) <- input ]
        actual = [ apply2 remWord8# a b | (a, b) <- input ]
    checkResults "remWord8#" input expected actual

    --
    -- quotWord8#
    --
    let input =
            [ (a, b) | a <- allWord8, b <- allWord8, b /= 0 ]
        expected = [ toWord8 (a `quot` b) | (a, b) <- input ]
        actual = [ apply2 quotWord8# a b | (a, b) <- input ]
    checkResults "quotWord8#" input expected actual

    --
    -- quotRemWord8#
    --
    let input =
            [ (a, b) | a <- allWord8, b <- allWord8, b /= 0 ]
        expected =
            [ (toWord8 q, toWord8 r)  | (a, b) <- input
            , let (q, r) = a `quotRem` b
            ]
        actual = [ apply3 quotRemWord8# a b | (a, b) <- input ]
    checkResults "quotRemWord8#" input expected actual

checkResults
    :: (Eq a, Eq b, Show a, Show b) => String -> [a] -> [b] -> [b] -> IO ()
checkResults test inputs expected actual =
    case findIndex (\(e, a) -> e /= a) (zip expected actual) of
        Nothing -> putStrLn $ "Pass: " ++ test
        Just i -> error $
            "FAILED: " ++ test ++ " for input: " ++ show (inputs !! i)
              ++ " expected: " ++ show (expected !! i)
              ++ " but got: " ++ show (actual !! i)

allWord8 :: [Word]
allWord8 = [ minWord8 .. maxWord8 ]

minWord8 :: Word
minWord8 = fromIntegral (minBound :: Word8)

maxWord8 :: Word
maxWord8 = fromIntegral (maxBound :: Word8)

toWord8 :: Word -> Word
toWord8 a = fromIntegral (fromIntegral a :: Word8)

addMany#
    :: Word8# -> Word8# -> Word8# -> Word8#
    -> Word8# -> Word8# -> Word8# -> Word8#
    -> Word8# -> Word8# -> Word8# -> Word8#
    -> Word8# -> Word8# -> Word8# -> Word8#
    -> Word8#
addMany# a b c d e f g h i j k l m n o p =
    a `plusWord8#` b `plusWord8#` c `plusWord8#` d `plusWord8#`
    e `plusWord8#` f `plusWord8#` g `plusWord8#` h `plusWord8#`
    i `plusWord8#` j `plusWord8#` k `plusWord8#` l `plusWord8#`
    m `plusWord8#` n `plusWord8#` o `plusWord8#` p
{-# NOINLINE addMany# #-}

addMany
    :: Word -> Word -> Word -> Word
    -> Word -> Word -> Word -> Word
    -> Word -> Word -> Word -> Word
    -> Word -> Word -> Word -> Word
    -> Word
addMany (W# a) (W# b) (W# c) (W# d)
        (W# e) (W# f) (W# g) (W# h)
        (W# i) (W# j) (W# k) (W# l)
        (W# m) (W# n) (W# o) (W# p)
            = W# (extendWord8# word8)
  where
    !word8 =
        addMany#
            (narrowWord8# a) (narrowWord8# b) (narrowWord8# c) (narrowWord8# d)
            (narrowWord8# e) (narrowWord8# f) (narrowWord8# g) (narrowWord8# h)
            (narrowWord8# i) (narrowWord8# j) (narrowWord8# k) (narrowWord8# l)
            (narrowWord8# m) (narrowWord8# n) (narrowWord8# o) (narrowWord8# p)
{-# NOINLINE addMany #-}

-- Convenient and also tests higher order functions on Word8#
apply1 :: (Word8# -> Word8#) -> Word -> Word
apply1 opToTest (W# a) = W# (extendWord8# (opToTest (narrowWord8# a)))
{-# NOINLINE apply1 #-}

apply2 :: (Word8# -> Word8# -> Word8#) -> Word -> Word -> Word
apply2 opToTest (W# a) (W# b) =
    let (# sa, sb #) = (# narrowWord8# a, narrowWord8# b #)
        r = opToTest sa sb
    in W# (extendWord8# r)
{-# NOINLINE apply2 #-}

apply3
  :: (Word8# -> Word8# -> (# Word8#, Word8# #)) -> Word -> Word -> (Word, Word)
apply3 opToTest (W# a) (W# b) =
    let (# sa, sb #) = (# narrowWord8# a, narrowWord8# b #)
        (# ra, rb #) = opToTest sa sb
    in (W# (extendWord8# ra), W# (extendWord8# rb))
{-# NOINLINE apply3 #-}

instance
        (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g, Eq h,
         Eq i, Eq j, Eq k, Eq l, Eq m, Eq n, Eq o, Eq p)
      => Eq (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p) where
    (a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1) ==
        (a2, b2, c2, d2, e2, f2, g2, h2, i2, j2, k2, l2, m2, n2, o2, p2) =
            a1 == a2 && b1 == b2 && c1 == c2 && d1 == d2 &&
            e1 == e2 && f1 == f2 && g1 == g2 && h1 == h2 &&
            i1 == i2 && j1 == j2 && k1 == k2 && l1 == l2 &&
            m1 == m2 && n1 == n2 && o1 == o2 && p1 == p2

instance
        (Show a, Show b, Show c, Show d, Show e, Show f, Show g, Show h,
         Show i, Show j, Show k, Show l, Show m, Show n, Show o, Show p)
      => Show (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p) where
    show (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p) =
        "(" ++ show a ++ "," ++ show b ++ "," ++ show c ++ "," ++ show d ++
        "," ++ show e ++ "," ++ show f ++ "," ++ show g ++ "," ++ show h ++
        "," ++ show i ++ "," ++ show j ++ "," ++ show k ++ "," ++ show l ++
        "," ++ show m ++ "," ++ show n ++ "," ++ show o ++ "," ++ show p ++
        ")"


{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE MagicHash #-}

module Main where

import Data.Int
import Data.List
import GHC.Prim
import GHC.Exts

-- Having a wrapper gives us two things:
-- * it's easier to test everything (no need for code using raw primops)
-- * we test the deriving mechanism for Int16#
data TestInt16 = T16 Int16#
    deriving (Eq, Ord)

mkT16 :: Int -> TestInt16
mkT16 (I# a) = T16 (narrowInt16# a)

main :: IO ()
main = do
    let input = [ (a, b) | a <- allInt16, b <- allInt16 ]

    --
    -- (==)
    --
    let expected = [ a == b | (a, b) <- input ]
        actual = [ mkT16 a == mkT16 b | (a, b) <- input ]
    checkResults "(==)" input expected actual

    --
    -- (/=)
    --
    let expected = [ a /= b | (a, b) <- input ]
        actual = [ mkT16 a /= mkT16 b | (a, b) <- input ]
    checkResults "(/=)" input expected actual

    --
    -- (<)
    --
    let expected = [ a < b | (a, b) <- input ]
        actual = [ mkT16 a < mkT16 b | (a, b) <- input ]
    checkResults "(<)" input expected actual

    --
    -- (>)
    --
    let expected = [ a > b | (a, b) <- input ]
        actual = [ mkT16 a > mkT16 b | (a, b) <- input ]
    checkResults "(>)" input expected actual

    --
    -- (<=)
    --
    let expected = [ a <= b | (a, b) <- input ]
        actual = [ mkT16 a <= mkT16 b | (a, b) <- input ]
    checkResults "(<=)" input expected actual

    --
    -- (>=)
    --
    let expected = [ a >= b | (a, b) <- input ]
        actual = [ mkT16 a >= mkT16 b | (a, b) <- input ]
    checkResults "(>=)" input expected actual

checkResults
    :: (Eq a, Eq b, Show a, Show b) => String -> [a] -> [b] -> [b] -> IO ()
checkResults test inputs expected actual =
    case findIndex (\(e, a) -> e /= a) (zip expected actual) of
        Nothing -> putStrLn $ "Pass: " ++ test
        Just i -> error $
            "FAILED: " ++ test ++ " for input: " ++ show (inputs !! i)
              ++ " expected: " ++ show (expected !! i)
              ++ " but got: " ++ show (actual !! i)

-- testing across the entire Int16 range blows the memory,
-- hence choosing a smaller range
allInt16 :: [Int]
allInt16 = [ -50 .. 50 ]


{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE MagicHash #-}

module Main where

import Data.Int
import Data.List
import GHC.Prim
import GHC.Exts

-- Having a wrapper gives us two things:
-- * it's easier to test everything (no need for code using raw primops)
-- * we test the deriving mechanism for Int8#
data TestInt8 = T8 Int8#
    deriving (Eq, Ord)

mkT8 :: Int -> TestInt8
mkT8 (I# a) = T8 (narrowInt8# a)

main :: IO ()
main = do
    let input = [ (a, b) | a <- allInt8, b <- allInt8 ]

    --
    -- (==)
    --
    let expected = [ a == b | (a, b) <- input ]
        actual = [ mkT8 a == mkT8 b | (a, b) <- input ]
    checkResults "(==)" input expected actual

    --
    -- (/=)
    --
    let expected = [ a /= b | (a, b) <- input ]
        actual = [ mkT8 a /= mkT8 b | (a, b) <- input ]
    checkResults "(/=)" input expected actual

    --
    -- (<)
    --
    let expected = [ a < b | (a, b) <- input ]
        actual = [ mkT8 a < mkT8 b | (a, b) <- input ]
    checkResults "(<)" input expected actual

    --
    -- (>)
    --
    let expected = [ a > b | (a, b) <- input ]
        actual = [ mkT8 a > mkT8 b | (a, b) <- input ]
    checkResults "(>)" input expected actual

    --
    -- (<=)
    --
    let expected = [ a <= b | (a, b) <- input ]
        actual = [ mkT8 a <= mkT8 b | (a, b) <- input ]
    checkResults "(<=)" input expected actual

    --
    -- (>=)
    --
    let expected = [ a >= b | (a, b) <- input ]
        actual = [ mkT8 a >= mkT8 b | (a, b) <- input ]
    checkResults "(>=)" input expected actual

checkResults
    :: (Eq a, Eq b, Show a, Show b) => String -> [a] -> [b] -> [b] -> IO ()
checkResults test inputs expected actual =
    case findIndex (\(e, a) -> e /= a) (zip expected actual) of
        Nothing -> putStrLn $ "Pass: " ++ test
        Just i -> error $
            "FAILED: " ++ test ++ " for input: " ++ show (inputs !! i)
              ++ " expected: " ++ show (expected !! i)
              ++ " but got: " ++ show (actual !! i)

allInt8 :: [Int]
allInt8 = [ minInt8 .. maxInt8 ]

minInt8 :: Int
minInt8 = fromIntegral (minBound :: Int8)

maxInt8 :: Int
maxInt8 = fromIntegral (maxBound :: Int8)


{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE MagicHash #-}

module Main where

import Data.Word
import Data.List
import GHC.Prim
import GHC.Exts

-- Having a wrapper gives us two things:
-- * it's easier to test everything (no need for code using raw primops)
-- * we test the deriving mechanism for Word16#
data TestWord16 = T16 Word16#
    deriving (Eq, Ord)

mkT16 :: Word -> TestWord16
mkT16 (W# a) = T16 (narrowWord16# a)

main :: IO ()
main = do
    let input = [ (a, b) | a <- allWord16, b <- allWord16 ]

    --
    -- (==)
    --
    let expected = [ a == b | (a, b) <- input ]
        actual = [ mkT16 a == mkT16 b | (a, b) <- input ]
    checkResults "(==)" input expected actual

    --
    -- (/=)
    --
    let expected = [ a /= b | (a, b) <- input ]
        actual = [ mkT16 a /= mkT16 b | (a, b) <- input ]
    checkResults "(/=)" input expected actual

    --
    -- (<)
    --
    let expected = [ a < b | (a, b) <- input ]
        actual = [ mkT16 a < mkT16 b | (a, b) <- input ]
    checkResults "(<)" input expected actual

    --
    -- (>)
    --
    let expected = [ a > b | (a, b) <- input ]
        actual = [ mkT16 a > mkT16 b | (a, b) <- input ]
    checkResults "(>)" input expected actual

    --
    -- (<=)
    --
    let expected = [ a <= b | (a, b) <- input ]
        actual = [ mkT16 a <= mkT16 b | (a, b) <- input ]
    checkResults "(<=)" input expected actual

    --
    -- (>=)
    --
    let expected = [ a >= b | (a, b) <- input ]
        actual = [ mkT16 a >= mkT16 b | (a, b) <- input ]
    checkResults "(>=)" input expected actual

checkResults
    :: (Eq a, Eq b, Show a, Show b) => String -> [a] -> [b] -> [b] -> IO ()
checkResults test inputs expected actual =
    case findIndex (\(e, a) -> e /= a) (zip expected actual) of
        Nothing -> putStrLn $ "Pass: " ++ test
        Just i -> error $
            "FAILED: " ++ test ++ " for input: " ++ show (inputs !! i)
              ++ " expected: " ++ show (expected !! i)
              ++ " but got: " ++ show (actual !! i)

-- testing across the entire Word16 range blows the memory,
-- hence choosing a smaller range
allWord16 :: [Word]
allWord16 = [ 0 .. 100 ]


{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE MagicHash #-}

module Main where

import Data.Word
import Data.List
import GHC.Prim
import GHC.Exts

-- Having a wrapper gives us two things:
-- * it's easier to test everything (no need for code using raw primops)
-- * we test the deriving mechanism for Word8#
data TestWord8 = T8 Word8#
    deriving (Eq, Ord)

mkT8 :: Word -> TestWord8
mkT8 (W# a) = T8 (narrowWord8# a)

main :: IO ()
main = do
    let input = [ (a, b) | a <- allWord8, b <- allWord8 ]

    --
    -- (==)
    --
    let expected = [ a == b | (a, b) <- input ]
        actual = [ mkT8 a == mkT8 b | (a, b) <- input ]
    checkResults "(==)" input expected actual

    --
    -- (/=)
    --
    let expected = [ a /= b | (a, b) <- input ]
        actual = [ mkT8 a /= mkT8 b | (a, b) <- input ]
    checkResults "(/=)" input expected actual

    --
    -- (<)
    --
    let expected = [ a < b | (a, b) <- input ]
        actual = [ mkT8 a < mkT8 b | (a, b) <- input ]
    checkResults "(<)" input expected actual

    --
    -- (>)
    --
    let expected = [ a > b | (a, b) <- input ]
        actual = [ mkT8 a > mkT8 b | (a, b) <- input ]
    checkResults "(>)" input expected actual

    --
    -- (<=)
    --
    let expected = [ a <= b | (a, b) <- input ]
        actual = [ mkT8 a <= mkT8 b | (a, b) <- input ]
    checkResults "(<=)" input expected actual

    --
    -- (>=)
    --
    let expected = [ a >= b | (a, b) <- input ]
        actual = [ mkT8 a >= mkT8 b | (a, b) <- input ]
    checkResults "(>=)" input expected actual

checkResults
    :: (Eq a, Eq b, Show a, Show b) => String -> [a] -> [b] -> [b] -> IO ()
checkResults test inputs expected actual =
    case findIndex (\(e, a) -> e /= a) (zip expected actual) of
        Nothing -> putStrLn $ "Pass: " ++ test
        Just i -> error $
            "FAILED: " ++ test ++ " for input: " ++ show (inputs !! i)
              ++ " expected: " ++ show (expected !! i)
              ++ " but got: " ++ show (actual !! i)

allWord8 :: [Word]
allWord8 = [ minWord8 .. maxWord8 ]

minWord8 :: Word
minWord8 = fromIntegral (minBound :: Word8)

maxWord8 :: Word
maxWord8 = fromIntegral (maxBound :: Word8)


{-# LANGUAGE MagicHash #-}

module Main where

import GHC.Exts

data Test1 = Test1 Int8# Word8#
    deriving (Show)

data Test2 = Test2 Int16# Word16#
    deriving (Show)

test1 :: Test1
test1 = Test1 (narrowInt8# 1#) (narrowWord8# 2##)

test2 :: Test2
test2 = Test2 (narrowInt16# 1#) (narrowWord16# 2##)

main :: IO ()
main = do
  print test1
  print test2


{-# LANGUAGE MagicHash #-}

import GHC.Exts
import Control.Exception

f :: ArithException -> Int#
f x = raise# (toException x)

main = print (I# (f Overflow))


{-# LANGUAGE MagicHash #-}

import GHC.Prim

main :: IO ()
main = go 1000000# 10 (2^100)

go :: Int# -> Integer -> Integer -> IO ()
go 0# _ _ = return ()
go n# a b = (a + b) `seq` go (n# -# 1#) a b
{-# NOINLINE go #-}

{-
This test is based on a strategy from rwbarton relying on the inefficiency
of `Integer` addition as defined by `integer-gmp` without `runRW#`.

    When I was testing the patch interactively, I measured allocations for,
    say, a million (large Integer) + (small Integer) additions.  If that
    addition allocates, say, 6 words, then one can fairly reliably write the
    program so that it will allocate between 6 million and 7 million words,
    total.
-}


{-# LANGUAGE MagicHash #-}
{-# LANGUAGE UnboxedTuples #-}

import Control.Monad (unless)
import GHC.Exts
import GHC.Types

data ByteArray s = BA (MutableByteArray# s)

main :: IO ()
main = do
    ba# <- IO (\s0 -> case newByteArray# 256# s0 of
                        (# s1, ba# #) -> (# s1, BA ba# #))
    let go n = do
            shrink ba# n
            sz <- getSize ba#
            unless (sz == n) $ print (sz, n)
    mapM go [128, 64, 63, 32, 2, 1]
    return ()

shrink :: ByteArray RealWorld -> Int -> IO ()
shrink (BA ba#) (I# n#) = IO (\s ->
    case shrinkMutableByteArray# ba# n# s of
      s' -> (# s', () #))

getSize :: ByteArray RealWorld -> IO Int
getSize (BA ba#) = IO (\s ->
    case getSizeofMutableByteArray# ba# s of
      (# s', n# #) -> (# s', I# n# #))


{-# LANGUAGE MagicHash #-}
module Main where

import GHC.Exts
import Data.Word
import Data.Int

data Packed1 = Packed1 Float# Float# Int# Float#
    deriving Show

data Packed2 =
    Packed2
        {-# UNPACK #-} !Float
        {-# UNPACK #-} !Float
        {-# UNPACK #-} !Int
        {-# UNPACK #-} !Float
    deriving Show

data Packed3 =
    Packed3
        {-# UNPACK #-} !Word8
        {-# UNPACK #-} !Int8
        {-# UNPACK #-} !Int64
        {-# UNPACK #-} !Float
        {-# UNPACK #-} !Word64
        {-# UNPACK #-} !Word32
        {-# UNPACK #-} !Float
        {-# UNPACK #-} !Double
    deriving Show

packed1 = go 0.0# 1.0# 2# 3.0#
  where
    go a b c d =
        Packed1 a b c d
            : go (a `plusFloat#` 1.0#)
                 (b `plusFloat#` 1.0#)
               (c +# 1#)
               (d `plusFloat#` 1.0#)

packed2 =
    [ Packed2
        (fromIntegral i)
        (fromIntegral (i + 1))
        (fromIntegral (i + 2))
        (fromIntegral (i + 3))
    | i <- [0..]
    ]

packed3 =
    [ Packed3
        (fromIntegral i)
        (fromIntegral (i + 1))
        (fromIntegral (i + 2))
        (fromIntegral (i + 3))
        (fromIntegral (i + 4))
        (fromIntegral (i + 5))
        (fromIntegral (i + 6))
        (fromIntegral (i + 6))
    | i <- [0..]
    ]

main :: IO ()
main = do
    print (take 3 packed1)
    print (take 3 packed2)
    print (take 3 packed3)


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

#include "MachDeps.h"

import GHC.Ptr(Ptr(..), nullPtr, plusPtr, minusPtr)
import GHC.Stable(
  StablePtr(..), castStablePtrToPtr, castPtrToStablePtr, newStablePtr)
import GHC.Exts
import Data.Char(ord)
#if WORD_SIZE_IN_BITS < 64
import GHC.Int (Int64(..))
import GHC.Word (Word64(..))
#endif

assertEqual :: (Show a, Eq a) => a -> a -> IO ()
assertEqual a b
  | a /= b = putStrLn (show a ++ " /= " ++ show b)
  | otherwise = return ()

readBytes :: MutableByteArray# s -> State# s -> Int# -> (# State# s, [Int] #)
readBytes marr s0 len = go s0 len []
 where
  go s 0# bs = (# s, bs #)
  go s i  bs = case readWord8Array# marr (i -# 1#) s of
    (# s', b #) -> go s' (i -# 1#) (I# (word2Int# b):bs)

indexBytes :: ByteArray# -> Int# -> [Int]
indexBytes arr len  =
  [I# (word2Int# (indexWord8Array# arr i)) | I# i <- [0..I# len - 1]]

fillByteArray :: MutableByteArray# s -> Int# -> Int -> State# s -> State# s
fillByteArray arr len (I# a) = go len
 where
  go 0# s = s
  go i s = go (i -# 1#) (writeInt8Array# arr (i -# 1#) a s)

test :: (Eq a, Show a)
  => String
  -> (ByteArray# -> Int# -> a)
  -> (MutableByteArray# RealWorld -> Int# -> State# RealWorld
      -> (# State# RealWorld, a #))
  -> (MutableByteArray# RealWorld -> Int# -> a -> State# RealWorld
      -> State# RealWorld)
  -> a
  -> [Int]
  -> Int
  -> IO ()
test name index read write val valBytes len = do
  putStrLn name
  mapM_ testAtOffset [0..16]
 where
  arrLen :: Int#
  arrLen = 24#

  fillerByte :: Int
  fillerByte = 0x34

  expectedArrayBytes :: Int -> [Int]
  expectedArrayBytes offset =
       replicate offset fillerByte
    ++ valBytes
    ++ replicate (I# arrLen - len - offset) fillerByte

  testAtOffset :: Int -> IO ()
  testAtOffset offset@(I# offset#) = runRW# (\s0 -> let
    (# s1, marr #) = newByteArray# arrLen s0
    s2 = fillByteArray marr arrLen fillerByte s1
    s3 = write marr offset# val s2
    (# s4, actual0 #) = read marr offset# s3
    (# s5, actualBytes0 #) = readBytes marr s4 arrLen
    (# _, arr #) = unsafeFreezeByteArray# marr s5
    actual1 = index arr offset#
    actualBytes1 = indexBytes arr arrLen
   in do
       assertEqual actual0 val
       assertEqual actual1 val
       assertEqual actualBytes0 (expectedArrayBytes offset)
       assertEqual actualBytes1 (expectedArrayBytes offset)
   )

intToBytes :: Int -> Int -> [Int]
intToBytes (I# val0) (I# len0) = let
    result = go val0 len0
    go v 0# = []
    go v len =
      I# (v `andI#` 0xff#) : go (v `uncheckedIShiftRL#` 8#) (len -# 1#)
  in
#if defined(WORDS_BIGENDIAN)
    reverse result
#else
    result
#endif

testIntArray ::
     String
  -> (ByteArray# -> Int# -> Int#)
  -> (MutableByteArray# RealWorld -> Int# -> State# RealWorld
        -> (# State# RealWorld, Int# #))
  -> (MutableByteArray# RealWorld -> Int# -> Int# -> State# RealWorld
        -> State# RealWorld)
  -> Int
  -> Int
  -> IO ()
testIntArray name0 index read write val0 len = do
  doOne (name0 ++ " positive") val0
  doOne (name0 ++ " negative") (negate val0)
 where
  doOne name val = test
    name
    (\arr i -> I# (index arr i))
    (\arr i s -> case read arr i s of (# s', a #) -> (# s', I# a #))
    (\arr i (I# a) s -> write arr i a s)
    val
    (intToBytes val len)
    len

#if WORD_SIZE_IN_BITS == 64
testInt64Array = testIntArray
#else
testInt64Array ::
     String
  -> (ByteArray# -> Int# -> Int64#)
  -> (MutableByteArray# RealWorld -> Int# -> State# RealWorld
        -> (# State# RealWorld, Int64# #))
  -> (MutableByteArray# RealWorld -> Int# -> Int64# -> State# RealWorld
        -> State# RealWorld)
  -> Int64
  -> Int
  -> IO ()
testInt64Array name0 index read write val0 len = do
  doOne (name0 ++ " positive") val0
  doOne (name0 ++ " negative") (negate val0)
 where
  doOne :: String -> Int64 -> IO ()
  doOne name val = test
    name
    (\arr i -> I64# (index arr i))
    (\arr i s -> case read arr i s of (# s', a #) -> (# s', I64# a #))
    (\arr i (I64# a) s -> write arr i a s)
    val
    (intToBytes (fromIntegral val) len)
    len
#endif

testWordArray ::
     String
  -> (ByteArray# -> Int# -> Word#)
  -> (MutableByteArray# RealWorld -> Int# -> State# RealWorld
        -> (# State# RealWorld, Word# #))
  -> (MutableByteArray# RealWorld -> Int# -> Word# -> State# RealWorld
        -> State# RealWorld)
  -> Word
  -> Int
  -> IO ()
testWordArray name index read write val len = test
  name
  (\arr i -> W# (index arr i))
  (\arr i s -> case read arr i s of (# s', a #) -> (# s', W# a #))
  (\arr i (W# a) s -> write arr i a s)
  val
  (intToBytes (fromIntegral val) len)
  len

#if WORD_SIZE_IN_BITS == 64
testWord64Array = testWordArray
#else
testWord64Array ::
     String
  -> (ByteArray# -> Int# -> Word64#)
  -> (MutableByteArray# RealWorld -> Int# -> State# RealWorld
        -> (# State# RealWorld, Word64# #))
  -> (MutableByteArray# RealWorld -> Int# -> Word64# -> State# RealWorld
        -> State# RealWorld)
  -> Word64
  -> Int
  -> IO ()
testWord64Array name index read write val len = test
  name
  (\arr i -> W64# (index arr i))
  (\arr i s -> case read arr i s of (# s', a #) -> (# s', W64# a #))
  (\arr i (W64# a) s -> write arr i a s)
  val
  (intToBytes (fromIntegral val) len)
  len
#endif

wordSizeInBytes :: Int
wordSizeInBytes = WORD_SIZE_IN_BITS `div` 8

int :: Int
int
  | WORD_SIZE_IN_BITS == 32 = 12345678
  | otherwise = 1234567890123

word :: Word
word = fromIntegral int

float :: Float
float = 123.456789

-- Test pattern generated by this python code:
-- >>> import struct
-- >>> import binascii
-- >>> binascii.hexlify(struct.pack('>f', 123.456789))
floatBytes :: Int
floatBytes = 0x42f6e9e0

double :: Double
double = 123.45678901234

-- Test pattern generated by this python code:
-- >>> import struct
-- >>> import binascii
-- >>> binascii.hexlify(struct.pack('>d', 123.45678901234))
doubleBytes :: Int
doubleBytes = 0x405edd3c07fb4b09

main :: IO ()
main = do
  testIntArray "Int8#"
    indexInt8Array# readInt8Array# writeInt8Array#
    123 1
  testIntArray "Int16#"
    indexWord8ArrayAsInt16# readWord8ArrayAsInt16# writeWord8ArrayAsInt16#
    12345 2
  testIntArray "Int32#"
    indexWord8ArrayAsInt32# readWord8ArrayAsInt32# writeWord8ArrayAsInt32#
    12345678 4
  testInt64Array "Int64#"
    indexWord8ArrayAsInt64# readWord8ArrayAsInt64# writeWord8ArrayAsInt64#
    1234567890123 8
  testIntArray "Int#"
    indexWord8ArrayAsInt# readWord8ArrayAsInt# writeWord8ArrayAsInt#
    int wordSizeInBytes

  testWordArray "Word8#"
    indexWord8Array# readWord8Array# writeWord8Array#
    123 1
  testWordArray "Word16#"
    indexWord8ArrayAsWord16# readWord8ArrayAsWord16# writeWord8ArrayAsWord16#
    12345 2
  testWordArray "Word32#"
    indexWord8ArrayAsWord32# readWord8ArrayAsWord32# writeWord8ArrayAsWord32#
    12345678 4
  testWord64Array "Word64#"
    indexWord8ArrayAsWord64# readWord8ArrayAsWord64# writeWord8ArrayAsWord64#
    1234567890123 8
  testWordArray "Word#"
    indexWord8ArrayAsWord# readWord8ArrayAsWord# writeWord8ArrayAsWord#
    word wordSizeInBytes

  test
    "Char#"
    (\arr i -> C# (indexWord8ArrayAsChar# arr i))
    (\arr i s ->
        case readWord8ArrayAsChar# arr i s of (# s', a #) -> (# s', C# a #))
    (\arr i (C# a) s -> writeWord8ArrayAsChar# arr i a s)
    'z'
    [ord 'z']
    1
  test
    "WideChar#"
    (\arr i -> C# (indexWord8ArrayAsWideChar# arr i))
    (\arr i s ->
        case readWord8ArrayAsWideChar# arr i s of (# s', a #) -> (# s', C# a #))
    (\arr i (C# a) s -> writeWord8ArrayAsWideChar# arr i a s)
    'ð œŽ'  -- See http://www.i18nguy.com/unicode/supplementary-test.html
    (intToBytes (ord 'ð œŽ') 4)
    4
  test
    "Addr#"
    (\arr i -> Ptr (indexWord8ArrayAsAddr# arr i))
    (\arr i s ->
        case readWord8ArrayAsAddr# arr i s of (# s', a #) -> (# s', Ptr a #))
    (\arr i (Ptr a) s -> writeWord8ArrayAsAddr# arr i a s)
    (nullPtr `plusPtr` int)
    (intToBytes int wordSizeInBytes)
    wordSizeInBytes

  stablePtr <- newStablePtr ()
  test
    "StablePtr#"
    (\arr i ->
        castStablePtrToPtr (StablePtr (indexWord8ArrayAsStablePtr# arr i)))
    (\arr i s -> case readWord8ArrayAsStablePtr# arr i s of
                   (# s', a #) -> (# s', castStablePtrToPtr (StablePtr a) #))
    (\arr i p s -> case castPtrToStablePtr p of
                     (StablePtr a) -> writeWord8ArrayAsStablePtr# arr i a s)
    (castStablePtrToPtr stablePtr)
    (intToBytes (castStablePtrToPtr stablePtr `minusPtr` nullPtr)
                wordSizeInBytes)
    wordSizeInBytes

  test
    "Float#"
    (\arr i -> F# (indexWord8ArrayAsFloat# arr i))
    (\arr i s ->
        case readWord8ArrayAsFloat# arr i s of (# s', a #) -> (# s', F# a #))
    (\arr i (F# a) s -> writeWord8ArrayAsFloat# arr i a s)
    float
    (intToBytes floatBytes 4)
    4
  test
    "Double#"
    (\arr i -> D# (indexWord8ArrayAsDouble# arr i))
    (\arr i s ->
        case readWord8ArrayAsDouble# arr i s of (# s', a #) -> (# s', D# a #))
    (\arr i (D# a) s -> writeWord8ArrayAsDouble# arr i a s)
    double
    (intToBytes doubleBytes 8)
    8


-- Tests created by Jan Stolarek <jan.stolarek@p.lodz.pl>

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

import GHC.Exts

main :: IO ()
main = do
  -- PrimOps for comparing Char#
  putStrLn "=== testing gtChar# ==="
  test "gtChar#" (a#    `gtChar#` a#   ) -- False
  test "gtChar#" (b#    `gtChar#` a#   ) -- True
  test "gtChar#" (a#    `gtChar#` b#   ) -- False
  test "gtChar#" (minC# `gtChar#` minC#) -- False
  test "gtChar#" (maxC# `gtChar#` maxC#) -- False
  test "gtChar#" (minC# `gtChar#` maxC#) -- False
  test "gtChar#" (maxC# `gtChar#` minC#) -- True

  putStrLn "=== testing geChar# ==="
  test "geChar#" (a#    `geChar#` a#   ) -- True
  test "geChar#" (b#    `geChar#` a#   ) -- True
  test "geChar#" (a#    `geChar#` b#   ) -- False
  test "geChar#" (minC# `geChar#` minC#) -- True
  test "geChar#" (maxC# `geChar#` maxC#) -- True
  test "geChar#" (minC# `geChar#` maxC#) -- False
  test "geChar#" (maxC# `geChar#` minC#) -- True

  putStrLn "=== testing ltChar# ==="
  test "ltChar#" (a#    `ltChar#` a#   ) -- False
  test "ltChar#" (b#    `ltChar#` a#   ) -- False
  test "ltChar#" (a#    `ltChar#` b#   ) -- True
  test "ltChar#" (minC# `ltChar#` minC#) -- False
  test "ltChar#" (maxC# `ltChar#` maxC#) -- False
  test "ltChar#" (minC# `ltChar#` maxC#) -- True
  test "ltChar#" (maxC# `ltChar#` minC#) -- False

  putStrLn "=== testing leChar# ==="
  test "leChar#" (a#    `leChar#` a#   ) -- True
  test "leChar#" (b#    `leChar#` a#   ) -- False
  test "leChar#" (a#    `leChar#` b#   ) -- True
  test "leChar#" (minC# `leChar#` minC#) -- True
  test "leChar#" (maxC# `leChar#` maxC#) -- True
  test "leChar#" (minC# `leChar#` maxC#) -- True
  test "leChar#" (maxC# `leChar#` minC#) -- False

  putStrLn "=== testing eqChar# ==="
  test "eqChar#" (a#    `eqChar#` a#   ) -- True
  test "eqChar#" (b#    `eqChar#` a#   ) -- False
  test "eqChar#" (a#    `eqChar#` b#   ) -- False
  test "eqChar#" (minC# `eqChar#` minC#) -- True
  test "eqChar#" (maxC# `eqChar#` maxC#) -- True
  test "eqChar#" (minC# `eqChar#` maxC#) -- False
  test "eqChar#" (maxC# `eqChar#` minC#) -- False

  putStrLn "=== testing neChar# ==="
  test "neChar#" (a#    `neChar#` a#   ) -- False
  test "neChar#" (b#    `neChar#` a#   ) -- True
  test "neChar#" (a#    `neChar#` b#   ) -- True
  test "neChar#" (minC# `neChar#` minC#) -- False
  test "neChar#" (maxC# `neChar#` maxC#) -- False
  test "neChar#" (minC# `neChar#` maxC#) -- True
  test "neChar#" (maxC# `neChar#` minC#) -- True

  -- PrimOps for comparing Int#
  putStrLn "=== testing ># ==="
  test ">#" (0#          ># 0#         ) -- False
  test ">#" (1#          ># 0#         ) -- True
  test ">#" (0#          ># 1#         ) -- False
  test ">#" (minI#       ># minI#      ) -- False
  test ">#" (maxI#       ># maxI#      ) -- False
  test ">#" (minI# +# 1# ># minI#      ) -- True
  test ">#" (minI#       ># minI# -# 1#) -- False (overflow)
  test ">#" (maxI# +# 1# ># maxI#      ) -- False (overflow)
  test ">#" (maxI#       ># maxI# -# 1#) -- True

  putStrLn "=== testing <# ==="
  test "<#" (0#          <# 0#         ) -- False
  test "<#" (1#          <# 0#         ) -- False
  test "<#" (0#          <# 1#         ) -- True
  test "<#" (minI#       <# minI#      ) -- False
  test "<#" (maxI#       <# maxI#      ) -- False
  test "<#" (minI#       <# minI# +# 1#) -- True
  test "<#" (minI# -# 1# <# minI#      ) -- False (overflow)
  test "<#" (maxI#       <# maxI# +# 1#) -- False (overflow)
  test "<#" (maxI# -# 1# <# maxI#      ) -- True

  putStrLn "=== testing >=# ==="
  test ">=#" (0#          >=# 0#         ) -- True
  test ">=#" (1#          >=# 0#         ) -- True
  test ">=#" (0#          >=# 1#         ) -- False
  test ">=#" (minI#       >=# minI#      ) -- True
  test ">=#" (maxI#       >=# maxI#      ) -- True
  test ">=#" (minI# +# 1# >=# minI#      ) -- True
  test ">=#" (minI#       >=# minI# -# 1#) -- False (overflow)
  test ">=#" (maxI# +# 1# >=# maxI#      ) -- False (overflow)
  test ">=#" (maxI#       >=# maxI# -# 1#) -- True

  putStrLn "=== testing <=# ==="
  test "<=#" (0#          <=# 0#         ) -- True
  test "<=#" (1#          <=# 0#         ) -- False
  test "<=#" (0#          <=# 1#         ) -- True
  test "<=#" (minI#       <=# minI#      ) -- True
  test "<=#" (maxI#       <=# maxI#      ) -- True
  test "<=#" (minI#       <=# minI# +# 1#) -- True
  test "<=#" (minI# -# 1# <=# minI#      ) -- False (overflow)
  test "<=#" (maxI#       <=# maxI# +# 1#) -- False (overflow)
  test "<=#" (maxI# -# 1# <=# maxI#      ) -- True

  putStrLn "=== testing ==# ==="
  test "==#" (0#          ==# 0#         ) -- True
  test "==#" (1#          ==# 0#         ) -- False
  test "==#" (0#          ==# 1#         ) -- False
  test "==#" (maxI#       ==# maxI#      ) -- True
  test "==#" (maxI# -# 1# ==# maxI#      ) -- False
  test "==#" (minI#       ==# minI#      ) -- True
  test "==#" (minI#       ==# minI# +# 1#) -- False
  test "==#" (minI#       ==# maxI# +# 1#) -- True (overflow)
  test "==#" (maxI# +# 1# ==# minI#      ) -- True (overflow)
  test "==#" (maxI#       ==# minI# -# 1#) -- True (overflow)
  test "==#" (minI# -# 1# ==# maxI#      ) -- True (overflow)

  putStrLn "=== testing /=# ==="
  test "/=#" (0#          /=# 0#         ) -- False
  test "/=#" (1#          /=# 0#         ) -- True
  test "/=#" (0#          /=# 1#         ) -- True
  test "/=#" (maxI#       /=# maxI#      ) -- False
  test "/=#" (maxI# -# 1# /=# maxI#      ) -- True
  test "/=#" (minI#       /=# minI#      ) -- False
  test "/=#" (minI#       /=# minI# +# 1#) -- True
  test "/=#" (minI#       /=# maxI# +# 1#) -- False (overflow)
  test "/=#" (maxI# +# 1# /=# minI#      ) -- False (overflow)
  test "/=#" (maxI#       /=# minI# -# 1#) -- False (overflow)
  test "/=#" (minI# -# 1# /=# maxI#      ) -- False (overflow)

  -- PrimOps for comparing Word#
  putStrLn "=== testing gtWord# ==="
  test "gtWord#" (zeroW#                    `gtWord#` zeroW#                    ) -- False
  test "gtWord#" (oneW#                     `gtWord#` zeroW#                    ) -- True
  test "gtWord#" (zeroW#                    `gtWord#` oneW#                     ) -- False
  test "gtWord#" (minW#                     `gtWord#` minW#                     ) -- False
  test "gtWord#" (maxW#                     `gtWord#` maxW#                     ) -- False
  test "gtWord#" ((minW# `plusWord#` oneW#) `gtWord#` minW#                     ) -- True
  test "gtWord#" (minW#                     `gtWord#` (minW# `minusWord#` oneW#)) -- False (overflow)
  test "gtWord#" ((maxW# `plusWord#` oneW#) `gtWord#` maxW#                     ) -- False (overflow)
  test "gtWord#" (maxW#                     `gtWord#` (maxW# `minusWord#` oneW#)) -- True

  putStrLn "=== testing ltWord# ==="
  test "ltWord#" (zeroW#                     `ltWord#` zeroW#                   ) -- False
  test "ltWord#" (oneW#                      `ltWord#` zeroW#                   ) -- False
  test "ltWord#" (zeroW#                     `ltWord#` oneW#                    ) -- True
  test "ltWord#" (minW#                      `ltWord#` minW#                    ) -- False
  test "ltWord#" (maxW#                      `ltWord#` maxW#                    ) -- False
  test "ltWord#" (minW#                      `ltWord#` (minW# `plusWord#` oneW#)) -- True
  test "ltWord#" ((minW# `minusWord#` oneW#) `ltWord#` minW#                    ) -- False (overflow)
  test "ltWord#" (maxW#                      `ltWord#` (maxW# `plusWord#` oneW#)) -- False (overflow)
  test "ltWord#" ((maxW# `minusWord#` oneW#) `ltWord#` maxW#                    ) -- True

  putStrLn "=== testing geWord# ==="
  test "geWord#" (zeroW#                    `geWord#` zeroW#                    ) -- True
  test "geWord#" (oneW#                     `geWord#` zeroW#                    ) -- True
  test "geWord#" (zeroW#                    `geWord#` oneW#                     ) -- False
  test "geWord#" (minW#                     `geWord#` minW#                     ) -- True
  test "geWord#" (maxW#                     `geWord#` maxW#                     ) -- True
  test "geWord#" ((minW# `plusWord#` oneW#) `geWord#` minW#                     ) -- True
  test "geWord#" (minW#                     `geWord#` (minW# `minusWord#` oneW#)) -- False (overflow)
  test "geWord#" ((maxW# `plusWord#` oneW#) `geWord#` maxW#                     ) -- False (overflow)
  test "geWord#" (maxW#                     `geWord#` (maxW# `minusWord#` oneW#)) -- True

  putStrLn "=== testing leWord# ==="
  test "leWord#" (zeroW#                     `leWord#` zeroW#                   ) -- True
  test "leWord#" (oneW#                      `leWord#` zeroW#                   ) -- False
  test "leWord#" (zeroW#                     `leWord#` oneW#                    ) -- True
  test "leWord#" (minW#                      `leWord#` minW#                    ) -- True
  test "leWord#" (maxW#                      `leWord#` maxW#                    ) -- True
  test "leWord#" (minW#                      `leWord#` (minW# `plusWord#` oneW#)) -- True
  test "leWord#" ((minW# `minusWord#` oneW#) `leWord#` minW#                    ) -- False (overflow)
  test "leWord#" (maxW#                      `leWord#` (maxW# `plusWord#` oneW#)) -- False (overflow)
  test "leWord#" ((maxW# `minusWord#` oneW#) `leWord#` maxW#                    ) -- True

  putStrLn "=== testing eqWord# ==="
  test "eqWord#" (zeroW#                     `eqWord#` zeroW#                    ) -- True
  test "eqWord#" (oneW#                      `eqWord#` zeroW#                    ) -- False
  test "eqWord#" (zeroW#                     `eqWord#` oneW#                     ) -- False
  test "eqWord#" (maxW#                      `eqWord#` maxW#                     ) -- True
  test "eqWord#" ((maxW# `minusWord#` oneW#) `eqWord#` maxW#                     ) -- False
  test "eqWord#" (minW#                      `eqWord#` minW#                     ) -- True
  test "eqWord#" (minW#                      `eqWord#` (minW# `plusWord#` oneW#) ) -- False
  test "eqWord#" (minW#                      `eqWord#` (maxW# `plusWord#` oneW#) ) -- True (overflow)
  test "eqWord#" ((maxW# `plusWord#` oneW#)  `eqWord#` minW#                     ) -- True (overflow)
  test "eqWord#" (maxW#                      `eqWord#` (minW# `minusWord#` oneW#)) -- True (overflow)
  test "eqWord#" ((minW# `minusWord#` oneW#) `eqWord#` maxW#                     ) -- True (overflow)

  putStrLn "=== testing neWord# ==="
  test "neWord#" (zeroW#                     `neWord#` zeroW#                    ) -- False
  test "neWord#" (oneW#                      `neWord#` zeroW#                    ) -- True
  test "neWord#" (zeroW#                     `neWord#` oneW#                     ) -- True
  test "neWord#" (maxW#                      `neWord#` maxW#                     ) -- False
  test "neWord#" ((maxW# `minusWord#` oneW#) `neWord#` maxW#                     ) -- True
  test "neWord#" (minW#                      `neWord#` minW#                     ) -- False
  test "neWord#" (minW#                      `neWord#` (minW# `plusWord#` oneW#) ) -- True
  test "neWord#" (minW#                      `neWord#` (maxW# `plusWord#` oneW#) ) -- False (overflow)
  test "neWord#" ((maxW# `plusWord#` oneW#)  `neWord#` minW#                     ) -- False (overflow)
  test "neWord#" (maxW#                      `neWord#` (minW# `minusWord#` oneW#)) -- False (overflow)
  test "neWord#" ((minW# `minusWord#` oneW#) `neWord#` maxW#                     ) -- False (overflow)

  -- PrimOps for comparing Double#
  putStrLn "=== testing >## ==="
  test ">##" (0.0##  >## 0.0## ) -- False
  test ">##" (1.0##  >## 0.0## ) -- True
  test ">##" (0.0##  >## 1.0## ) -- False
  test ">##" (0.0##  >## nan## ) -- False
  test ">##" (nan##  >## 0.0## ) -- False
  test ">##" (nan##  >## nan## ) -- False
  test ">##" (infp## >## infp##) -- False
  test ">##" (infn## >## infn##) -- False
  test ">##" (infp## >## infn##) -- True
  test ">##" (infn## >## infp##) -- False
  test ">##" (infp## >## nan## ) -- False
  test ">##" (infn## >## nan## ) -- False
  test ">##" (nan##  >## infp##) -- False
  test ">##" (nan##  >## infn##) -- False

  putStrLn "=== testing <## ==="
  test "<##" (0.0##  <## 0.0## ) -- False
  test "<##" (1.0##  <## 0.0## ) -- False
  test "<##" (0.0##  <## 1.0## ) -- True
  test "<##" (0.0##  <## nan## ) -- False
  test "<##" (nan##  <## 0.0## ) -- False
  test "<##" (nan##  <## nan## ) -- False
  test "<##" (infp## <## infp##) -- False
  test "<##" (infn## <## infn##) -- False
  test "<##" (infp## <## infn##) -- False
  test "<##" (infn## <## infp##) -- True
  test "<##" (infp## <## nan## ) -- False
  test "<##" (infn## <## nan## ) -- False
  test "<##" (nan##  <## infp##) -- False
  test "<##" (nan##  <## infn##) -- False

  putStrLn "=== testing >=## ==="
  test ">=##" (0.0##  >=## 0.0## ) -- True
  test ">=##" (1.0##  >=## 0.0## ) -- True
  test ">=##" (0.0##  >=## 1.0## ) -- False
  test ">=##" (0.0##  >=## nan## ) -- False
  test ">=##" (nan##  >=## 0.0## ) -- False
  test ">=##" (nan##  >=## nan## ) -- False
  test ">=##" (infp## >=## infp##) -- True
  test ">=##" (infn## >=## infn##) -- True
  test ">=##" (infp## >=## infn##) -- True
  test ">=##" (infn## >=## infp##) -- False
  test ">=##" (infp## >=## nan## ) -- False
  test ">=##" (infn## >=## nan## ) -- False
  test ">=##" (nan##  >=## infp##) -- False
  test ">=##" (nan##  >=## infn##) -- False

  putStrLn "=== testing <=## ==="
  test "<=##" (0.0##  <=## 0.0## ) -- True
  test "<=##" (1.0##  <=## 0.0## ) -- False
  test "<=##" (0.0##  <=## 1.0## ) -- True
  test "<=##" (0.0##  <=## nan## ) -- False
  test "<=##" (nan##  <=## 0.0## ) -- False
  test "<=##" (nan##  <=## nan## ) -- False
  test "<=##" (infp## <=## infp##) -- True
  test "<=##" (infn## <=## infn##) -- True
  test "<=##" (infp## <=## infn##) -- False
  test "<=##" (infn## <=## infp##) -- True
  test "<=##" (infp## <=## nan## ) -- False
  test "<=##" (infn## <=## nan## ) -- False
  test "<=##" (nan##  <=## infp##) -- False
  test "<=##" (nan##  <=## infn##) -- False

  putStrLn "=== testing ==## ==="
  test "==##" (0.0##  ==## 0.0## ) -- True
  test "==##" (1.0##  ==## 0.0## ) -- False
  test "==##" (0.0##  ==## 1.0## ) -- False
  test "==##" (0.0##  ==## nan## ) -- False
  test "==##" (nan##  ==## 0.0## ) -- False
  test "==##" (nan##  ==## nan## ) -- False
  test "==##" (infp## ==## infp##) -- True
  test "==##" (infn## ==## infn##) -- True
  test "==##" (infp## ==## infn##) -- False
  test "==##" (infn## ==## infp##) -- False
  test "==##" (infp## ==## nan## ) -- False
  test "==##" (infn## ==## nan## ) -- False
  test "==##" (nan##  ==## infp##) -- False
  test "==##" (nan##  ==## infn##) -- False

  putStrLn "=== testing /=## ==="
  test "/=##" (0.0##  /=## 0.0## ) -- False
  test "/=##" (1.0##  /=## 0.0## ) -- True
  test "/=##" (0.0##  /=## 1.0## ) -- True
  test "/=##" (0.0##  /=## nan## ) -- True
  test "/=##" (nan##  /=## 0.0## ) -- True
  test "/=##" (nan##  /=## nan## ) -- True
  test "/=##" (infp## /=## infp##) -- False
  test "/=##" (infn## /=## infn##) -- False
  test "/=##" (infp## /=## infn##) -- True
  test "/=##" (infn## /=## infp##) -- True
  test "/=##" (infp## /=## nan## ) -- True
  test "/=##" (infn## /=## nan## ) -- True
  test "/=##" (nan##  /=## infp##) -- True
  test "/=##" (nan##  /=## infn##) -- True

  -- PrimOps for comparing Float#
  putStrLn "=== testing gtFloat# ==="
  test "gtFloat#" (zeroF# `gtFloat#` zeroF#) -- False
  test "gtFloat#" (oneF#  `gtFloat#` zeroF#) -- True
  test "gtFloat#" (zeroF# `gtFloat#` oneF# ) -- False
  test "gtFloat#" (zeroF# `gtFloat#` nanF# ) -- False
  test "gtFloat#" (nanF#  `gtFloat#` zeroF#) -- False
  test "gtFloat#" (nanF#  `gtFloat#` nanF# ) -- False
  test "gtFloat#" (infpF# `gtFloat#` infpF#) -- False
  test "gtFloat#" (infnF# `gtFloat#` infnF#) -- False
  test "gtFloat#" (infpF# `gtFloat#` infnF#) -- True
  test "gtFloat#" (infnF# `gtFloat#` infpF#) -- False
  test "gtFloat#" (infpF# `gtFloat#` nanF# ) -- False
  test "gtFloat#" (infnF# `gtFloat#` nanF# ) -- False
  test "gtFloat#" (nanF#  `gtFloat#` infpF#) -- False
  test "gtFloat#" (nanF#  `gtFloat#` infnF#) -- False

  putStrLn "=== testing ltFloat# ==="
  test "ltFloat#" (zeroF# `ltFloat#` zeroF#) -- False
  test "ltFloat#" (oneF#  `ltFloat#` zeroF#) -- False
  test "ltFloat#" (zeroF# `ltFloat#` oneF# ) -- True
  test "ltFloat#" (zeroF# `ltFloat#` nanF# ) -- False
  test "ltFloat#" (nanF#  `ltFloat#` zeroF#) -- False
  test "ltFloat#" (nanF#  `ltFloat#` nanF# ) -- False
  test "ltFloat#" (infpF# `ltFloat#` infpF#) -- False
  test "ltFloat#" (infnF# `ltFloat#` infnF#) -- False
  test "ltFloat#" (infpF# `ltFloat#` infnF#) -- False
  test "ltFloat#" (infnF# `ltFloat#` infpF#) -- True
  test "ltFloat#" (infpF# `ltFloat#` nanF# ) -- False
  test "ltFloat#" (infnF# `ltFloat#` nanF# ) -- False
  test "ltFloat#" (nanF#  `ltFloat#` infpF#) -- False
  test "ltFloat#" (nanF#  `ltFloat#` infnF#) -- False

  putStrLn "=== testing geFloat# ==="
  test "geFloat#" (zeroF# `geFloat#` zeroF#) -- True
  test "geFloat#" (oneF#  `geFloat#` zeroF#) -- True
  test "geFloat#" (zeroF# `geFloat#` oneF# ) -- False
  test "geFloat#" (zeroF# `geFloat#` nanF# ) -- False
  test "geFloat#" (nanF#  `geFloat#` zeroF#) -- False
  test "geFloat#" (nanF#  `geFloat#` nanF# ) -- False
  test "geFloat#" (infpF# `geFloat#` infpF#) -- True
  test "geFloat#" (infnF# `geFloat#` infnF#) -- True
  test "geFloat#" (infpF# `geFloat#` infnF#) -- True
  test "geFloat#" (infnF# `geFloat#` infpF#) -- False
  test "geFloat#" (infpF# `geFloat#` nanF# ) -- False
  test "geFloat#" (infnF# `geFloat#` nanF# ) -- False
  test "geFloat#" (nanF#  `geFloat#` infpF#) -- False
  test "geFloat#" (nanF#  `geFloat#` infnF#) -- False

  putStrLn "=== testing leFloat# ==="
  test "leFloat#" (zeroF# `leFloat#` zeroF#) -- True
  test "leFloat#" (oneF#  `leFloat#` zeroF#) -- False
  test "leFloat#" (zeroF# `leFloat#` oneF# ) -- True
  test "leFloat#" (zeroF# `leFloat#` nanF# ) -- False
  test "leFloat#" (nanF#  `leFloat#` zeroF#) -- False
  test "leFloat#" (nanF#  `leFloat#` nanF# ) -- False
  test "leFloat#" (infpF# `leFloat#` infpF#) -- True
  test "leFloat#" (infnF# `leFloat#` infnF#) -- True
  test "leFloat#" (infpF# `leFloat#` infnF#) -- False
  test "leFloat#" (infnF# `leFloat#` infpF#) -- True
  test "leFloat#" (infpF# `leFloat#` nanF# ) -- False
  test "leFloat#" (infnF# `leFloat#` nanF# ) -- False
  test "leFloat#" (nanF#  `leFloat#` infpF#) -- False
  test "leFloat#" (nanF#  `leFloat#` infnF#) -- False

  putStrLn "=== testing eqFloat# ==="
  test "eqFloat#" (zeroF# `eqFloat#` zeroF#) -- True
  test "eqFloat#" (oneF#  `eqFloat#` zeroF#) -- False
  test "eqFloat#" (zeroF# `eqFloat#` oneF# ) -- False
  test "eqFloat#" (zeroF# `eqFloat#` nanF# ) -- False
  test "eqFloat#" (nanF#  `eqFloat#` zeroF#) -- False
  test "eqFloat#" (nanF#  `eqFloat#` nanF# ) -- False
  test "eqFloat#" (infpF# `eqFloat#` infpF#) -- True
  test "eqFloat#" (infnF# `eqFloat#` infnF#) -- True
  test "eqFloat#" (infpF# `eqFloat#` infnF#) -- False
  test "eqFloat#" (infnF# `eqFloat#` infpF#) -- False
  test "eqFloat#" (infpF# `eqFloat#` nanF# ) -- False
  test "eqFloat#" (infnF# `eqFloat#` nanF# ) -- False
  test "eqFloat#" (nanF#  `eqFloat#` infpF#) -- False
  test "eqFloat#" (nanF#  `eqFloat#` infnF#) -- False

  putStrLn "=== testing neFloat# ==="
  test "neFloat#" (zeroF# `neFloat#` zeroF#) -- False
  test "neFloat#" (oneF#  `neFloat#` zeroF#) -- True
  test "neFloat#" (zeroF# `neFloat#` oneF# ) -- True
  test "neFloat#" (zeroF# `neFloat#` nanF# ) -- True
  test "neFloat#" (nanF#  `neFloat#` zeroF#) -- True
  test "neFloat#" (nanF#  `neFloat#` nanF# ) -- True
  test "neFloat#" (infpF# `neFloat#` infpF#) -- False
  test "neFloat#" (infnF# `neFloat#` infnF#) -- False
  test "neFloat#" (infpF# `neFloat#` infnF#) -- True
  test "neFloat#" (infnF# `neFloat#` infpF#) -- True
  test "neFloat#" (infpF# `neFloat#` nanF# ) -- True
  test "neFloat#" (infnF# `neFloat#` nanF# ) -- True
  test "neFloat#" (nanF#  `neFloat#` infpF#) -- True
  test "neFloat#" (nanF#  `neFloat#` infnF#) -- True
    where
      -- every integer is compared to 1 representing True. This
      -- results in printing "True" when the primop should return True
      -- and printing "False" when it should return False
      test :: String -> Int# -> IO ()
      test str x = putStrLn $ str ++ " " ++ (show (I# x == 1))
      a            = 'a'
      b            = 'b'
      !(C# a#)     = a
      !(C# b#)     = b
      zeroW        = 0 :: Word
      oneW         = 1 :: Word
      !(W# zeroW#) =  zeroW
      !(W# oneW#)  =  oneW
      nan          =  0.0 / 0.0 :: Double
      infp         =  1.0 / 0.0 :: Double
      infn         = -1.0 / 0.0 :: Double
      !(D# nan##)  =  0.0 / 0.0
      !(D# infp##) =  1.0 / 0.0
      !(D# infn##) = -1.0 / 0.0
      zeroF        = 0.0 :: Float
      oneF         = 1.0 :: Float
      nanF         = 0.0 / 0.0 :: Float
      infpF        = 1.0 / 0.0 :: Float
      infnF        = -1.0 / 0.0 :: Float
      !(F# zeroF#) =  0.0
      !(F# oneF#)  =  1.0
      !(F# nanF#)  =  0.0 / 0.0
      !(F# infpF#) =  1.0 / 0.0
      !(F# infnF#) = -1.0 / 0.0
      minC         = minBound :: Char
      maxC         = maxBound :: Char
      !(C# minC#)  = minC
      !(C# maxC#)  = maxC
      minI         = minBound :: Int
      maxI         = maxBound :: Int
      !(I# minI#)  = minI
      !(I# maxI#)  = maxI
      minW         = minBound :: Word
      maxW         = maxBound :: Word
      !(W# minW#)  = minW
      !(W# maxW#)  = maxW


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

import Data.Bits (finiteBitSize)
import GHC.Exts

main :: IO ()
main = do
  -- 0 is the annihilator of andI#
  print (I# (maxI# `andI#`    0#) == 0)
  print (I# (minI# `andI#`    0#) == 0)
  print (I# (0#    `andI#` maxI#) == 0)
  print (I# (0#    `andI#` minI#) == 0)
  print (I# (0#    `andI#`    0#) == 0)
  -- integer with all bits set to 1 is the neutral element of orI#,
  -- in two's complement this is -1
  print (I# (maxI# `andI#`   -1#) == maxI)
  print (I# (minI# `andI#`   -1#) == minI)
  print (I# (-1#   `andI#` maxI#) == maxI)
  print (I# (-1#   `andI#` minI#) == minI)
  print (I# (-1#   `andI#`   -1#) == -1)
  -- these two numbers have every other bit set, they should give 0
  print (I# (magicInt1# `andI#` magicInt2#) == 0)

  -- integer with all bits set to 1 is the annihilator of orI#,
  print (I# (maxI# `orI#`    -1#) == -1)
  print (I# (minI# `orI#`    -1#) == -1)
  print (I# (-1#   `orI#`  maxI#) == -1)
  print (I# (-1#   `orI#`  minI#) == -1)
  print (I# (-1#   `orI#`    -1#) == -1)
  -- 0 is the neutral element of orI#
  print (I# (maxI# `orI#`     0#) == maxI)
  print (I# (minI# `orI#`     0#) == minI)
  print (I# (0#    `orI#`  maxI#) == maxI)
  print (I# (0#    `orI#`  minI#) == minI)
  print (I# (0#    `orI#`     0#) == 0)
  -- this time we should get an integer with all bits set, that is -1
  print (I# (magicInt1# `orI#` magicInt2#) == -1)

  -- surprising as the first two tests may look, this is what we expect from
  -- bitwise negation in two's complement enccoding
  print (I# (notI#  0#) == -1)
  print (I# (notI# -1#) ==  0)
  -- magic int numbers are bitwise complementary
  print (I# (notI# magicInt1#) == magicInt2)
  print (I# (notI# magicInt2#) == magicInt1)

  -- 0 is the identity of xor
  print (I# (minI# `xorI#`    0#) == minI)
  print (I# (maxI# `xorI#`    0#) == maxI)
  print (I# (0#    `xorI#` minI#) == minI)
  print (I# (0#    `xorI#` maxI#) == maxI)
  -- anything xored with itself is 0
  print (I# (maxI# `xorI#` maxI#) == 0)
  print (I# (minI# `xorI#` minI#) == 0)
  -- xoring with -1 is like bitwise negation (because -1 has all bits set to 1)
  print (I# (minI# `xorI#`   -1#) == maxI)
  print (I# (maxI# `xorI#`   -1#) == minI)
  print (I# (-1#   `xorI#` minI#) == maxI)
  print (I# (-1#   `xorI#` maxI#) == minI)
  -- since these two have exactly the opposite bits turned on they should
  -- give an int with all bits set, and that is -1 as you probably already
  -- remember by now
  print (I# (magicInt1# `xorI#` magicInt2#) == -1)
    where
      intBitSize = finiteBitSize (undefined :: Int)
      minI  = minBound :: Int
      maxI  = maxBound :: Int
      minI# = x
          where !(I# x) = minBound
      maxI# = x
          where !(I# x) = maxBound
      magicInt1 = sum $ map (2^) [0,2..intBitSize] :: Int
      magicInt2 = sum $ map (2^) [1,3..intBitSize] :: Int
      magicInt1# = x
          where !(I# x) = magicInt1
      magicInt2# = x
          where !(I# x) = magicInt2