{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies #-}

-- Strangely, this program does not elicit an error message
-- in GHC 5.03.  I don't know why. It fails correctly in
-- 5.04

module ShouldFail where

class Eq ce => Collects e ce | ce -> e where
    empty :: ce
    empty = error("empty")

data Stupid = Stupid -- without equality

instance Collects Bool Stupid where


{-# LANGUAGE RankNTypes #-}

module ShouldCompile where

data Foo a b = Foo { foo :: a -> b }

-- kind error in here
bar :: String -> (forall a . Foo a) -> IO ()
bar s _ = putStrLn s


-- Record construction should fail statically
-- if there are any strict fields,
-- including in the non-record case.

module ShouldFail where

data S = S { x::Int, y:: ! Int }
data T = T Int !Int
data U = U Int  Int

s1 = S {}       -- Bad
s2 = S { x=3 }  -- Bad
s3 = S { y=3 }  -- Ok
t  = T {}       -- Bad
u  = U {}       -- Ok


-- Tests kind error messages

-- GHC 6.6 stops on the first kind error it encounters,
-- so we only get one error report here.  I'll leave
-- the other tests in here, though, in case matters improve
-- again

module ShouldFail where

data T k = T (k Int)

f :: [Maybe]
f x = x

g :: T Int
g x = x

h :: Int Int
h x = x


-- Killed GHC 5.04.2

module ShouldFail where

class Foo a where
  foo :: a -> ()

data Bar = Bar { bar :: () }

test :: Bar
test = undefined { foo = () }
        -- The point is that foo is a class method,
        -- but not a record selector


module ShouldFail where

-- in Haskell 98, methods must mention the class variable
-- (SourceForge bug #756454).
class Foo a where
    bug :: ()


module ShouldFail where

-- Without any extensions enabled both of these should fail

newtype N1 = N1 Int deriving ( Enum )
data    N2 = N2 Int deriving ( Enum )


-- Gave a bad error message in a version of 6.3, as a
-- result of 6.3's new duplicate-instance reporting structure
--
--      Foo.hs:4:5:
--          No instance for `Eq Foo'
--          When deriving the `Eq' instance for type `Bar'

module ShouldFail where

data Bar = Bar Foo deriving Eq
data Foo = Foo deriving Eq

instance Eq Foo where
    Foo == Foo = True


-- Gave a nasty
--      tcLookupGlobal: `FunnyError.$dmb' is not in scope
-- failure in GHC 6.2, because the type-checking of
-- the default method didn't recover.

module ShouldFail where

class A x where
   a :: x -> ()
   b :: x -> Bool -> ()
   b x "Foo" = () -- deliberate type error

instance A Int where
   a _ = ()


{-# LANGUAGE FlexibleInstances #-}

module ShouldFail where

class Foo a where
  op :: a -> a

instance {-# OVERLAPPABLE #-} Foo a => Foo [a]
instance {-# OVERLAPPING #-} Foo [Int]

foo :: Foo a => [a] -> [a]
foo x = op x
-- Correct instance depends on instantiation of 'a'


{-# LANGUAGE RankNTypes, KindSignatures #-}

module ShouldFail where

-- There should be a kind error, when unifying (a b) against (c d)

foo = [ undefined :: forall a b. a b,
        undefined :: forall (c:: (* -> *) -> *) (d :: * -> *). c d ]


{-# LANGUAGE MagicHash #-}

module ShouldFail where

-- The danger here is getting a type like
--      f :: forall (a::??). a -> Bool
-- and hence allowing the bogus calls that follow

f x = True

h v = f 3#
-- h v = (f 3#, f 4.3#, f True)


{-# LANGUAGE RankNTypes #-}

module ShouldFail where

-- With the new typechecker (GHC 7.1), these now all pass

f1 :: (forall a. Eq a => [a]) -> Bool
f1 xs@(x:_)  = x

f2 :: (forall a. Eq a => [a]) -> Bool
f2 [x] = x

f3 :: (forall a. Eq a => [a]) -> Bool
f3 (x:[]) = x


{-# LANGUAGE DatatypeContexts, ExistentialQuantification #-}

-- Tests the "stupid theta" in pattern-matching
-- when there's an existential as well

module ShouldCompile  where

data (Show a) => Obs a = forall b. LiftObs a b

f :: Obs a -> String    -- Needs a (Show a) context
f (LiftObs _ _) = "yes"


{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
{-# LANGUAGE RankNTypes, ExistentialQuantification #-}

-- An interesting interaction of universals and existentials, prompted by
-- http://www.haskell.org/pipermail/haskell-cafe/2004-October/007160.html
--
-- Note the nested pattern-match in runProg; tc183 checks the
-- non-nested version

-- 3 Sept 2010: with the new typechecker, this one succeeds

module Foo  where

import Control.Monad.Trans

data Bar m
  = forall t. (MonadTrans t, Monad (t m))
           => Bar (t m () -> m ()) (t m Int)

data Foo = Foo (forall m. Monad m => Bar m)

runProg :: Foo -> IO ()
runProg (Foo (Bar run op)) = run (prog op)
-- This nested match "ought" to work; because
--    runProg (Foo b) = case b of
--                          Bar run op -> run (prog op)
-- does work. But the interactions with GADTs and
-- desugaring defeated me, and I removed (in GHC 6.4) the ability
-- to instantiate functions on the left

prog :: (MonadTrans t, Monad (t IO)) => a -> t IO ()
prog x = error "urk"


module ShouldFail where

foo :: IO (Num a => a -> a)
foo = error "urk"

-- baz :: (Num a => a -> a) -> Int
-- baz = error "urk"


-- Ambiguity error reporting

module Main where

import Data.Array.MArray (thaw,freeze)
import Data.Array.Unboxed as UA (UArray,listArray)
import Data.Array.IArray as IA (Array,listArray)

main :: IO ()
main = do let sL = [1,4,6,3,2,5]
              dim = length sL
              help :: [FlatVector]
              help = [listFlatVector (1,s) [0|i<-[1..s]]|s<-sL]
              tmp :: Vector FlatVector
              tmp = listVector (1,dim) help
          v <- thaw tmp
          return ()

type FlatVector  = UArray Int Double

listFlatVector :: (Int,Int) -> [Double] -> FlatVector
listFlatVector = UA.listArray

type Vector a = Array Int a

listVector :: (Int,Int) -> [a] -> Vector a
listVector = IA.listArray


-- Both blocks are illegal Haskell 98, because of the un-saturated
-- type synonym, but (rather obscurely) at one point (GHC 6.3), we
-- acceped 'blah', but rejected 'blah1'

module ShouldFail where

data T = T

-- This was erroneously accepted
type Foo a = String -> Maybe a
type Bar m = m Int
blah = undefined :: Bar Foo

type Foo1 a = Maybe a
type Bar1 m = m Int
blah1 = undefined :: Bar1 Foo1


{-# LANGUAGE ImplicitParams #-}

-- The defn of foo should be rejected; it's monomorphic, but
-- the implicit parameter escapes

module Foo where

baz = let ?x = 5 in print foo

foo = woggle 3

woggle :: (?x :: Int) => Int -> Int
woggle y = ?x + y


-- Error message in monomorphic case

module ShouldFail where

  f = (*)       -- Monomorphic
  g :: Num b => b -> b
  g x = f x x


-- Fails with a kind error.
-- The current error message was rather horrible (trac bug #312):
--
--    Kind error: Expecting kind `k_a1JA -> k_a1JE -> k_a1JI -> *',
--                but `DUnit t' has kind `k_a1JA -> k_a1JE -> *'
--
-- as we couldn't tidy kinds, because they didn't have OccNames.
-- This test recalls the bad error message.

module ShouldFail where

newtype Object f' f t o1 o2  = Object (f' t o1 -> f t o2)
type DUnit t o1 o2       = ()

type T f g t o1 o2  = Either (f t o1 o2) (g t o1 o2)

type LiftObject t f' f         = T (Object f' f t) (DUnit t)


{-# LANGUAGE UndecidableInstances, FlexibleInstances, TypeOperators,
             MultiParamTypeClasses, FunctionalDependencies, DatatypeContexts #-}

-- This one crashed GHC 6.3 due to an error in TcSimplify.add_ors

module Foo where

data Zero   = Zero deriving Show
data One    = One deriving Show
infixl 9 :@
data (Number a, Digit b) => a :@ b = a :@ b deriving Show

class Digit a
instance Digit Zero
instance Digit One

class Number a
instance Number Zero
instance Number One
instance (Number a, Digit b) => Number (a :@ b)

--- Pretty printing of numbers ---
class PrettyNum a where
    prettyNum   :: a -> String

instance PrettyNum Zero where
    prettyNum _ = "0"

instance PrettyNum One where
    prettyNum _ = "1"

instance (Number a, Digit b, PrettyNum a, PrettyNum b)
      => PrettyNum (a :@ b) where
    prettyNum ~(a:@b)
                = prettyNum a ++ prettyNum b

--- Digit addition ---
class (Number a, Digit b, Number c)
   => AddDigit a b c | a b -> c where
    addDigit    :: a -> b -> c
    addDigit    = undefined

instance Number a => AddDigit a Zero a
instance AddDigit Zero One One
instance AddDigit One One (One:@Zero)
instance Number a => AddDigit (a:@Zero) One (a:@One)
instance AddDigit a One a'
      => AddDigit (a:@One) One (a':@Zero)

--- Addition ---
class (Number a, Number b, Number c)
   => Add a b c | a b -> c where
    add     :: a -> b -> c
    add     = undefined

instance Number n => Add n Zero n
instance Add Zero One One
instance Add One One (One:@One)
instance Number n
      => Add (n:@Zero) One (n:@One)
instance AddDigit n One r'
      => Add (n:@One) One (r':@Zero)
instance (Number n1, Digit d1, Number n2, Digit n2
         ,Add n1 n2 nr', AddDigit (d1:@nr') d2 r)
      => Add (n1:@d1) (n2:@d2) r

foo = show $ add (One:@Zero) (One:@One)

-- Add (One:@Zero) (One:@One) c, Show c
-- ==> Number One, Digit Zero, Number One, Digit One
--     Add One One nr', AddDigit (Zero:@nr') One c, Show c
--
-- ==> Add One One nr', AddDigit (Zero:@nr') One c, Show c
--
-- ==> Add One One (One:@One), AddDigit (Zero:@(One:@One)) One c, Show c
--
-- ==> AddDigit (Zero:@(One:@One)) One c, Show c


-- Class used as a type, recursively

module ShouldFail where

class XML a where toXML :: a -> XML


-- A missing kind check made GHC 6.4 crash on this one

module ShouldFail where

class Foo f where
        baa :: f a -> f

instance Foo Maybe where
        baa z = z


-- Kind error message test

module ShouldFail where

type IntMap a = [a]

data SymDict a = SymDict {idcounter:: Int, itot::IntMap a}

data SymTable = SymTable {  dict::SymDict   }


{-# LANGUAGE DatatypeContexts #-}
-- Test the stupid context on newtypes
-- (GHC 6.4 dropped it on the floor by mistake)
module ShouldFail where

newtype Floating a => Test a = Test [a]

x = Test [False, True]


{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies,
             FlexibleInstances, UndecidableInstances #-}
-- UndecidableInstances because (L a b) is no smaller than (C a b)

-- This one shows up another rather subtle functional-dependecy
-- case.  The error is:
--
--    Could not deduce (C a b') from the context (C a b)
--      arising from the superclasses of an instance declaration at Foo.hs:8:0
--    Probable fix: add (C a b') to the instance declaration superclass context
--    In the instance declaration for `C (Maybe a) a'
--
-- Since L is a superclass of the (sought) constraint (C a b'), you might
-- think that we'd generate the superclasses (L a b') and (L a b), and now
-- the fundep will force b=b'.  But GHC is very cautious about generating
-- superclasses when doing context reduction for instance declarations,
-- because of the danger of superclass loops.
--
-- So, today, this program fails.  It's trivial to fix by adding a fundep for C
--      class (G a, L a b) => C a b | a -> b

-- Note: Sept 08: when fixing Trac #1470, tc138 started working!
-- This test is a very strange one (fundeps, undecidable instances),
-- so I'm just marking it as "should-succeed".  It's not very clear to
-- me what the "right" answer should be; when we have the type equality
-- story more worked out we might want to think about that.

module ShouldFail where

class G a
class L a b | a -> b
class (G a, L a b) => C a b

instance C a b' => G (Maybe a)
instance C a b  => C (Maybe a) a
instance L (Maybe a) a


-- Should be rejected by Haskell 98

module Foo  where

type Foo = Double
instance Bounded Foo


-- GHC 6.4 gave pretty horrible error messages
-- for some of these examples
-- c.f. SourceForge [ ghc-Bugs-1231273 ] confusing error

module ShouldFail where

f :: Int -> Int
f x = x

bar = f 3 9

rot xs = 3 `f` 4

bot xs = map (3 `f`) xs

t = ((\Just x -> x) :: Maybe a -> a) (Just 1)

g :: Int -> Int
g x y = True


{-# LANGUAGE MultiParamTypeClasses #-}

-- Tests top-level ambiguity resolution
-- This made a post-6.4 GHC fall over in TcSimplify

module ShouldFail where

class Foo a
instance Foo (a -> b)

foo :: Foo a => a -> ()
foo = undefined

class Bar a r
-- The same happens if we use fundeps:
-- class Bar a r | r -> a

bar :: Bar a r => r -> ()
bar = undefined

test = foo bar


{-# LANGUAGE UndecidableInstances, FlexibleInstances,
             MultiParamTypeClasses, FunctionalDependencies #-}

module Foo  where

data Z          = Z
data S a        = S a

class MinMax a b c d | a b -> c d, a c d -> b, b c d -> a
instance MinMax Z Z Z Z -- (a)
instance MinMax a Z Z a -- (b)   -- L1: wrongly flagged as error src.
instance MinMax Z b Z b -- (c)
instance MinMax a b c d => MinMax (S a) (S b) (S c) (S d)
                        -- (d)

class Extend a b  where extend :: a -> b ->  b
instance Extend Z b where  Z `extend` b = b
instance MinMax a b _c b  => Extend a b where
        _a `extend` b = b

t       :: MinMax a b _c d => a -> b -> d
t _ _   = (undefined :: d)

n0      = Z
n1      = S n0

t1 = n1 `t` n0      -- L2

t2 = n1 `extend` n0 -- L3: uncommenting just this line produces
                    --     an error message pointing at L1 and L2
                    --     with no mention of the real culprit, L3.

-- t1   :: S Z      -- L4: uncommenting this and L3 produces an
                    --  error message rightly pointing at L2 and L3.

{-  n0 :: Z;  n1 :: S Z

Call of extend gives wanted: Extend (S Z) Z
Use instance =>  MinMax (S Z) Z gamma Z
FD on (b) => gamma ~ Z, Z ~ S Z
             =>  MinMax (S Z) Z Z Z
FD on (a), 3rd fundep => Z ~ S Z
      (b) again (sadly)   Z ~ S Z

-}
{-

Here's what is happening.

Lacking the type signature t1 :: S Z, we get

  n0 :: Z
  n1 :: S v1
  t1 :: d1      with constraint ([L2] MinMax (S v1) Z c1 d1)
  t2 :: Z       with constraint ([L3] Extend (S v1) Z)

     [L2] MinMax (S v1) Z c1 d1, [L3] Extend (S v1) Z
--->    <by instance for Extend a b>
     [L2] MinMax (S v1) Z c1 d1, [L3] MinMax (S v1) Z c2 Z}
--->    <combining these two constraints using (a b -> c d)
     [L2] MinMax (S v1) Z c1 Z, [L3] MinMax (S v1) Z c1 Z}

Now there are the two constraints are indistinguishable,
and both give rise to the same error:

--->    <combining first with [L1] instance MinMax a Z Z a>
     c1=Z, Z=S v1       ERROR

In either case, the error points to L1.

A different sequence leads to a different error:

     [L2] MinMax (S v1) Z c1 d1, [L3] Extend (S v1) Z
--->    <by instance for Extend a b>
     [L2] MinMax (S v1) Z c1 d1, [L3] MinMax (S v1) Z c2 Z}
--->    <combining first with [L1] instance MinMax a Z Z a>
     [L2] MinMax (S v1) Z Z (S2 v1), [L3] MinMax (S v1) Z c2 Z}

Now combining the two constraints gives rise to the error, but
this time pointing to L2,L3.

I can't explain exactly why adding the type signature for t1
changes the order.

Hmm.  Perhaps a good improvement strategy would be:
  - first do improvement against the instance declarations
  - and only then do pairwise improvement between constraints

I've implemented that, and indeed it improves the result.
Instead of:

  Foo.hs:1:0:
    Couldn't match `S Z' against `Z'
      Expected type: S Z
      Inferred type: Z
    When using functional dependencies to combine
      MinMax a Z Z a, arising from the instance declaration at Foo.hs:10:0
      MinMax (S Z) Z _c d, arising from use of `t' at Foo.hs:25:8-10

we get

  Foo.hs:1:0:
    Couldn't match `S Z' against `Z'
      Expected type: S Z
      Inferred type: Z
    When using functional dependencies to combine
      MinMax a Z Z a, arising from the instance declaration at Foo.hs:10:0
      MinMax (S Z) Z _c Z, arising from use of `extend' at Foo.hs:27:8-15

And this error in t2 is perfectly correct.  You get it even if you comment
out the entire definition of t1.
-}


-- Both sets should fail in Haskell98

{-# LANGUAGE Haskell98 #-}

module ShouldCompile where

  f1 :: Eq a => a -> Bool
  f1 x = (x == x) || g1 True || g1 "Yes"

  g1 :: Ord a => a -> Bool
  g1 y = (y <= y) || f1 True

---------

  f2 :: Eq a => a -> Bool
  f2 x = (x == x) || g2 True || g2 "Yes"

  g2 y = (y <= y) || f2 True


{-# LANGUAGE RankNTypes, ScopedTypeVariables #-}

-- This fails, because the type in the pattern doesn't exactly match
-- the context type.  We don't do subsumption in patterns any more.

-- GHC 7.0: now we do again

module Foo where

foo :: (forall c. c -> c) -> [Char]
foo (f :: forall a. [a] -> [a]) = f undefined


module Foo1 where

-- Variant: class used as data
class SClass a where
 sFun :: a -> SData a

data SData a = SCon (SClass a)


module Foo1 where

-- Variant: ill-kinded.
class XClass a where
 xFun :: a -> XData

data XData = XCon XClass


-- This one caused a panic in GHC 6.4

module Foo1 where

data List elem = Cons elem List | Nil

t1 :: List
t1 = Cons 1 Nil


{-# LANGUAGE ConstrainedClassMethods #-}

module Main where

class C a where
  op :: (Show a, Show b) => a -> b -> String
        -- This class op adds a constraint on 'a'

        -- In GHC 7.0 this is fine, and it's a royal
        -- pain to reject it when in H98 mode, so
        -- I'm just allowing it

instance C Int where
  op x y = show x ++ " " ++ show y

main = print (op (1::Int) 2)


module ShouldFail where

-- !!! constraining the type variable in a class head is illegal
-- Simpler version of tcfail149
class Foo a where
  op :: Eq a => a -> a


{-# LANGUAGE DatatypeContexts, MultiParamTypeClasses #-}
module ShouldFail where

class (Show a, Eq a, Monad m) => Name m a where
    hashName :: a -> m Int
    newName :: m a

data Name a => Exp a = MkExp a
-- The kind error should be reported here
-- GHC 6.4 reported an error with the class decl


{-# LANGUAGE ExistentialQuantification #-}

-- This test made Hugs fail (Oct 05) because the constraint
-- from the 'toInteger' call escaped from the pattern match

module ShouldFail where

data T = forall a. C a

test (C x) = toInteger x


-- Killed a test compiler, so I thought it was worth including

module ShouldFail where

f :: a -> [a]
f x = g x
    where
      g y = if y  then [] else [y]


{-# LANGUAGE MultiParamTypeClasses #-}

module ShouldFail where

data T a = MkT

class C a b where
  op :: T a -> T b -> Bool

-- Repeated type variable in an instance constraint
-- should require UndecidableInstances
instance C a a => Eq (T a) where
  (==) = op


{-# LANGUAGE GADTs #-}

-- Data type returns the wrong type

module ShouldFail where

data T a where
     P :: L1 -> L2

data L1 = L1
data L2 = L2


{-# LANGUAGE ExistentialQuantification #-}

-- Illegal existential context on a newtype

module ShouldFail where

newtype Foo = forall a . Foo a


{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies,
             FlexibleInstances #-}
-- NB: *no* UndecidableInstances

-- This one (due to Oleg) made 6.4.1 go into a loop in the typechecker,
-- despite the lack of UndecidableInstances
--
-- The example corresponds to a type function (realized as a class E
-- with functional dependencies) in the context of an instance.
-- The function in question is
--
--      class E m a b | m a -> b
--      instance E m (() -> ()) (m ())
--
-- We see that the result of the function, "m ()" is smaller (in the
-- number of constructors) that the functions' arguments, "m" and
-- "() -> ()" together. Plus any type variable free in the result is also
-- free in at least one of the arguments. And yet it loops.
module ShouldFail where

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

instance Foo m () where
    foo _ _ = True

instance (E m a b, Foo m b) => Foo m (a->()) where
    foo m f = undefined

class E m a b | m a -> b where
    tr :: m c -> a -> b

-- There is only one instance of the class with functional dependencies
instance E m (() -> ()) (m ()) where
    tr x = undefined

-- GHC(i) loops

test = foo (\f -> (f ()) :: ()) (\f -> (f ()) :: ())


{-# LANGUAGE ExplicitForAll #-}

-- This one actually crashed in 6.4.1
-- There's a kind error in the signature for bar,
-- and we were recovering, and then crashing when we found
-- a scoped type variable not in scope

 data Val v sm = Val
 foo :: forall v sm. Val v sm
 foo = undefined
   where foo1 :: Val v sm
         foo1 = bar
 -- Correct type signature: bar :: forall v sm. Val v sm
 bar :: forall v. Val v
 bar = undefined foo


{-# LANGUAGE UnboxedTuples #-}

module ShouldFail where

h :: Int -> (# Int, Int #)
h x = (# x,x #)

foo x = case h x of
          ~(# p, q #) -> p


-- Kind error message

module ShouldFail where

data T k = T (k Int)

g :: T Int
g x = x


-- Kind error message

module ShouldFail where

f :: [Maybe]
f x = x


-- Kind error message should not contain bangs

module ShouldFail where

import Foreign.ForeignPtr

data Foo = Foo {-# UNPACK #-} !(ForeignPtr)


{-# LANGUAGE MagicHash #-}

-- Tests tagToEnum# hacks

module ShouldFail where

import GHC.Base

-- Test 1: Polymorphic
f :: a
f = tagToEnum# 0#

-- Test 2: Int value (not an Enumeration TyCon)
class Unboxable value where
    readUnboxable  :: Int -> value
instance Unboxable Int where
    readUnboxable (I# value#) =  tagToEnum# value#


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

module ShouldFail where

import Control.Concurrent

-- Attempt to put a polymorphic value in an MVar
-- Fails, but the error message is worth keeping an eye on
--
-- Actually (Dec 06) it succeeds now
--
-- In GHC 7.0 it fails again! (and rightly so)
--
-- With the Visible Type Application patch, this succeeds again.
--
-- Sept 16: fails again as it should

foo = do var <- newEmptyMVar :: IO (MVar (forall a. Show a => a -> String))
         putMVar var (show :: forall b. Show b => b -> String)


-- Without -XScopedTypeVariables, this should fail

module ShouldFail where

destroy :: (forall a. (a -> Maybe (b,a)) -> a -> c) -> [b] -> c
destroy = error "urk"


{-# LANGUAGE GADTs #-}
{-# OPTIONS_GHC -fwarn-incomplete-patterns #-}
-- Test inspired by trac #366
-- The C2 case is impossible due to the types

module ShouldCompile where

data T a where
    C1 :: T Char
    C2 :: T Float

inaccessible :: T Char -> Char
inaccessible C1 = ' '
inaccessible C2 = ' '


-- Test trac #719 (shouldn't give the entire do block in the error message)

module ShouldFail where

foo = do
          putChar
          putChar 'a'
          putChar 'a'
          putChar 'a'
          putChar 'a'
          putChar 'a'
          putChar 'a'
          putChar 'a'
          putChar 'a'
          putChar 'a'
          putChar 'a'
          putChar 'a'
          putChar 'a'
          putChar 'a'
          putChar 'a'
          putChar 'a'
          putChar 'a'
          putChar 'a'
          putChar 'a'
          putChar 'a'
          putChar 'a'
          putChar 'a'
          putChar 'a'
          putChar 'a'
          putChar 'a'
          putChar 'a'
          putChar 'a'
          putChar 'a'
          putChar 'a'
          putChar 'a'
          putChar 'a'
          putChar 'a'
          putChar 'a'
          putChar 'a'
          putChar 'a'
          putChar 'a'
          putChar 'a'
          putChar 'a'
          putChar 'a'
          putChar 'a'
          putChar 'a'
          putChar 'a'
          putChar 'a'
          putChar 'a'
          putChar 'a'
          putChar 'a'
          putChar 'a'
          putChar 'a'
          putChar 'a'
          putChar 'a'
          putChar 'a'
          putChar 'a'
          putChar 'a'
          putChar 'a'
          putChar 'a'
          putChar 'a'
          putChar 'a'
          putChar 'a'
          putChar 'a'


-- Trac #958

module ShoulFail where

data Succ a = S a       -- NB: deriving Show omitted
data Seq a = Cons a (Seq (Succ a)) | Nil deriving Show


{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies #-}

module ShouldFail where

class C a b | a -> b

instance C [p] [q]
        -- Coverage condition fails


module ShouldFail where

-- This one made GHC fall over on implication constraints
-- Silly, but one more test does no harm

import Text.Printf

phex :: a -> b
phex x = printf "0x%x" x


{-# LANGUAGE GADTs #-}

-- This one made GHC 6.6 give the very unhelpful error
-- Foo8.hs:11:10:
--    Couldn't match kind `?' against `* -> * -> *'
--    When matching the kinds of `t :: ?' and `t1 :: * -> * -> *'
--      Expected type: t1
--      Inferred type: t
--    In the pattern: Nil

module ShouldFail where

data PatchSeq p a b where
    Nil   :: PatchSeq p a a
    U  :: p a b -> PatchSeq p a b
    (:-)  :: PatchSeq p a b -> PatchSeq p b c -> PatchSeq p a c

-- is_normal :: PatchSeq p a b -> Bool
is_normal Nil = True
is_normal (U _) = True
is_normal (U _ :- _) = True
is_normal _ = False


module ShouldFail where

newtype (f <.> g) a = Compose (f (g a))


{-# OPTIONS -XImpredicativeTypes #-}

module Foo where

data Capture a = Base a
               | Capture (Capture (forall x . x -> a))

g :: Capture (forall a . a ->  a)
g = Base id  -- Fails; need a rigid signature on 'id'
    -- Actually, succeeds now, with visible type application
    -- Disagree: should not succeed because it instantiates
    --           Base with a forall type

-- This function should definitely be rejected, with or without type signature

h1 = Capture g

h2 :: Capture b
h2 = Capture g


-- Crashed GHC 6.6!
-- Trac #1153

module ShouldFail where

eval :: Int -> String -> String ->  String
eval 0 root actual = evalRHS 0 root actual

evalRHS :: Int -> a
evalRHS 0 root actual =  eval 0 root actual


{-# LANGUAGE GADTs #-}

-- Newtype in GADT syntax

module ShouldFail where

newtype Bug a where Bug :: a -> Maybe a


module ShouldFail where

-- See Trac #1176
-- This is really a pretty-printer test, not a typechecker test
--
-- Before ghc-7.2 the error messages looked like this (notice the wrong
-- indentation):

{-
tcfail177.hs:9:12:
    Couldn't match expected type `Bool' with actual type `Int'
    In the return type of a call of `foo'
    In the expression:
      foo
        ["One........" ~?= "1", "Two" ~?= "2", "Thre........." ~?= "3",
     "Four" ~?= "4", ....]
    In an equation for `allTest1':
        allTest1
          = foo
              ["One........" ~?= "1", "Two" ~?= "2", "Thre........." ~?= "3",
         ....]

tcfail177.hs:18:12:
    Couldn't match expected type `Bool' with actual type `Int'
    In the return type of a call of `foo'
    In the expression:
      foo
        ["One........" ~?= "1", "Two.................." ~?= "2",
       "Thre........." ~?= "3", "Four" ~?= "4", ....]
    In an equation for `allTest2':
        allTest2
          = foo
              ["One........" ~?= "1", "Two.................." ~?= "2",
             "Thre........." ~?= "3", ....]
-}

allTest1 :: Bool
allTest1 = foo
           ["One........" ~?= "1"
           ,"Two" ~?= "2"
           ,"Thre........." ~?= "3"
           ,"Four" ~?= "4"
           ,"Five" ~?= "5"
           ]

allTest2 :: Bool
allTest2 = foo
           ["One........" ~?= "1"
           ,"Two.................." ~?= "2"
           ,"Thre........." ~?= "3"
           ,"Four" ~?= "4"
           ,"Five" ~?= "5"
           ]

(~?=) :: a -> a -> Bool
(~?=) = error "urk"

foo :: a -> Int
foo x = 0


-- See Trac #1221

module ShouldFail where

a :: Num a => (Bool -> [a]) -> [a]
a x = x True ++ [1]

y :: b -> ()
y = const ()

-- Typechecks ok
b = a (const [2])

-- This one had an uninformative error message
c = a y

-- More informative
d = a ()


{-# LANGUAGE ExistentialQuantification #-}

-- Examples from Doaitse Swierstra and Brandon Moore
-- GHC users mailing list, April 07, title "Release plans"

-- This one should fail, but Hugs passes it

module ShouldFail where

data T s = forall x. T (s -> (x -> s) -> (x, s, Int))

run :: T s -> Int
run ts  = case ts of
             T g -> let (x,_, b) =  g x id
                    in b


-- Showed up a bug in bodySplitTyConApp

module ShouldFail where

p :: f b
p = error "urk"

g x = case p of
        True -> ()


-- GHC 6.7 at one point said wog's type was:
--
--    wog :: forall t e (m :: * -> *).
--           (Monad GHC.Prim.Any1, Monad m) =>
--           t -> Something (m Bool) e
--
-- The stupid 'GHC.Prim.Any1' arose because of type ambiguity
-- which should be reported, and wasn't.

module ShouldFail where

data Something d e = Something{ bar::  d, initializer::e   }

foo :: (Monad m) => Something (m Bool) n
foo = undefined

wog x = foo{bar = return True}


module Foo where

import qualified Prelude
import Prelude hiding( Maybe )

data Maybe a = Foo

f :: Prelude.Maybe a -> Int
f Foo = 3


module ShouldCompile where

newtype Swizzle = MkSwizzle (forall a. Ord a => [a] -> [a])


{-# OPTIONS_GHC -XScopedTypeVariables #-}
-- We don't actually want scoped type variables, but this flag makes the
-- forall be recognised by the parser

module ShouldCompile where

newtype Swizzle = MkSwizzle (forall a. Ord a => [a] -> [a])


-- See Trac #1606

module ShouldFail where

f :: Int -> Int -> Bool -> Bool -> Int -> Int
f a b = \ x y -> let { y1 = y; y2 = y1; y3 = y2; y4 = y3; y5 = y4;
                       y6 = y5; y7 = y6 } in x


-- Trac #1814

module ShouldFail where

import Tcfail186_Help

foo = f "hoo"


module Tcfail186_Help where

type PhantomSyn a  = Int

f = (\_ -> 2) :: PhantomSyn a -> Int


-- Trac #1806

module ShouldFail where

data Foo = (:::)

foo (x ::: y) = ()


{-# LANGUAGE RankNTypes, KindSignatures #-}
{-# OPTIONS_GHC -Werror #-}

-- Trac #959

module ShouldFail where

import Data.Kind (Type)

data D (f :: (Type -> Type) -> Type -> Type)
       (af :: Type -> Type)
       (ax :: Type) =
  D (af (f af ax))

data CList (f :: (Type -> Type) -> Type -> Type) (a :: Type) =
  RCons a (CList (D f) a)

type CycleList a = forall f. CList f a

chead :: CycleList a -> a
chead ys = case ys of (RCons x xs) -> x


-- Checks that the correct type is used checking the using clause of
-- the group when a by clause is present

{-# OPTIONS_GHC -XTransformListComp #-}

module ShouldFail where

foo = [ length x
      | x <- [1..10]
      , then group by x using take 2
      ]


-- Checks that the ordering constraint on the groupWith function is respected

{-# OPTIONS_GHC -XTransformListComp #-}

module ShouldFail where

import GHC.Exts (groupWith)

data Unorderable = Gnorf | Pinky | Brain

foo = [ ()
      | x <- [Gnorf, Brain]
      , then group by x using groupWith
      ]


-- Checks that the correct type is used checking the using clause of the group

{-# OPTIONS_GHC -XTransformListComp #-}

module ShouldFail where

data Unorderable = Gnorf | Pinky | Brain

foo = [ ()
      | x <- [Gnorf, Brain]
      , then group using take 5
      ]


-- Checks that the correct type is used checking the using clause of the transform

{-# OPTIONS_GHC -XTransformListComp #-}

module ShouldFail where

import Data.List(inits)

z :: [Int]
z = [x | x <- [3, 2, 1], then inits]


{-# LANGUAGE RankNTypes, GADTs #-}

module ShouldFail where

data Foo a where
  Foo :: Int -> Foo (forall a. a)


{-# LANGUAGE RankNTypes #-}

module ShouldFail where

bar :: Num (forall a. a) => Int -> Int
bar = error "urk"


{-# LANGUAGE RankNTypes #-}

module ShouldFail where

foo :: [forall a. a] -> Int
foo = error "urk"


{-# LANGUAGE ScopedTypeVariables #-}

module ShouldFail where

f3 :: forall a. [a] -> [a]
Just f3 = Just (\(x:xs) -> xs ++ [ x :: a ])   -- Not OK!
        -- The type variable does not scope in a pattern binding


-- trac #2179

module Main where

main = "hi"


{-# LANGUAGE MagicHash #-}

module ShouldFail where

f = let x = ( 1#, 'c' ) in x


{-# LANGUAGE RankNTypes #-}

-- Claus reported by email that
-- GHCi, version 6.9.20080217 loops on this program
-- http://www.haskell.org/pipermail/cvs-ghc/2008-June/043173.html
-- So I'm adding it to the test suite so that we'll see it if it happens again

module Foo where

data HsDoc id
  = DocEmpty
  | DocParagraph (HsDoc id)

gfoldl' :: (forall a b . c (a -> b) -> a -> c b) -> (forall g . g -> c g) -> a -> c a
gfoldl' k z hsDoc = case hsDoc of
                          DocEmpty                  -> z DocEmpty
--                        (DocParagraph hsDoc)      -> z DocParagraph `k` hsDoc


-- trac #2307
-- This was accepted due to a bug in GHC

{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies,
             UndecidableInstances, IncoherentInstances,
             FlexibleInstances #-}

module Foo where

class C a b c | b -> c
instance C Bool Int Float
instance C Char Int Double


-- trac #2806

{-# LANGUAGE MagicHash, UnboxedTuples, BangPatterns #-}
{-# OPTIONS_GHC -Wunbanged-strict-patterns #-}

module Foo where

import GHC.Base

pass1 = 'a'
    where !x = 5#

pass2 = 'a'
    where !(I# x) = 5

pass3 = 'a'
    where !(b, I# x) = (True, 5)

pass4 = 'a'
    where !(# b, I# x #) = (# True, 5 #)

pass5 = 'a'
    where !(# b, x #) = (# True, 5# #)

fail1 = 'a'
    where x = 5#

fail2 = 'a'
    where (I# x) = 5

fail3 = 'a'
    where (b, I# x) = (True, 5)

fail4 = 'a'
    where (# b, I# x #) = (# True, 5 #)

fail5 = 'a'
    where (# b, x #) = (# True, 5# #)

fail6 = 'a'
    where (I# !x) = 5

fail7 = 'a'
    where (b, !(I# x)) = (True, 5)

fail8 = 'a'
    where (# b, !(I# x) #) = (# True, 5 #)

fail9 = 'a'
    where (# b, !x #) = (# True, 5# #)
{-
-- Now in tcfail203a.hs, because it's an error
fail10 = 'a'
    where !(b, ~(c, (I# x))) = (True, (False, 5))
-}


-- trac #2806

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

module Foo where

import GHC.Base

fail10 = 'a'
    where !(b, ~(c, (I# x))) = (True, (False, 5))


{-# OPTIONS_GHC -Wall #-}
{-# OPTIONS_GHC -Werror #-}

-- Trac #3261

module Foo where

foo :: Int
foo = ceiling 6.3


module Fail where

f x = foldl (+) [1 .. x] 'a'


{-# LANGUAGE TupleSections, UnboxedTuples #-}
module ShouldCompile where

a :: Bool -> (Int, Bool)
a = ( , True)

b :: Int -> Bool -> (Int, Bool)
b = (1, )

c :: a -> (a, Bool)
c = (True || False, )

d :: Bool -> (#Int, Bool#)
d = (# , True#)

e :: Int -> Bool -> (#Int, Bool#)
e = (#1, #)

f :: a -> (#a, Bool#)
f = (#True || False, #)


module Foo where

f :: Int -> [Int] -> [Int]
-- Want an error message that says 'take' is applied to too many args
f x = take x []

g :: [Int]
-- Want an error message that says 'take' is applied to too few args
g = take 3


module Ctx where

f :: (Monad m, Eq a) => a -> m a -> Bool
f x y = (return x == y)


module FancyContextsWithoutExtension1 where

type Showish = Show

f :: (Showish a) => a -> a
f = undefined


module TcFail209a where

g :: ((Show a, Num a), Eq a) => a -> a
g = undefined


{-# LANGUAGE TypeFamilies #-}
module FancyContextsWithoutExtension2 where

type family Indexed a :: * -> Constraint
type instance Indexed Int = Show
type instance Indexed Bool = Num

f :: (Indexed Int a) => a -> a
f = undefined


{-# LANGUAGE ImplicitParams, FlexibleContexts #-}

module ShouldFail where

class (?imp :: Int) => D t where
    methodD :: t -> t

instance (?imp :: Int) => D Int where
    methodD x = x + ?imp

test :: D Int => Int -- Requires FlexibleContexts
test = methodD ?imp

-- Should get reasonable error about unbound ?imp
use :: IO ()
use = print test


{-# LANGUAGE ConstraintKinds, MagicHash #-}
module ShouldFail where

import GHC.Exts

-- If we turn on ConstraintKinds the typing rule for
-- tuple types is generalised. This test checks that
-- we get a reasonable error for unreasonable tuples.

f :: (Maybe, Either Int)
f = (Just 1, Left 1)

g :: (Int#, Int#)
g = (1#, 2#)


{-# LANGUAGE TypeFamilies, ConstraintKinds #-}
module ShouldFail where

import GHC.Exts( Constraint )

type family F a :: Constraint

class (F a) => C a where


{-# LANGUAGE TypeFamilies, ConstraintKinds #-}
module ShouldFail where

import GHC.Exts( Constraint )

type family F a :: Constraint

class C a where
instance (F a) => C [a] where


{-# LANGUAGE ImplicitParams, MagicHash #-}

module ShouldFail where

import GHC.Exts

-- As of GHC 7.4, we don't allow unlifted types in ImplicitParms
foo :: (?x :: Int#) => Int
foo = I# ?x


{-# LANGUAGE ConstraintKinds, MultiParamTypeClasses, UndecidableInstances #-}
module TcFail where

class cls (A cls) => A cls c where


-- Test we can't hide cycles with type synonyms
{-# LANGUAGE ConstraintKinds, MultiParamTypeClasses, UndecidableInstances #-}
module TcFail where

type Aish = A

class Aish a => A a where


{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-}

module Tcfail218 where

class C a b where foo :: (a,b)

instance                    C [Int] Bool where foo = undefined
instance                    C [a]   b   where foo = undefined
instance {-# INCOHERENT #-} C a     Int where foo = undefined

x :: ([a],Bool)
-- Needs C [a] b.
-- Should fail, as a more specific, unifying but not matching
-- non-incoherent instance exists, namely C [Int] Bool
x = foo

-- Needs C [a] Int.
-- Should succeed, because two instances match, but one is incoherent
y :: ([a],Int)
y = foo


{-# LANGUAGE FlexibleInstances, UndecidableInstances #-}
module ShouldFail where

class Class1 a
class Class1 a => Class2 a
class Class2 a => Class3 a

-- This was wrongfully accepted by ghc-7.0 to ghc-7.10.
-- It is missing a `Class1 a` constraint.
instance Class3 a => Class2 a


module Foo where

import Prelude hiding( Int )

data Int = Int

f :: Int
f = 3


{-# LANGUAGE MultiWayIf #-}

module TcMultiWayIfFail where

x1 = if | True      -> 1 :: Int
        | False     -> "2"
        | otherwise -> [3 :: Int]


module NoNullaryTC where

class A where
  f :: a -> a


{-# LANGUAGE MultiParamTypeClasses #-}
module TcNullaryTCFail where

class A
instance A
instance A


{-# LANGUAGE StaticPointers   #-}

module StaticPointersFail01 where

import GHC.StaticPtr

f0 :: StaticPtr Int
f0 = static g

g :: Int -> Int
g = id


{-# LANGUAGE StaticPointers     #-}
{-# LANGUAGE ImpredicativeTypes #-}

module StaticPointersFail02 where

import GHC.StaticPtr

f1 :: StaticPtr ((forall a . a -> a) -> b)
f1 = static (undefined :: (forall a . a -> a) -> b)

f2 :: StaticPtr (Monad m => a -> m a)
f2 = static return


{-# LANGUAGE StaticPointers     #-}

module StaticPointersFail03 where

import GHC.StaticPtr
import Data.Typeable

f1 :: (Typeable a, Typeable m, Monad m) => a -> m a
f1 = deRefStaticPtr (static return)


{-# LANGUAGE TypeApplications, RankNTypes, PolyKinds #-}

module VtaFail1 where

pairup_nosig x y = (x, y)

answer_nosig = pairup_nosig @Int @Bool 5 True

addOne :: Num a => a -> a
addOne x = x + 1

answer_constraint_fail = addOne @Bool 5

answer_lambda = (\x -> x) @Int 12

pair :: forall a. a -> forall b. b -> (a, b)
pair = (,)

a = pair 3 @Int @Bool True

data First (a :: * -> *) = F

first :: First a -> Int
first _ = 0

fInt = first @Int F -- should fail

data Proxy (a :: k) = P -- This expands to P (kind variable) (type variable)

foo :: Proxy a -> Int
foo _ = 0

baz = foo @Bool (P :: Proxy Int) -- should fail

data Three (a :: * -> k -> *) = T

too :: Three a -> Int
too _ = 3

threeBad = too @Maybe T
threeWorse = too @( -> ) (T :: Three Either)

plus :: Int -> Int -> Int
plus = (+)

b = plus @Int 5 7
c = plus @Rational 5 10
d = (+) @Int @Int @Int 12 14

e = show @Int @Float (read "5")
f = show (read @Int @Bool @Float "3")

silly :: a -> Bool
silly _ = False

g = silly @Maybe      -- should fail


{-# LANGUAGE Rank2Types #-}

module Main where
import Prelude hiding( succ, pred )

newtype Ch = Ch (forall a. (a -> a) -> a -> a)

apply :: Ch -> (a->a) -> a -> a
apply (Ch f) = f

instance Eq Ch where
  a == b = isZero (a - b)

instance Show Ch where
  show a = show (fromCh a)

instance Num Ch where
  fromInteger n = toCh n
  m + n = apply n succ m
  m - n = apply n pred m
  m * n = apply m (n +) zero

zero :: Ch
zero = Ch (\f z -> z)

succ :: Ch -> Ch
succ n = Ch (\f z -> f (apply n f z))

isZero :: Ch -> Bool
isZero n = apply n (const False) True

toCh :: Integer -> Ch
toCh 0 = zero
toCh n = succ (toCh (n-1))

fromCh :: Ch -> Int
fromCh n = apply n (+1) 0

pred :: Ch -> Ch
pred n = snd (apply n g (zero, zero))
 where g (m,_) = (succ m, m)

main = print ((3+4)*12 - 10::Ch)


-- Test -fdefer-type-errors
-- Should compile and run

{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# OPTIONS_GHC -fdefer-type-errors #-}

module Main where

t5624 :: IO ()
t5624 = putStr "Hello World" >> putStr ','

a :: Int
a = 'p'

data B = B
b :: B -> Bool
b x = x == x

data C a where
  C1 :: C Int
  C2 :: Bool -> C Bool

c :: C Int -> Bool
c (C2 x) = True

d :: a -> a
d = 1

e = 'p'
f = e 'q'

h :: a -> (Char,Char)
h x = (x,'c')

data T a where
  K  :: a -> T a

i a = seq (not (K a)) ()

class MyClass a where myOp :: a -> String

j = myOp 23 -- Two errors, should not combine them

-- No longer reported as an error: Trac #12466
k :: (Int ~ Bool) => Int -> Bool
k x = x

l :: IO ()
l = putChar >> putChar 'p'

main :: IO ()
main = print "No errors!"


{-# LANGUAGE UnboxedTuples, MagicHash, GADTs,
             DataKinds, PolyKinds, ExplicitForAll #-}

module Main where

import GHC.Exts

data G a where
  MkG :: G (TupleRep [LiftedRep, IntRep])

-- tests that we don't eta-expand functions that are levity-polymorphic
-- see CoreArity.mkEtaWW
foo :: forall a (b :: TYPE a). G a -> b -> b
foo MkG = (\x -> x) :: forall (c :: TYPE (TupleRep [LiftedRep, IntRep])). c -> c

data H a where
  MkH :: H IntRep

-- tests that we don't push coercions that make args levity-polymorphic
-- see Simplify.simplCast
bar :: forall (r :: RuntimeRep) (a :: TYPE r). H r -> (a -> a -> (# a, a #)) -> a -> (# a, a #)
bar MkH = (\f x -> f x x) :: forall (b :: TYPE IntRep). (b -> b -> (# b, b #)) -> b -> (# b, b #)

main :: IO ()
main = do
  let (# b, x #) = foo MkG (# True, 3# #)
  print b
  print (I# x)

  let (# y, z #) = bar MkH (#,#) 8#
  print (I# y)
  print (I# z)


{-# LANGUAGE ImplicitParams, RankNTypes #-}
{-# OPTIONS_GHC -dcore-lint #-}
module Main where

import GHC.Stack

f0 = putStrLn $ prettyCallStack ?loc
     -- should be empty

f1 :: (?loc :: CallStack) => IO ()
f1 = putStrLn $ prettyCallStack ?loc
     -- should show the location of f1's call-site

f3 :: ((?loc :: CallStack) => () -> IO ()) -> IO ()
f3 x = x ()
       -- the call-site for the functional argument should be added to the
       -- stack..

f4 :: (?loc :: CallStack) => ((?loc :: CallStack) => () -> IO ()) -> IO ()
f4 x = x ()
       -- as should the call-site for f4 itself

f5 :: (?loc1 :: CallStack) => ((?loc2 :: CallStack) => () -> IO ()) -> IO ()
f5 x = x ()
       -- we only push new call-sites onto CallStacks with the name IP name

f6 :: (?loc :: CallStack) => Int -> IO ()
f6 0 = putStrLn $ prettyCallStack ?loc
f6 n = f6 (n-1)
       -- recursive functions add a SrcLoc for each recursive call

f7 :: IO ()
f7 = putStrLn (prettyCallStack $ id (\_ -> callStack) ())
       -- shouldn't crash. See #14043.

main :: IO ()
main = do f0
          f1
          f3 (\ () -> putStrLn $ prettyCallStack ?loc)
          f4 (\ () -> putStrLn $ prettyCallStack ?loc)
          f5 (\ () -> putStrLn $ prettyCallStack ?loc3)
          f6 5
          f7


{-# LANGUAGE ImplicitParams, RankNTypes #-}

module Main where

f0 :: (?x :: Int) => () -> Int
f0 () = let ?x = 5 in ?x
   -- Should always return 5

f1 :: (?x :: Int) => () -> Int
f1 = let ?x = 5 in \() -> ?x
   -- Should always return 5

f2 () = let ?x = 5 in \() -> ?x
   -- Inferred type: Num a => () -> () -> a
   -- should always return 5

f3 :: () -> ((?x :: Int) => Int)
-- Deep skolemisation means that the local x=5 still wins
f3 = let ?x = 5 in \() -> ?x

main = let ?x = 0 in
       do { print (f0 ())
          ; print (f1 ())
          ; print (f2 () ())
          ; print (f3 ()) }


{-# LANGUAGE MonadComprehensions, ParallelListComp #-}

-- !!! Parallel list comprehensions

module Main where

f xs = [ (x,y) | x <- xs, x>3 | y <- xs ]

main = print (f [0..10])


{-# LANGUAGE BangPatterns, TypeApplications, UnboxedTuples, MagicHash,
             UnboxedSums, NoMonomorphismRestriction #-}
{-# OPTIONS_GHC -Wno-unused-binds -Wno-unbanged-strict-patterns #-}

module Main where

import Control.Exception
import GHC.Exts

-- This stress-tests the semantics of strict patterns.

ok :: a -> IO ()
ok x = do
  evaluate x
  putStrLn "Evaluation successful."

bad :: a -> IO ()
bad x = do
  r <- try @SomeException $ evaluate x
  case r of
    Left _  -> putStrLn "Exception thrown as expected."
    Right _ -> putStrLn "Exception not thrown when expected."

-- OK
a = True
  where x :: Num a => a
        !x = undefined   -- x is a function. Should be OK.

-- should fail
b = True
  where x :: a
        !x = undefined

-- OK
c = True
  where I# _ = undefined

-- bad
d = True
  where I# _x = undefined

-- OK
e = True
  where _ = undefined :: Int#

-- bad
f = True
  where _x = undefined :: Int#

-- OK
g = True
  where (# _ #) = undefined

-- OK
h = True
  where (# _x #) = undefined

-- bad
i = True
  where (# _x #) = undefined :: (# Int# #)

-- bad
j = True
  where !True = False

-- OK
k = True
  where True = False

-- OK
l = True
  where 3# = 4#

-- bad
m = True
  where !3# = 4#

-- bad
n = True
  where _x = undefined :: (# () #)

-- OK
o = True
  where (# _x #) = undefined :: (# () #)

-- OK
p = True
  where (# _ | #) = (# | True #)

-- bad
q = True
  where (# _x | #) = (# | True #) :: (# Int# | Bool #)

-- OK
r = True
  where (# _x | #) = (# | True #)

-- bad
s = True
  where !(# x #) = undefined

main :: IO ()
main = do
  ok a
  bad b
  ok c
  bad d
  ok e
  bad f
  ok g
  ok h
  bad i
  bad j
  ok k
  ok l
  bad m
  bad n
  ok o
  ok p
  bad q
  ok r
  bad s


{-# OPTIONS_GHC -fdefer-type-errors -fno-warn-deferred-type-errors #-}

import Control.Exception
import Data.Functor

a :: Int
a = 'a'

main :: IO ()
main = do
  catch (void $ evaluate a)
        (\e -> do let err = show (e :: TypeError)
                  putStrLn ("As expected, TypeError: " ++ err))
  catch (void $ evaluate a)
        (\e -> do let err = show (e :: ErrorCall)
                  putStrLn ("Something went horribly wrong: " ++ err))


{-# LANGUAGE ImplicitParams #-}
{-# OPTIONS_GHC -dcore-lint #-}

import GHC.Stack

f1 :: (?loc :: CallStack) => CallStack
-- we can solve CallStacks in local functions from CallStacks
-- in the outer context
f1 = let y x = (?loc :: CallStack)
     in y 0

main :: IO ()
main = do putStrLn $ prettyCallStack f1


{-# LANGUAGE ImplicitParams, PartialTypeSignatures #-}

module Main where

import GHC.Stack

f1 :: (?loc :: CallStack) => String
f1 = show $ map (srcLocStartLine . snd) $ getCallStack ?loc

f2 :: (?loc :: CallStack) => _
f2 = show $ map (srcLocStartLine . snd) $ getCallStack ?loc

f3 :: (?loc :: CallStack, _) => String
f3 = show $ map (srcLocStartLine . snd) $ getCallStack ?loc

main :: IO ()
main = do
  putStrLn f1
  putStrLn f2
  putStrLn f3


{-# LANGUAGE ImplicitParams, RankNTypes #-}
import GHC.Stack

foo :: (?callStack :: CallStack) => [Int]
foo = map (srcLocStartLine . snd) (getCallStack ?callStack)

bar1 :: [Int]
bar1 = foo

bar2 :: [Int]
bar2 = let ?callStack = freezeCallStack ?callStack in foo

main :: IO ()
main = do
  print bar1
  print bar2
  withFrozenCallStack (error "look ma, no stack!")


{-# LANGUAGE MagicHash, DataKinds #-}
-- See also TypeOf.hs

import GHC.Prim
import Data.Typeable

data CharHash = CharHash Char#

main :: IO ()
main = print $ typeRep (Proxy :: Proxy 'CharHash)


{-# LANGUAGE RoleAnnotations #-}
{-# OPTIONS_GHC -fdefer-type-errors #-}

module Main where

import Control.Exception

newtype Representational a = Representational ()
type role Representational representational

newtype Phantom a = Phantom ()
type role Phantom phantom

testRepresentational :: Representational Char -> Representational Bool
testRepresentational = id
{-# NOINLINE testRepresentational #-}

testPhantom :: Phantom Char -> Phantom Bool
testPhantom = id
{-# NOINLINE testPhantom #-}

throwsException :: String -> a -> IO ()
throwsException c v = do
  result <- try (evaluate v)
  case result of
    Right _ -> error (c ++ " (Failure): No exception!")
    Left (TypeError _) -> putStrLn (c ++ "(Success): exception found")

main = do
  throwsException "representational" testRepresentational
  throwsException "phantom" testPhantom


module T11647Sub (main) where

main :: IO ()
main = return ()


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

import Data.Kind
import Data.Typeable

type family F x a b
type instance F Type       a b = a
type instance F Constraint a b = b

foo :: x :~: y -> F x a b -> F y a b
foo Refl = id

unsafeCoerce :: a -> b
unsafeCoerce x = case eqT :: Maybe (Type :~: Constraint) of
                   Nothing -> error "No more bug!"
                   Just r  -> foo r x

main :: IO ()
main = let x :: Int
           x = 42
       in print (unsafeCoerce x :: Double)


{-# LANGUAGE DataKinds, PolyKinds, ExplicitForAll, MagicHash, UnboxedTuples,
             TypeFamilies, GADTs #-}

module Main where

import GHC.Exts

idint :: forall (a :: TYPE IntRep). a -> a
idint x = x

five _ = idint 3# +# idint 2#

type family F a where
  F Int = (# Bool, Int# #)
  F Char = (# Double, Int# #)

data G a where
  GInt :: G Int
  GChar :: G Char

f :: G a -> F a
f GInt = (# True, 3# #)
f GChar = (# 3.14, 5# #)

f' :: G a -> F a
f' GInt = (# False, 7# #)
f' GChar = (# 2.71829, 11# #)

g :: (# Bool, Int# #) -> String
g (# b, x #) = show b ++ " " ++ show (I# x)

h :: (# Double, Int# #) -> String
h (# d, x #) = show d ++ " " ++ show (I# x)

cond :: forall (a :: TYPE (TupleRep [LiftedRep, IntRep])). Bool -> a -> a -> a
cond True x _ = x
cond False _ x = x

main :: IO ()
main = do
  print (I# (five ()))
  putStrLn (g (f GInt))
  putStrLn (g (cond False (f GInt) (f' GInt)))
  putStrLn (h (cond True (f GChar) (f' GChar)))


{-# Language FlexibleInstances, TypeFamilies,
             DataKinds, PolyKinds, MagicHash #-}

module Main where

import Data.Kind
import GHC.Exts

class Shw (a :: TYPE rep) where
  shw :: a -> String

instance Int# ~ a => Shw (a :: TYPE IntRep) where
  shw a = "I#" ++ show (I# a)

main = putStrLn (shw 3#)


{-# OPTIONS_GHC -fdefer-type-errors #-}

module Main where

main :: () -> ()
main = undefined


{-# LANGUAGE ConstraintKinds #-}       -- For 'C'
{-# LANGUAGE MultiParamTypeClasses #-} -- For nullary 'Trivial' class
{-# LANGUAGE ImplicitParams #-}
{-# OPTIONS_GHC -Wno-simplifiable-class-constraints #-}
module Main where

import qualified GHC.Stack as Ghc

class Trivial where
instance Trivial where

type C = (Ghc.HasCallStack, Trivial)

-- | Print the functions on the call stack.
callStack :: C => IO ()
callStack = print $ map fst (Ghc.getCallStack Ghc.callStack)

f :: C => a -> IO ()
f x = callStack

type C2 =  (?x::Int, ?y::Int)

h1 :: C2 => Int -> IO ()
h1 v = print (?x+v)

h2 :: C2 => Int -> IO ()
h2 v = let ?x = 0 in h1 v

main = do { let { ?x = 3; ?y = 4 }  in h2 4
            -- Should print 4+0 = 4

          ; f "ugh"
            -- Should print @["callStack", "f"]@.
          }


{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE MagicHash #-}
import GHC.Exts
import Type.Reflection

main = do
    case typeRep @(Int -> Char) of
      App a b -> print (a, b)

    case typeRep @(Int# -> Char) of
      App a b -> print (a, b)

    case typeRep @(Int# -> Char) of
      App a b -> print $ App a (typeRep @String)


{-# LANGUAGE TypeApplications #-}

import Type.Reflection

main :: IO ()
main = do
    print $ typeRep @((,,))
    print $ typeRep @((,,) Int)
    print $ typeRep @((,,) Int Int Int)


import Data.Typeable

data Î© = Î©

main :: IO ()
main = print $ typeOf Î©


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

module Main where

class Foo a b | a -> b where
    foo :: a -> Maybe b
    foo x = Nothing

    bar :: a -> b

instance Foo (Maybe a) a where
    bar (Just x) = x

main = do { print (foo (Just 'x'))
          ; print (bar (Just 'y')) }


{-# LANGUAGE TemplateHaskell, FlexibleInstances, ScopedTypeVariables,
             ScopedTypeVariables, GADTs, RankNTypes, FlexibleContexts,
             MultiParamTypeClasses, GeneralizedNewtypeDeriving,
             DeriveDataTypeable,
             OverlappingInstances, UndecidableInstances, CPP #-}

module Main (main) where

import T1735_Help.Basics
import T1735_Help.Xml

data YesNo = Yes | No
    deriving (Eq, Show, Typeable)
instance Sat (ctx YesNo) => Data ctx YesNo where
    toConstr _ Yes = yesConstr
    toConstr _ No  = noConstr
    gunfold _ _ z c  = case constrIndex c of
                           1 -> z Yes
                           2 -> z No
                           _ -> error "Foo"
    dataTypeOf _ _ = yesNoDataType
yesConstr :: Constr
yesConstr = mkConstr yesNoDataType "Yes" [] Prefix
noConstr :: Constr
noConstr = mkConstr yesNoDataType "No" [] Prefix
yesNoDataType :: DataType
yesNoDataType = mkDataType "YesNo" [yesConstr, noConstr]

newtype MyList a = MkMyList { unMyList :: [a] }
    deriving (Show, Eq, Typeable)
instance (Sat (ctx (MyList a)), Sat (ctx [a]), Data ctx a)
      => Data ctx (MyList a) where
    gfoldl _ f z x  = z MkMyList `f` unMyList x
    toConstr _ (MkMyList _) = mkMyListConstr
    gunfold _ k z c  = case constrIndex c of
                           1 -> k (z MkMyList)
                           _ -> error "Foo"
    dataTypeOf _ _ = myListDataType
mkMyListConstr :: Constr
mkMyListConstr = mkConstr myListDataType "MkMyList" [] Prefix
myListDataType :: DataType
myListDataType = mkDataType "MyList" [mkMyListConstr]

#ifdef FOO
rigidTests :: Maybe (Maybe [YesNo])
rigidTests =
 mkTest [Elem "No"  []] (Just [No])
#endif

rigidManualTests :: Maybe (Maybe (MyList YesNo))
rigidManualTests =
 mkTest [Elem "MkMyList" [Elem "Yes" []]] (Just (MkMyList [Yes]))

mkTest :: (Eq a, Xml a) => [Element] -> Maybe a -> Maybe (Maybe a)
mkTest es v = case fromXml es of
                  v' | v == v'   -> Nothing
                     | otherwise -> Just v'

main :: IO ()
main = print rigidManualTests


module Main (main, arid1, arid2) where

import Prelude hiding (id, (.))
import qualified Prelude
import Control.Category
import Control.Arrow
import System.IO
import Debug.Trace

main = do { xs <- runXIOState arid1        -- Works with arid2
          ; print xs }

runXIOState :: IOSLA () c -> IO [c]
runXIOState f = runIOSLA f ()

newtype IOSLA a b = IOSLA { runIOSLA :: a -> IO [b] }

instance Arrow IOSLA where
    arr f = IOSLA $ \ x -> return [f x]

instance Category IOSLA where
    id = arr id

-- arr :: Arrow m => (b->c) -> m b c
-- id  :: Category m => m b b
-- (arr id) :: Arrow m => m a a

arid1 :: Arrow m => m a a
arid1 = arr id

arid2 :: Arrow m => m a a
arid2 = arr Prelude.id


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

module Main where

import Data.Kind (Type)

type family F a :: Type
type instance F Int = (Int, ())

class C a
instance C ()
instance (C (F a), C b) => C (a, b)

f :: C (F a) => a -> Int
f _ = 2

main :: IO ()
main = print (f (3 :: Int))


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

module Main where

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

type family Id m
type instance Id m = m

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

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

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

main = print (showMu item)


{-# LANGUAGE  DeriveDataTypeable,
              FlexibleContexts, FlexibleInstances,
              MultiParamTypeClasses,
              OverlappingInstances, UndecidableInstances,
              Rank2Types, KindSignatures, EmptyDataDecls #-}

{-# OPTIONS_GHC -Wall #-}

module Main (main) where

class Sat a where
    dict :: a -- Holds a default value

class Sat a => Data a where
    gunfold :: (forall b r. Data b => (b -> r) -> r) -> a

instance (Sat [a], Data a) => Data [a] where
   gunfold _  = []

class Data a => Default a where
    defaultValue :: a
    defaultValue = gunfold (\c -> c dict)

instance Default t => Sat t where
    dict = defaultValue

instance Default a => Default [a] where
    defaultValue = []

data Proposition = Prop Expression
data Expression  = Conj [Expression]

instance Data Expression => Data Proposition where
  gunfold k = k Prop

instance (Data [Expression],Sat Expression) => Data Expression where
-- DV: Notice what happens when we remove the Sat Expression above!
--     Everything starts working!
  gunfold k = k Conj

instance Default Expression
instance Default Proposition

main :: IO ()

main = case (defaultValue :: Proposition) of
         Prop exp -> case exp of
                         Conj _ -> putStrLn "Hurray2!"

{-  Need Default Proposition
    for which we have an instance

Instance
   Default Proposition
needs superclass
   Data Proposition
via instance dfun, needs
   Data Expression
via instance dfun, needs
   Sat Expression
via instance dfun, needs
   Default Expression
for which we have an instance

Instance
   d1: Default Expression
needs superclass  [d1 = MkD d2 ..]
   d2: Data Expression {superclass Sat Expression}
via instance dfun, [d2 = dfun d3 d4]  needs
   d3 : Sat Expression (and d4 : Data [Expression])
via instance dfun, [d3 = dfun d5] needs
   d5 Default Expression
for which we have an instance [d5 = d1]

    d1 = MkD d2 ..
    d2 = dfun d3 d4
    d3 = dfun d1

Instance
   d1: Default Expression
needs superclass  [d1 = MkD d2 ..]
   d2: Data Expression {superclass Sat Expression  d2' = sc d2 }
via instance dfun, [d2 = dfun d3 d4]  needs
   d3 : Sat Expression (and d4 : Data [Expression])
and we can solve: d3 = d2'... no: recursion checker will reject

-}


{-# LANGUAGE  DeriveDataTypeable,
              FlexibleContexts, FlexibleInstances,
              MultiParamTypeClasses,
              OverlappingInstances, UndecidableInstances,
              Rank2Types, KindSignatures, EmptyDataDecls #-}

{-# OPTIONS_GHC -Wall #-}

module Main (main) where

import Data.Typeable

class Sat a where
    dict :: a

class ( Sat (ctx a)) => Data ctx a where
    gunfold :: Proxy ctx
            -> (forall b r. Data ctx b => c (b -> r) -> c r)
            -> (forall r. r -> c r)
            -> Constr
            -> c a
    dataTypeOf :: Proxy ctx -> a -> DataType

newtype ID x = ID { unID :: x }

fromConstrB :: Data ctx a
            => Proxy ctx
            -> (forall b. Data ctx b => b)
            -> Constr
            -> a
fromConstrB ctx f = unID . gunfold ctx k z
 where
  k c = ID (unID c f)
  z = ID

data DataType = DataType
                        { tycon   :: String
                        , datarep :: DataRep
                        }

data Constr = Constr { conrep    :: ConstrRep
                     , constring :: String
                     , confields :: [String]
                     , confixity :: Fixity
                     , datatype  :: DataType
                     }

data DataRep = AlgRep [Constr]
data ConstrRep = AlgConstr ConIndex

type ConIndex = Int

data Fixity = Prefix
            | Infix

constrRep :: Constr -> ConstrRep
constrRep = conrep

-- | Constructs an algebraic datatype
mkDataType :: String -> [Constr] -> DataType
mkDataType str cs = DataType
                        { tycon   = str
                        , datarep = AlgRep cs
                        }

-- | Constructs a constructor
mkConstr :: DataType -> String -> [String] -> Fixity -> Constr
mkConstr dt str fields fix =
        Constr
                { conrep    = AlgConstr idx
                , constring = str
                , confields = fields
                , confixity = fix
                , datatype  = dt
                }
  where
    idx = head [ i | (c,i) <- dataTypeConstrs dt `zip` [1..],
                     showConstr c == str ]

-- | Gets the constructors
dataTypeConstrs :: DataType -> [Constr]
dataTypeConstrs dt = case datarep dt of
                     AlgRep cons -> cons

-- | Gets the string for a constructor
showConstr :: Constr -> String
showConstr = constring

-- | Gets the index of a constructor
constrIndex :: Constr -> ConIndex
constrIndex con = case constrRep con of
                  AlgConstr idx -> idx

nilConstr :: Constr
nilConstr    = mkConstr listDataType "[]" [] Prefix
consConstr :: Constr
consConstr   = mkConstr listDataType "(:)" [] Infix
listDataType :: DataType
listDataType = mkDataType "Prelude.[]" [nilConstr,consConstr]

instance (Sat (ctx [a]), Data ctx a) =>
         Data ctx [a] where
  gunfold _ k z c = case constrIndex c of
                      1 -> z []
                      2 -> k (k (z (:)))
                      _ -> error "gunfold List"
  dataTypeOf _ _ = listDataType

class (Data DefaultD a) => Default a where
    defaultValue :: a
    defaultValue = defaultDefaultValue

defaultDefaultValue :: Data DefaultD a => a
{-# NOINLINE defaultDefaultValue #-}
defaultDefaultValue = res
    where res = case datarep $ dataTypeOf defaultProxy res of
                    AlgRep (c:_) ->
                        fromConstrB defaultProxy (defaultValueD dict) c
                    AlgRep [] ->
                        error "defaultDefaultValue: Bad DataRep"

data DefaultD a = DefaultD { defaultValueD :: a }

defaultProxy :: Proxy DefaultD
defaultProxy = error "defaultProxy"

-- dfun3
instance Default t => Sat (DefaultD t) where
    dict = DefaultD { defaultValueD = defaultValue }

-- dfun5
instance Default a => Default [a] where
    defaultValue = []
data Proposition = Proposition Expression deriving (Show, Typeable)
data Expression = Conjunction [Expression] deriving (Show, Typeable)

constr_Proposition :: Constr
constr_Proposition = mkConstr dataType_Proposition "Proposition" [] Prefix
dataType_Proposition :: DataType
dataType_Proposition = mkDataType "Proposition" [constr_Proposition]

-- dfun1
instance Data DefaultD Proposition
    where gunfold _ k z c = case constrIndex c of
                            1 -> k (z Proposition)
                            _ -> error "gunfold: fallthrough"
          dataTypeOf _ _ = dataType_Proposition

constr_Conjunction :: Constr
constr_Conjunction = mkConstr dataType_Expression "Conjunction" [] Prefix
dataType_Expression :: DataType
dataType_Expression = mkDataType "Expression" [constr_Conjunction]

-- dfun2
instance (Sat (ctx [Expression]), Sat (ctx Expression))
      => Data ctx Expression
    where gunfold _ k z c = case constrIndex c of
                            1 -> k (z Conjunction)
                            _ -> error "gunfold: fallthrough"
          dataTypeOf _ _ = dataType_Expression

-- dfun0
instance Default Proposition where
    defaultValue = defaultDefaultValue

-- dfun4
instance Default Expression where
    defaultValue = defaultDefaultValue

main :: IO ()
main = putStrLn (show (defaultValue :: Proposition))

{- The trouble comes from "instance Default Expression"

Define:  dfun4 : Default Expression = MkDefault d_aCl (..)

Simplify the superclass:
  Wanted:  d_aCl : Data DefaultD Expression
  Derived: d_aCn : Sat DefaultD Expression       d_aCn = $p1 d_aCl  {irrelevant}

  by dfun2                                       d_aCl = dfun2 d_aCo d_aCp
  Wanted: d_aCo : Sat (DefaultD [Expression])
          d_aCp : Sat (DefaultD Expression)

  by dfun3                                       d_aCo = dfun3 d_aCq
  Wanted:  d_aCq : Default [Expression]
  Derived: d_aCr : Data DefaultD [Expression]    d_aCr = $p1 d_aCq  {irrelevant}

  by dfun5                                       d_aCq = dfun5 aCu
  Wanted:  d_aCu : Default Expression
  Derived: d_aCw : Data DefaultD Expression      d_aCw = $p1 d_aCu
  Derived: d_aCx : Sat (DefaultD Expression)     d_aCx = $p1 d_aCw
     -- These two deriveds are unnecessary,
     -- and dangerous, because we later satisfy
     -- d_aCu from dfun4 which does not visibly
     -- depend on d_aCl

Now we satisfy                                   d_aCu = dfun4
                                                 d_aCp = d_aCx
Result = disaster:
                d_aCp = d_aCx
                      = $p1 d_aCw
                      = $p1 ($p1 d_aCu)
                      = $p1 ($p1 dfun4)
                      = $p1 ($p1 (MkDefault d_aCl ...))
                      = $p1 d_aCl
                      = $p1 (dfun2 d_aCo d_aCp)
                      = d_aCp
-}


{- # LANGUAGE MonoLocalBinds # -}
module Main where

import T4809_IdentityT (IdentityT(..), XML, runIdentityT)
import T4809_XMLGenerator (XMLGenT(..), XMLGen(genElement), Child, EmbedAsChild(..), unXMLGenT)
import System.IO (BufferMode(..), hSetBuffering, stdout)

page :: XMLGenT (IdentityT IO) XML
page = genElement (Nothing, "ul") [] [ asChild (asChild "foo")]
--    where
--       item :: XMLGenT (IdentityT IO) [Child (IdentityT IO)]
--       item = (asChild $ asChild (return "bar" :: XMLGenT (IdentityT IO) String))

main :: IO ()
main =
    do hSetBuffering stdout LineBuffering
       r <- runIdentityT (unXMLGenT page)
       print r


{-# LANGUAGE MultiParamTypeClasses, TypeSynonymInstances, FlexibleInstances, TypeFamilies, GeneralizedNewtypeDeriving #-}
{-# OPTIONS_GHC -fno-warn-orphans  #-}
module T4809_IdentityT
    ( evalIdentityT
    , IdentityT(..)
    , XML(..)
    ) where

import Control.Applicative
import Control.Monad        (MonadPlus)
import Control.Monad.Trans  (MonadTrans(lift), MonadIO(liftIO))
import T4809_XMLGenerator (XMLGenT(..), EmbedAsChild(..), Name)
import qualified T4809_XMLGenerator as HSX

data XML
  = Element Name [Int] [XML] | CDATA Bool String
    deriving Show

-- * IdentityT Monad Transformer

newtype IdentityT m a = IdentityT { runIdentityT :: m a }
    deriving (Functor, Monad, MonadIO, MonadPlus)

instance Monad m => Applicative (IdentityT m) where
instance Monad m => Alternative (IdentityT m) where

instance MonadTrans IdentityT where
    lift = IdentityT

evalIdentityT :: (Functor m, Monad m) => XMLGenT (IdentityT m) XML -> m XML
evalIdentityT = runIdentityT . HSX.unXMLGenT

-- * HSX.XMLGenerator for IdentityT

instance (Functor m, Monad m) => HSX.XMLGen (IdentityT m) where
    type XML (IdentityT m) = XML
    newtype Child (IdentityT m) = IChild { unIChild :: XML }
    genElement n _attrs children = HSX.XMLGenT $
                                  do children' <- HSX.unXMLGenT (fmap (map unIChild . concat) (sequence children))
                                     return (Element n [] children')

instance (Monad m, MonadIO m, Functor m) => EmbedAsChild (IdentityT m) String where
    asChild s =
        do liftIO $ putStrLn "EmbedAsChild (IdentityT m) String"
           XMLGenT . return . (:[]) . IChild . CDATA True $ s


{-# LANGUAGE CPP, TypeFamilies, MultiParamTypeClasses, FunctionalDependencies,
      FlexibleContexts, FlexibleInstances, UndecidableInstances, OverlappingInstances,
      TypeSynonymInstances, GeneralizedNewtypeDeriving #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  HSX.XMLGenerator
-- Copyright   :  (c) Niklas Broberg 2008
-- License     :  BSD-style (see the file LICENSE.txt)
--
-- Maintainer  :  Niklas Broberg, niklas.broberg@chalmers.se
-- Stability   :  experimental
-- Portability :  requires newtype deriving and MPTCs with fundeps
--
-- The class and monad transformer that forms the basis of the literal XML
-- syntax translation. Literal tags will be translated into functions of
-- the GenerateXML class, and any instantiating monads with associated XML
-- types can benefit from that syntax.
-----------------------------------------------------------------------------
module T4809_XMLGenerator where

import Control.Applicative
import Control.Monad
import Control.Monad.Trans
import Control.Monad.Cont  (MonadCont)
import Control.Monad.Error (MonadError)
import Control.Monad.Reader(MonadReader)
import Control.Monad.Writer(MonadWriter)
import Control.Monad.State (MonadState)
import Control.Monad.RWS   (MonadRWS)
import Control.Monad (MonadPlus(..),liftM)

----------------------------------------------
-- General XML Generation

-- | The monad transformer that allows a monad to generate XML values.
newtype XMLGenT m a = XMLGenT (m a)
  deriving (Monad, Functor, MonadIO, MonadPlus, MonadWriter w, MonadReader r,
            MonadState s, MonadRWS r w s, MonadCont, MonadError e)

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

instance Monad m => Alternative (XMLGenT m) where

-- | un-lift.
unXMLGenT :: XMLGenT m a -> m a
unXMLGenT   (XMLGenT ma) =  ma

instance MonadTrans XMLGenT where
 lift = XMLGenT

type Name = (Maybe String, String)

-- | Generate XML values in some XMLGenerator monad.
class Monad m => XMLGen m where
 type XML m
 data Child m
 genElement  :: Name -> [XMLGenT m [Int]] -> [XMLGenT m [Child m]] -> XMLGenT m (XML m)
 genEElement :: Name -> [XMLGenT m [Int]]                          -> XMLGenT m (XML m)
 genEElement n ats = genElement n ats []

-- | Embed values as child nodes of an XML element. The parent type will be clear
-- from the context so it is not mentioned.
class XMLGen m => EmbedAsChild m c where
 asChild :: c -> XMLGenT m [Child m]

instance (MonadIO m, EmbedAsChild m c, m ~ n) => EmbedAsChild m (XMLGenT n c) where
 asChild m = do
      liftIO $ putStrLn "EmbedAsChild m (XMLGenT n c)"
      a <- m
      asChild a

instance (MonadIO m, EmbedAsChild m c) => EmbedAsChild m [c] where
  asChild cs =
      do liftIO $ putStrLn "EmbedAsChild m [c]"
         liftM concat . mapM asChild $ cs

instance (MonadIO m, XMLGen m) => EmbedAsChild m (Child m) where
 asChild c =
     do liftIO $ putStrLn "EmbedAsChild m (Child m)"
        return . return $ c


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

import GHC.Exts

{-# NOINLINE foo1 #-} -- Make it harder to get right
foo1 x = (# x,x #)

{-# NOINLINE foo2 #-} -- Make it harder to get right
foo2 x = (# x, (# True, False #) #)

{-# NOINLINE foo3 #-} -- Make it harder to get right
foo3 (# x,y #) = x

main = print $ foo3 (# if b then x + y else x - y, 30 #)
  where (# x,  _ #) = foo1 10
        (# y, (# b, _ #) #) = foo2 20


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

import GHC.Exts

{-# NOINLINE foo #-} -- Make it harder to get right
foo :: Double# -> (# (# Double#, Double# #), Double# #)
foo x = (# (# x, x #), x #)

main :: IO ()
main = case foo 1.0## of
        (# (# x, y #), z #) -> print (D# x + D# y + D# z)


{-# LANGUAGE FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving, OverlappingInstances, UndecidableInstances #-}
module Main where

class (Monad m) => MonadIO m where
    -- | Lift a computation from the 'IO' monad.
    liftIO :: IO a -> m a

instance MonadIO IO where
    liftIO = id

class XMLGenerator m where
    genElement :: (Maybe String, String) -> m ()

newtype IdentityT m a = IdentityT { runIdentityT :: m a }
    deriving (Functor, Applicative, Monad, MonadIO)

instance (MonadIO m) => (XMLGenerator (IdentityT m)) where
    genElement _ = liftIO $ putStrLn "in genElement"

main :: IO ()
main =
    do runIdentityT web
       putStrLn "done."

class (Widgets x) => MonadRender x
class (XMLGenerator m)  => Widgets m
-- instance Widgets (IdentityT IO) -- if you uncomment this, it will work
instance (XMLGenerator m, MonadRender m) => Widgets m
instance MonadRender (IdentityT IO)

web :: ( MonadIO m
       , Widgets m
       , XMLGenerator m
       ) => m ()
web =
    do liftIO $ putStrLn "before"
       genElement (Nothing, "p")
       return ()


{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, OverlappingInstances,
    UndecidableInstances, FunctionalDependencies #-}

module Main where

class Container a b | a -> b where
    make :: b -> a

data Cont a = Cont a deriving (Show, Eq)

instance Container (Cont a) a where
    make x = Cont x

instance (Container a b, Show a, Eq a, Num b) => Num a where
    fromInteger x = make (fromInteger x)

d = fromInteger 3 :: Cont Integer

main = print d


{-# LANGUAGE UndecidableInstances #-}
module Main where

class         L0 a where l0 :: a -> a
class L0 a => L1 a where l1 :: a -> a
class L1 a => L2 a where l2 :: a -> a

data Worksfine = Worksfine deriving Show
instance                                   L0 Worksfine where l0 = id
instance                                   L1 Worksfine where l1 = l2
instance {- undecidable -} L1 Worksfine => L2 Worksfine where l2 = l0

data WorksfineToo = WorksfineToo deriving Show
instance                                      L0 WorksfineToo where l0 = id
instance {- undecidable -} L2 WorksfineToo => L1 WorksfineToo where l1 = l2
instance {- undecidable -} L1 WorksfineToo => L2 WorksfineToo where l2 = id

-- l1 LoopsAtRuntime = <loop>
-- l2 LoopsAtRuntime = <loop>
data LoopsAtRuntime = LoopsAtRuntime deriving Show
instance                                        L0 LoopsAtRuntime where l0 = id
instance {- undecidable -} L2 LoopsAtRuntime => L1 LoopsAtRuntime where l1 = l2
instance {- undecidable -} L1 LoopsAtRuntime => L2 LoopsAtRuntime where l2 = l0

main = do
  print (l1 WorksfineToo)
  print (l2 WorksfineToo)
  print (l1 LoopsAtRuntime)
  print (l2 LoopsAtRuntime)


{-# LANGUAGE FlexibleContexts #-}

import Prelude hiding (Semigroup(..))

{-
[Summary of the program] Ring is defined as a subclass of Semigroup,
inheriting multiplication.  Additive is a wrapper that extracts the additive
structure of Ring and reifies it as Semigroup.  For simplicity, the code omits
ring operations (+ and *) and defines only the additive and multiplicative
identities.

[The bug] If there is a cyclic class hierarchy like

    class B a => Semigroup a                  where ...
    class Semigroup (Additive a) => Ring a    where ...
    instance Ring a => Semigroup (Additive a) where ...

then uses of B's methods on (Additive a) in the method implementations of the
third declaration "instance Ring a => Semigroup (Additive a)" will:

    1. be accepted by the compiler even in cases where B (Additive a) is not
       derivable.
    2. result in <<loop>>.
 -}

class B a where
    b :: a
class B a => Semigroup a where
    unit :: a
class (Semigroup a, Semigroup (Additive a)) => Ring a where
    zero :: a
newtype Additive a = Additive a

-- The source compiles whether with or without this instance declaration in GHC
-- 7.2.1 - 7.4.1 and produces <<loop>>.
--
-- GHC 7.0.4 rejects this source without this declaration and produces
-- terminating code with the declaration.
instance B a => B (Additive a) where
   b = Additive b

instance Ring a => Semigroup (Additive a) where
    unit = b -- Use a method of type (B a => ...) with a instantiated as
             -- (Additive a).  This causes <<loop>>.

-- Now try to instantiate Ring and evaluate `unit'.
instance B Int where
    b = 1234567890
instance Semigroup Int where
    unit = 1
instance Ring Int where
    zero = 0
main = case (unit :: Additive Int) of -- Force the additive identity of Int.
         Additive x -> print x


{-# OPTIONS_GHC -fdefer-type-errors #-}

module Main where

a = ["x", 1 :: Int]

main :: IO ()
main = putStrLn "Hello World"


{-# LANGUAGE FlexibleInstances, UndecidableInstances #-}

module Main where

main :: IO ()
main =  do
  let k1 = func1 1 :: Int
  print $ show k1
  let k2 = outer :: Int
  print $ show k2

outer :: Class3 a => a
outer = func1 1

class Class1 a where
  func1 :: Int -> a

class Class1 a => Class2 a where
  func2 :: Int -> a

class Class2 a => Class3 a where
  func3 :: Int -> a

instance Class1 Int where
  func1 = id

instance (Class1 a, Class3 a) => Class2 a where
  func2 = func3

instance Class3 Int where
  func3 = id

--
-- "1"
-- tests: <<loop>>


-- Correct type, which is inferred by GHC 7.6.1 and
-- works fine with GHC 7.6.2:
-- test :: Maybe (Maybe (r -> ())) -> r -> ()

-- Incorrect type, resulting in a runtime <<loop>>,
-- inferred by GHC 7.6.2 and also accepted by GHC 7.6.1:
-- test :: a -> r -> ()

module Main where

test zd
 = let f = let g = case zd of
                       Nothing       -> const ()
                       Just Nothing  -> const ()
                       Just (Just p) -> p
           in  g
   in f

main :: IO ()
main = do
  let x = test (Just Nothing) ()
  print x

{-
There is a bug in the type checker of 7.6.1 and 7.6.2, which accepts
an incorrect type resulting in <<loop>> at runtime. Furthermore, 7.6.2
even automatically infers this incorrect type. Hence, the attached
code has the following behavior:

- No explicit type: Code works in 7.6.1, loops in 7.6.2
- Correct explicit type: Code works fine in 7.6.1 and 7.6.2
- Incorrect explicit type: Code loops in 7.6.1 and 7.6.2

The incorrect type has a parameter that is too polymorphic, i.e. an
"a" type is accepted while the function does a pattern match on the
parameter from which it is clear that it should be a Maybe type. In
7.4.* versions this incorrect type is not accepted.
-}


{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ImpredicativeTypes #-}
{-# OPTIONS_GHC -fdefer-type-errors #-}
module Main where

doA :: (forall b. a) -> [a]
doA = undefined

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

main = do { print "Hello 1"

          ; f `seq` print "Hello 2"
              -- The casts are pushed inside the lambda
              -- for f, so this seq succeeds fine
              -- It does require ImpredicativeTypes, because we instantiate
              -- seq's type (c->d->d) with f's type (c:= (forall b. a) -> a),
              -- which is polymorphic (it has foralls).

          ; f (error "urk") `seq` print "Bad"
              -- But when we *call* f we get a type error
        }


{-# LANGUAGE TypeFamilies #-}
class Test a where test :: a
instance (a ~ Int, b ~ Int) => Test (a -> b) where test = id


module Main where

x :: ((->) Int) Bool
x = (==0)

main = print $ x 0


{-# LANGUAGE MagicHash #-}
module Main where
import GHC.Exts

go :: () -> Int#
go () = 0#

main = print (lazy (I# (go $ ())))


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

import Data.Typeable
import Data.Kind

test1 :: Bool
test1 = typeRep (Proxy :: Proxy (() :: Type)) ==
        typeRep (Proxy :: Proxy (() :: Constraint))

test2 :: Bool
test2 = typeRepTyCon (typeRep (Proxy :: Proxy (Int,Int))) ==
        typeRepTyCon (typeRep (Proxy :: Proxy (Eq Int, Eq Int)))

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


{-# LANGUAGE DataKinds #-}
module Main where

import Data.Typeable

data A = A

main = print $ typeRep (Proxy :: Proxy A) == typeRep (Proxy :: Proxy 'A)


{-# LANGUAGE RoleAnnotations, StandaloneDeriving, FlexibleContexts, UndecidableInstances, GADTs, TypeFamilies #-}

import Data.Coerce (Coercible, coerce)
import Data.Monoid (mempty, First(First), Last())

newtype Age = Age Int deriving Show
newtype Foo = Foo Age deriving Show
newtype Bar = Bar Age deriving Show
newtype Baz = Baz Bar deriving Show

type role Map nominal representational
data Map a b = Map a b deriving Show

-- Higher kinded coercions (#8541)
newtype List a = List [a] deriving Show
data T f = T (f Int)

-- It should be possible to coerce _under_ undersaturated newtypes
newtype NonEtad a b = NonEtad (Either b a) deriving Show

-- It should be possible to coerce recursive newtypes, in some situations
-- (#8503)
newtype Fix f = Fix (f (Fix f))
deriving instance Show (f (Fix f)) => Show (Fix f)

-- Later, however, this stopped working (#9117)
-- newtype FixEither a = FixEither (Either a (FixEither a)) deriving Show

-- This ensures that explicitly given constraints are consulted, even
-- at higher depths
-- This stopped working with the fix to #9117
--data Oracle where Oracle :: Coercible (Fix (Either Age))
--                                      (Fix (Either Int)) => Oracle
--foo :: Oracle -> Either Age (Fix (Either Age)) -> Fix (Either Int)
--foo Oracle = coerce

-- This ensures that Coercible looks into newtype instances (#8548)
data family Fam k
newtype instance Fam Int = FamInt Bool deriving Show

main = do
    print (coerce $ one                       :: Age)
    print (coerce $ age                       :: Int)
    print (coerce $ Baz (Bar age)             :: Foo)

    print (coerce (id::Bar->Bar) age          :: Foo)
    print (coerce Baz age                     :: Foo)
    print (coerce $ (Age 1, Foo age)          :: (Baz, Baz))

    print (coerce $ Map one one               :: Map Int Age)

    print (coerce $ Just one                  :: First Int)
    print (coerce $ (mempty :: Last Age)      :: Last Int)

    printT (coerce $ (T (Left age)     :: T (Either Age))  :: T (Either Int))
    printT (coerce $ (T (Left one)     :: T (Either Int))  :: T (Either Age))
    printT (coerce $ (T [one]          :: T [])            :: T List)
    printT (coerce $ (T (List [one])   :: T List)          :: T [])

    printT (coerce $ (T (NonEtad (Right age)) :: T (NonEtad Age)) :: T (NonEtad Int))

    print (coerce $ (Fix (Left ()) :: Fix (Either ())) :: Either () (Fix (Either ())))
    print (coerce $ (Left () :: Either () (Fix (Either ()))) :: Fix (Either ()))

--    print (coerce $ (FixEither (Left age) :: FixEither Age)
--               :: Either Int (FixEither Int))
--    print (coerce $ (Left one :: Either Int (FixEither Age)) :: FixEither Age)

    print (coerce $ True :: Fam Int)
    print (coerce $ FamInt True :: Bool)

--    foo `seq` return ()

  where one = 1 :: Int
        age = Age one
        printT (T x) = print x


{-# LANGUAGE MultiParamTypeClasses #-}

module Main where

class R where
  f :: Int -> Int
  g :: a -> a

instance R where
  f = (+1)
  g = id

main = print (g (f 0))


-- !! Test for (->) instances

module Main where

class Flob k where
  twice :: k a a  -> k a a

instance Flob (->) where
  twice f = f . f

inc :: Int -> Int
inc x = x+1

main = print (twice inc 2)


-- !!! space leak from overloading !!!
module Main where

-- This program develops a space leak if sfoldl isn't compiled with some
-- care.  See comment about polymorphic recursion in TcMonoBinds.lhs

import System.Environment (getArgs)
import GHC.IO

sfoldl :: (a -> Int -> a) -> a -> [Int] -> a
sfoldl f z [] = z
sfoldl f z (x:xs) = {-# SCC "sfoldl1" #-} (sfoldl f fzx (fzx `seq` xs))
                  where fzx = {-# SCC "fzx" #-} (f z x)

main = IO (\s -> case print (sfoldl (+) (0::Int) [1..200000]) of { IO a -> a s })


{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-}
-- !!! One method class from Sergey Mechveliani
--     showed up problematic newtype dict rep.
module Main where
import Data.Ratio

class MBConvertible a b  where  cm :: a -> b -> Maybe b

c :: MBConvertible a b => a -> b -> b
c                         a    b =  case  cm a b
                                    of
                                      Just b' -> b'
                                      _       -> error "c a b  failed"

instance MBConvertible Int Int  where  cm a _ = Just a

instance (MBConvertible a b,Integral b) => MBConvertible a (Ratio b)
  where
  cm a f =  case  cm a (numerator f)  of  Just a' -> Just (a'%1)
                                          _       -> Nothing

main =  let  f  = 1%1 :: Ratio Int
             n2 = 2::Int
             g  = (c n2 f) + f
        in
             putStr (shows g "\n")


{-# LANGUAGE ExistentialQuantification #-}
-- !!! Tests existential data types
--     Originally from Kevin Glynn
module Main(main) where

data Coordinate3D = Coord3D {cx, cy, cz::Double}
                    deriving (Eq, Show)

-- We Represent a line by two coordinates which it passes through.
data Line = MkLine Coordinate3D Coordinate3D

class PictureObject pot where

      -- Returns ordered (rel to 0 0 0) of points where the object
      -- intersects the given line.
      intersectLineObject :: pot -> Line -> [Coordinate3D]

      getPictureName :: pot -> String

data Sphere =
   Sphere Coordinate3D                  -- Centre
          Double                        -- Radius
          Double                        -- ambient coeff
          Double                        -- diffuse coeff
          Double                        -- specular coeff
          Double                        -- phong specular exponent

intersectLineSphere :: Sphere -> Line -> [Coordinate3D]
intersectLineSphere sp line = []

instance PictureObject Sphere where
         intersectLineObject = intersectLineSphere
         getPictureName _ = "Sphere"

data Cube =
   Cube Coordinate3D            -- Origin corner
        Coordinate3D            -- Opposite corner
        Double                  -- ambient coeff
        Double                  -- diffuse coeff
        Double                  -- specular coeff
        Double                  -- phong specular exponent
   deriving (Eq, Show)

intersectLineCube :: Cube -> Line -> [Coordinate3D]
intersectLineCube cube line = []

instance PictureObject Cube where
         intersectLineObject = intersectLineCube
         getPictureName _ = "Cube"

data GenPic = forall pot. (PictureObject pot) => MkGenPic pot

sphere :: Sphere
sphere = Sphere (Coord3D 1 1 1) 1 1 1 1 1

cube :: Cube
cube = Cube (Coord3D 1 1 1) (Coord3D 2 2 2) 1 1 1 1

obj_list:: [GenPic]
obj_list = [MkGenPic sphere, MkGenPic cube]

putName :: PictureObject pot => pot -> IO ()
putName x = putStr $ getPictureName x

main :: IO ()
main = do { sequence_ $ map put_it obj_list }
     where
       put_it (MkGenPic s) = putStrLn (getPictureName s)


-- !!! Dfun naming bug

module Main where

  data TT  = TT
  data TTT = TTT

  class CC  a where
        op_cc :: a -> a

  class CCT a where
        op_cct :: a -> a

  -- These two instances should get different dfun names!
  -- In GHC 4.04 they both got $fCCTTT

  instance CC TTT where
        op_cc = id

  instance CCT TT where
        op_cct = id

  main = case op_cc TTT of
           TTT -> print "ok"


{-# LANGUAGE DatatypeContexts #-}
-- !!! Selectors for data and newtypes with contexts

-- This program, reported in Aug'00 by Jose Emilio Labra Gayo
-- gave rise to a Lint error because the selector 'newout' below
-- was given the type
--      Eq f => NewT f -> f
-- but lacked a dictionary argument in its body.

module Main where

newtype (Eq f) => NewT  f = NewIn  { newout  :: f }
data    (Eq f) => DataT f = DataIn { dataout :: f }

main = print (newout (NewIn "ok new") ++ dataout (DataIn " ok data"))


{-# LANGUAGE Rank2Types #-}

-- !!! Check that record selectors for polymorphic fields work right

module Main where

class Foo a where
  bar :: a -> [a]

instance Foo Int where
  bar x = replicate x x

instance Foo Bool where
  bar x = [x, not x]

data Record = R {
     blub :: forall a. Foo a => a -> [a]
    }

main = do { let r = R {blub = bar}
          ; print (blub r (3::Int))
          ; print (blub r True)
          }


{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies #-}

-- !!! Functional dependencies

module Main where

class Foo a b | a -> b where
    foo :: a -> b

instance Foo [a] (Maybe a) where
    foo []    = Nothing
    foo (x:_) = Just x

instance Foo (Maybe a) [a] where
    foo Nothing  = []
    foo (Just x) = [x]

test3:: [a] -> [a]
test3 = foo . foo
-- First foo must use the first instance,
-- second must use the second.  So we should
-- get in effect:       test3 (x:xs) = [x]

main:: IO ()
main = print (test3 "foo")


{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies #-}

-- !!! Functional dependencies
-- This one gave "zonkIdOcc:  FunDep_a11w" in earlier days

module Main (main) where

data ERR a b = EOK a | ERR b deriving (Show)
data Error   = No | Notatall deriving (Show, Eq)

class MonadErr m e | m -> e where
   aerturn ::           e   -> m a
   areturn ::           a   -> m a
   acatch  ::           a   -> (a -> m b) -> (e -> m b) -> m b
   (>>>=)  ::           m a -> (a -> m b) -> m b
   (>>>)   ::           m a -> m b        -> m b

data BP a = BP (Int -> (ERR a Error, Int))

instance MonadErr BP Error where
   aerturn k             = BP $ \s  -> (ERR k, s)
   areturn k             = BP $ \s  -> (EOK k, s)
   acatch  k try handler = BP $ \s  -> let BP try'     = try  k
                                           (r,s1)      = try' s
                                           (BP c2, s2) = case r of
                                                           EOK r -> (areturn r, s1)
                                                           ERR r -> (handler r, s)
                                       in  c2 s2
   a >>> b =  a >>>= \_ -> b

   (BP c1) >>>= fc2      = BP $ \s0 -> let (r,s1) = c1 s0
                                           BP c2 = case r of
                                                     EOK r -> fc2 r
                                                     ERR r -> BP (\s -> (ERR r, s))
                                       in c2 s1

run_BP :: Int -> BP a -> (ERR a Error, Int)
run_BP st (BP bp) = bp st

foo :: (ERR Int Error, Int)
foo = run_BP 111 (aerturn No)

main = print (show foo)


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

-- !!! Existential data tyes
-- Hugs didn't like this one

module Main (main) where

class MyClass a b where
        foo :: a -> b -> Int

data Special = forall b. (MyClass Int b)=> MkSpecial b
data General a = forall b. (MyClass a b)=> MkGeneral b

instance MyClass Int Bool where
   foo x False = -x
   foo x True  = x

xs :: [General Int]
xs = [MkGeneral True, MkGeneral False]

main = print [foo (3::Int) x | MkGeneral x <- xs]
        -- Without the (::Int) part we get an
        -- incomprehensible error message :-(


{-# LANGUAGE ImplicitParams #-}

-- !!! Implicit parameter test

module Main where

main = do { let ?x = 13 in putStrLn $ show $ foo
          ; let ?x = 14 in putStrLn $ show $ baz () }

foo :: (?x :: Int) => Int
foo = ?x

-- Check that defaulting works too
baz () = ?x


{-# LANGUAGE ParallelListComp #-}

-- !!! Parallel list comprehensions

module Main where

f xs = [ (x,y) | x <- xs, x>3 | y <- xs ]

main = print (f [0..10])


-- !!! Newtypes

-- This one made ghc 5.01 (after newtype squashing) fall over
-- by generating Core code that contained a pattern match on
-- the InPE data constructor (which doesn't exist)

module Main where

data Expr e = One e | Many [e]
newtype PExpr a = InPE (Expr (PExpr a), Int)

one :: Int -> PExpr e -> PExpr e
one l x = InPE (One (plus1 x), l)

plus1 :: PExpr a -> PExpr a
plus1 x@(InPE (_, loc)) = InPE (Many [plus1 x], loc)

get :: PExpr e -> Int
get (InPE (_,l)) = l

main = print (get (plus1 (InPE (Many [], 0))))


-- !!! Newtypes

-- A variation of tc014 that Sigbjorn said failed

module Main where

data Expr a b = One a | Many [b]
newtype Pat a   = InP (Expr a (Pat a), Int)
newtype PExpr a = InPE (Expr a (PExpr a), Int)

plus1 x@(InPE (_, loc)) = InPE (Many [x], loc)
one x l = InPE (One (plus1 x), l)

outP (InP x) = x

getPatNames p
  = case outP p of
      (One n, _)     -> [n]
      (Many ps, _) -> concatMap getPatNames ps

main = print (take 10 (map getPatNames (repeat (InP (One "n", 1)))))


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

-- !!! Functional dependencies
-- This one made the 5.00.1 typechecker go into an infinite loop.
-- The context simplifier keep thinking it was doing an 'improve'
-- step, and hence kept going round and round.

module Main where

main = print (get ((AttributeLeaf (MyLabel "x") 4)::Env1) (MyLabel "x"))

class Eq l => Domain d l | d -> l where
        (<<) :: d -> d -> d
        empty :: d
class Domain e l => Environment e l t | e -> l t where
        get :: e -> l -> Maybe t
        attribute :: l -> t -> e

class Eq' a where
        (=?=) :: a -> a -> Bool

newtype MyLabel = MyLabel String deriving Eq

instance Eq' MyLabel where
        l =?= l' = l == l'

data BinTreeEnv l t =
        EmptyEnv |
        AttributeLeaf l t |
        Union (BinTreeEnv l t) (BinTreeEnv l t)

instance (Eq l, Eq' l) => Domain (BinTreeEnv l t) l where
        EmptyEnv << d = d
        d << EmptyEnv = d
        d << d' = Union d d'
        empty = EmptyEnv

instance (Eq l, Eq' l) => Environment (BinTreeEnv l t) l t where
        get EmptyEnv l = Nothing
        get (AttributeLeaf l t) l' = if l =?= l' then Just t
                                     else Nothing
        get (Union d d') l = error "!??"

        attribute l t = AttributeLeaf l t

type Env1 = BinTreeEnv MyLabel Integer


{-# LANGUAGE ImplicitParams, Rank2Types #-}

-- !!! Implicit parameters, and Rank-2 types
-- This one made the 5.00.1 not print anything

module Main where

foo :: ((?x :: Int) => IO a) -> Int -> IO a
        -- Note the rank2 type
foo s z = do  let ?x = z   in s         -- Should pick up ?x = z
              let ?x = z+3 in s         -- Ditto z+3

main = foo (print ?x) 42


{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-}

class Monad m => C1 m x

class (Monad m, C1 m x) => C2 m x
  where
    c2 :: x -> m x

class C1 m x => C3 m x
  where
    c3 :: x -> m x

instance Monad m => C1 m Bool

instance C2 Maybe Bool
  where
    c2 = return

instance C3 Maybe Bool
  where
    c3 = return

main = do { print (c2 True :: Maybe Bool) ;
            print (c3 True :: Maybe Bool) }

------------------------------------------------------------------------
{-      Here's the email from Ralf Laemmel
        reporting a bug in Hugs

1. If you evaluate "test",
   then you get as expected "Just True".

2. Now remove the "Monad M" constraint
   in the class C2. [giving the class C3]
   This is of course legal and semantics-preserving
   since the monad constraints is implied by C1
   anyway.

3. Now evaluate "test" again. Oops, it diverges.

I did this Hugs Version February 2001 under Solaris
and Linux. Command line option -98 is needed of course.
Funny enough, if CTRL-C the evaluation of "test"
and you try it the second time (without reloading
anything etc.), then you see "Program error: {_Gc Black
Hole}". Of course, there is no such black hole.

I extracted the above fragment from a huge problem.
The scheme is the following. It seems have to do
with multi-parameter classes. It definitely has to
do with multi-layered class hierarchies where one
class has a class-wide superclass, as C2 has C1 in
the example. It seems that the superclass is
properly propagated during type-inference/checking
but it is not properly propagated, as for as code
determination in overloading resolution.

Please, let me know if I can be of further assistance.
I am actually amazed how general this scheme is
(3 classes, 2 parameters). How does it come that it
was not detected much earlier.

Anyway, good luck,
Ralf

P.S.: I have more problems in a larger application.
Certain overloaded expressions diverge. I can recover
from that usually by using explicit function types
for top-level functions, where again -- as in C1 above
-- I repeat some constraints which are derivable. I was
not able to extract a simple program for that problem.
But I would be glad to help you by checking if the
problem is gone after you did the bug fix.

--
Dr.-Ing. Ralf Laemmel
CWI & VU, Amsterdam, The Netherlands
http://www.cwi.nl/~ralf/
http://www.cs.vu.nl/~ralf/

-}


{-# LANGUAGE ImplicitParams, RankNTypes #-}

-- GHC 5.02 got this one wrong.

module Main where

-- Implicit parameters bug
-- mbs@cse.ogi.edu 24-Oct-2001 22:21:27

f :: (?x :: Int) => ((?x :: Int) => Int) -> Int -> Int
f g y = if y == 0
        then g
        else let ?x = ?x + 1
             in f g (y - 1)

h :: (?x :: Int) => Int
h = ?x

main = print (let ?x = 0 in f h 10)
-- The result should be 10!


{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-}

-- Hugs (2001) diverges when evaluating main, unless (Monad m) is
-- added as an extra superclass to C2, which should not be necessary.

module Main where

class Monad m => C1 m x

class (C1 m x) => C2 m x where
    c2 :: x -> m x

instance Monad m => C1 m Bool

instance C2 Maybe Bool where
    c2 = return

test :: Maybe Bool
test = c2 True

main = print test


{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies,
             TypeSynonymInstances, FlexibleInstances #-}

-- This bizarre program failed because TcSimplify built a loop of
-- dictionaries, due to an obscure bug in the way in which superclasses
-- were added

module Main where

import Data.List
import Data.Map

class (Ord oid) => Object o oid | o -> oid where

data Access oid

class (Object o oid) => SecurityModel model o oid | model -> o

class (SecurityModel model o oid) => SecurityPolicy policy model o oid where
    checkAccess :: policy -> model -> Access oid -> Bool
    checkAccess _ _ _ = True
    checkModel :: policy -> model -> Bool
    checkModel _ _ = True

------------------------------------------------------------
-- The Linux instance
------------------------------------------------------------

type LinuxObjectId = Either [String] String

data LinuxObject = File [String] deriving (Eq, Show)

instance Object LinuxObject LinuxObjectId

data LinuxSecurityModel =
    LinuxSecurityModel { lsmObjectSet   :: Map LinuxObjectId LinuxObject }

-- Now defined in Data.Map, don't think this affects the bug:
-- instance (Show a, Show b) => Show (Map a b) where
--     show fm = show (fmToList fm)

instance Show LinuxSecurityModel where
    show lsm = "LSM:" ++ "\tObjects:  " ++ show (lsmObjectSet lsm)

instance SecurityModel LinuxSecurityModel LinuxObject LinuxObjectId

data LinuxSecurityPolicy = LinuxSecurityPolicy
instance SecurityPolicy LinuxSecurityPolicy LinuxSecurityModel LinuxObject LinuxObjectId

model :: Map LinuxObjectId LinuxObject
model =  fromList [ (Left [], File []), (Left ["home"], File ["home"]) ]

--      works
-- model :: (LinuxObjectId, LinuxObject)
-- model =  (Left [], File [])

main :: IO ()
main = do { putStrLn (show model) }


-- This test checks in which way the type checker handles phantom types in
-- RULES.  We would like these type variables to be generalised, but some
-- versions of GHC instantiated them to `()', which seriously limited the
-- applicability of such RULES.

module Main (main)
where

data T a = C

foo :: T a -> String
{-# NOINLINE foo #-}
foo C = "rewrite rule did NOT fire"

{-# RULES

-- this rule will not fire if the type argument of `T' is constrained to `()'
--
"foo/C" foo C = "rewrite rule did fire"

 #-}

main = putStrLn $ foo (C :: T Int)


{-# LANGUAGE ImplicitParams #-}

-- Implicit parameters should not give rise to ambiguity.

module Main (main) where

foo :: (?x :: [a]) => Int -> String
foo n = show (n + length ?x)

main = do { putStrLn (let ?x = [True,False] in foo 3) ;
            putStrLn (let ?x = "fred"       in foo 4) }


{-# LANGUAGE ImplicitParams, TypeSynonymInstances, FlexibleInstances, ConstrainedClassMethods #-}

-- Class ops that bind no new type variables

module Main where

        import Data.List( sort )

        just = [Just "fred",Just "bill"]

        main = do { putStrLn (let ?p = "ok1" in fc1);
                    putStrLn (let ?p = "ok2" in fc2);
                    putStrLn (show (fd1 just)) ;
                    putStrLn (show (fd2 just)) }

        -- This class has no tyvars in its class op context
        -- One uses a newtype, the other a data type
        class C1 a where
            fc1 :: (?p :: String) => a;
        class C2 a where
            fc2 :: (?p :: String) => a;
            opc :: a

        instance C1 String where
            fc1 = ?p;
        instance C2 String where
            fc2 = ?p;
            opc = "x"

        -- This class constrains no new type variables in
        -- its class op context
        class D1 a where
            fd1 :: (Ord a) => [a] -> [a]
        class D2 a where
            fd2 :: (Ord a) => [a] -> [a]
            opd :: a

        instance D1 (Maybe a) where
            fd1 xs = sort xs
        instance D2 (Maybe a) where
            fd2 xs = sort xs
            opd = Nothing


{-# LANGUAGE ImplicitParams #-}

-- Like tcrun024, but cross module

module Main where
        import TcRun025_B

        just = [Just "fred",Just "bill"]

        main = do { putStrLn (let ?p = "ok1" in fc1);
                    putStrLn (let ?p = "ok2" in fc2);
                    putStrLn (show (fd1 just)) ;
                    putStrLn (show (fd2 just)) }