{-# LANGUAGE TypeOperators, TypeFamilies #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
    -- The type of 'empty' is indeed ambiguous

module T2544 where

import Data.Kind

data (:|:) a b = Inl a | Inr b

class Ix i where
   type IxMap i :: Type -> Type
   empty  :: IxMap i [Int]

data BiApp a b c = BiApp (a c) (b c)

instance (Ix l, Ix r) => Ix (l :|: r) where
   type IxMap (l :|: r) = BiApp (IxMap l) (IxMap r)
   empty = BiApp empty empty

-- [W] w1: a c ~ IxMap ii1 [Int]                  (from first 'empty')
-- [W] w2: b c ~ IxMap ii2 [Int]                  (from second 'empty')
-- [W] w3: BiApp a b c ~ IxMap (l :|: r) [Int]    (from call of BiApp
--           ~ BiApp (IxMap l) (IxMap r) [Int]

-- If we process w3 first, we'll rewrite it with w1, w2
-- yielding two constraints (Ix io ~ IxMap l, Ix i1 ~ IxMap r)
-- both with location of w3.  Then we report just one of them,
-- because we suppress multiple errors from the same location
--
-- But if we process w1,w2 first, we'll get the same constraints
-- but this time with different locations.


{-# LANGUAGE GADTs, TypeFamilies, EmptyDataDecls #-}

module T2627b where

data R a b
data W a b
data Z

type family Dual a
type instance Dual Z = Z
type instance Dual (R a b) = W a (Dual b)
type instance Dual (W a b) = R a (Dual b)

data Comm a where
    Rd :: (c -> Comm d) -> Comm (R c d)
    Wr :: e  -> Comm f  -> Comm (W e f)
    Fin :: Int -> Comm Z

conn :: (Dual a ~ b, Dual b ~ a) => Comm a -> Comm b -> (Int, Int)
conn (Rd k) (Wr a r) = conn undefined undefined

{-
 [G] a ~ R c d
 [G] b ~ W e f
 [W] Dual alpha ~ beta, [W] Dual beta ~ alpha
-}


{-# LANGUAGE EmptyDataDecls, TypeFamilies, TypeOperators, ScopedTypeVariables #-}
module Overflow where
import Control.Concurrent

data (:*:) a b
data (:+:) a b

data family PChan a
data    instance PChan (a :+: b) = E (IO (PChan a)) (IO (PChan b))
newtype instance PChan (a :*: b) = O (IO (Either (PChan a) (PChan b)))

type family Dual a
type instance Dual (a :+: b) = Dual a :*: Dual b
type instance Dual (a :*: b) = Dual a :+: Dual b

class Connect s where
    newPChan :: (s ~ Dual c, c ~ Dual s) => IO (PChan s, PChan c)

pchoose :: (t -> a) -> MVar a -> IO (t,b) -> IO b
pchoose = undefined

instance (Connect a, Connect b) => Connect (a :*: b) where
    newPChan = do
        v <- newEmptyMVar

        -- This version is in T2664a
        -- correct implementation:
        -- return (O $ takeMVar v, E (pchoose Left v newPChan) (pchoose Right v newPChan))

        -- type error leads to stack overflow (even without UndecidableInstances!)
        return (O $ takeMVar v, E (pchoose Right v newPChan) (pchoose Left v newPChan))

{- The last line gives rise to:

  [G] (a :*: b) ~ Dual c
  [G] c ~ Dual (a :*: b)
-->
  [G] c ~ Dual a :+: Dual b

  [W] PChan c ~ PChan (Dual b :+: Dual a)
--> decompose
  [W] c ~ Dual b :+: Dual a
--> subst
  [W] Dual a :+: Dual b ~ Dual b :+: Dual a
--> decompose
  [W] Dual a ~ Dual b
  [W] Dual b ~ Dual a
-}


{-# LANGUAGE EmptyDataDecls, TypeFamilies, TypeOperators, ScopedTypeVariables #-}
module Overflow where
import Control.Concurrent

data (:*:) a b
data (:+:) a b

data family PChan a
data    instance PChan (a :+: b) = E (IO (PChan a)) (IO (PChan b))
newtype instance PChan (a :*: b) = O (IO (Either (PChan a) (PChan b)))

type family Dual a
type instance Dual (a :+: b) = Dual a :*: Dual b
type instance Dual (a :*: b) = Dual a :+: Dual b

class Connect s where
    newPChan :: (s ~ Dual c, c ~ Dual s) => IO (PChan s, PChan c)

pchoose :: (t -> a) -> MVar a -> IO (t,b) -> IO b
pchoose = undefined

instance (Connect a, Connect b) => Connect (a :*: b) where
    newPChan = do
        v <- newEmptyMVar
        -- correct implementation:
        return (O $ takeMVar v, E (pchoose Left v newPChan) (pchoose Right v newPChan))

        -- This version is in T2664
        -- type error leads to stack overflow (even without UndecidableInstances!)
        --return (O $ takeMVar v, E (pchoose Right v newPChan) (pchoose Left v newPChan))


{-# LANGUAGE TypeFamilies #-}

module T2677 where

type family A x
type instance A a = Bool
type instance A Int = Char


{-# LANGUAGE AllowAmbiguousTypes, TypeFamilies #-}
-- Type of x is ambiguous

module T2693 where

type family TFn a :: *

-- Boiled down version
f :: Maybe ()
f = do
  let Just x = undefined :: Maybe (TFn a)
  let n = fst x + fst x
  return ()

f2 :: Maybe ()
f2 = do
  let x :: TFn a
      x = undefined
  let n = fst x + snd x
  return ()

-- Close to the original report
data PVR a = PVR {pvrX :: Int} deriving (Eq)

g :: () -> Maybe (TFn a)
g _ = undefined

h :: Maybe ()
h = do pvs <- mapM g undefined
       let n = (map pvrX pvs) `min` (map pvrX pvs)
       undefined


{-# LANGUAGE TypeFamilies #-}
-- Test for no type indices

module T2888 where

class C w where
  data D:: * -> *


{-# LANGUAGE TypeFamilies #-}
module T3092 where

data T a = T1 a
data instance T Int = T2 Char

type S b = b
type instance S Int = Char


{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeFamilies #-}

-- A very bogus program (multiple errors) but
-- sent GHC 6.12 into a loop

module T3330a where

newtype Writer w a = Writer { runWriter :: (a, w) }
execWriter :: Writer w a -> w
execWriter m = snd (runWriter m)

data AnyF (s :: * -> *) = AnyF
class HFunctor (f :: (* -> *) -> * -> *)
type family PF (phi :: * -> *) :: (* -> *) -> * -> *

children :: s ix -> (PF s) r ix -> [AnyF s]
children p x = execWriter (hmapM p collect x)

{-
0 from instantiating hmap
2 from instantiating collect

  (forall ixx. (phi0 ixx -> r0 ixx -> m0 (r'0 ixx) ~ s ix))
  phi0 ix0 ~ s2 ix2 -> r2 ix2 -> Writer [AnyF s2] (r2 ix2)
  f0 r0 ix0 ~ PF s r ix
  m0 (f0 r'0 ix0) ~ Writer [AnyF s] a0

Hence ix0 := ix
      r0  := r
      f0  := PF s
      phi0 := (->) s2 ix2
      m0 := Writer [AnyF s]
      a0 : = f0 r'0 ix0

  (forall ixx. ((->) (s2 ix2 -> ixx) (r ixx -> Writer [AnyF s] (r'0 ixx)) ~ s ix))

  s2 ix2 ix0 ~ (->) (s2 ix2) (r2 ix2 -> Writer [AnyF s2] (r2 ix2))

-}

collect :: HFunctor (PF s) => s ix -> r ix -> Writer [AnyF s] (r ix)
collect = error "collect"

hmapM :: (forall ix. phi ix -> r ix -> m (r' ix))
      -> phi ix -> f r ix -> m (f r' ix)
hmapM _ = error "hmapM"


{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}

-- Bizarrely this made 6.10 loop

module T3330b where

class RFunctor c a b where
    type Res c a b :: *
    rmap :: (a -> b) -> c -> Res c a b

instance (a ~ c) => RFunctor c a b where
    type Res c a b = b
    rmap f = f

instance (RFunctor c a b, a ~ c) => RFunctor [c] a b where
    type Res [c] a b = [b]
    rmap f = map (map f)


{-# LANGUAGE EmptyDataDecls, TypeFamilies, TypeOperators, GADTs, KindSignatures #-}

module T3330c where

import Data.Kind

data (f :+: g) x = Inl (f x) | Inr (g x)

data R :: (Type -> Type) -> Type where
  RSum  :: R f -> R g -> R (f :+: g)

class Rep f where
  rep :: R f

instance (Rep f, Rep g) => Rep (f :+: g) where
  rep = RSum rep rep

type family Der (f :: Type -> Type) :: Type -> Type
type instance Der (f :+: g) = Der f :+: Der g

plug :: Rep f => Der f x -> x -> f x
plug = plug' rep where

plug' :: R f -> Der f x -> x -> f x
plug' (RSum rf rg) (Inl df) x = Inl (plug rf df x)

{-
rf :: R f1, rg :: R g1
Given by GADT match: f ~ f1 :+: g1

Second arg has type (Der f x)
    = (Der (f1:+:g1) x)
    = (:+:) (Der f1) (Der g1) x
Hence df :: Der f1 x

Inl {f3,g3,x} (plug {f2,x1} rf df x)  gives rise to
  result of Inl:   ((:+:) f3 g3 x ~ f x)
  first arg (rf):  (R f1 ~ Der f2 x1)
  second arg (df): (Der f1 x ~ x1)
  result of plug:  (f2 x1 ~ x -> f3 x)

  result of Inl: ((:+:) f3 g3 x ~ f x)
       by given  ((:+:) f3 g3 x ~ (:+:) f1 g1 x)
  hence need f3~f1, g3~g1

So we are left with
   first arg:      (R f1 ~ Der f2 x1)
   second arg:     (Der f1 x ~ x1)
   result:         (f2 x1  ~  (->) x (f3 x))

Decompose result:
          f2 ~ (->) x
          x1 ~ f1 x
Hence
        first:  R f1 ~ Der ((->) x) (f1 x)
  decompose  : R ~ Der ((->) x)
               f1 ~ f1 x

-}


{-# LANGUAGE TypeFamilies, GADTs #-}

module T3440 where

type family Fam a :: *

data GADT :: * -> * where
   GADT :: a -> Fam a -> GADT (Fam a)

unwrap :: GADT (Fam a) -> (a, Fam a)
unwrap (GADT x y) = (x, y)


{-# LANGUAGE TypeFamilies #-}
module T4093a where

type family Foo x
type instance Foo () = Maybe ()

hang :: (Foo e ~ Maybe e) => Foo e
hang = Just ()

-- Type is not ambiguous; should get a complaint
-- for (e ~ ()) arising from the Just ()

{- Ambiguity check

 [G] Foo e ~ Maybe e
 [W] Foo e ~ Foo e0
 [W] Foo e0 ~ Maybe e0
---
 [G] Foo e ~ fsk
 [G] fsk ~ Maybe e

 [W] Foo e ~ fmv1
 [W] Foo e0 ~ fmv2
 [W] fmv1 ~ fmv2
 [W] fmv2 ~ Maybe e0

--->   fmv1 := fsk
 [G] Foo e ~ fsk
 [G] fsk ~ Maybe e

 [W] Foo e0 ~ fmv2
 [W] fsk ~ fmv2
 [W] fmv2 ~ Maybe e0

--->
 [G] Foo e ~ fsk
 [G] fsk ~ Maybe e

 [W] Foo e0 ~ fmv2
 [W] fmv2 ~ Maybe e
 [W] fmv2 ~ Maybe e0

Now the question is whether we get a derived equality e ~ e0.  Currently
we don't, but we easily could.  But then we'd need to be careful not to
report insoluble Int ~ Bool if we had
   F a ~ Int, F a ~ Bool
-}


{-# LANGUAGE GADTs, EmptyDataDecls, ScopedTypeVariables, TypeFamilies #-}

module T4093b where

data C
data O

type family   EitherCO e a b :: *
type instance EitherCO C a b = a
type instance EitherCO O a b = b

data MaybeC ex t where
  JustC    :: t -> MaybeC C t
  NothingC ::      MaybeC O t

data Block (n :: * -> * -> *) e x

blockToNodeList ::
  forall n e x. (EitherCO e (A C O n) (A O O n) ~ A e O n,
                 EitherCO x (A C C n) (A C O n) ~ A C x n) =>
    Block n e x -> A e x n

type A e x n = (MaybeC e (n C O), MaybeC x (n O C))
blockToNodeList b = foldBlockNodesF (f, l) b z
  where
    z :: EitherCO e (EitherCO e (A C O n) (A O O n)) (EitherCO e (A C O n) (A O O n))
    z = undefined

    f :: n C O -> EitherCO e (A C O n) (A O O n) -> EitherCO e (A C O n) (A O O n)
    f n _ = (JustC n, NothingC)

    l :: n O C -> EitherCO e (A C O n) (A O O n) -> EitherCO e (A C C n) (A O C n)
    l _ = undefined

foldBlockNodesF  :: forall n a b c e x .
                   ( n C O       -> a -> b
                   , n O C       -> b -> c)
                 -> (Block n e x -> EitherCO e a b -> EitherCO x c b)
foldBlockNodesF _ = undefined


{-# LANGUAGE TypeFamilies #-}

module T4099 where

type family T a

foo :: a -> T a -> Int
foo x = error "urk"

bar1 :: b -> T b -> Int
bar1 a x = foo (error "urk") x

bar2 :: b -> Maybe b -> Int
bar2 a x = foo (error "urk") x


{-# LANGUAGE TypeFamilies, TypeOperators, EmptyDataDecls #-}

module T4174 where

import Data.Kind (Type)

data True
data False

data Minor1

data GHC6'8 m
data GHC6'10 m

type family a :<=: b :: {-Bool-} Type
type instance GHC6'10 m1 :<=: GHC6'8 m2 = False

type a :>=: b = b :<=: a

data Way ghcVersion tablesNextToCode profiling threaded

type family GHCVersion way :: {-GHCVersion-} Type
type instance GHCVersion (Way v n p t) = v

type family Threaded way :: {-Bool-} Type
type instance Threaded (Way v n p t) = t

data Field w s t
data SmStep
data RtsSpinLock

field :: String -> m (Field w a b)
field = undefined

type family WayOf (m :: Type -> Type) :: Type

sync_large_objects :: (Monad m,
                       (GHCVersion (WayOf m) :>=: GHC6'10 Minor1) ~ True,
                       Threaded (WayOf m) ~ True)
                   => m (Field (WayOf m) SmStep RtsSpinLock)
sync_large_objects = field "sync_large_objects"

testcase :: Monad m => m (Field (Way (GHC6'8 minor) n t p) a b)
testcase = sync_large_objects

{- Wanted constraints from the occurrence of sync_large_objects

   (WayOf m) ~ (Way (GHC6'8 minor) n t p)
   a ~ SmStep
   b ~ RtsSpinLock

   Threaded (WayOf m) ~ True
     == Threaded (Way (GHC6'8 minor) n t p) ~ True
     == p ~ True

   (GHCVersion (WayOf m) :>=: GHC6'10 Minor1) ~ True,
     == (GHC6'10 Minor1 :<=: GHCVersion (WayOf m)) ~ True,
     == (GHC6'10 Minor1 :<=: GHCVersion (Way (GHC6'8 minor) n t p))) ~ True,
     == (GHC6'10 Minor1 :<=: GHC6'8 minor) ~ True
     == False ~ True

-}


{-# LANGUAGE TypeFamilies  #-}

module T4179 where

class DoC a where
     type A2 a
     type A3 a
     op :: a -> A2 a -> A3 a

data Con x = InCon (x (Con x))
type FCon x = x (Con x)

-- should have been changed to this, which works
-- foldDoC :: Functor f => (f a -> a) -> A2 (FCon f) -> Con f -> a
-- foldDoC f i (InCon t) = f (fmap (foldDoC f i) t)
-- this original version causes GHC to hang
foldDoC :: Functor f => (f a -> a) -> Con f -> a
foldDoC f (InCon t) = f (fmap (foldDoC f) t)

doCon :: (DoC (FCon x)) => Con x -> A2 (FCon x) -> A3 (FCon x)
doCon (InCon x) = op x

-- Note that if this is commented out then there's no hang:
-- presumably because GHC doesn't have to perform type deduction for foldDoC.
fCon :: (Functor x, DoC (FCon x)) => Con x -> A2 (FCon x) -> A3 (FCon x)
fCon = foldDoC op


{-# LANGUAGE TypeFamilies, FlexibleInstances #-}
module T4246 where

class Stupid a where
   type F a

instance {-# OVERLAPPABLE #-} Stupid a where
   type F a = a

instance {-# OVERLAPPING #-} Stupid Int where
   type F Int = Bool

type family G a :: *
type instance G Int = Int
type instance G Int = Bool


{-# LANGUAGE TypeFamilies, FunctionalDependencies, RankNTypes, MultiParamTypeClasses #-}
module T4254 where

class FD a b | a -> b where
  op :: a -> b;
  op = undefined

instance FD Int Bool

ok1   :: forall a b. (a~Int,FD a b) => a -> b
ok1    = op
-- Should be OK: op has the right type

ok2   :: forall a b. (a~Int,FD a b,b~Bool) => a -> Bool
ok2    = op
-- Should be OK: needs the b~Bool

fails :: forall a b. (a~Int,FD a b) => a -> Bool
fails  = op
-- Could fail: no proof that b~Bool
-- But can also succeed; it's not a *wanted* constraint


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

-- See also Trac #5763 for why we don't really want to see
-- an occurs-check error from this program

module T4272 where

class Family f where
   terms :: f a -> a

class Family (TermFamily a) => TermLike a where
   type TermFamily a :: * -> *

laws :: forall a b. TermLike a => TermFamily a a -> b
laws t = prune t (terms (undefined :: TermFamily a a))

prune :: TermLike x => TermFamily x x -> TermFamily x x -> b
prune = undefined

-- terms :: Family f => f a -> a
--    Instantiate with f = TermFamily a
-- terms :: Family (TermFamily a) => TermFamily a a -> a
-- (terms (undefined::TermFamily a a) :: Family (TermFamily a) => a
-- So the call to prune forces the equality
--    TermFamily a a ~ a
-- which triggers an occurs check


-- The behavior of type-inference and OverlappingInstances has changed
-- between GHC 6.12 and GHC 7.0 such that the following code
-- type-checks under 6.12, but not 7.0rc2. I assume this change has
-- something to do with the new type checker in GHC 7, but it is not
-- clear to me if this change in behavior is intended. Nor am I clear
-- how to achieve something similar to the old behavior. This is
-- preventing HSP (and by extension, happstack) from migrating to GHC
-- 7. I reported this earlier on the mailing lists, but I have further
-- simplified the test case here.

{-# LANGUAGE TypeFamilies, MultiParamTypeClasses
  , FlexibleContexts, FlexibleInstances, UndecidableInstances
  , TypeSynonymInstances, GeneralizedNewtypeDeriving
  #-}
module XMLGenerator where

newtype XMLGenT m a = XMLGenT (m a)
   deriving (Functor, Applicative, Monad)

class Monad m => XMLGen m where
 type XML m
 data Child m
 genElement :: String -> XMLGenT m (XML m)

class XMLGen m => EmbedAsChild m c where
    asChild :: c -> XMLGenT m [Child m]

instance {-# OVERLAPPING #-} (EmbedAsChild m c, m1 ~ m) => EmbedAsChild m (XMLGenT m1 c)

instance {-# OVERLAPPABLE #-} (XMLGen m,  XML m ~ x) => EmbedAsChild m x

data Xml = Xml
data IdentityT m a = IdentityT (m a)
instance Functor (IdentityT m)
instance Applicative (IdentityT m)
instance Monad (IdentityT m)
instance XMLGen (IdentityT m) where
    type XML (IdentityT m) = Xml

data Identity a = Identity a
instance Functor Identity
instance Applicative Identity
instance Monad Identity

instance {-# OVERLAPPING #-} EmbedAsChild (IdentityT IO) (XMLGenT Identity ())

data FooBar = FooBar

instance {-# OVERLAPPING #-} EmbedAsChild (IdentityT IO) FooBar where
  asChild b = asChild $ (genElement "foo")
  -- asChild :: FooBar -> XMLGenT (XMLGenT (IdentityT IO) [Child (IdentityT IO)])

{-     ---------- Deriving the constraints ----------
 asChild :: EmbedAsChild m c => c -> XMLGenT m [Child m]
 genElement :: XMLGen m => String -> XMLGenT m (XML m)

 Wanted: EmbedAsChild m c, with m = IdentityT IO
                                c = XMLGenT meta (XML meta)
         XMLGen meta

  ie     EmbedAsChild (IdentityT IO) (XMLGen meta (XML meta)
         XMLGen meta

We have instances
    EmbedAsChild (IdentityT IO) FooBar
    EmbedAsChild (IdentityT IO) (XMLGenT Identity ())
    EmbedAsChild m              (XMLGenT m1 c)
    EmbedAsChild m              x
-}


{-# LANGUAGE ConstraintKinds, FlexibleInstances, TypeFamilies,
     MultiParamTypeClasses, FlexibleContexts, UndecidableInstances, ScopedTypeVariables #-}
module T5515 where

class ctx (Arg ctx) => Bome ctx where
  type BArg ctx
instance ctx a => Bome ctx where
  type BArg ctx = a

class C f a
class C f (Arg f) => Some f where
  type Arg f
instance C f a => Some f where
  type Arg f = a


{-# LANGUAGE AllowAmbiguousTypes, RankNTypes, TypeFamilies, KindSignatures #-}

-- The type of 'run' is actually ambiguous

module T5934 where
import Control.Monad.ST

data Gen s
type GenST s = Gen (PrimState (ST s))

run :: (forall s. GenST s) -> Int
run = 0

type family PrimState (m :: * -> *)


{-# LANGUAGE TypeFamilies #-}

module T6123 where

type family Id a

cid :: a ~ Id a => a -> a
cid x = x

cundefined = cid undefined


{-# LANGUAGE TypeFamilies #-}

module T7010 where

type Vector = Serial Float
data Serial v = Serial

class MakeValueTuple a where
   type ValueTuple a :: *

instance MakeValueTuple Float where
   type ValueTuple Float = IO Float

instance (MakeValueTuple v) => MakeValueTuple (Serial v) where
   type ValueTuple (Serial v) = Serial (ValueTuple v)

stereoFromMono :: (v, v)
stereoFromMono = undefined

processIO ::
   (MakeValueTuple a) =>
   (ValueTuple a, ValueTuple a) ->
   (a, a)
processIO = undefined

phoneme :: (Vector, Vector)
phoneme = processIO stereoFromMono

{-

   ( MakeValueTuple Vector  =  MakeValueTuple (Serial Float)
   , ValueTuple Vector ~ ValueTuple Vector    (agf))

--> MakeValueTuple Float
--> <solved>
-}

withArgs ::
   (MakeValueTuple b) =>
   (a, ValueTuple b) ->
   (a, b)
withArgs = undefined

plug ::
   (MakeValueTuple c) =>
   (c, ValueTuple c)
plug = undefined

filterFormants :: (Float, Vector)
filterFormants = withArgs plug

{- Call to withArgs generates

    (MakeValueTuple Vector, (c,ValueTuple c)~(Float,ValueTuple Vector), MakeValueTuple c)
=   (MakeValueTuple (Serial Float), ValueTuple Float ~ ValueTuple (Serial Float), MakeValueTuple Float)
=   (MakeValueTuple (Serial Float), MakeValueTuple Float,
     IO Float ~ Serial (ValueTuple Float))

     IO Float ~ Serial f, ValueTuple Float ~ f
=    IO Float ~ Serial f, IO Float ~ f
-}


{-# LANGUAGE TypeFamilies #-}
module T7102A where
type family T a b


{-# LANGUAGE TypeFamilies #-}
module T7102B where
import T7102A
type instance T a b = a
from :: a -> T a b
from = id


{-# LANGUAGE TypeFamilies #-}
module T7102C where
import T7102A
type instance T a b = b
to :: T a b -> b
to = id


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

-- This one produced a Lint error in GHC 7.4 and 7.6

module Foo where

type family F a

class C b where {}

foo :: a -> F a
foo x = error "urk"

h :: (b -> ()) -> Int
h = error "urk"

f = h (\x -> let g :: C (F a) => a -> Int
                 g y = length [x, foo y]
             in ())


{-# LANGUAGE CPP, TypeFamilies, Rank2Types, FlexibleContexts, FlexibleInstances, GADTs, StandaloneDeriving, UndecidableInstances #-}

module T7354 where

type family Base t :: * -> *
data family Prim t :: * -> *

class Functor (Base t) => Unfoldable t where
  embed :: Base t t -> t
  ana
    :: (a -> Base t a) -- ^ a (Base t)-coalgebra
    -> a               -- ^ seed
    -> t               -- ^ resulting fixed point
  ana g = a where a = embed . fmap a . g

data instance Prim [a] b = Cons a b | Nil deriving (Eq,Ord,Show,Read)

coalg 0 = Nil
coalg n = Cons n (n-1)
alg Nil = 1
alg (Cons a b) = a * b

instance Functor (Prim [a]) where
  fmap f (Cons a b) = Cons a (f b)
  fmap _ Nil = Nil

foo = ana alg

bar = foo  -- With 7.6, the definition of foo is simply discarded by
           -- by the type checker, which makes Lint complain about bar


module T7354a where

import T7354b

foo = embed ()

bar = foo


{-# LANGUAGE TypeFamilies, FlexibleContexts #-}
module T7354b where

import Data.Kind (Type)

type family Base t :: Type -> Type

class Unfoldable t where
  embed :: Base t t -> t


{-# LANGUAGE TypeFamilies #-}

module T7536 where

type T v = Int

type family TF a :: *
type instance TF (T a) = a


{-# LANGUAGE FlexibleContexts, TypeFamilies #-}
module T7729 where
import Control.Monad

class Monad m => PrimMonad m where
  type PrimState m

class MonadTrans t where
  lift :: Monad m => m a -> t m a

class (PrimMonad (BasePrimMonad m), Monad m) => MonadPrim m where
  type BasePrimMonad m :: * -> *
  liftPrim :: BasePrimMonad m a -> m a

newtype Rand m a = Rand {
  runRand :: Maybe (m ()) -> m a
  }

instance Monad m => Functor (Rand m) where
  fmap = liftM

instance Monad m => Applicative (Rand m) where
  pure = return
  (<*>) = ap

instance (Monad m) => Monad (Rand m) where
  return           = Rand . const . return
  (Rand rnd) >>= f = Rand $ \g -> (\x -> runRand (f x) g) =<< rnd g

instance MonadTrans Rand where
  lift = Rand . const

instance MonadPrim m => MonadPrim (Rand m) where
  type BasePrimMonad (Rand m) = BasePrimMonad m
  liftPrim = liftPrim . lift


{-# LANGUAGE FlexibleContexts, TypeFamilies #-}
module T7729a where
import Control.Monad

class Monad m => PrimMonad m where
  type PrimState m

class MonadTrans t where
  lift :: Monad m => m a -> t m a

class (PrimMonad (BasePrimMonad m), Monad m) => MonadPrim m where
  type BasePrimMonad m :: * -> *
  liftPrim :: BasePrimMonad m a -> m a

newtype Rand m a = Rand {
  runRand :: Maybe (m ()) -> m a
  }

instance Monad m => Functor (Rand m) where
  fmap = liftM

instance Monad m => Applicative (Rand m) where
  pure  = return
  (<*>) = ap

instance (Monad m) => Monad (Rand m) where
  return           = Rand . const . return
  (Rand rnd) >>= f = Rand $ \g -> (\x -> runRand (f x) g) =<< rnd g

instance MonadTrans Rand where
  lift = Rand . const

instance MonadPrim m => MonadPrim (Rand m) where
  type BasePrimMonad (Rand m) = BasePrimMonad m
  liftPrim x = liftPrim (lift x)   -- This line changed from T7729

{-
  liftPrim :: (MonadPrim m) => BasePrimMonad m a -> m a
  lift :: MonadTrans t, Monad m => m a -> t m a

  sig of liftPrim :: BasePrimMonad (Rand m) a -> Rand m a
                   = BasePrimMonad m a -> Rand m a

  x :: BasePrimMonad (Rand m) a
  lift @ t=tt @ m=m1
  liftPrim @ m=m2 @ a=aa

  forall m. (Monad m) => BasePrimMonad (Rand m) a ~ m1 a   -- x arg of lift

                         tt m1 a    -- Result of lift
                               ~
                            BasePrimMonad m2 a   -- Arg of liftPrim

                         Rand m a      -- expected type of RHS
                             ~
                             m2 a  -- Result of liftPrim
    m = m_and
    m1 = m_aql
    m2 = m_aqf
    tt = t_aqj

---->
     m2 := Rand m

a)     BasePrimMonad (Rand m) ~ m1
b)     tt m1 ~ BasePrimMonad (Rand m)

--->  process (b) first
    CFunEqCan   BasePrimMonad (Ramd m) ~ s_atH
                s_atH ~ tt m1

--->  now process (a)
    m1 ~ s_atH ~ tt m1    -- An obscure occurs check
-}


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

module T7788 where

data Proxy a = Proxy

foo :: Proxy (F (Fix Id)) -> ()
foo = undefined

newtype Fix a = Fix (a (Fix a))
newtype Id a = Id a

type family F a
type instance F (Fix a) = F (a (Fix a))
type instance F (Id a) = F a

main :: IO ()
main = print $ foo Proxy


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

-- This used to fail because of the silent-superclass
-- mechanism, but now it succeeds as it should

module T7862 where

type family Scalar t

newtype Tower s a = Tower [a]

type instance Scalar (Tower s a) = a

class (Num (Scalar t), Num t) => Mode t where
    (<+>) :: t -> t -> t

instance Num a => Mode (Tower s a) where
    Tower as <+> _ = undefined
      where
        _ = (Tower as) <+> (Tower as)

instance Num a => Num (Tower s a) where


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

module T7938 where

data KProxy (a :: *) = KP

class Foo (a :: k1) (b :: k2) where
  type Bar a

instance Foo (a :: k1) (b :: k2) where
  type Bar a = (KP :: KProxy k2)


{-# LANGUAGE TypeFamilies, DataKinds, TypeOperators, GADTs #-}
module T7967 where

import Data.Kind (Type)

data Nat = Zero | Succ Nat

data SNat :: Nat -> Type where
  SZero :: SNat Zero
  SSucc :: SNat n -> SNat (Succ n)

data HList :: [Type] -> Type where
  HNil :: HList '[]
  HCons :: h -> HList t -> HList (h ': t)

data Index :: Nat -> [Type] -> Type where
  IZero :: Index Zero (h ': t)
  ISucc :: Index n l -> Index (Succ n) (h ': l)

type family Lookup (n :: Nat) (l :: [Type]) :: Type
type instance Lookup Zero (h ': t) = h
type instance Lookup (Succ n) (h ': t) = Lookup n t

hLookup :: Index n l -> HList l -> Lookup n l
hLookup IZero (HCons h _) = h
hLookup (ISucc n) (HCons _ t) = hLookup n t
hLookup _ _ = undefined

-- So far, so good. But, I wanted a way to convert `SNat`s to `Index`es. When
-- I add the (wrong) code below, and got a bogus error above

sNatToIndex :: SNat n -> HList l -> Index n l
sNatToIndex SZero HNil = IZero


{-# LANGUAGE MultiParamTypeClasses, TypeFamilies #-}

module T8129 where

type family F (x :: *) :: *

class (y ~ F x) => C x y

z = () :: C x y => ()


{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleInstances #-}

module Test where

data Vector a = Vector a
data Matrix a = Matrix a

class Build f where
    build' :: BoundsOf f -> f -> ContainerOf f

type family BoundsOf x where
    BoundsOf (a->a->a) = (Int,Int)
    BoundsOf (a->a)    = Int

type family ContainerOf x where
    ContainerOf (a->a)    = Vector a
    ContainerOf (a->a->a) = Matrix a

instance (Num a) => Build (a->a) where
    build' = buildV

buildV :: (Integral a, Num b) => a -> (b -> c) -> Vector c
buildV _ _ = undefined


{-# LANGUAGE TypeFamilies #-}
module T8227
  (
    absoluteToParam
  ) where

import Data.Kind (Type)
import T8227a

type family Scalar a :: Type
type instance Scalar (a -> v) = a -> Scalar v

arcLengthToParam :: Scalar (V p) -> p -> Scalar (V p) -> Scalar (V p)
arcLengthToParam = undefined

absoluteToParam :: Scalar (V a) -> a -> Scalar (V a)
absoluteToParam eps seg = arcLengthToParam eps eps

{-

Scalar (V a) ~ Scalar (V p0)
Scalar (V a) ~ p0
Scalar (V a) ~ Scalar (V p0) -> Scalar (V p0)

--->
Scalar (V a)  ~ fuv0
Scalar (V p0) ~ fuv1
fuv0 ~ fuv1
fuv0 ~ p0
fuv0 ~ fuv1 -> fuv1

---> p0 := fuv0

Scalar (V a)    ~ fuv0    (CFunEqCan)
Scalar (V fuv0) ~ fuv1    (CFunEqCan)
fuv0 ~ fuv1
p0 ~ fuv0
fuv0 ~ fuv1 -> fuv1

-}


{-# LANGUAGE TypeFamilies #-}
module T8227a where

import Data.Kind (Type)

type family V a :: Type

type instance V Double    = Double
type instance V (a -> b)   = V b


{-# LANGUAGE TypeFamilies, GADTs #-}

module T8368 where

data Foo = Bar

data family Fam a
data instance Fam a where
  MkFam :: Foo


{-# LANGUAGE TypeFamilies, GADTs #-}

module T8368a where

data family Fam a b
data instance Fam Int b where
  MkFam :: Fam Bool b


{-# LANGUAGE TypeFamilies #-}
module T8518 where

import Data.Maybe
import Control.Applicative

class Continuation c where
    type Z c
    type B c
    type F c
    continue ::  c -> (Z c) -> (B c) -> Maybe ((F c), c)

callCont :: Continuation c => c -> (Z c) -> (B c) -> Maybe (F c)
callCont c z b = rpt (4 :: Int) c z b
    where
        rpt 0 c' z' b' = fromJust (fst <$> (continue c' z' b'))
        rpt i c' z' b' = let c'' = fromJust (snd <$> (continue c' z' b')) in rpt (i-1) c''


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

module T8550 where

type family F a
type instance F () = F ()
data A where
  A :: F () ~ () => A
x :: A
x = A

main :: IO ()
main = seq A (return ())

-- Note: This worked in GHC 7.8, but I (Richard E) think this regression
-- is acceptable.


{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeFamilies #-}

module T9036 where

import Data.Kind

class UncurryM t where
  type GetMonad t :: Type -> Type

class Curry a b where
  type Curried a b :: Type

gSimple :: String -> String -> [String]
gSimple = simpleLogger (return ())

simpleLogger :: Maybe (GetMonad t after) -> t `Curried` [t]
simpleLogger _  _ = undefined


{-# LANGUAGE TypeFamilies, DataKinds #-}

module T9097 where

import GHC.Exts

type family Foo x where
  Foo True = False
  Foo False = False
  Foo Any = True


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

module T9160 where
import Language.Haskell.TH

$( do { cls_nm <- newName "C"
      ; a_nm   <- newName "a"
      ; k_nm   <- newName "k"
      ; f_nm   <- newName "F"
      ; return [ClassD [] cls_nm [KindedTV a_nm (VarT k_nm)] []
                 [OpenTypeFamilyD
                   (TypeFamilyHead f_nm [] (KindSig (VarT k_nm)) Nothing)]]})

-- Splices in:
--     class C (a :: k) where
--       type F :: k

instance C (a :: *) where
  type F = Maybe   -- Should be illegal


 {-# LANGUAGE TypeFamilies #-}

module T9167 where

class C a where
   type F b


{-# LANGUAGE PolyKinds, TypeFamilies #-}

module T9171 where
data Base

type family GetParam (p::k1) (t::k2) :: k3

type instance GetParam Base t = t

foo = undefined :: GetParam Base (GetParam Base Int)


{-# LANGUAGE RankNTypes, MagicHash, TypeFamilies, PolyKinds #-}

module T9357 where
import GHC.Exts

type family F (a :: k1) :: k2

type instance F Int# = Int
 -- This one is actually OK (F is poly-kinded;
 -- c.f. Trac #11120 comment:19

type instance F (forall a. a->a) = Int
 -- But this one is not (impredicative)


{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE UndecidableInstances #-}

module T9371 where

import Data.Monoid

class C x where
    data D x :: *
    makeD :: D x

instance {-# OVERLAPPABLE #-} Monoid x => C x where
    data D x = D1 (Either x ())
    makeD = D1 (Left mempty)

instance (Monoid x, Monoid y) => C (x, y) where
    data D (x,y) = D2 (x,y)
    makeD = D2 (mempty, mempty)

instance Show x => Show (D x) where
    show (D1 x) = show x

main = print (makeD :: D (String, String))


{-# LANGUAGE
     TypeFamilies
   , KindSignatures
   #-}

module T9433 where

type family Id x :: *
type instance Id a = a

type family Map (f :: * -> *) x :: *
type instance Map f [a] = [f a]

x :: Map Id [Bool]
x = []


{-# LANGUAGE TypeFamilies, UndecidableInstances #-}

module T9554 where

import Data.Proxy

type family F a where
  F a = F (F a)

foo :: Proxy (F Bool) -> Proxy (F Int)
foo x = x

main = case foo Proxy of Proxy -> putStrLn "Made it!"


module T9580 where

import T9580a
import Data.Coerce

foo :: Dimensional Int Double -> Double
foo x = coerce x


{-# LANGUAGE KindSignatures, TypeFamilies #-}
module T9580a( Dimensional ) where

import Data.Kind (Type)

data family Dimensional var :: Type -> Type
newtype instance Dimensional Int v = Quantity' v


{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE FlexibleContexts #-}

module T9662 where

import Data.Kind (Type)

data Exp a = Exp
data (a:.b) = a:.b

type family Plain e :: Type
type instance Plain (Exp a) = a
type instance Plain (a:.b) = Plain a :. Plain b

class (Plain (Unlifted pattern) ~ Tuple pattern) => Unlift pattern where
   type Unlifted pattern
   type Tuple pattern

modify :: (Unlift pattern) =>
   pattern ->
   (Unlifted pattern -> a) ->
   Exp (Tuple pattern) -> Exp (Plain a)
modify p f = undefined

data Atom a = Atom

atom :: Atom a
atom = Atom

instance (Unlift pa, int ~ Atom Int) => Unlift (pa :. int) where
   type Unlifted (pa :. int) = Unlifted pa :. Exp Int
   type Tuple (pa :. int) = Tuple pa :. Int

data Shape sh = Shape

backpermute ::
   (Exp sh -> Exp sh') ->
   (Exp sh' -> Exp sh) ->
   Shape sh -> Shape sh'
backpermute = undefined

test :: Shape (sh:.k:.m:.n) -> Shape (sh:.m:.n:.k)
test =
   backpermute
      (modify (atom:.atom:.atom:.atom)
         (\(sh:.k:.m:.n) -> (sh:.m:.n:.k)))
      id

-- With this arg instead of just 'id', it worked
--    (modify (atom:.atom:.atom:.atom)
--       (\(ix:.m:.n:.k) -> (ix:.k:.m:.n)))


{-# LANGUAGE TypeFamilies #-}
module T9896 where

class Test a where
  type TestT a :: *

instance Test Bool where
  newtype TestT Bool = Int


{-# LANGUAGE TypeFamilies #-}

type family T a b :: *
type instance T Int = IO   -- must fail: too few args


{-# LANGUAGE TypeFamilies #-}

type family T a :: * -> *
type instance T Int Float = Char   -- must fail: extra arguments


{-# LANGUAGE TypeFamilies #-}

module ShouldFail where

type family T a
type instance T (a, [b])     = T (b, b)        -- var occurs more often
type instance T (a, Maybe b) = T (a, Maybe b)  -- not smaller
type instance T (a, IO [b])  = T (a, T b)      -- nested tyfam application


{-# LANGUAGE TypeFamilies #-}
module A where
type family A a


{-# LANGUAGE TypeFamilies #-}
module B (A, X) where
import A
data X
type instance A (X, b) = ()


{-# LANGUAGE RankNTypes #-}
module C (x) where
import Data.Proxy
import B
x :: Proxy b -> (forall t. Proxy t -> Bool -> A (t, b)) -> (Bool -> ())
x _ f = f (undefined :: Proxy X)


{-# LANGUAGE TypeFamilies #-}

module Main where

import Data.Proxy
import A
import C

data Y
type instance A (a, Y) = Bool

y :: Proxy a -> Bool -> A (a, Y)
y _ = id

z :: Bool -> ()
z = x (undefined :: Proxy Y) y

main = print (z True)


{-# LANGUAGE TypeFamilies #-}

module T13092c_1 where

type family F a
type instance F Int = ()


{-# LANGUAGE TypeFamilies #-}

module T13092c_2 (F) where

import T13092c_1

data X
type instance F (X, b) = Bool


{-# LANGUAGE TypeFamilies #-}

module T13092c_3 (F) where

import T13092c_2


{-# LANGUAGE TypeFamilies #-}

module T13092c_4 where

import T13092c_3

type instance F (a, Char) = String


module A where

import O

x _ = 1 -- Generate a silly warning, so we know A was really compiled
x _ = 2 -- (and thus the reason B fails is that the bug is fixed)


module B where

import F

f :: F Int -> Bool
f = id


{-# LANGUAGE TypeFamilies #-}

module F where

type family F a :: *


{-# LANGUAGE TypeFamilies #-}

module O where

import F

type instance F Int = Bool


import Distribution.Simple
main = defaultMain


{-# LANGUAGE TypeFamilies #-}

module Main where

import Prelude hiding (lookup)
import Data.Char (ord)
import qualified Data.Map as Map
import Data.Kind (Type)

-- Generic maps as ATs
-- -------------------

class GMapKey k where
  data GMap k :: Type -> Type
  empty       :: GMap k v
  lookup      :: k -> GMap k v -> Maybe v
  insert      :: k -> v -> GMap k v -> GMap k v

instance GMapKey Int where
  data GMap Int v        = GMapInt (Map.Map Int v)
  empty                  = GMapInt Map.empty
  lookup k (GMapInt m)   = Map.lookup k m
  insert k v (GMapInt m) = GMapInt (Map.insert k v m)

instance GMapKey Char where
  data GMap Char v        = GMapChar (GMap Int v)
  empty                   = GMapChar empty
  lookup k (GMapChar m)   = lookup (ord k) m
  insert k v (GMapChar m) = GMapChar (insert (ord k) v m)

instance GMapKey () where
  data GMap () v           = GMapUnit (Maybe v)
  empty                    = GMapUnit Nothing
  lookup () (GMapUnit v)   = v
  insert () v (GMapUnit _) = GMapUnit $ Just v

instance (GMapKey a, GMapKey b) => GMapKey (a, b) where
  data GMap (a, b) v            = GMapPair (GMap a (GMap b v))
  empty                         = GMapPair empty
  lookup (a, b) (GMapPair gm)   = lookup a gm >>= lookup b
  insert (a, b) v (GMapPair gm) = GMapPair $ case lookup a gm of
                                    Nothing  -> insert a (insert b v empty) gm
                                    Just gm2 -> insert a (insert b v gm2  ) gm

instance (GMapKey a, GMapKey b) => GMapKey (Either a b) where
  data GMap (Either a b) v                = GMapEither (GMap a v) (GMap b v)
  empty                                   = GMapEither empty empty
  lookup (Left  a) (GMapEither gm1  _gm2) = lookup a gm1
  lookup (Right b) (GMapEither _gm1 gm2 ) = lookup b gm2
  insert (Left  a) v (GMapEither gm1 gm2) = GMapEither (insert a v gm1) gm2
  insert (Right a) v (GMapEither gm1 gm2) = GMapEither gm1 (insert a v gm2)

-- Test code
-- ---------

nonsence :: GMap Bool String
nonsence = undefined

myGMap :: GMap (Int, Either Char ()) String
myGMap = insert (5, Left 'c') "(5, Left 'c')"    $
         insert (4, Right ()) "(4, Right ())"    $
         insert (5, Right ()) "This is the one!" $
         insert (5, Right ()) "This is the two!" $
         insert (6, Right ()) "(6, Right ())"    $
         insert (5, Left 'a') "(5, Left 'a')"    $
         empty
main = putStrLn $ maybe "Couldn't find key!" id $ lookup (5, Right ()) myGMap


{-# LANGUAGE TypeFamilies #-}

module Main where

import Prelude hiding (lookup)
import Data.Char (ord)
import qualified Data.Map as Map
import Data.Kind (Type)

-- Generic maps as toplevel indexed data types
----------------------------------------------

data family GMap k :: Type -> Type
data instance GMap Int          v = GMapInt    (Map.Map Int v)
data instance GMap Char         v = GMapChar   (GMap Int v)
data instance GMap ()           v = GMapUnit   (Maybe v)
data instance GMap (a, b)       v = GMapPair   (GMap a (GMap b v))
data instance GMap (Either a b) v = GMapEither (GMap a v) (GMap b v)

class GMapKey k where
  empty       :: GMap k v
  lookup      :: k -> GMap k v -> Maybe v
  insert      :: k -> v -> GMap k v -> GMap k v

instance GMapKey Int where
  empty                  = GMapInt Map.empty
  lookup k (GMapInt m)   = Map.lookup k m
  insert k v (GMapInt m) = GMapInt (Map.insert k v m)

instance GMapKey Char where
  empty                   = GMapChar empty
  lookup k (GMapChar m)   = lookup (ord k) m
  insert k v (GMapChar m) = GMapChar (insert (ord k) v m)

instance GMapKey () where
  empty                    = GMapUnit Nothing
  lookup () (GMapUnit v)   = v
  insert () v (GMapUnit _) = GMapUnit $ Just v

instance (GMapKey a, GMapKey b) => GMapKey (a, b) where
  empty                         = GMapPair empty
  lookup (a, b) (GMapPair gm)   = lookup a gm >>= lookup b
  insert (a, b) v (GMapPair gm) = GMapPair $ case lookup a gm of
                                    Nothing  -> insert a (insert b v empty) gm
                                    Just gm2 -> insert a (insert b v gm2  ) gm

instance (GMapKey a, GMapKey b) => GMapKey (Either a b) where
  empty                                   = GMapEither empty empty
  lookup (Left  a) (GMapEither gm1  _gm2) = lookup a gm1
  lookup (Right b) (GMapEither _gm1 gm2 ) = lookup b gm2
  insert (Left  a) v (GMapEither gm1 gm2) = GMapEither (insert a v gm1) gm2
  insert (Right a) v (GMapEither gm1 gm2) = GMapEither gm1 (insert a v gm2)

-- Test code
-- ---------

nonsence :: GMap Bool String
nonsence = undefined

myGMap :: GMap (Int, Either Char ()) String
myGMap = insert (5, Left 'c') "(5, Left 'c')"    $
         insert (4, Right ()) "(4, Right ())"    $
         insert (5, Right ()) "This is the one!" $
         insert (5, Right ()) "This is the two!" $
         insert (6, Right ()) "(6, Right ())"    $
         insert (5, Left 'a') "(5, Left 'a')"    $
         empty
main = putStrLn $ maybe "Couldn't find key!" id $ lookup (5, Right ()) myGMap


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

import GHC.Exts
import GHC.Types

class BoxIt (a :: TYPE 'WordRep) where
    type Boxed a :: Type
    boxed :: a -> Boxed a

instance BoxIt Char# where
    type Boxed Char# = Char
    boxed x = C# x

main :: IO ()
main = print $ boxed 'c'#


{-# LANGUAGE TypeFamilies, UndecidableInstances #-}
{-# OPTIONS_GHC -Wnot #-}

module Main where

-- See http://article.gmane.org/gmane.comp.lang.haskell.general/16796
-- and Trac #2985

instance (Num a, Num b, a ~ b) => Num (a,b) where
    (x,y) * (u,v) = (x*u-y*v, x*v+y*u)

test1 = (1,1) * (2,2)
main = print test1


{-# LANGUAGE TypeFamilies, StandaloneDeriving, FlexibleInstances, GADTs #-}
module Main where

import Data.Ix

-- Deriving Enum with phantom type parameter
data T a = R | S | T deriving( Enum, Show )

-- Tests that deriving works for data families
data family Foo a

data instance Foo Int
  = A | B | C | D
  deriving (Eq, Enum)

f :: Foo Int -> Bool
f A = True
f B = False
f _ = True

-- Tests that deriving works for GADTs
data Bar a where
   P :: Int -> Bar Int
   Q :: Bar Int

deriving instance (Eq (Bar Int))

main = do { print [R .. T]
          ; print (map f [B .. D])
          ; print [P 3 == P 3, P 4 == Q] }


{-# LANGUAGE ConstraintKinds, TypeFamilies, FlexibleInstances #-}
module Main where

import GHC.Exts (Constraint)

import Prelude hiding (Functor, fmap)

import           Data.Set (Set)
import qualified Data.Set as S (map, fromList)

class Functor f where
    type C f a :: Constraint
    type C f a = ()

    fmap :: (C f a, C f b) => (a -> b) -> f a -> f b

instance Functor Set where
    type C Set a = Ord a
    fmap = S.map

instance Functor [] where
    fmap = map
--    type C [] a = ()

testList = fmap (+1) [1,2,3]
testSet  = fmap (+1) (S.fromList [1,2,3])

main = do { print testList; print testSet }


{-# LANGUAGE TemplateHaskell #-}
module Lib where

import Language.Haskell.TH

x :: Int -> ExpQ
x n = [| 3 + n |]


{-# LANGUAGE TemplateHaskell #-}

import Lib (x)

main = putStrLn "Hello World" >> print $(x 10)


module M where

f = case () of
  () -> ()
  where x = x


module M where

f = if True then do undefined else undefined


module M where

-- The array package used to have things in this sort of pattern, where
-- the "parse error" rule is needed to close the do block's layout

f :: [IO ()]
f = [do
   undefined
   undefined
   | _ <- undefined]


{-# LANGUAGE PatternGuards #-}

module M where

f | Just x <- undefined,
    let y = x,
    undefined x y
  = ()


module M where

-- GHC's Lexer.x had a piece of code like this

f = if True then do
        case () of
            () -> ()
            else ()


module M where

-- GHC's RdrHsSyn.lhs had a piece of code like this

f :: IO ()
f
 | True = do
 let x = ()
     y = ()
 return ()
 | True = return ()


{-# LANGUAGE TemplateHaskell #-}

module M where

-- The paren here closes the open-splice - it doesn't match an
-- opening paren

f :: IO ()
f = do print $( [| 'a' |] )


{-# LANGUAGE RecursiveDo, DoRec #-}
{-# OPTIONS_GHC -fno-warn-deprecated-flags #-}

module M where

-- do, mdo and rec should all open layouts

f :: IO ()
f = do print 'a'
       print 'b'

g :: IO ()
g = mdo print 'a'
        print 'b'

h :: IO ()
h = do print 'a'
       rec print 'b'
           print 'c'
       print 'd'


module M where

f :: Char
f = let {x = 'a'} in x


{-# LANGUAGE MagicHash #-}

module Q where

import GHC.Exts
import GHC.Integer

v :: Int
v = I# (integerToInt (smallInteger 3#))

w :: Word
w = W# (integerToWord (wordToInteger 3##))


{-# LANGUAGE MagicHash #-}

module Main (main) where

import GHC.Base
import GHC.Integer

main :: IO ()
main = case i of
       I# i# ->
           print (gcd (smallInteger i#) (smallInteger i#))

{-# NOINLINE i #-}
i :: Int
i = minBound


module Main (main) where

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

main :: IO ()
main = do p "plusInteger"        plusInteger
          p "timesInteger"       timesInteger
          p "minusIntegerN"      minusIntegerN
          p "minusIntegerP"      minusIntegerP
          p "negateInteger"      negateInteger
          p "eqIntegerE"         eqIntegerE
          p "eqIntegerN"         eqIntegerN
          p "neqIntegerE"        neqIntegerE
          p "neqIntegerN"        neqIntegerN
          p "absIntegerP"        absIntegerP
          p "absIntegerZ"        absIntegerZ
          p "absIntegerN"        absIntegerN
          p "signumIntegerP"    signumIntegerP
          p "signumIntegerZ"    signumIntegerZ
          p "signumIntegerN"    signumIntegerN
          p "leIntegerL"        leIntegerL
          p "leIntegerE"        leIntegerE
          p "leIntegerG"        leIntegerG
          p "gtIntegerL"        gtIntegerL
          p "gtIntegerE"        gtIntegerE
          p "gtIntegerG"        gtIntegerG
          p "ltIntegerL"        ltIntegerL
          p "ltIntegerE"        ltIntegerE
          p "ltIntegerG"        ltIntegerG
          p "geIntegerL"        geIntegerL
          p "geIntegerE"        geIntegerE
          p "geIntegerG"        geIntegerG
          p "compareIntegerL"   compareIntegerL
          p "compareIntegerE"   compareIntegerE
          p "compareIntegerG"   compareIntegerG
          p "gcdInteger"        gcdInteger
          p "lcmInteger"        lcmInteger
          p "andInteger"        andInteger
          p "orInteger"         orInteger
          p "xorInteger"        xorInteger
          p "complementInteger" complementInteger
          p "quotRemInteger"    quotRemInteger
          p "divModInteger"     divModInteger
          p "shiftLInteger"     shiftLInteger
          p "shiftRInteger"     shiftRInteger
          p "quotInteger"       quotInteger
          p "remInteger"        remInteger
          p "divInteger"        divInteger
          p "modInteger"        modInteger
          p "doubleFromInteger" doubleFromInteger
          p "floatFromInteger"  floatFromInteger
          p "decodeIntegerDouble" decodeIntegerDouble
          p "encodeIntegerDouble" encodeIntegerDouble
          p "encodeIntegerFloat"  encodeIntegerFloat
          p "integerToWord"       integerToWord
          p "integerToInt"        integerToInt
          p "wordToInteger"       wordToInteger
          p "intToInteger"        intToInteger
          p "word64ToInteger"     word64ToInteger
          p "int64ToInteger"      int64ToInteger

    where p :: Show a => String -> a -> IO ()
          p str x = putStrLn (str ++ ": " ++ show x)

plusInteger :: Integer
plusInteger = 100003 + 100004

timesInteger :: Integer
timesInteger = 100005 * 6832

minusIntegerN :: Integer
minusIntegerN = 100007 - 100998
minusIntegerP :: Integer
minusIntegerP = 100999 - 100010

negateInteger :: Integer
negateInteger = negate 200011

eqIntegerE :: Bool
eqIntegerE = (100012 :: Integer) == 100012
eqIntegerN :: Bool
eqIntegerN = (100013 :: Integer) == 100014

neqIntegerE :: Bool
neqIntegerE = (100015 :: Integer) /= 100015
neqIntegerN :: Bool
neqIntegerN = (100016 :: Integer) /= 100017

absIntegerP :: Integer
absIntegerP = abs 200018
absIntegerZ :: Integer
absIntegerZ = abs 0
absIntegerN :: Integer
absIntegerN = abs (-200019)

signumIntegerP :: Integer
signumIntegerP = signum 100020
signumIntegerZ :: Integer
signumIntegerZ = signum 0
signumIntegerN :: Integer
signumIntegerN = signum (-100021)

leIntegerL :: Bool
leIntegerL = (100022 :: Integer) <= 100023
leIntegerE :: Bool
leIntegerE = (100024 :: Integer) <= 100024
leIntegerG :: Bool
leIntegerG = (100026 :: Integer) <= 100025

gtIntegerL :: Bool
gtIntegerL = (100026 :: Integer) > 100027
gtIntegerE :: Bool
gtIntegerE = (100028 :: Integer) > 100028
gtIntegerG :: Bool
gtIntegerG = (100030 :: Integer) > 100031

ltIntegerL :: Bool
ltIntegerL = (100032 :: Integer) < 100033
ltIntegerE :: Bool
ltIntegerE = (100034 :: Integer) < 100034
ltIntegerG :: Bool
ltIntegerG = (100036 :: Integer) < 100035

geIntegerL :: Bool
geIntegerL = (100037 :: Integer) >= 100038
geIntegerE :: Bool
geIntegerE = (100039 :: Integer) >= 100039
geIntegerG :: Bool
geIntegerG = (100041 :: Integer) >= 100040

compareIntegerL :: Ordering
compareIntegerL = (100042 :: Integer) `compare` 100043
compareIntegerE :: Ordering
compareIntegerE = (100044 :: Integer) `compare` 100044
compareIntegerG :: Ordering
compareIntegerG = (100046 :: Integer) `compare` 100045

gcdInteger :: Integer
gcdInteger = 100048 `gcd` 150072

lcmInteger :: Integer
lcmInteger = 100050 `lcm` 100060

andInteger :: Integer
andInteger = 100052 .&. 140053

orInteger :: Integer
orInteger = 100054 .|. 140055

xorInteger :: Integer
xorInteger = 100056 `xor` 140057

complementInteger :: Integer
complementInteger = complement 200058

quotRemInteger :: (Integer, Integer)
quotRemInteger = 100059 `quotRem` 123

divModInteger :: (Integer, Integer)
divModInteger = 100060 `divMod` 456

shiftLInteger :: Integer
shiftLInteger = 100061 `shiftL` 4

shiftRInteger :: Integer
shiftRInteger = 100062 `shiftR` 4

quotInteger :: Integer
quotInteger = 100063 `quot` 156

remInteger :: Integer
remInteger = 100064 `rem` 156

divInteger :: Integer
divInteger = 100286 `div` 156

modInteger :: Integer
modInteger = 100086 `mod` 156

-- For the conversion functions, we can't just check that e.g. 100065
-- is in the resulting core, because it will be regardless of whether
-- the rules fire or not. So we add 100066, and thus rely on the
-- Double addition rule also firing.
doubleFromInteger :: Double
doubleFromInteger = fromInteger 100065 + 100066

floatFromInteger :: Float
floatFromInteger = fromInteger 100067 + 100068

encodeIntegerDouble :: Double
encodeIntegerDouble = encodeFloat 100069 2

encodeIntegerFloat :: Float
encodeIntegerFloat = encodeFloat 100070 2

integerToWord :: Word
integerToWord = fromInteger 100071 + 100072

integerToInt :: Int
integerToInt = fromInteger 100073 + 100074

wordToInteger :: Integer
wordToInteger = toInteger (100075 :: Word) + 100076

intToInteger :: Integer
intToInteger = toInteger (100077 :: Int) + 100078

word64ToInteger :: Integer
word64ToInteger = toInteger (100079 :: Word64) + 100080

int64ToInteger :: Integer
int64ToInteger = toInteger (100081 :: Int64) + 100082

decodeIntegerDouble :: (Integer, Int)
decodeIntegerDouble = decodeFloat (100083 :: Double)


{-# LANGUAGE CPP #-}

module IntegerConversionRules where

#if __GLASGOW_HASKELL__ < 709
import Data.Word (Word)
#endif

f1 :: Int -> Double
f1 = fi

f2 :: Int -> Float
f2 = fi

f3 :: Int -> Int
f3 = fi

f4 :: Int -> Word
f4 = fi

fi :: (Integral a, Num b) => a -> b
fi = fromIntegral


module Main (main) where

import Data.Int
import Data.Word

around :: Integer -> [Integer]
around i = [i - 2, i - 1, i, i + 1, i + 2]

dump :: Show a => String -> [a] -> IO ()
dump s xs = do putStrLn "===================================="
               putStrLn s
               mapM_ print xs

main :: IO ()
main = do let xs :: [[Integer]]
              xs = [around 0,
                    around (2^30),
                    around (2^31),
                    around (2^32),
                    around (2^33),
                    around (2^34),
                    around (2^62),
                    around (2^63),
                    around (2^64),
                    around (2^65),
                    around (2^66),
                    around (-(2^30)),
                    around (-(2^31)),
                    around (-(2^32)),
                    around (-(2^33)),
                    around (-(2^34)),
                    around (-(2^62)),
                    around (-(2^63)),
                    around (-(2^64)),
                    around (-(2^65)),
                    around (-(2^66))]
              xsInt :: [[Int]]
              xsInt = map (map fromInteger) xs
              xsIntInteger :: [[Integer]]
              xsIntInteger = map (map toInteger) xsInt
              xsInt32 :: [[Int32]]
              xsInt32 = map (map fromInteger) xs
              xsInt32Integer :: [[Integer]]
              xsInt32Integer = map (map toInteger) xsInt32
              xsInt64 :: [[Int64]]
              xsInt64 = map (map fromInteger) xs
              xsInt64Integer :: [[Integer]]
              xsInt64Integer = map (map toInteger) xsInt64
              xsWord :: [[Word]]
              xsWord = map (map fromInteger) xs
              xsWordInteger :: [[Integer]]
              xsWordInteger = map (map toInteger) xsWord
              xsWord32 :: [[Word32]]
              xsWord32 = map (map fromInteger) xs
              xsWord32Integer :: [[Integer]]
              xsWord32Integer = map (map toInteger) xsWord32
              xsWord64 :: [[Word64]]
              xsWord64 = map (map fromInteger) xs
              xsWord64Integer :: [[Integer]]
              xsWord64Integer = map (map toInteger) xsWord64
          dump "xs" xs
          dump "xsInt" xsInt
          dump "xsIntInteger" xsIntInteger
          dump "xsInt32" xsInt32
          dump "xsInt32Integer" xsInt32Integer
          dump "xsInt64" xsInt64
          dump "xsInt64Integer" xsInt64Integer
          dump "xsWord" xsWord
          dump "xsWordInteger" xsWordInteger
          dump "xsWord32" xsWord32
          dump "xsWord32Integer" xsWord32Integer
          dump "xsWord64" xsWord64
          dump "xsWord64Integer" xsWord64Integer

test :: String -> Integer -> Integer -> IO ()
test what want got
 | want == got = return ()
 | otherwise   = print (what, want, got)


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

module Main (main) where

import Data.List (group)
import Data.Bits
import Data.Word
import Control.Monad

import GHC.Word
import GHC.Base
import GHC.Integer.GMP.Internals (Integer(S#,Jp#,Jn#))
import qualified GHC.Integer.GMP.Internals as I

-- NOTE: Some of the following operations were provided with
-- integer-gmp-0.5.1, but were not ported to integer-gmp-1.0.0 (yet);
-- so we use naive reference-implementations instead for the meantime
-- in order to keep the reference-output untouched.

recipModInteger :: Integer -> Integer -> Integer
recipModInteger = I.recipModInteger

gcdExtInteger :: Integer -> Integer -> (Integer, Integer)
gcdExtInteger a b = case I.gcdExtInteger a b of (# g, s #) -> (g, s)

powModSecInteger :: Integer -> Integer -> Integer -> Integer
powModSecInteger = I.powModSecInteger

powModInteger :: Integer -> Integer -> Integer -> Integer
powModInteger = I.powModInteger

-- FIXME: Lacks GMP2 version
powInteger :: Integer -> Word -> Integer
powInteger x e = x^e

exportInteger :: Integer -> MutableByteArray# RealWorld -> Word# -> Int# -> IO Word
exportInteger = I.exportIntegerToMutableByteArray

exportIntegerAddr :: Integer -> Addr# -> Int# -> IO Word
exportIntegerAddr = I.exportIntegerToAddr

importInteger :: ByteArray# -> Word# -> Word# -> Int# -> Integer
importInteger = I.importIntegerFromByteArray

importIntegerAddr :: Addr# -> Word# -> Int# -> IO Integer
importIntegerAddr a l e = I.importIntegerFromAddr a l e

-- helpers
data MBA = MBA { unMBA :: !(MutableByteArray# RealWorld) }
data BA  = BA  { unBA  :: !ByteArray# }

newByteArray :: Word# -> IO MBA
newByteArray sz = IO $ \s -> case newPinnedByteArray# (word2Int# sz) s of (# s, arr #) -> (# s, MBA arr #)

indexByteArray :: ByteArray# -> Word# -> Word8
indexByteArray a# n# = W8# (indexWord8Array# a# (word2Int# n#))

-- indexMutableByteArray :: MutableByteArray# RealWorld -> Word# -> IO Word8
-- indexMutableByteArray a# n# = IO $ \s -> case readWord8Array# a# (word2Int# n#) s of (# s', v #) -> (# s', W# v #)

writeByteArray :: MutableByteArray# RealWorld -> Int# -> Word8 -> IO ()
writeByteArray arr i (W8# w) = IO $ \s -> case writeWord8Array# arr i w s of s -> (# s, () #)

lengthByteArray :: ByteArray# -> Word
lengthByteArray ba = W# (int2Word# (sizeofByteArray# ba))

unpackByteArray :: ByteArray# -> [Word8]
unpackByteArray ba | n == 0    = []
                   | otherwise = [ indexByteArray ba i | W# i <- [0 .. n-1] ]
  where
    n = lengthByteArray ba

freezeByteArray :: MutableByteArray# RealWorld -> IO BA
freezeByteArray arr = IO $ \s -> case unsafeFreezeByteArray# arr s of (# s, arr #) -> (# s, BA arr #)

----------------------------------------------------------------------------
main :: IO ()
main = do
    print $ powModInteger b e m
    print $ powModInteger b e (m-1)
    print $ powModSecInteger b e (m-1)

    putStrLn "\n# gcdExtInteger"
    print $ gcdExtInteger b e
    print $ gcdExtInteger e b
    print $ gcdExtInteger x y
    print $ gcdExtInteger y x
    print $ gcdExtInteger x (-y)
    print $ gcdExtInteger (-x) y
    print $ gcdExtInteger (-x) (-y)

    -- see Trac #15350
    do
        let a = 2
            b = 2^65 + 1
        print $ gcdExtInteger a b
        print $ gcdExtInteger a (-b)
        print $ gcdExtInteger (-a) b
        print $ gcdExtInteger (-a) (-b)
        print $ gcdExtInteger b a
        print $ gcdExtInteger b (-a)
        print $ gcdExtInteger (-b) a
        print $ gcdExtInteger (-b) (-a)

    putStrLn "\n# powInteger"
    print $ powInteger 12345 0
    print $ powInteger 12345 1
    print $ powInteger 12345 30
    print $ [ (x,i) | x <- [-7..71], let i = recipModInteger x (2*3*11*11*17*17), i /= 0 ]

    putStrLn "\n# nextPrimeInteger"
    print $ I.nextPrimeInteger b
    print $ I.nextPrimeInteger e
    print $ [ k | k <- [ 0 .. 200 ], S# (I.testPrimeInteger k 25#) `elem` [1,2] ]
    print $ rle [ S# (I.testPrimeInteger k 25#) | k <- [ x .. x + 1000 ] ]
    print $ rle [ S# (I.testPrimeInteger k 25#) | k <- [ e .. e + 1000 ] ]

    -- import/export primitives
    print $ [ W# (I.sizeInBaseInteger x 2#)   | x <- [b1024,b*e,b,e,m,x,y,-1,0,1] ]
    print $ [ W# (I.sizeInBaseInteger x 256#) | x <- [b1024,b*e,b,e,m,x,y,-1,0,1] ]

    BA ba <- do
        MBA mba <- newByteArray 128##
        forM_ (zip [0..127] [0x01..]) $ \(I# i, w) -> do
            writeByteArray mba i w

        let a = byteArrayContents# (unsafeCoerce# mba)

        print =<< importIntegerAddr a 0## 1#
        print =<< importIntegerAddr a 0## 0#

        print =<< importIntegerAddr (plusAddr# a 22#) 1## 1#
        print =<< importIntegerAddr (plusAddr# a 97#) 1## 0#

        print =<< importIntegerAddr a 23## 1#
        print =<< importIntegerAddr a 23## 0#

        -- no-op
        print =<< exportIntegerAddr 0 (plusAddr# a 0#) 1#

        -- write into array
        print =<< exportIntegerAddr b (plusAddr# a  5#) 1#
        print =<< exportIntegerAddr e (plusAddr# a 50#) 0#

        print =<< exportInteger m mba 85## 1#
        print =<< exportInteger m mba 105## 0#

        print =<< importIntegerAddr (plusAddr# a 85#)  17## 1#
        print =<< importIntegerAddr (plusAddr# a 105#) 17## 0#

        -- read back full array
        print =<< importIntegerAddr a 128## 1#
        print =<< importIntegerAddr a 128## 0#

        freezeByteArray mba

    print $ importInteger ba 0## 0## 1#
    print $ importInteger ba 0## 0## 0#

    print $ importInteger ba 5## 29## 1#
    print $ importInteger ba 50## 29## 0#

    print $ importInteger ba 0## 128## 1#
    print $ importInteger ba 0## 128## 0#

    return ()
  where
    b = 2988348162058574136915891421498819466320163312926952423791023078876139
    e = 2351399303373464486466122544523690094744975233415544072992656881240319
    m = 10^(40::Int)

    x = 5328841272400314897981163497728751426
    y = 32052182750761975518649228050096851724

    b1024 = roll (map fromIntegral (take 128 [0x80::Int .. ]))

    rle = map (\x -> (length x, head x)) . group

    roll :: [Word8] -> Integer
    roll = GHC.Base.foldr (\b a -> a `shiftL` 8 .|. fromIntegral b) 0


module Main (main) where

main :: IO ()
main = do
    print $ length vals

  where
    boundaries :: [Integer]
    boundaries = [fromIntegral (maxBound :: Int) - 3,
                  fromIntegral (maxBound :: Int) - 2,
                  fromIntegral (maxBound :: Int) - 1,
                  fromIntegral (maxBound :: Int),
                  fromIntegral (maxBound :: Int) + 1,
                  fromIntegral (maxBound :: Int) + 2,
                  fromIntegral (maxBound :: Int) + 3,

                  fromIntegral (minBound :: Int) - 3,
                  fromIntegral (minBound :: Int) - 2,
                  fromIntegral (minBound :: Int) - 1,
                  fromIntegral (minBound :: Int),
                  fromIntegral (minBound :: Int) + 1,
                  fromIntegral (minBound :: Int) + 2,
                  fromIntegral (minBound :: Int) + 3,

                  fromIntegral (maxBound :: Word) - 3,
                  fromIntegral (maxBound :: Word) - 2,
                  fromIntegral (maxBound :: Word) - 1,
                  fromIntegral (maxBound :: Word),
                  fromIntegral (maxBound :: Word) + 1,
                  fromIntegral (maxBound :: Word) + 2,
                  fromIntegral (maxBound :: Word) + 3,

                  -3, -2, -1, 0, 1, 2, 3]
    vals = filter (\(x, y) -> x /= y) [(x - y, x + negate y) |
                                       x <- boundaries, y <- boundaries]


{-# LANGUAGE NoImplicitPrelude #-}
module Test where
import GHC.Base

data U1 p = U1

instance Functor U1 where
    fmap f U1 = U1

instance Applicative U1 where
    pure _ = U1
    U1 <*> U1 = U1

instance Alternative U1 where
    empty = U1
    U1 <|> U1 = U1


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

-- | Test case for Trac #5486
-- Test case reduced from HsOpenSSL package BN module
module Bad where

import           Control.Exception hiding (try)
import           Foreign
import qualified Data.ByteString as BS

import           Foreign.C.Types
import           GHC.Base
import           GHC.Integer.GMP.Internals

newtype BigNum = BigNum (Ptr BIGNUM)
data BIGNUM

data ByteArray = BA  !ByteArray#
data MBA       = MBA !(MutableByteArray# RealWorld)

foreign import ccall unsafe "BN_free"
        _free :: Ptr BIGNUM -> IO ()

foreign import ccall unsafe "BN_bn2mpi"
        _bn2mpi :: Ptr BIGNUM -> Ptr CChar -> IO CInt

foreign import ccall unsafe "memcpy"
        _copy_in :: ByteArray# -> Ptr () -> CSize -> IO ()

foreign import ccall unsafe "memcpy"
        _copy_out :: Ptr () -> ByteArray# -> CSize -> IO ()

unwrapBN :: BigNum -> Ptr BIGNUM
unwrapBN (BigNum p) = p

wrapBN :: Ptr BIGNUM -> BigNum
wrapBN = BigNum

bnToInteger :: BigNum -> IO Integer
bnToInteger bn = do
  nlimbs <- ((\hsc_ptr -> peekByteOff hsc_ptr 8)) (unwrapBN bn) :: IO CInt
  case nlimbs of
    0 -> return 0
    1 -> do (I# i) <- ((\hsc_ptr -> peekByteOff hsc_ptr 0)) (unwrapBN bn) >>= peek
            negative <- ((\hsc_ptr -> peekByteOff hsc_ptr 16)) (unwrapBN bn) :: IO CInt
            if negative == 0
               then return $ S# i
               else return $ 0 - (S# i)
    _ -> do
      let !(I# nlimbsi) = fromIntegral nlimbs
          !(I# limbsize) = ((8))
      (MBA arr) <- newByteArray (nlimbsi *# limbsize)
      (BA ba) <- freezeByteArray arr
      limbs <- ((\hsc_ptr -> peekByteOff hsc_ptr 0)) (unwrapBN bn)
      _ <- _copy_in ba limbs $ fromIntegral $ nlimbs * ((8))
      negative <- ((\hsc_ptr -> peekByteOff hsc_ptr 16)) (unwrapBN bn) :: IO CInt
      if negative == 0
         then return $ J# nlimbsi ba
         else return $ 0 - (J# nlimbsi ba)

newByteArray :: Int# -> IO MBA
newByteArray sz = IO $ \s ->
  case newByteArray# sz s of { (# s', arr #) ->
  (# s', MBA arr #) }

freezeByteArray :: MutableByteArray# RealWorld -> IO ByteArray
freezeByteArray arr = IO $ \s ->
  case unsafeFreezeByteArray# arr s of { (# s', arr' #) ->
  (# s', BA arr' #) }

integerToBN :: Integer -> IO BigNum
integerToBN (S# 0#) = do
  bnptr <- mallocBytes ((24))
  ((\hsc_ptr -> pokeByteOff hsc_ptr 0)) bnptr nullPtr
  let one :: CInt
      one = 1
      zero :: CInt
      zero = 0
  ((\hsc_ptr -> pokeByteOff hsc_ptr 20)) bnptr one
  ((\hsc_ptr -> pokeByteOff hsc_ptr 8)) bnptr zero
  ((\hsc_ptr -> pokeByteOff hsc_ptr 12)) bnptr zero
  ((\hsc_ptr -> pokeByteOff hsc_ptr 16)) bnptr zero
  return (wrapBN bnptr)

integerToBN (S# v) = do
  bnptr <- mallocBytes ((24))
  limbs <- malloc :: IO (Ptr CULong)
  poke limbs $ fromIntegral $ abs $ I# v
  ((\hsc_ptr -> pokeByteOff hsc_ptr 0)) bnptr limbs
  let one :: CInt
      one = 1
  ((\hsc_ptr -> pokeByteOff hsc_ptr 20)) bnptr one
  ((\hsc_ptr -> pokeByteOff hsc_ptr 8)) bnptr one
  ((\hsc_ptr -> pokeByteOff hsc_ptr 12)) bnptr one
  ((\hsc_ptr -> pokeByteOff hsc_ptr 16)) bnptr (if (I# v) < 0 then one else 0)
  return (wrapBN bnptr)

integerToBN v@(J# nlimbs_ bytearray)
  | v >= 0 = do
      let nlimbs = (I# nlimbs_)
      bnptr <- mallocBytes ((24))
      limbs <- mallocBytes (((8)) * nlimbs)
      ((\hsc_ptr -> pokeByteOff hsc_ptr 0)) bnptr limbs
      ((\hsc_ptr -> pokeByteOff hsc_ptr 20)) bnptr (1 :: CInt)
      _ <- _copy_out limbs bytearray (fromIntegral $ ((8)) * nlimbs)
      ((\hsc_ptr -> pokeByteOff hsc_ptr 8)) bnptr ((fromIntegral nlimbs) :: CInt)
      ((\hsc_ptr -> pokeByteOff hsc_ptr 12)) bnptr ((fromIntegral nlimbs) :: CInt)
      ((\hsc_ptr -> pokeByteOff hsc_ptr 16)) bnptr (0 :: CInt)
      return (wrapBN bnptr)
  | otherwise = do bnptr <- integerToBN (0-v)
                   ((\hsc_ptr -> pokeByteOff hsc_ptr 16)) (unwrapBN bnptr) (1 :: CInt)
                   return bnptr

integerToMPI :: Integer -> IO BS.ByteString
integerToMPI v = bracket (integerToBN v) (_free . unwrapBN) bnToMPI

bnToMPI :: BigNum -> IO BS.ByteString
bnToMPI bn = do
  bytes <- _bn2mpi (unwrapBN bn) nullPtr
  allocaBytes (fromIntegral bytes) (\buffer -> do
    _ <- _bn2mpi (unwrapBN bn) buffer
    BS.packCStringLen (buffer, fromIntegral bytes))


{-# LANGUAGE MagicHash, UnboxedTuples #-}
-- Test case for Trac #5681
module Main where

import GHC.Prim

work :: Int -> Int
work n = work (n-1)

main :: IO ()
main = case spark# (work 2) realWorld# of
           (# _, _ #) -> case par# (work 1) of
                             _ -> return ()


module M where

import Control.Monad.Primitive
import qualified Data.Vector.Unboxed.Mutable as V
import System.IO.Unsafe (unsafePerformIO)

foo :: ()
foo = unsafePerformIO $ do
    _ <- V.replicate 1 0.0 :: IO (V.MVector RealWorld Double)
    return ()


{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE MagicHash, UnliftedFFITypes #-}
module T7575 where

import GHC.Prim
import GHC.Word
import GHC.Types

foreign import ccall unsafe "hs_eqWord64" dummy_eqWord64# :: Word64# -> Word64# -> Bool

check :: Word64 -> Word64 -> Bool
check (W64# x#) (W64# y#) = dummy_eqWord64# x# y#

check2 :: Word64 -> Bool
check2 x = check x 0


{-# LANGUAGE MagicHash, UnboxedTuples #-}
import GHC.Prim
import GHC.IO

main = IO $ \s ->
  let (# s1, p0 #) = newByteArray# 10# s
      (# s2, p #) = unsafeFreezeByteArray# p0 s1
      (# s3, q #) = newByteArray# 10# s2
  in (# copyByteArray# p 0# q 0# 10# s, () #)


{-# LANGUAGE ForeignFunctionInterface #-}
module SymbolsViaSections where
foreign export ccall test :: Int -> IO ()
test :: Int -> IO ()
test i = putStrLn (replicate i '.')


{-# OPTIONS -XRecursiveDo #-}

-- test that we have all the promised instances

module Main(main) where

import Control.Monad.Fix
import qualified Control.Monad.ST      as SST
import qualified Control.Monad.ST.Lazy as LST

generic :: MonadFix m => m [Int]
generic = mdo xs <- return (1:xs)
              return (take 4 xs)

io :: IO [Int]
io = generic

sst :: SST.ST s [Int]
sst = generic

lst :: LST.ST s [Int]
lst = generic

mb :: Maybe [Int]
mb = generic

ls :: [[Int]]
ls = generic

main :: IO ()
main = do
        print   =<< io
        print   $   SST.runST sst
        print   $   LST.runST lst
        print   $   mb
        print   $   ls


{-# OPTIONS -XRecursiveDo #-}

-- test of user defined instance of MonadFix

module Main (main) where

import Control.Monad
import Control.Monad.Fix

data X a = X a deriving Show

instance Functor X where
  fmap f (X a) = X (f a)

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

instance Monad X where
  return      = X
  (X a) >>= f = f a

instance MonadFix X where
  mfix f = fix (f . unX)
         where unX ~(X x) = x

z :: X [Int]
z = mdo x <- return (1:x)
        return (take 4 x)

main = print z


{-# OPTIONS -XRecursiveDo #-}

-- test let bindings

module Main (main) where

import Control.Monad.Fix

t :: IO Int
t = mdo x <- return (l "1")
        let l [] = 0
            l (x:xs) = 1 + l xs
        return x

main :: IO ()
main = t >>= print


{-# OPTIONS -XRecursiveDo #-}

-- test let bindings, polymorphism is ok provided they are not
-- isolated in a recursive segment
-- NB. this is not what Hugs does!

module Main (main) where

import Control.Monad.Fix

t :: IO (Int, Int)
t = mdo let l [] = 0
            l (x:xs) = 1 + l xs
        return (l "1", l [1,2,3])

main :: IO ()
main = t >>= print


{-# OPTIONS -XRecursiveDo #-}

-- test scoping

module Main (main) where

import Control.Monad.Fix
import Data.Maybe ( fromJust )

t = mdo x <- fromJust (mdo x <- Just (1:x)
                           return (take 4 x))
        return x

main :: IO ()
main = print t


{-# OPTIONS -XRecursiveDo #-}

-- This test, from Iavor Diatchki, made GHC 6.2 loop (testLoop)
-- or panic (testPanic); there was a Lint error.
-- The reason was a missing bindInstsOfLocalFuns in tcStmtAndThen

module ShouldCompile where

import Control.Monad.Fix

testLoop _  = mdo x <- mapM undefined (f x)
                  let f _ = []
                  return (f x)

testPanic _  = mdo x <- f x
                   let f _ = return ()
                   f x


{-# LANGUAGE RecursiveDo #-}
module T10004 where

bar :: IO ()
bar = do rec {}
         return ()


{-# OPTIONS -XRecursiveDo #-}

-- let bindings are monomorphic if used prior to their definition

module Main (main) where

import Control.Monad.Fix

t :: IO (Int, Int)
t = mdo x <- return (l "1", l [1,2,3])
        let l [] = 0
            l (x:xs) = 1 + l xs
        return x

main :: IO ()
main = t >>= print


{-# OPTIONS -XRecursiveDo #-}

-- shadowing is not allowed

module Main (main) where

import Control.Monad.Fix

t :: IO ()
t = mdo x <- return 1
        x <- return 2
        return ()

main :: IO ()
main = t


{-# OPTIONS -XRecursiveDo #-}

-- shadowing is not allowed II

module Main (main) where

import Control.Monad.Fix

t :: IO ()
t = mdo x <- return 1
        let x 0 = 4
        return ()

main :: IO ()
main = t


{-# OPTIONS -XRecursiveDo #-}

-- OLD: mdo requires MonadFix instance, even
--      if no recursion is present

-- Dec 2010: Small change of behaviour
--     MonadFix is only required if recursion is present

module Main (main) where

import Control.Monad.Fix

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

data X a = X a deriving Show

instance Functor X where
    fmap = liftM

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

instance Monad X where
  return      = X
  (X a) >>= f = f a

z :: X [Int]
z = mdo { a <- return 1; return [a] }

main = print z


-- use of mdo requires an extension,
-- so let's try not enabling it

module Main (main) where

import Control.Monad.Fix

main :: IO ()
main = mdo x <- return (1:x)
           return ()


{-# LANGUAGE DoRec #-}

-- check that do-rec does not perform segmentation
t :: IO [Int]
t = do rec xs <- return (1:xs)
           print (length (take 10 xs))     -- would diverge without segmentation
       return (take 10 xs)

-- should diverge when run
-- currently it exhibits itself via a blocked MVar operation
main :: IO ()
main = t >>= print


{-# OPTIONS -XRecursiveDo -XScopedTypeVariables #-}

module Main(main) where

import Control.Monad.Fix
import Data.Array.IO
import Control.Monad

norm a = mdo (_, sz) <- getBounds a
             s <- ioaA 1 s sz 0
             return ()
    where
          ioaA i s sz acc
           | i > sz = return acc
           | True   = do v <- readArray a i
                         writeArray a i (v / s)
                         ioaA (i+1) s sz $! (v + acc)

toList a = do (_, sz) <- getBounds a
              mapM (\i -> readArray a i) [1..sz]

test    :: Int -> IO ()
test sz = do
        (arr :: IOArray Int Float) <- newArray (1, sz) 12
        putStrLn "Before: "
        toList arr >>= print
        norm arr
        putStrLn "After: "
        lst <- toList arr
        print lst
        putStrLn ("Normalized sum: " ++ show (sum lst))

main = test 10


{-# OPTIONS -XRecursiveDo #-}

module Main(main) where

import Control.Monad.Fix
import Control.Monad.ST
import Data.STRef
import Prelude hiding (traverse)

newtype Node s a = N (STRef s Bool, Node s a, a, Node s a)

newNode       :: Node s a -> a -> Node s a -> ST s (Node s a)
newNode b c f = do v <- newSTRef False
                   return (N (v, b, c, f))

ll :: ST s (Node s Int)
ll = mdo n0 <- newNode n3 0 n1
         n1 <- newNode n0 1 n2
         n2 <- newNode n1 2 n3
         n3 <- newNode n2 3 n0
         return n0

data Direction = Forward | Backward deriving Eq

traverse                      :: Direction -> Node s a -> ST s [a]
traverse dir (N (v, b, i, f)) =
       do visited <- readSTRef v
          if visited
             then return []
             else do writeSTRef v True
                     let n = if dir == Forward then f else b
                     is <- traverse dir n
                     return (i:is)

l2dll        :: [a] -> ST s (Node s a)
l2dll (x:xs) = mdo c <- newNode l x f
                   (f, l) <- l2dll' c xs
                   return c

l2dll'          :: Node s a -> [a] -> ST s (Node s a, Node s a)
l2dll' p []     = return (p, p)
l2dll' p (x:xs) = mdo c <- newNode p x f
                      (f, l) <- l2dll' c xs
                      return (c, l)

insertAfter :: Node s a -> a -> ST s (Node s a)
insertAfter cur@(N (v, prev, val, next)) i
     = do vis <- newSTRef False
          let newCell = N (vis, cur, i, next)
          return (N (v, prev, val, newCell))

test = runST (do l   <- l2dll [1 .. 10]
                 l'  <- insertAfter l  12
                 l'' <- insertAfter l' 13
                 traverse Forward l'')

main = print test


{-# LANGUAGE DoRec #-}

main :: IO ()
main = do x <- return (length [1 .. 42 :: Int])
          rec b <- return x
              let a = const c
              c <- print "x"
          print (b, a b)


{-# LANGUAGE RecursiveDo #-}

-- check that mdo does perform segmentation
t :: IO [Int]
t = mdo xs <- return (1:xs)
        print (length (take 10 xs))     -- would diverge without segmentation
        return (take 10 xs)

main :: IO ()
main = t >>= print


{-# LANGUAGE DoRec #-}

-- check that do-rec does not perform segmentation
-- compare with ../should_fail/mdofail006.hs
t :: IO [Int]
t = do rec xs <- return (1:xs)
       print (length (take 10 xs))     -- would work since out of the segment
       return (take 10 xs)

main :: IO ()
main = t >>= print


-- !!! Importing unknown module
module M where
import N


-- !!! Exporting non-existent datatype transparently
module M(T(K1)) where
x = 'a' -- dummy definition to get round a separate bug


-- !!! Empty where declarations list
module Mod100 where

y = 3

x = v where v = 2 where

{- Example of a nested context not being further
   indented than the enclosing - an error (from the
   Sec B.2 of the H98 report).

f x = let
       h y = let
     p z = z
             in p
      in h

-}

f e = let { x = e; y = x } in y

z = 'a' where

class A a where

instance A Int where

instance A Char


-- !!! Re-exporting a subset of a alg. data type's constructors
module Mod101 where

import Mod101_AuxB

-- ConB is not imported by Mod101_AuxB, hence not exported either.
x :: DataA
x = ConB False


--
-- Helper module for mod101.hs
module Mod101_AuxA where

data DataA = ConA Int | ConB Bool


--
-- Helper module for mod101.hs
--
module Mod101_AuxB ( DataA(..) ) where

import Mod101_AuxA ( DataA(ConA) )


-- !!! Fixed bug: Re-exporting a subset of a class' methods
module Mod102 where

import Mod102_AuxB

-- methB is not imported by Mod102_AuxB, hence not exported either.
x :: Bool -> ()
x = methB False


--
-- Helper module for mod102.hs
--
module Mod102_AuxA where

class ClassA a where
  methA :: Int  -> a
  methB :: Bool -> a


--
-- Helper module for mod102.hs
--
module Mod102_AuxB ( ClassA(..) ) where

import Mod102_AuxA ( ClassA(methA) )


-- !!! Layout rule extension (restricting empty do's).
module Foo where

g :: Int -> (Int -> IO a) -> IO a
g x cont = cont x

f :: Int -> IO Int
f x = do
  g x $ \ y -> do
  f y


-- !!! Redefining imported Prelude entities
module A where
--import Prelude

head = "head"


-- !!! Re-defining Prelude entities
module Ring where
import qualified Prelude
import Data.List ( nub )

l1 + l2 = l1 Prelude.++ l2
l1 * l2 = nub (l1 + l2)

succ = (Prelude.+ 1)


-- !!! local aliases
module M where

import qualified GHC.List as M
import qualified Data.Maybe as M

x = M.length
b = M.isJust


-- !!! Redefining and using Prelude entities
module F where

sin :: Float -> Float
sin x = (x::Float)
f x = Prelude.sin (F.sin x)


-- !!! Local alias same as module
module F where

import Prelude as F

x = 'a'


-- !!! redefining and using Prelude entities
module A( null, nonNull ) where
import Prelude hiding( null )
import qualified Prelude
null, nonNull :: Int -> Bool
null    x = x == 0
nonNull x = not (Prelude.null [x]) && not (null x)


-- !!! Re-defining Prelude class
module M where

import Prelude
--import qualified Prelude

class Eq a where
 equal  :: a -> a -> Prelude.Bool
 negate :: a -> a

instance Eq Prelude.Int where
  equal x y = x Prelude.== y
  negate x  = Prelude.negate x
x = M.negate (2 :: Prelude.Int)


-- !!! Hiding an abstract (Prelude) type
module M where

import Prelude   hiding ( Char )
import Data.Char hiding ( ord, Char )
import qualified Data.Char ( ord )

type Char = Int

ord :: Char -> Int
ord x = Data.Char.ord (chr x) + 1


-- !!! Hiding an abstract (Prelude) class
module M where

import Prelude hiding ( Eq )

class Eq a where
  equ :: a -> Bool

f :: Eq a => a -> Bool
f x = equ x


-- !!! Type re-exportation test
-- (from bug reported by Ross Paterson.)
module Mod114 (Stuff) where
import Mod114_Help hiding(Stuff(..))


module Mod114_Help(Stuff(Foo, Bar)) where data Stuff = Foo | Bar


-- !!! class method (re-)exportation trickery
module M where

import Mod115_B

f = m1 (1::Int)
g = m2 (2::Int)


-- re-exporting m2 outside of C(..)
module Mod115_A( C(m1), m2) where

class C a where
  m1 :: a -> Int
  m2 :: a -> Bool

instance C Int where
  m1 _ = 1
  m2 _ = True


-- re-export all of C
module Mod115_B (C(..)) where

import Mod115_A (C(m1), m2)


-- !!! data ctor (re-)exportation
module M (T(M1), M2) where

data T = M1 Int | M2 Int


-- !!! field name (re-)exportation trickery
module M where

import Mod117_B

f = m1 undefined
g = m2 undefined


-- re-exporting m2 outside of T(..)
module Mod117_A( T(T,m1), m2) where

data T = T { m1 :: Int, m2 :: Int}


-- re-export all of T
module Mod117_B (T(..)) where

import Mod117_A ( T(T,m1),m2 )


-- !!! more class method (re-)exportation trickery.
module M where

import Mod118_B

g = m2 (2::Int)


-- re-exporting m2 outside of C(..)
module Mod118_A( C(m1), m2) where

class C a where
  m1 :: a -> Int
  m2 :: a -> Bool

instance C Int where
  m1 _ = 1
  m2 _ = True


-- re-export all of C
module Mod118_B (C(..)) where

import Mod118_A hiding (C(m1))
import Mod118_A (C)


-- !!! module re-exportation
module M where
import Mod119_B(f)


module Mod119_B (module Mod119_A) where
import Mod119_A


-- !!! Correct class export
module M(C(m1,m2,m3)) where
class C a where
  m1 :: a
  m2, m3 :: a


-- !!! (..) importation of partially exported types
-- (test / bug report due to Ross Paterson.)
module M where
import Mod120_A(T(..))
f = Foo


-- !!! (..) importation of partially exported class
-- (test / bug report due to Ross Paterson.)
module M where
import Mod121_A(C(..))
f = m2 (1::Int)


module Mod121_A(C(m1)) where

class C a where
  m1 :: a -> Int
  m2 :: a -> Bool


-- !!! exporting a method (but not its class)
module M where
import Mod122_A

f :: C a => a -> a
f = m1


module Mod122_A (m1) where

class C a where m1 :: a -> a


-- !!! exporting a field name (but not its type)
module M where
import Mod123_A

f :: T -> Int
f x = f1 x


module Mod123_A (f1) where

data T = MkT { f1 :: Int }


-- !!! hiding an entity T (where T is both a type and a dcon.)
module M where

import Mod124_A hiding (T)

x :: T
x = undefined


-- !!! hiding an entity T (where T is both a type and a dcon.)
module M where

import Mod125_A hiding (T)

--x :: T
x = T


-- !!! hiding an entity T (where T is both a class and a dcon.)
module M where

import Mod126_A hiding (T)

--x :: T
x = T


module Mod126_A where

class T a where m1 :: a -> a

data T1 = T


-- !!! hiding an entity T (where T is both a class and a dcon.)
module M where

import Mod127_A hiding (T)

x :: T a => a -> a
x = undefined


module Mod127_A where

class T a where m1 :: a -> a

data T1 = T


-- !!! Cumulative exportation
module M where
import Mod128_A(T(..))

f = Con


-- repeated exports of a type/class accumulate.
module Mod128_A(T,T(Con)) where

data T = Con


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

-- !!! hiding class members (but not class.)
module M where

import Prelude hiding ( (<), (>))

x :: Ord a => a -> a
x = undefined


-- !!! Omitted member from export list
module M(C(m1,m3)) where
class C a where
  m1 :: a
  m2, m3 :: a


-- !!! hiding class members.
module M where

import Prelude hiding ( (<), (>))

x :: Int -> Int
x = (<) 2


-- !!! unqual name conflicts in export lists.  Should fail
module C ( Mod131_A.f, g, module Mod131_B ) where
import Mod131_B(f)
import qualified Mod131_A(f)
g = f


-- !!! dcon hiding (in the presence of identically named tycon.)
-- (test contributed by Ross Paterson.)
module M where
import Mod132_B

foo = Foo


-- exporting everything but the Foo dcon.
module Mod132_B (module Mod132_A) where

import Mod132_A hiding (Foo)
import Mod132_A (Foo)


-- Control.Monad.Except re-exports Control.Monad.Fix.
-- This test checks that the subordinate-name test
-- for a class operation (when renaming the instance decl)
-- works correctly.

module ShouldCompile where

import Control.Monad
import Control.Monad.Except

data Foo a = Foo a

instance Functor Foo where
  fmap = liftM

instance Applicative Foo where
  pure = Foo
  (<*>) = ap

instance Monad Foo where
  return         = pure
  (Foo a) >>= k  = k a

instance MonadFix Foo where
         mfix = undefined


-- Test that 'hiding' hides the qualified name too

module Main where
import Prelude hiding (head)

main  = do print (Prelude.head [0..])
           head

head = print "head"


-- !!! Re-exporting qualified import.
module M (module Data.List) where

import Data.List as Data.Char


-- !!! Re-exporting qualified module.
module M  where

import Prelude ()   -- Forces the import to come from Mod136_A
import Mod136_A

x = zipWith5


module Mod136_A ( module Data.List ) where
   -- Only things in scope unqualified (from the Prelude)
   -- and qualified Data.List.x, will be exported

import qualified Data.List


-- !!! Re-exporting alias which maps to multiple mods.
module M  where

import Mod137_A

x = zipWith5
y = isLatin1


module Mod137_A (module Data.Char) where

import Data.Char
import Data.List as Data.Char


-- !!! Re-exporting alias which maps to multiple mods; some qualified.
module M  where

import Mod138_A

x = zipWith5
y = isLatin1


module Mod138_A (module Data.Char) where

import qualified Data.Char
import Data.List as Data.Char


-- !!! re-exporting module alias, with hiding.
module M where

import Mod139_B

z = Bar
a = Mod139_B.x

y = m1 (2::Int)


module Mod139_A where

data Foo = Bar

class C a where
  m1 :: a -> Int

instance C Int where
  m1 _ = 2

x = 'x'


module Mod139_B ( module A ) where

import Mod139_A as A hiding (C,Foo)


-- !!! Duplicate member in export list
module M(C(m1,m2,m2,m3)) where
class C a where
  m1 :: a
  m2, m3 :: a


-- !!! hiding tycon _only_.
module M where

import Mod140_A

a = Bar


-- !!! re-exportation to override select entities.
module M where

import Mod141_A

a :: String
a = partition


module Mod141_A (partition, module Data.List) where

import Data.List hiding (partition)

partition :: String
partition = "partition"


-- !!! Conflicting re-exportation of var
module M (module M, module Mod142_A) where

import Mod142_A

x = 'x'


-- !!! Conflicting re-exportation of tycon
module M (module M, module Mod143_A) where

import Mod143_A

data Foo = Baz


-- !!! Conflicting re-exportation of dcon
module M (module Mod144_A,module M) where

import Mod144_A

data Foo1 = Bar


-- !!! Conflicting re-exportation of class methods
module Mod145(module Mod145, module Mod145_A) where

import Mod145_A

class C1 a where
  m1 :: a -> Int


module Mod145_A where

class C2 a where
  m1 :: (a,a) -> Int


-- !!! Conflicting re-exportation of class methods
module Mod146(module Mod146, module Mod145_A) where

import Mod145_A

class C1 a where
  m1 :: a -> Int


-- !!! exporting tycon (but not dcon with same name.)
module M where

import Mod147_A

x = D 4


module Mod147_A(D) where

data D = D Int


-- !!! re-exportation and ambiguity
-- should not fail as the absence of an export
-- list spec means "export all entities defined,
-- but none imported".
module M where id x = [];


-- !!! re-exportation and ambiguity again.
-- Exporting M (=> id) is not ambiguous, as
-- Prelude isn't also exported.
module M (module M) where id x = x;


-- !!! Correct class export
module M(C(..)) where
class C a where
  m1 :: a
  m2, m3 :: a


-- !!! ambiguous re-exportation.
module M (module M,module Prelude) where id x = x;


-- !!! ambiguous re-exportation.
module M (module M,id) where id x = x;


-- !!! ambiguous re-exportation.
module M (module Prelude,id) where id x = x;


-- !!! ambiguous re-exportation.
module M (id) where id x = x;


-- !!! Default export list isn't the same as (module M)
-- This should succeed, exporting only the local 'sort',
-- and not being confused by the 'sort' from 'List'.
-- (Hugs gets this wrong)

module M where

import Data.List as M
sort = "foo"


-- !!! ambiguous re-exportation.
module M(module M) where

import Prelude as M
id x = x


-- !!! non-ambiguous re-exportation.
module M (module Prelude) where id x = x;


-- !!! cumulative re-exportation of data constructors
module M where

import Mod157_D

-- Mod157_D re-exports the type T using (..). T is defined
-- in Mod157_A, but (only) two of its constructors are visible
-- in Mod157_D, one via Mod157_B, the other via Mod157_C.
a = A
b = B


module Mod157_A (T(..)) where

data T = A | B | C


module Mod157_B (T(..)) where

import Mod157_A(T(A))


module Mod157_C(T(..)) where

import Mod157_A(T(B))


module Mod157_D(T(..)) where

import Mod157_B(T(..))
import Mod157_C(T(..))


-- !!! cumulative re-exportation of data constructors, pt 2.
module M where

import Mod157_D

-- Mod157_D re-exports the type T using (..). T is defined
-- in Mod157_A, but (only) two of its constructors is visible
-- in Mod157_D, one via Mod157_B, the other via Mod157_C.
a = A
b = B
-- C is out of scope.
c = C


-- !!! cumulative re-exportation of class methods
module M where

import Mod159_D

-- Mod159_D re-exports the class C using (..). C is defined
-- in Mod159_A, but (only) two of its methods are visible
-- in Mod159_D, one via Mod159_B, the other via Mod159_C.
a = m1 'a'
b = m2 'b'


module Mod159_A (C(..)) where

class C a where
  m1 :: a -> Int
  m2 :: a -> Int
  m3 :: a -> Int

instance C Char where
  m1 _ = 1
  m2 _ = 2
  m3 _ = 3


module Mod159_B (C(..)) where

import Mod159_A(C(m1))


module Mod159_C(C(..)) where

import Mod159_A(C(m2))


module Mod159_D(C(..)) where

import Mod159_B(C(..))
import Mod159_C(C(..))


-- !!! Correct abstract class export
module M(C) where
class C a where
  m1 :: a
  m2, m3 :: a


-- !!! cumulative re-exportation of class methods, pt 2.
module M where

import Mod159_D

-- Mod159_D re-exports the class C using (..). C is defined
-- in Mod159_A, but (only) two of its methods are visible
-- in Mod159_D, one via Mod159_B, the other via Mod159_C.
a = m1 'a'
b = m2 'b'
-- m3 isn't in scope
c = m3 'c'


-- !!! Testing export of unknown name
module Bar(bar) where
foo = foo


-- !!! hiding a type (but not dcon of same name)
module M where

import Mod162_A hiding (T())

x = T


-- !!! lazy name conflict reporting for field labels/selectors.
module M where

import Mod163_A

data T = MkT { f :: Int }


module Mod163_A where

data C = MkC { f :: Char }


-- !!! lazy name conflict reporting for data constructors
module M where

import Mod164_A
import Mod164_B

f x =
  case x of
    D1 -> 'a'


-- !!! lazy name conflict reporting for data constructors (pt.2)
module M where

import Mod164_A as A
import Mod164_B as A

f x =
  case x of
    A.D1 -> 'a'


-- !!! lazy name conflict reporting for data constructors (pt.3)
module M where

import Mod164_A as A
import Mod164_B

f x =
  case x of
    A.D1 -> 'a'


-- !!! qualified + hiding type constructors (or classes)
module M where

import qualified Mod164_A hiding (T)

data T = D1 | D3

f = D1
g = Mod164_A.D1


-- !!! hiding Prelude method names
-- (based on bug report by Iavor Diatchi:
--   http://haskell.org/pipermail/hugs-bugs/2003-October/001369.html
-- )
module M where

import Prelude hiding ( negate, enumFrom,
                        enumFromThen, enumFromTo,
                        enumFromThenTo )
import Data.Ix hiding ( rangeSize )
negate = undefined
enumFrom = undefined
enumFromThen = undefined
enumFromTo = undefined
enumFromThenTo = undefined
rangeSize = undefined

x = [negate,enumFrom, enumFromThen, enumFromTo, enumFromThenTo, rangeSize]


-- !!! Non-clashing local binding and occurrence.
module M where

m :: Int
m = let length _ = 5 in length []


-- !!! Testing non-member function in explicit class export list
module M(C(m1,m2,m3,Left)) where
class C a where
  m1 :: a
  m2, m3 :: a


-- !! Lone import of field label
-- (contributed/reported by Ross Paterson.)
module M where

import Mod170_A(field)

x = field


module Mod170_A (Type(..)) where

data Type = Constr { field :: Int }


-- !! Test import-unused warnings on 'module M' exports
-- This one should not generate any warnings

module M (module Mod171_A, h) where

import Mod171_A -- This isn't unused...
import Mod171_B -- even though this imports all the same stuff

h :: Int -> Int
h = g


module Mod171_A where

f :: Int -> Int
f x = x


module Mod171_B (g, module Mod171_A) where
import Mod171_A

g :: Int -> Int
g = f


-- Hugs failed this test Jan06

module Mod172 where

import Mod172_B (f,g)


module Mod172_B( module Mod172_C ) where

import Mod172_C


module Mod172_C( f,g ) where

class A a where f :: a
data R = R { g :: Int }


module ShouldCompile where

import Mod173_Aux

t1 = partition  -- From the import

nub = True
t2 = nub        -- Unambiguous; nub should not have been exported

t3 = frob


module Mod173_Aux( module Mod173_Aux ) where

import qualified Data.List as Mod173_Aux( nub )
        -- This should not be exported

import Data.List as Mod173_Aux( partition )
        -- This one should be exported

frob x = Mod173_Aux.nub (x::[Int])      -- This one should


module ShouldCompile where

import Prelude ()
import Control.Monad( Monad(return), unless )
  -- Should report Monad and return as unused imports
import GHC.Base
  -- But not their import from here

x = True
y x = unless


module ShouldCompile where

import Prelude ()
import Data.Maybe( Maybe(..) )
import Data.Maybe

f x = Just x


module Main where

import Mod178_2

main :: IO ()
main = print foo


module Main(main) where
import qualified Mod179_A hiding ()
main = print Mod179_A.x


-- !!! Testing duplicate type synonyms
type T = Int
type T = Float


module ShouldFail where

import qualified Mod180_B as Mod180_A
import Mod180_B (T)
import Mod180_A (x)

z :: T
z = x
  -- fiendishly, this error message must mention Mod180_A.T (the type
  -- of x), but in the current scope, Mod180_A.T means something different:
  -- due to the 'import .. as' above, Mod180_A.T actually refers to Mod180_B.T.
  -- GHC should notice this and use a fully qualified name "main:Mod180_A.T"
  -- in the error message.


-- !!! Testing duplicate classes
class C a where m :: a
class C a where m :: a


-- !!! Qualified import of unknown module
module M where
import qualified N


-- !!! Testing duplicate members
class C1 a where m :: a
class C2 a where m :: a


-- !!! Testing duplicate type constructors
data T = K1
data T = K2


-- !!! Testing duplicate data constructors
data T1 = K
data T2 = K


module ShouldFail where
-- !!! Testing duplicate type variables
type T a a = Either a a


module ShouldFail where
-- !!! Testing duplicate type variables
data T a a = K a a


module ShouldFail where
-- !!! Testing bogus (or existential) type variables
data T a = K a b


module ShouldFail where
-- !!! Testing bogus (or existential) type variables
type T a = Either a b


module ShouldFail where
-- !!! Testing recursive type synonyms
type T1 = (Int,T2)
type T2 = (Int,T1)


-- !!! Testing for out of scope Prelude types.
-- was: Imported tycon clashes with local definition
--      (but that's OK, as long as the type isn't _used_.)
module M where
import Prelude(Int)
type Int = Char


-- !!! Exporting "constructor" of a type synonym
module M(T(K1)) where
type T = T'
data T' = K1


-- !!! Imported class clashes with local class definition
module M where
import Prelude(Eq,Bool)
class Eq a where (==) :: a -> a -> Bool


-- !!! Defining local type with same name as imported class
-- was: Imported class clashes with local type definition
module M where
import Prelude(Eq,Bool)
type Eq = Bool


-- !!! Defining local class with same name as imported type.
-- was: Imported tycon clashes with local class definition
module M where
import Prelude(Int,Bool)
class Int a where (==) :: a -> a -> Bool


-- !!! Redefining an imported name
-- was: Imported var clashes with local var definition
module M where
import Prelude(id)
id x = x


-- !!! Defining local value with same name as imported class member.
-- was: Imported member fun clashes with local var definition
module M where
import Data.Ix(Ix(..))
index x = x


-- !!! Redefining imported data constructors
-- was: Imported constructor clashes with local constructor
module M where
import Prelude(Bool(True,False))
data T = True


-- !!! Hiding lists "intersect" part 1
module M where
import Prelude hiding (const,id)
import Prelude hiding (const)
x = const


-- !!! Hiding lists "intersect" part 2
module M where
import Prelude hiding (const,id)
import Prelude hiding (const)
x = id


-- !!! Class decl clashes with type decl
module M where
type C = Int
class C a where f :: a


-- !!! Class variable constraints on member funs
module M where
class C a where f :: Eq a => a


-- !!! Exporting unknown constructor
module M(T(K1,K2)) where
data T = K1


-- !!! Cyclic class hierarchy
module M where
class C2 a => C1 a where f :: a
class C1 a => C2 a where g :: a


-- !!! Repeated variable in instance predicate
module M where
instance Eq a => Eq (Either a a)


-- !!! Not "simple type" in instance
module M where
instance Eq a


-- !!! Type synonym in instance
module M where
instance Eq String


-- !!! Repeated instance decl
module M where
data T = T Int
instance Eq T
instance Eq T


-- !!! Type sigs in instance decl
module M where
data T = T Int
instance Eq T where
  (==) :: T -> T -> Bool
  T x == T y = x == y


-- !!! Instances of superclasses exist
module M where
data T = T Int
instance Ord T


-- !!! Instance context can't satisfy class-hierarchy constraint
module M where
class Foo a
class Foo a => Bar a
instance Num a => Foo [a]
instance (Eq a, Enum a) => Bar [a]


-- !!! Class decl can't use pattern bindings
module M where
class C a where
  x,y :: a
  (x,y) = error "foo"


-- !!! Default decl for non-method
module M where
class C a where
  x :: a
  y = error "foo"


-- !!! Duplicate export of constructor
module M(T(K1,K1)) where
data T = K1


-- !!! Default decl for non-method
module M where
data T = C deriving (Foo)


-- !!! Duplicate derived instance
module M where
data T = C deriving (Eq,Eq)


-- !!! Duplicate derived instance
module M where
data T = C deriving (Eq)
instance Eq T


-- !!! Duplicate derived instance
module M where
class C a
data T = K deriving (C)


-- !!! Duplicate derived instance
module M where
data T = K deriving (Ord)


-- !!! Illegal deriving Enum
module M where
data T = K Int deriving (Enum)


-- !!! Illegal deriving Ix
module M where
import Data.Ix(Ix)
data T = K1 Int | K2 deriving (Eq,Ord,Ix)


-- !!! Multiple (identical) default decls
module M where
default (Int,Integer)
default (Int,Integer)


-- !!! Malformed pattern (unknown constructor)
module M where
f K = error "foo"


-- !!! Omitted constructor from export list
module M(T(K1)) where
data T = K1|K2


-- !!! Malformed pattern (arity)
module M where
f (Left) = error "foo"


-- !!! Malformed infix expression
module M where
f a b c = a==b==c


-- !!! Malformed binding (qualified)
module M where
x = let M.y = 'a' in M.y


-- !!! Bindings of different arities
module M where
f 0 = id
f x y = x+y


-- !!! Pattern binding must bind (not an error in standard Haskell)
module M where
x = let ['a'] = "a" in 'a'


-- !!! Malformed lhs (pointless but legal in Haskell 1.3, rejected by Hugs)
module M where
x = let [] = "a" in 'a'


-- !!! Multiple value bindings
module M where
f x = 'a'
g x = 'b'
f x = 'c'


-- !!! Type decl but no body
module M where
f :: Int -> Bool


-- !!! Multiple type decls
module M where
f :: Int -> Bool
f :: Int -> Bool
f = even


-- !!! Illegal @ in expression
module M where
f x = x@1


-- !!! Exporting non-existent type/class
module M(T) where
x = 'a' -- dummy definition to get round a separate bug


-- !!! Illegal ~ in expression
module M where
f x = x~1


{-# OPTIONS_GHC -fno-warn-typed-holes #-}
-- !!! Illegal _ in expression
module M where
f x = x _ 1


-- !!! Undefined variable in expression
module M where
f x = g x


-- !!! Undefined qualified variable in expression
module M where
f x = Prelude.g x


-- !!! Undefined qualifier in expression
module M where
f x = N.g x


-- !!! Qualifying with local module name
module M where
f x = M.f x


-- !!! Multiple modules per file
module M where
foo = 'a'

module N where
bar = 'b'


-- !!! Naked fixity declaration
module M where
infix $$$
x = 'a'


-- !!! Importing unknown class/tycon
module M where
import Prelude(C)


-- !!! Exporting non-existent module
module M(module N) where
x = 'a' -- dummy definition to get round a separate bug


-- !!! Importing unknown name
module M where
import Prelude(f)


-- !!! Importing Tycon with bogus constructor
module M where
import Prelude(Either(Left,Right,Foo))


-- !!! Importing Tycon with missing constructor
module M where
import Prelude(Either(Left))


-- !!! Importing Tycon with duplicate constructor
module M where
import Prelude(Either(Left,Right,Right))


-- !!! Correct tycon import (explicit constructor list)
module M where
import Prelude(Either(Left,Right))
x = (Left 'a', Right 'a')


-- !!! Correct tycon import (implicit constructor list)
module M where
import Prelude(Either(..))
x = (Left 'a', Right 'a')


-- !!! Correct abstract tycon import
module M where
import Prelude(Either)


-- !!! Trying to use constructors of abstractly imported type.
module M where
import Prelude(Either)
x = Left 'a'


-- !!! Honouring qualified imports lists
-- was: Known bug: Qualified import ignores import list
module M where
import qualified Prelude (map)
x = Prelude.Left 'a'


{-# OPTIONS_GHC -Wall #-}

-- !!! Sublist for non-class/tycon
module M where
import Prelude(map(..))


-- !!! Exporting non-existent type transparently
module M(T(..)) where
x = 'a' -- dummy definition to get round a separate bug


-- !!! Sublist for non-class/tycon
module M where
import Prelude(Left(..))


-- !!! Importing Class with bogus member
module M where
import Prelude(Eq((==),(/=),eq))