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

-- Similar to tc024, but cross module

module TcRun025_B where

        import Data.List( sort )

        -- 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 Rank2Types #-}

-- Crashed GHC 5.04 with tcTyC
--      panic: tcSplitTyConApp forall x{-r6S-} :: *.
--                              Main.L{-rr-} x{-r6S-}

-- GHC 6.3: this is now an error (can do subsumption in patterns)

module Main where

newtype FA c = FA (forall x . c x)
newtype L x = L [x]

my_nil = FA (L []) :: FA L

sample :: String
sample = case my_nil of FA (L x) -> "foo"++x

-- -- but this works fine
-- sample = case my_nil of FA x -> case x of L y -> "foo"++y

main = print sample


{-# LANGUAGE ImplicitParams #-}

-- Killed GHC 5.04.1

module Main where

type CTPar = ([Double],Int)

us :: (?ctPar :: CTPar) => [Double]
us = let (d,_) = ?ctPar in d

main = let ?ctPar = ([3.4],2) in print us


{-# OPTIONS_GHC -dcore-lint #-}
{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies,
             FlexibleInstances, UndecidableInstances #-}

-- This is a rather exotic functional-dependency test.
-- It crashed GHC 5.04.3 with a core-lint error, because
-- of a bug in tcSimplifyRestricted (fixed Apr 03)

module Main where

class ComposePS a b c | a b -> c where
    (.>) :: PSOp a -> PSOp b -> PSOp c
    (V a) .> (V b) = V (a ++ b)

instance (ConcatPS a b c, CheckPS c Id Id d) => ComposePS a b d

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

data PSOp a = V [String] deriving Show

data Id
data Push t rest
data Pop t rest

class Reverse a b c | a b -> c
instance                           Reverse Id b b
instance Reverse a (Pop t b)  c => Reverse (Pop t a) b c
instance Reverse a (Push t b) c => Reverse (Push t a) b c

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

class ConcatPS a b c | a b -> c where
    ccat :: a -> b -> c
instance ConcatPS Id a a
instance ConcatPS a b c => ConcatPS (Pop t a) b (Pop t c)
instance ConcatPS a b c => ConcatPS (Push t a) b (Push t c)

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

class CheckPS a b c d | a b c -> d where
    check :: a -> b -> c -> d
    check _ _ _ = error "oki"

instance Reverse a b c => CheckPS Id a b c

instance CheckPS a b (Push t c) d => CheckPS (Push t a) b c d

instance CheckPS a (Pop t b) Id d => CheckPS (Pop t a) b Id d

instance CheckPS a b c d => CheckPS (Pop t a) b (Push t c) d

v1 :: PSOp (Pop a Id)
v1 = V []

v2 :: PSOp Id
v2 = V []

t = v1 .> v2

main = print t


{-# LANGUAGE DatatypeContexts #-}
-- Killed GHC 5.02.3

-- Confusion about whether the wrapper for a data constructor
-- with a "stupid context" includes the stupid context or not
-- Core lint catches it, but it seg-faults if it runs

module Main where

data Color = Red
           | Black
             deriving Show

data Ord k => Tree k d = None
                       | Node{color::Color,
                              key::k,
                              item::d,
                              left::(Tree k d),
                              right::(Tree k d)}
                         deriving Show

insert k i t = (insert2 t) {color=Black}
    where insert2 None = Node{color=Red,
                              key=k,
                              item=i,
                              left=None,
                              right=None}

main = print (insert 1 2 None)


{-# LANGUAGE UndecidableInstances #-}

-- Test recursive dictionaries

module Main where

data D r = ZeroD | SuccD (r (D r));

instance (Eq (r (D r))) => Eq (D r) where
    ZeroD     == ZeroD     = True
    (SuccD a) == (SuccD b) = a == b
    _         == _         = False;

equalDC :: D [] -> D [] -> Bool;
equalDC = (==);

foo :: D []
foo = SuccD [SuccD [ZeroD], ZeroD]

main = print (foo == foo)


{-# LANGUAGE MultiParamTypeClasses, GeneralizedNewtypeDeriving #-}

-- A newtype-deriving test

module Main where

class C a b where
  op :: a -> b -> b
instance C [a] Char where
  op [] x = x
  op _  x = 'z'

newtype T = T Char deriving( Show, C [a] )

main = do { print (op [] 'x')
          ; print (op [] (T 'y')) }


{-# LANGUAGE UndecidableInstances #-}

-- This tests the recursive-dictionary stuff.

module Main where

data Fix f = In (f (Fix f))

instance Show (f (Fix f)) => Show (Fix f) where
  show (In x) = "In " ++ show x -- No parens, but never mind

instance Eq (f (Fix f)) => Eq (Fix f) where
  (In x) == (In y) = x==y

data L x = Nil | Cons Int x  deriving( Show, Eq )

main = do { print (In Nil);
            print (In Nil == In Nil) }


{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FlexibleContexts,
             UndecidableInstances, TypeSynonymInstances #-}

-- This test made GHC 6.3 build a superclass loop, in
-- the instance ClassA a String declaration

module Main where

class (Sat (a -> b -> String), ClassB b) => ClassA a b

class ClassB a where
  fun :: a -> String

class Sat x where
   sat :: x

instance ClassA a b => Sat (a -> b -> String) where
  sat = const fun

instance ClassA a String
-- Badness was that the ClassB superclass dict was loopy
--
-- Needs Sat (a -> String -> String), ClassB String
-- --> ClassA a String, ClassB String
-- and adding ClassA gives superclass ClassB.

instance ClassB String where
  fun = id

main = print ((sat :: Int -> String -> String) 3 "hello")


{-# LANGUAGE ExplicitForAll, TypeOperators #-}

module Main where

-- Infix type operator
f1 :: forall m a b. (a `m` b) -> ((a `m` b) -> a) -> a
f1 x g = g x

-- Infix type operator..  Commented out because we no longer
-- infix operators to be variables; they are type constructors
-- f2 :: forall a b (-->). (a --> b) -> ((a --> b) -> b) -> b
-- f2 x g = g x

main = do { print (f1 (3,5) fst)
--        ; print (f2 (3,5) snd)
          }


{-# LANGUAGE Rank2Types #-}

-- Tests subsumption for infix operators (in this case (.))
-- Broke GHC 6.4!

-- Now it breaks the impredicativity story
--   (id {a}) . (id {a}) :: a -> a
-- And (forall m. Monad m => m a) /~ IO a

module Main(main) where

foo :: (forall m. Monad m => m a) -> IO a
foo = id . id

main :: IO ()
main = foo (return ())


{-# LANGUAGE Rank2Types #-}

-- Another test for the new feature that contexts in a mutually
-- recursive group do not need to be of the same length
-- I'm putting it here mainly to document the need

-- GHC used to say:
--
-- Bug.lhs:23:10:
--     Inferred type is less polymorphic than expected
--      Quantified type variable `c' is mentioned in the environment:
--        printCatalog :: c -> IO () (bound at Bug.lhs:28:0)
--    In the `viewCatalog' field of a record

-- Bug.lhs:27:0:
--    Contexts differ in length
--    When matching the contexts of the signatures for
--      printer :: Viewer
--      printCatalog :: forall c. (Catalog c) => View c
--    The signature contexts in a mutually recursive group should all be identical

module Main where

import Prelude hiding (traverse)

class Catalog c where
  mtraverse :: c -> Viewer -> IO ()

instance Catalog Int where
  mtraverse i v = viewShowable v i

type View a = a -> IO ()

data Viewer = Viewer {
    viewShowable :: forall s. Show s => View s,
    viewCatalog :: forall c. Catalog c => View c
  }

printer :: Viewer
--printer = Viewer {
--  viewCatalog = \x -> mtraverse x printer,
--  viewShowable = putStrLn . show }
printer = Viewer {
  viewCatalog = printCatalog,
  viewShowable = putStrLn . show }

printCatalog :: forall c. Catalog c => View c
printCatalog x = mtraverse x printer

data X = X {
    cat :: Int
  }

instance Catalog X where
  mtraverse x v = do
    viewCatalog v (cat x)

main = do
  let x = X { cat = 20 }
  mtraverse x printer


{-# LANGUAGE ConstrainedClassMethods #-}

module Main where

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

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

main = do { putStrLn (op True 'x'); putStrLn (op False (3::Int)) }


module Main where

import TcRun038_B( Foo(..), bar )

instance Foo Int where
  op x = x+1

main = print (bar (3::Int))


{-# LANGUAGE FlexibleContexts #-}

module TcRun038_B where

class Foo a where
  op :: a -> Int

-- Note the (Foo Int) constraint here; and the fact
-- that there is no (Foo Int) instance in this module
-- It's in the importing module!

bar :: Foo Int => Int -> Int
bar x = op x + 7


{-# LANGUAGE GADTs, ExplicitForAll #-}

-- Test for GADTs and implication constraints

module Main where

data T a where
  MkT :: Num a => a -> T a

f :: Read a => T a -> String -> a
f (MkT n) s = n + read s

----------------
data GADT a where
  MkG :: Num a => a -> GADT [a]

g :: forall b. Read b => GADT b -> String -> b
g (MkG n) s = -- Here we know Read [b]
              n : (read s)

main = do print (f (MkT (3::Int)) "4")
          print (g (MkG (3::Int)) "[4,5]")


-- Sven Panne found this example; a mistake in typechecking
-- lazy patterns made functions too strict in a version of
-- GHC 6.7

module Main where

import Foreign

-- Strangely enough, this works if newtype is used...
data Elem a = Elem a

instance Storable a => Storable (Elem a) where
   sizeOf ~(Elem r) = 3 * sizeOf r
   alignment ~(Elem r) = alignment r
   peek ptr = do r <- peekElemOff (castPtr ptr) 0; return (Elem r)
   poke ptr (Elem r) = poke (castPtr ptr) r

main :: IO ()
main = do
   putStrLn "*** main 1"
   allocaBytes 100 $ \buf -> do
      poke buf (Elem 12345)
      putStrLn "*** main 2"
      Elem x <- peekElemOff buf 0
      print (x :: Int)
      putStrLn "*** main 3"


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

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

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

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

d = (,1,)

e = (# , True #)

f = (# 1, #)

g = (# , True || False #)

h = (# ,1, #)

unchanged :: a -> (# Int #)
unchanged _binding = (# 1 #)

main = do
    print (a 1, b False, c "Hello", c 1337, d "Yeah" "Baby")
    case e 1 of { (# x1, x2 #) ->
    case f False of { (# x3, x4 #) ->
    case g "Hello" of { (# x5, x6 #) ->
    case g 1337 of { (# x7, x8 #) ->
    case h "Yeah" "Baby" of { (# x9, x10, x11 #) ->
    print (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11) }}}}}


{-# LANGUAGE TupleSections, RankNTypes, ImpredicativeTypes #-}

-- Sept 16: This test involves wholesale use of impredicative polymorphism
--          and I'm amazed it has worked for so long. Anyway it is now
--          failing, which is OK.  We don't really support impredicative
--          polymorphism!
--
-- The test was added by Max in 5e8ff849, apparently to test tuple sections

module Main where

e :: a -> (forall b. b -> b -> b) -> (a, String, forall c. c -> c -> c)
e = (,"Hello" ++ "World",)

dropFunction :: (a, String, forall c. c -> c -> c) -> (a, String, Int)
dropFunction (x, y, z) = (x, y, z 10 20)

main = print (dropFunction $ e "Meh" (flip const), dropFunction $ e 10 const)


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

import GHC.Exts ( Constraint )

type Showish = Show

f :: (Showish a) => a -> String
f x = show x ++ show x

data T = T
data F = F

data GADT a where
    Tish :: GADT T
    Fish :: GADT F

type family Indexed a b :: Constraint
type instance Indexed T b = Show b
type instance Indexed F b = Num b

g :: (Indexed a b) => GADT a -> b -> Either String b
g Tish x = Left (show x)
g Fish x = Right (x + 1)

type TwoConstraints a = (Show a, Num a)

-- We'll NOINLINE h so that we test the code generation for
-- constraint tuples
{-# NOINLINE h #-}
h :: TwoConstraints a => a -> String
h x = show (x + 1)

main :: IO ()
main = do
    print $ f 9
    print $ f True

    print $ g Tish 10
    print $ g Tish False
    print $ g Fish 11
    print $ g Fish 12.0

    print $ h 13
    print $ h 14.0


{-# LANGUAGE TypeFamilies, ConstraintKinds #-}

import qualified Data.Set as S
import GHC.Exts ( Constraint )

class RMonad m where
    type RMonadCtxt m a :: Constraint
    returnR :: (RMonadCtxt m a) => a -> m a
    bindR :: (RMonadCtxt m a, RMonadCtxt m b) => m a -> (a -> m b) -> m b

instance RMonad [] where
    type RMonadCtxt [] a = ()
    returnR x = [x]
    bindR = flip concatMap

instance RMonad S.Set where
    type RMonadCtxt S.Set a = Ord a
    returnR x = S.singleton x
    bindR mx fxmy = S.fromList [y | x <- S.toList mx, y <- S.toList (fxmy x)]

main = do
    print $ (returnR 1 ++        returnR 2) `bindR`
            (\x -> returnR (x + 1) ++        returnR (x + 2))
    print $ (returnR 1 `S.union` returnR 2) `bindR`
            (\x -> returnR (x + 1) `S.union` returnR (x + 2))


{-# LANGUAGE ImplicitParams, FlexibleContexts #-}

-- !!! Implicit parameter superclass constraint
-- These examples actually crashed GHC 4.08.2

module Main where

class C t where
    methodC :: t -> t

instance (?imp :: Int) => C Int where
    methodC x = ?imp + x

-- Check implicit parameter constraints in instance heads
test1 :: Int
test1 = methodC 10
  where ?imp = 2

test2 :: (?imp :: Int) => Int
test2 = methodC 20
  where ?imp = 2

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

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

-- Check implicit parameter constraints in *superclass*, not just in instances
test3 :: Int
test3 = methodD 10
  where ?imp = 2

test4 :: (?imp :: Int) => Int
test4 = methodD 20
  where ?imp = 2

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

main = do
    print test1
    print $ let ?imp = 3 in test2
    print test3
    print $ let ?imp = 3 in test4
    print $ let ?imp = 3 in test5


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

module Main where

-- Here we abstract over a *constraint*!
-- T :: Constraint -> *

data T a where
  MkT :: a => T a

f :: T (Ord x) -> x -> Bool
f MkT x = x > x

g :: T (Ord Int)
g = MkT

main = print (f g 4)


{-# LANGUAGE UnboxedTuples #-}

-- !!! Check that unboxed tuples can be function arguments
module Main where

data Ex = Ex (# Int,Int #)

{-# NOINLINE f #-} -- Make it harder to get right
f :: (# Int,Int #) -> Int
f x = error "urk"

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

main = print $ g (Ex (# 10, f (# 20, 30 #) #))


{-# LANGUAGE MagicHash, UnboxedTuples #-}

module Main where

import GHC.Prim (Int#, Double#)

main :: IO ()
main = let f = int2Integer# 0# in putStrLn ""

{-# NOINLINE int2Integer# #-}
int2Integer# :: Int# -> (# Int#, Double# #)
int2Integer# x = (# x, 1.0## #)


{-# LANGUAGE UnboxedTuples #-}

module Main where

type T a = Int -> (# Int, Int #)

{-# NOINLINE f2 #-}
f2 :: T a -> T a
f2 t = \x -> case t x of _ -> (# 3,4 #) -- NB: wildcard has unboxed tuple type

main = print $ case f2 (\x -> (# x, x + 1 #)) 10 of (# y, z #) -> y + z


{-# LANGUAGE UnboxedTuples #-}

module Main where

type T a = Int -> (# Int, Int #)

{-# NOINLINE g #-}
--g :: (# Int, Int #) -> (# Int, Int #)
g t =  case t of r -> (r :: (# Int, Int #))

{-# NOINLINE f #-}
f :: T a -> T a
f t = \x -> case t x of r -> r

main = print $ case f (\x -> g (# x, x + 1 #)) 10 of (# y, z #) -> y + z


{-# LANGUAGE UnboxedTuples #-}

module Main where

-- Tests unboxed tuple slow calls

{-# NOINLINE g #-}
g :: Int -> (# Int, Int #) -> Int -> (# Int, (# Int #) #) -> (# #) -> Int
g a (# b, c #) d (# e, (# f #) #) (# #) = a + b + c + d + e + f

{-# NOINLINE h #-}
h :: (Int -> (# Int, Int #) -> Int -> (# Int, (# Int #) #) -> (# #) -> Int) -> (Int, Int)
h g = (g5, g5')
  where
    -- Apply all the arguments at once
    g5' = g 1 (# 2, 3 #) 4 (# 5, (# 6 #) #) (# #)

    -- Try to force argument-at-a-time application as a stress-test
    g1 = g 1
    g2 = g1 `seq` g1 (# 2, 3 #)
    g3 = g2 `seq` g2 4
    g4 = g3 `seq` g3 (# 5, (# 6 #) #)
    g5 = g4 `seq` g4 (# #)

main = print $ h g


{-# LANGUAGE DataKinds, TypeOperators, TypeFamilies #-}
module Main(main) where
import GHC.TypeLits as L
import Data.Proxy

--------------------------------------------------------------------------------
-- Test top-reactions

tsub :: Proxy (x + y) -> Proxy y -> Proxy x
tsub _ _ = Proxy

tsub2 :: Proxy (x + y) -> (Proxy x, Proxy y)
tsub2 _ = (Proxy, Proxy)

tdiv :: Proxy (x L.* y) -> Proxy y -> Proxy x
tdiv _ _ = Proxy

tdiv2 :: Proxy (x L.* y) -> (Proxy x, Proxy y)
tdiv2 _ = (Proxy, Proxy)

troot :: Proxy (x ^ y) -> Proxy y -> Proxy x
troot _ _ = Proxy

tlog :: Proxy (x ^ y) -> Proxy x -> Proxy y
tlog _ _ = Proxy

tleq :: ((x <=? y) ~ True) => Proxy y -> Proxy x
tleq _ = Proxy

main :: IO ()
main = print [ sh (tsub  (Proxy :: Proxy 5) (Proxy :: Proxy 3)) == "2"
             , let (p, q) = tsub2 (Proxy :: Proxy 0)
               in (sh p, sh q) == ("0", "0")
             , sh (tdiv  (Proxy :: Proxy 8) (Proxy :: Proxy 2)) == "4"
             , let (p, q) = tdiv2 (Proxy :: Proxy 1)
               in (sh p, sh q) == ("1", "1")
             , sh (troot (Proxy :: Proxy 9) (Proxy :: Proxy 2)) == "3"
             , sh (tlog  (Proxy :: Proxy 8) (Proxy :: Proxy 2)) == "3"
             , sh (tleq  (Proxy :: Proxy 0))                    == "0"
             ]
  where
  sh x = show (natVal x)


{-# LANGUAGE DataKinds, TypeOperators, TypeFamilies #-}
module Main(main) where
import GHC.TypeLits
import Data.Proxy

--------------------------------------------------------------------------------
-- Test top-reactions

tappend :: Proxy (AppendSymbol x y) -> Proxy x -> Proxy y
tappend _ _ = Proxy

tappend2 :: Proxy (AppendSymbol x y) -> (Proxy x, Proxy y)
tappend2 _ = (Proxy, Proxy)

main :: IO ()
main = print [ symbolVal (tappend (Proxy :: Proxy "abc") (Proxy :: Proxy "ab"))
               == "c"
             , let (p, q) = tappend2 (Proxy :: Proxy "")
               in (symbolVal p, symbolVal q) == ("", "")
             ]
  where
  sh x = show (natVal x)


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

--
-- Test case adopted from the HList library
-- http://www.cwi.nl/~ralf/HList/
--
-- Tests functional dependencies, overlapping instances....

module Main where

--
-- Type-level Booleans; nothing weird
--
data HTrue; hTrue :: HTrue; hTrue = undefined
data HFalse; hFalse :: HFalse; hFalse = undefined
class HBool x; instance HBool HTrue; instance HBool HFalse
instance Show HTrue where show _ = "HTrue"
instance Show HFalse where show _ = "HFalse"

--
-- Value-level incarnation; nothing too weird.
-- Rely on lazy show for type-level Booleans
--
typeEq :: TypeEq t t' b => t -> t' -> b
typeEq = undefined

--
-- Type-level cast
--
class TypeCast   a b   | a -> b, b->a   where typeCast   :: a -> b
class TypeCast'  t a b | t a -> b, t b -> a where typeCast'  :: t->a->b
class TypeCast'' t a b | t a -> b, t b -> a where typeCast'' :: t->a->b
instance TypeCast'  () a b => TypeCast a b where typeCast x = typeCast' () x
instance TypeCast'' t a b => TypeCast' t a b where typeCast' = typeCast''
instance TypeCast'' () a a where typeCast'' _ x  = x

--
-- Type-level type equality
--

class TypeEq' () x y b => TypeEq x y b | x y -> b
class TypeEq' q x y b | q x y -> b
class TypeEq'' q x y b | q x y -> b
instance TypeEq' () x y b => TypeEq x y b
-- This instance used to work <= GHC 6.2
-- instance TypeEq' () x x HTrue
-- There were some problems however with GHC CVS 6.3.
-- So we favour the following, more stable (?) instance instead.
instance TypeCast b HTrue => TypeEq' () x x b
instance TypeEq'' q x y b => TypeEq' q x y b
instance TypeEq'' () x y HFalse

--
-- Let's test.
-- The following should print "(HTrue,HFalse)".
--

main = print $ ( typeEq "42" "88"
               , typeEq "42" (42::Int)
               )


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

import qualified Data.ByteString as BS
import Type.Reflection
import Data.Binary
import GHCi.TH.Binary ()

import GHC.Exts
import Data.Kind
import Data.Proxy

testRoundtrip :: Typeable a => TypeRep a -> IO ()
testRoundtrip rep
  | rep /= rep' = putStrLn $ "bad: " ++ show rep ++ " /= " ++ show rep'
  | otherwise   = putStrLn $ "good: " ++ show rep
  where
    rep' = decode (encode rep)

main :: IO ()
main = do
    testRoundtrip (typeRep :: TypeRep Int)
    testRoundtrip (typeRep :: TypeRep Int#)
    testRoundtrip (typeRep :: TypeRep IO)
    testRoundtrip (typeRep :: TypeRep Maybe)
    testRoundtrip (typeRep :: TypeRep TYPE)
    testRoundtrip (typeRep :: TypeRep RuntimeRep)
    testRoundtrip (typeRep :: TypeRep 'IntRep)
    testRoundtrip (typeRep :: TypeRep (->))
    testRoundtrip (typeRep :: TypeRep (Proxy Int))
    testRoundtrip (typeRep :: TypeRep (Proxy Int#))
    testRoundtrip (typeRep :: TypeRep Type)
    testRoundtrip (typeRep :: TypeRep (Int -> Int))
    testRoundtrip (typeRep :: TypeRep 5)
    testRoundtrip (typeRep :: TypeRep "hello world")
    testRoundtrip (typeRep :: TypeRep ('Just 5))


{-# LANGUAGE PolyKinds #-}

import Type.Reflection
import Data.Kind

data ComposeK (f :: k' -> Type) (g :: k -> k') a = ComposeK (f (g a))

main :: IO ()
main = do
    let x :: ComposeK Maybe Maybe Int
        x = undefined

    App x y <- pure $ typeOf x
    print (x, y)

    App x y <- pure x
    print (x, y)

    App x y <- pure x
    print (x, y)

    App x y <- pure x   -- This makes GHC panic
    print (x, y)


{-# LANGUAGE PolyKinds, TypeFamilies #-}

-- | Test equality predicates of Type.Reflection.
module Main where

import Type.Reflection
import Data.Kind
import Data.Maybe
import Data.Proxy
import Data.Functor.Const
import Data.Functor.Product

--data Product (f :: k -> Type) (g :: k -> Type) (a :: k)
--    = Product (f x) (g x)

test1 :: IO ()
test1 = do
    let x = typeRep :: TypeRep (Maybe String)
        y = typeRep :: TypeRep (Maybe Int)

    checkEq False x y
    App maybe1 _ <- pure x
    App maybe2 _ <- pure y
    checkEq True maybe1 maybe2

test2 :: IO ()
test2 = do
    let x = typeRep :: TypeRep (Proxy String)
        y = typeRep :: TypeRep (Proxy Int)

    checkEq False x y
    App proxy1 _ <- pure x
    App proxy2 _ <- pure y
    checkEq True proxy1 proxy2

test3 :: IO ()
test3 = do
    let x = typeRep :: TypeRep (Product (Const String) (Const Int) Int)
        y = typeRep :: TypeRep (Product (Const String) (Const Char) Int)
    checkEq False x y
    App dx _ <- pure x   -- "d" stands for decomposed
    App dy _ <- pure y
    checkEq False dx dy
    App ddx _ <- pure dx
    App ddy _ <- pure dy
    checkEq True ddx ddy

test4 :: IO ()
test4 = do
    let x = typeRep :: TypeRep (Product (Const String) (Const Int) Int)
        y = typeRep :: TypeRep (Product (Const String) (Const Int) Char)

    checkEq False x y
    App dx _ <- pure x
    App dy _ <- pure y
    checkEq True dx dy
    App ddx _ <- pure dx
    App ddy _ <- pure dy
    checkEq True ddx ddy

main :: IO ()
main = sequence_ [test1, test2, test3, test4]

type IsEqual = Bool

check :: Bool -> String -> IO ()
check success msg = putStrLn $ goodBad ++ " " ++ msg
  where goodBad
          | success    = "good"
          | otherwise  = "bad "

checkEq :: IsEqual -> TypeRep a -> TypeRep b -> IO ()
checkEq expected a b =
    check success (show a ++ " == " ++ show b ++ "?")
  where success = isJust (a `eqTypeRep` b) == expected


{-# LANGUAGE DataKinds, UnicodeSyntax #-}
{-# OPTIONS -Wno-star-is-type #-}

import Data.Typeable
import GHC.Types

-- Test that Typeable works for various wired-in types.
-- See, for instance, #11120.

main :: IO ()
main = do
  print $ typeOf "hello world"
  print $ typeOf '4'
  print $ typeOf (42 :: Int)
  print $ typeOf (42 :: Word)
  print $ typeOf (3.1415 :: Double)
  print $ typeOf (return () :: IO ())
  print $ typeOf ('a', 1::Int, "hello")
  print $ typeOf (typeOf "hi")
  print $ typeOf True
  print $ typeOf EQ
  print $ typeOf (id :: Int -> Int)

  print $ typeOf (Proxy :: Proxy (Eq Int))
  print $ typeOf (Proxy :: Proxy (Int, Int))
  print $ typeOf (Proxy :: Proxy "hello world")
  print $ typeOf (Proxy :: Proxy 1)
  print $ typeOf (Proxy :: Proxy [1,2,3])
  print $ typeOf (Proxy :: Proxy 'EQ)
  print $ typeOf (Proxy :: Proxy TYPE)
  print $ typeOf (Proxy :: Proxy (TYPE 'LiftedRep))
  print $ typeOf (Proxy :: Proxy *)
  print $ typeOf (Proxy :: Proxy â˜…)
  print $ typeOf (Proxy :: Proxy 'LiftedRep)
  print $ typeOf (Proxy :: Proxy '(1, "hello"))
  print $ typeOf (Proxy :: Proxy (~~))


{-# LANGUAGE DataKinds #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE UnboxedTuples #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE StarIsType #-}
{-# LANGUAGE UnicodeSyntax #-}

{-# OPTIONS -Wno-star-is-type #-}

import Data.Typeable
import Data.Kind
import GHC.Exts

-- Test that Typeable works for various wired-in types.
-- See, for instance, #11120.

rep :: forall a. Typeable a => TypeRep
rep = typeRep (Proxy :: Proxy a)

main :: IO ()
main = do
  -- the basics
  print $ rep @String
  print $ rep @Char
  print $ rep @Int
  print $ rep @Word
  print $ rep @Double
  print $ rep @(IO ())
  print $ rep @IO
  print $ rep @"hi"
  print $ rep @(Char, Int, String)
  print $ rep @Bool
  print $ rep @Ordering
  print $ rep @(Int -> Int)
  print $ rep @((Eq Int, Eq String) :: Constraint)

  -- Unboxed things (#12049)
  print $ rep @Int#
  print $ rep @(##)
  print $ rep @(# Int#, Int #)

  -- Various instantiations of a kind-polymorphic type
  print $ rep @(Proxy (Eq Int))
  print $ rep @(Proxy (Int, Int))
  print $ rep @(Proxy "hello world")
  print $ rep @(Proxy 1)
  print $ rep @(Proxy [1,2,3])
  print $ rep @(Proxy 'EQ)
  print $ rep @(Proxy TYPE)
  print $ rep @(Proxy (TYPE 'LiftedRep))
  print $ rep @(Proxy *)
  print $ rep @(Proxy â˜…)
  print $ rep @(Proxy 'LiftedRep)

  -- Something lifted and primitive
  print $ rep @RealWorld  -- #12132


{-# LANGUAGE UndecidableInstances, OverlappingInstances, Rank2Types,
    KindSignatures, EmptyDataDecls, MultiParamTypeClasses, CPP #-}

{-

(C) 2004--2005 Ralf Laemmel, Simon D. Foster

This module approximates Data.Generics.Basics.

-}

module T1735_Help.Basics (

 module Data.Typeable,
 module T1735_Help.Context,
 module T1735_Help.Basics

) where

import Data.Typeable
import T1735_Help.Context

------------------------------------------------------------------------------
-- The ingenious Data class

class (Typeable a, Sat (ctx a)) => Data ctx a

   where

     gfoldl :: Proxy ctx
            -> (forall b c. Data ctx b => w (b -> c) -> b -> w c)
            -> (forall g. g -> w g)
            -> a -> w a

     -- Default definition for gfoldl
     -- which copes immediately with basic datatypes
     --
     gfoldl _ _ z = z

     gunfold :: Proxy ctx
             -> (forall b r. Data ctx b => c (b -> r) -> c r)
             -> (forall r. r -> c r)
             -> Constr
             -> c a

     toConstr :: Proxy ctx -> a -> Constr

     dataTypeOf :: Proxy ctx -> a -> DataType

     -- incomplete implementation

     gunfold _ _ _ _ = undefined

     dataTypeOf _ _ = undefined

     -- | Mediate types and unary type constructors
     dataCast1 :: Typeable t
               => Proxy ctx
               -> (forall b. Data ctx b => w (t b))
               -> Maybe (w a)
     dataCast1 _ _ = Nothing

     -- | Mediate types and binary type constructors
     dataCast2 :: Typeable t
               => Proxy ctx
               -> (forall b c. (Data ctx b, Data ctx c) => w (t b c))
               -> Maybe (w a)
     dataCast2 _ _ = Nothing

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

-- Generic transformations

type GenericT ctx = forall a. Data ctx a => a -> a

-- Generic map for transformations

gmapT :: Proxy ctx -> GenericT ctx -> GenericT ctx

gmapT ctx f x = unID (gfoldl ctx k ID x)
  where
    k (ID g) y = ID (g (f y))

-- The identity type constructor

newtype ID x = ID { unID :: x }

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

-- Generic monadic transformations

type GenericM m ctx = forall a. Data ctx a => a -> m a

-- Generic map for monadic transformations

gmapM :: Monad m => Proxy ctx -> GenericM m ctx -> GenericM m ctx
gmapM ctx f = gfoldl ctx k return
    where k c x = do c' <- c
                     x' <- f x
                     return (c' x')

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

-- Generic queries

type GenericQ ctx r = forall a. Data ctx a => a -> r

-- Map for queries

gmapQ :: Proxy ctx -> GenericQ ctx r -> GenericQ ctx [r]
gmapQ ctx f = gmapQr ctx (:) [] f

gmapQr :: Data ctx a
       => Proxy ctx
       -> (r' -> r -> r)
       -> r
       -> GenericQ ctx r'
       -> a
       -> r
gmapQr ctx o r f x = unQr (gfoldl ctx k (const (Qr id)) x) r
  where
    k (Qr g) y = Qr (\s -> g (f y `o` s))

-- The type constructor used in definition of gmapQr
newtype Qr r a = Qr { unQr  :: r -> r }

------------------------------------------------------------------------------
--
-- Generic unfolding
--
------------------------------------------------------------------------------

-- | Build a term skeleton
fromConstr :: Data ctx a => Proxy ctx -> Constr -> a
fromConstr ctx = fromConstrB ctx undefined

-- | Build a term and use a generic function for subterms
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

-- | Monadic variation on \"fromConstrB\"
fromConstrM :: (Monad m, Data ctx a)
            => Proxy ctx
            -> (forall b. Data ctx b => m b)
            -> Constr
            -> m a
fromConstrM ctx f = gunfold ctx k z
 where
  k c = do { c' <- c; b <- f; return (c' b) }
  z = return

------------------------------------------------------------------------------
--
-- Datatype and constructor representations
--
------------------------------------------------------------------------------

--
-- | Representation of datatypes.
-- | A package of constructor representations with names of type and module.
-- | The list of constructors could be an array, a balanced tree, or others.
--
data DataType = DataType
                        { tycon   :: String
                        , datarep :: DataRep
                        }

              deriving Show

-- | Representation of constructors
data Constr = Constr
                        { conrep    :: ConstrRep
                        , constring :: String
                        , confields :: [String] -- for AlgRep only
                        , confixity :: Fixity   -- for AlgRep only
                        , datatype  :: DataType
                        }

instance Show Constr where
 show = constring

-- | Equality of constructors
instance Eq Constr where
  c == c' = constrRep c == constrRep c'

-- | Public representation of datatypes
data DataRep = AlgRep [Constr]
             | IntRep
             | FloatRep
             | StringRep
             | NoRep

            deriving (Eq,Show)

-- | Public representation of constructors
data ConstrRep = AlgConstr    ConIndex
               | IntConstr    Integer
               | FloatConstr  Double
               | StringConstr String

               deriving (Eq,Show)

--
-- | Unique index for datatype constructors.
-- | Textual order is respected. Starts at 1.
--
type ConIndex = Int

-- | Fixity of constructors
data Fixity = Prefix
            | Infix  -- Later: add associativity and precedence

            deriving (Eq,Show)

------------------------------------------------------------------------------
--
-- Observers for datatype representations
--
------------------------------------------------------------------------------

-- | Gets the type constructor including the module
dataTypeName :: DataType -> String
dataTypeName = tycon

-- | Gets the public presentation of datatypes
dataTypeRep :: DataType -> DataRep
dataTypeRep = datarep

-- | Gets the datatype of a constructor
constrType :: Constr -> DataType
constrType = datatype

-- | Gets the public presentation of constructors
constrRep :: Constr -> ConstrRep
constrRep = conrep

-- | Look up a constructor by its representation
repConstr :: DataType -> ConstrRep -> Constr
repConstr dt cr =
      case (dataTypeRep dt, cr) of
        (AlgRep cs, AlgConstr i)      -> cs !! (i-1)
        (IntRep,    IntConstr i)      -> mkIntConstr dt i
        (FloatRep,  FloatConstr f)    -> mkFloatConstr dt f
        (StringRep, StringConstr str) -> mkStringConstr dt str
        _ -> error "repConstr"

------------------------------------------------------------------------------
--
-- Representations of algebraic data types
--
------------------------------------------------------------------------------

-- | 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
                        _ -> error "dataTypeConstrs"

-- | Gets the field labels of a constructor
constrFields :: Constr -> [String]
constrFields = confields

-- | Gets the fixity of a constructor
constrFixity :: Constr -> Fixity
constrFixity = confixity

------------------------------------------------------------------------------
--
-- From strings to constr's and vice versa: all data types
--
------------------------------------------------------------------------------

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

-- | Lookup a constructor via a string
readConstr :: DataType -> String -> Maybe Constr
readConstr dt str =
      case dataTypeRep dt of
        AlgRep cons -> idx cons
        IntRep      -> mkReadCon (\i -> (mkPrimCon dt str (IntConstr i)))
        FloatRep    -> mkReadCon (\f -> (mkPrimCon dt str (FloatConstr f)))
        StringRep   -> Just (mkStringConstr dt str)
        NoRep       -> Nothing
  where

    -- Read a value and build a constructor
    mkReadCon :: Read t => (t -> Constr) -> Maybe Constr
    mkReadCon f = case (reads str) of
                    [(t,"")] -> Just (f t)
                    _ -> Nothing

    -- Traverse list of algebraic datatype constructors
    idx :: [Constr] -> Maybe Constr
    idx cons = let fit = filter ((==) str . showConstr) cons
                in if fit == []
                     then Nothing
                     else Just (head fit)

------------------------------------------------------------------------------
--
-- Convenience functions: algebraic data types
--
------------------------------------------------------------------------------

-- | Test for an algebraic type
isAlgType :: DataType -> Bool
isAlgType dt = case datarep dt of
                 (AlgRep _) -> True
                 _ -> False

-- | Gets the constructor for an index
indexConstr :: DataType -> ConIndex -> Constr
indexConstr dt idx = case datarep dt of
                        (AlgRep cs) -> cs !! (idx-1)
                        _           -> error "indexConstr"

-- | Gets the index of a constructor
constrIndex :: Constr -> ConIndex
constrIndex con = case constrRep con of
                    (AlgConstr idx) -> idx
                    _ -> error "constrIndex"

-- | Gets the maximum constructor index
maxConstrIndex :: DataType -> ConIndex
maxConstrIndex dt = case dataTypeRep dt of
                        AlgRep cs -> length cs
                        _         -> error "maxConstrIndex"

------------------------------------------------------------------------------
--
-- Representation of primitive types
--
------------------------------------------------------------------------------

-- | Constructs the Int type
mkIntType :: String -> DataType
mkIntType = mkPrimType IntRep

-- | Constructs the Float type
mkFloatType :: String -> DataType
mkFloatType = mkPrimType FloatRep

-- | Constructs the String type
mkStringType :: String -> DataType
mkStringType = mkPrimType StringRep

-- | Helper for mkIntType, mkFloatType, mkStringType
mkPrimType :: DataRep -> String -> DataType
mkPrimType dr str = DataType
                        { tycon   = str
                        , datarep = dr
                        }

-- Makes a constructor for primitive types
mkPrimCon :: DataType -> String -> ConstrRep -> Constr
mkPrimCon dt str cr = Constr
                        { datatype  = dt
                        , conrep    = cr
                        , constring = str
                        , confields = error $ concat ["constrFields : ", (tycon dt), " is primative"]
                        , confixity = error "constrFixity"
                        }

mkIntConstr :: DataType -> Integer -> Constr
mkIntConstr dt i = case datarep dt of
                  IntRep -> mkPrimCon dt (show i) (IntConstr i)
                  _ -> error "mkIntConstr"

mkFloatConstr :: DataType -> Double -> Constr
mkFloatConstr dt f = case datarep dt of
                    FloatRep -> mkPrimCon dt (show f) (FloatConstr f)
                    _ -> error "mkFloatConstr"

mkStringConstr :: DataType -> String -> Constr
mkStringConstr dt str = case datarep dt of
                       StringRep -> mkPrimCon dt str (StringConstr str)
                       _ -> error "mkStringConstr"

------------------------------------------------------------------------------
--
-- Non-representations for non-presentable types
--
------------------------------------------------------------------------------

-- | Constructs a non-representation
mkNorepType :: String -> DataType
mkNorepType str = DataType
                        { tycon   = str
                        , datarep = NoRep
                        }

-- | Test for a non-representable type
isNorepType :: DataType -> Bool
isNorepType dt = case datarep dt of
                   NoRep -> True
                   _ -> False


{-# LANGUAGE UndecidableInstances, OverlappingInstances, EmptyDataDecls #-}

{-

(C) 2004 Ralf Laemmel

Context parameterisation and context passing.

-}

module T1735_Help.Context

where

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

--
-- The Sat class from John Hughes' "Restricted Data Types in Haskell"
--

class Sat a
  where
    dict :: a

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

-- No context

data NoCtx a

noCtx :: NoCtx ()
noCtx = undefined

instance Sat (NoCtx a) where dict = undefined

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

-- Pair context

data PairCtx l r a
   = PairCtx { leftCtx  :: l a
             , rightCtx :: r a }

pairCtx :: l () -> r () -> PairCtx l r ()
pairCtx _ _ = undefined

instance (Sat (l a), Sat (r a))
      => Sat (PairCtx l r a)
  where
    dict = PairCtx { leftCtx  = dict
                   , rightCtx = dict }

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


{-# LANGUAGE TemplateHaskell, FlexibleInstances, MultiParamTypeClasses,
             UndecidableInstances, OverlappingInstances, CPP #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
-- This is a module full of orphans, so don't warn about them

module T1735_Help.Instances () where

import T1735_Help.Basics
import Data.Typeable

charType :: DataType
charType = mkStringType "Prelude.Char"

instance Sat (ctx Char) =>
         Data ctx Char where
  toConstr _ x = mkStringConstr charType [x]
  gunfold _ _ z c = case constrRep c of
                      (StringConstr [x]) -> z x
                      _ -> error "gunfold Char"
  dataTypeOf _ _ = charType

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
  gfoldl _ _ z []     = z []
  gfoldl _ f z (x:xs) = z (:) `f` x `f` xs
  toConstr _ []    = nilConstr
  toConstr _ (_:_) = consConstr
  gunfold _ k z c = case constrIndex c of
                      1 -> z []
                      2 -> k (k (z (:)))
                      _ -> error "gunfold List"
  dataTypeOf _ _ = listDataType
  dataCast1 _ f = gcast1 f


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

module Main (main) where

import SYBWC.Basics
import 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 T1735_Help.State where

import Control.Monad (ap, liftM)

newtype StateT s m a = StateT { runStateT :: s -> m (a,s) }

instance Monad m => Monad (StateT s m) where
    return a = StateT $ \s -> return (a, s)
    m >>= k  = StateT $ \s -> do
        ~(a, s') <- runStateT m s
        runStateT (k a) s'
    fail str = StateT $ \_ -> fail str

instance Monad m => Functor (StateT s m) where
    fmap = liftM

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

get :: Monad m => StateT s m s
get = StateT $ \s -> return (s, s)

put :: Monad m => s -> StateT s m ()
put s = StateT $ \_ -> return ((), s)


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

module T1735_Help.Xml (Element(..), Xml, fromXml) where

import T1735_Help.Basics
import T1735_Help.Instances ()
import T1735_Help.State

data Element = Elem String [Element]
             | CData String
             | Attr String String

fromXml :: Xml a => [Element] -> Maybe a
fromXml xs = case readXml xs of
             Just (_, v) -> return v
             Nothing -> error "XXX"

class (Data XmlD a) => Xml a where
    toXml :: a -> [Element]
    toXml = defaultToXml

    readXml :: [Element] -> Maybe ([Element], a)
    readXml = defaultReadXml

    readXml' :: [Element] -> Maybe ([Element], a)
    readXml' = defaultReadXml'

instance (Data XmlD t, Show t) => Xml t

data XmlD a = XmlD { toXmlD :: a -> [Element], readMXmlD :: ReadM Maybe a }

xmlProxy :: Proxy XmlD
xmlProxy = error "xmlProxy"

instance Xml t => Sat (XmlD t) where
    dict = XmlD { toXmlD = toXml, readMXmlD = readMXml }

defaultToXml :: Xml t => t -> [Element]
defaultToXml x = [Elem (constring $ toConstr xmlProxy x) (transparentToXml x)]

transparentToXml :: Xml t => t -> [Element]
transparentToXml x = concat $ gmapQ xmlProxy (toXmlD dict) x

-- Don't do any defaulting here, as these functions can be implemented
-- differently by the user. We do the defaulting elsewhere instead.
-- The t' type is thus not used.

defaultReadXml :: Xml t => [Element] -> Maybe ([Element], t)
defaultReadXml es = readXml' es

defaultReadXml' :: Xml t => [Element] -> Maybe ([Element], t)
defaultReadXml' = readXmlWith readVersionedElement

readXmlWith :: Xml t
            => (Element -> Maybe t)
            -> [Element]
            -> Maybe ([Element], t)
readXmlWith f es = case es of
                       e : es' ->
                           case f e of
                               Just v -> Just (es', v)
                               Nothing -> Nothing
                       [] ->
                           Nothing

readVersionedElement :: forall t . Xml t => Element -> Maybe t
readVersionedElement e = readElement e

readElement :: forall t . Xml t => Element -> Maybe t
readElement (Elem n es) = res
    where resType :: t
          resType = typeNotValue resType
          resDataType = dataTypeOf xmlProxy resType
          con = readConstr resDataType n
          res = case con of
                Just c -> f c
                Nothing -> Nothing
          f c =     let m :: Maybe ([Element], t)
                        m = constrFromElements c es
                    in case m of
                           Just ([], x) -> Just x
                           _ -> Nothing
readElement _ = Nothing

constrFromElements :: forall t . Xml t
                   => Constr -> [Element] -> Maybe ([Element], t)
constrFromElements c es
 = do let st = ReadState { xmls = es }
          m :: ReadM Maybe t
          m = fromConstrM xmlProxy (readMXmlD dict) c
      -- XXX Should we flip the result order?
      (x, st') <- runStateT m st
      return (xmls st', x)

type ReadM m = StateT ReadState m

data ReadState = ReadState {
                     xmls :: [Element]
                 }

getXmls :: Monad m => ReadM m [Element]
getXmls = do st <- get
             return $ xmls st

putXmls :: Monad m => [Element] -> ReadM m ()
putXmls xs = do st <- get
                put $ st { xmls = xs }

readMXml :: Xml a => ReadM Maybe a
readMXml
 = do xs <- getXmls
      case readXml xs of
          Nothing -> fail "Cannot read value"
          Just (xs', v) ->
              do putXmls xs'
                 return v

typeNotValue :: Xml a => a -> a
typeNotValue t = error ("Type used as value: " ++ typeName)
    where typeName = dataTypeName (dataTypeOf xmlProxy t)

-- The Xml [a] context is a bit scary, but if we don't have it then
-- GHC complains about overlapping instances

instance (Xml a {-, Xml [a] -}) => Xml [a] where
    toXml = concatMap toXml
    readXml = f [] []
        where f acc_xs acc_vs [] = Just (reverse acc_xs, reverse acc_vs)
              f acc_xs acc_vs (x:xs) = case readXml [x] of
                                           Just ([], v) ->
                                               f acc_xs (v:acc_vs) xs
                                           _ ->
                                               f (x:acc_xs) acc_vs xs

instance Xml String where
    toXml x = [CData x]
    readXml = readXmlWith f
        where f (CData x) = Just x
              f _ = Nothing


import Type

main :: IO ()
main = return ()


module TyCon where

import Unbound.Generics.LocallyNameless (Alpha (..))
import {-# SOURCE #-} Type   (TyName)

data AlgTyConRhs
  = NewTyCon TyName

instance Alpha AlgTyConRhs where
  isTerm (NewTyCon nm) = isTerm nm


module Type where

import Unbound.Generics.LocallyNameless (Alpha (..),Name)
import TyCon

data TType = VarTy

type TyName = Name TType

instance Alpha TType where
  isTerm VarTy = False


module Unbound.Generics.LocallyNameless where

import Data.Typeable (Typeable)

data Name a = Name

class Alpha a where
  isTerm :: a -> Bool

instance Typeable a => Alpha (Name a) where
  isTerm _ = False


{-# LANGUAGE ScopedTypeVariables #-}
module T12441 where
import T12441A
f :: forall b a. (a, b)
f = undefined


module T12441A where
import {-# SOURCE #-} T12441


import Distribution.Simple
main = defaultMain


module DuplicateModuleName (Window(..)) where

data Window = Window deriving (Show)


module DuplicateModuleName (Window(..)) where

data Window = Window


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

--
-- Test case adopted from the HList library
-- http://www.cwi.nl/~ralf/HList/
--

module FakePrelude where

--
-- Type-level Booleans; nothing weird
--
data HTrue; hTrue :: HTrue; hTrue = undefined
data HFalse; hFalse :: HFalse; hFalse = undefined
class HBool x; instance HBool HTrue; instance HBool HFalse
instance Show HTrue where show _ = "HTrue"
instance Show HFalse where show _ = "HFalse"

--
-- Type-level type equality
--
class HBool b => TypeEq x y b | x y -> b

--
-- Value-level incarnation; nothing too weird.
-- Rely on lazy show for type-level Booleans
--
typeEq :: TypeEq t t' b => t -> t' -> b
typeEq = undefined

--
-- Type-level cast
--
class TypeCast x y | x -> y, y -> x
 where
  typeCast :: x -> y


{-# LANGUAGE OverlappingInstances, UndecidableInstances #-}

--
-- Test case adopted from the HList library
-- http://www.cwi.nl/~ralf/HList/
--
-- Tests functional dependencies and overlapping instances

module Main where

import FakePrelude
import TypeEq
import TypeCast

--
-- Let's test.
-- The following should print "(HTrue,HFalse)".
--

main = print $ ( typeEq "42" "88"
               , typeEq "42" (42::Int)
               )


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

--
-- Test case adopted from the HList library
-- http://www.cwi.nl/~ralf/HList/
--

module TypeCast where

import FakePrelude

--
-- We are ready to reveal the definition of type cast.
--
instance TypeCast x x where typeCast = id


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

--
-- Test case adopted from the HList library
-- http://www.cwi.nl/~ralf/HList/
--

module TypeEq where

import FakePrelude

--
-- Type-level type equality;
-- defined in terms of type-level cast
--
instance TypeEq x x HTrue
instance (HBool b, TypeCast HFalse b) => TypeEq x y b
--
-- NOTE! instance TypeEq x y HFalse -- would violate functional dependency
--


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

module Main where

type Null = (# #)

{-# NOINLINE showNull #-}
showNull :: Null -> String
showNull (# #) = "(# #)"

{-# NOINLINE showNullAlt #-}
showNullAlt :: (# Null | Null #) -> String
showNullAlt (# n1 | #) = "(# " ++ showNull n1 ++ " | #)"
showNullAlt (# | n2 #) = "(# | " ++ showNull n2 ++ " #)"

main :: IO ()
main = do
    putStrLn (showNull (# #))
    putStrLn (showNullAlt (# (# #) | #))
    putStrLn (showNullAlt (# | (# #) #))


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

module Lib where

import GHC.Prim

-- Can't unboxed tuples and sums to FFI, we should fail appropriately.

foreign import ccall "f1" f1 :: (# Int | Int #) -> IO Int
foreign import ccall "f2" f2 :: (# (# Int, Int #) | (# Float#, Float# #) #) -> IO Int
foreign import ccall "f3" f3 :: (# (# #) | Void# | (# Int# | String #) #) -> IO Int


{-# LANGUAGE DataKinds, PolyKinds #-}

module Example where

import Data.Typeable
import GHC.Exts

data Wat (a :: TYPE (SumRep '[LiftedRep, IntRep])) = Wat a


{-# LANGUAGE UnboxedTuples #-}

module Main where

type Null = (# #)

{-# NOINLINE showNull #-}
showNull :: Null -> String
showNull (# #) = "(# #)"

{-# NOINLINE showNullPair #-}
showNullPair :: (# Null, Null #) -> String
showNullPair (# n1, n2 #) = "(# " ++ showNull n1 ++ ", " ++ showNull n2 ++ " #)"

main :: IO ()
main = do
    putStrLn (showNullPair (# (# #), (# #) #))


{-# LANGUAGE UnboxedSums #-}

module Main where

import T14051a

main :: IO ()
main = print $ case func () of
  (# True | #) -> 123
  _ -> 321


{-# LANGUAGE UnboxedSums #-}

module T14051a where

func :: s -> (# Bool | Bool #)
func _ = (# True | #)


{-# LANGUAGE UnboxedTuples #-}

{-# NOINLINE f #-}
f :: (# #) -> [Int]
f (# #) = [ 1 .. ]

main :: IO ()
main = print (sum (take 10 (f (# #))))


{-# LANGUAGE UnboxedSums #-}

module UbxSumLevPoly where

-- this failed thinking that (# Any | True #) :: TYPE (SumRep [LiftedRep, b])
-- But of course that b should be Lifted!

-- It was due to silliness in TysWiredIn using the same uniques for different
-- things in mk_sum.

p = True
  where (# _x | #) = (# | True #)


{-# LANGUAGE UnboxedSums, MagicHash #-}

module Main where

import GHC.Prim
import GHC.Types

import System.Mem (performMajorGC)

type Either1 a b = (# a | b #)

showEither1 :: (Show a, Show b) => Either1 a b -> String
showEither1 (# left | #)  = "Left " ++ show left
showEither1 (# | right #) = "Right " ++ show right

showEither2 :: (# Int# | Float# #) -> String
showEither2 (# i | #) = "Left " ++ show (I# i)
showEither2 (# | f #) = "Right " ++ show (F# f)

showEither3 :: Show a => (# a | Int# #) -> String
showEither3 (# a | #) = "Left " ++ show a
showEither3 (# | i #) = "Right " ++ show (I# i)

type T = (# Int | Bool | String | Char | Either Int Bool | Int# | Float# #)

showEither4 :: T -> String
showEither4 (# i | | | | | | #) = "Alt0: " ++ show i
showEither4 (# | b | | | | | #) = "Alt1: " ++ show b
showEither4 (# | | s | | | | #) = "Alt2: " ++ show s
showEither4 (# | | | c | | | #) = "Alt3: " ++ show c
showEither4 (# | | | | e | | #) = "Alt4: " ++ show e
showEither4 (# | | | | | i | #) = "Alt5: " ++ show (I# i)
showEither4 (# | | | | | | f #) = "Alt6: " ++ show (F# f)

main :: IO ()
main = do
    putStrLn (showEither1 e1_1)
    putStrLn (showEither1 e1_2)
    putStrLn (showEither2 e2_1)
    putStrLn (showEither2 e2_2)
    putStrLn (showEither3 e3_1)
    putStrLn (showEither3 e3_2)

    putStrLn (showEither4 e4_1)
    putStrLn (showEither4 e4_2)
    putStrLn (showEither4 e4_3)
    putStrLn (showEither4 e4_4)
    putStrLn (showEither4 e4_5)
    putStrLn (showEither4 e4_6)
    putStrLn (showEither4 e4_7)

    -- make sure we don't put pointers to non-pointer slots
    performMajorGC

    -- make sure pointers in unboxed sums are really roots
    putStrLn (showEither1 e1_1)
  where
    -- boxed types only
    e1_1, e1_2 :: Either1 String Int
    e1_1 = (# "error" | #)
    e1_2 = (# | 10 #)

    -- prim types only
    e2_1, e2_2 :: (# Int# | Float# #)
    e2_1 = (# 10# | #)
    e2_2 = (# | 1.2# #)

    -- a mix of prim and boxed types
    e3_1, e3_2 :: (# String | Int# #)
    e3_1 = (# "OK" | #)
    e3_2 = (# | 123# #)

    -- big arity
    e4_1, e4_2, e4_3, e4_4, e4_5, e4_6, e4_7 :: T
    e4_1 = (# 10 | | | | | | #)
    e4_2 = (# | False | | | | | #)
    e4_3 = (# | | "ok" | | | | #)
    e4_4 = (# | | | 'a' | | | #)
    e4_5 = (# | | | | Right True | | #)
    e4_6 = (# | | | | | 123# | #)
    e4_7 = (# | | | | | | 54.3# #)


{-# LANGUAGE UnboxedSums, MagicHash #-}

module Main where

type Ty = (# (Int -> Int) | (Int -> Int) #)

{-# NOINLINE apply #-}
apply :: Ty -> Int
apply (# f | #) = f 0
apply (# | f #) = f 1

main :: IO ()
main = do
  print (apply (# (\x -> x * 2) | #))
  print (apply (# | (\x -> x * 3) #))


{-# LANGUAGE UnboxedSums, MagicHash #-}

module Main where

type Ty = (# () | () #)

{-# NOINLINE showTy #-}
showTy :: Ty -> String
showTy (# _ | #)  = "(# _ | #)"
showTy (# | () #) = "(# | () #)"

main :: IO ()
main = do
  print (showTy (# undefined | #))
  print (showTy (# | () #))


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

module Lib where

import GHC.Prim

data B = B1 Int# Int# Int# Int# Int# | B2 Float#

type UbxB = (# (# Int#, Int#, Int#, Int#, Int# #) | Float# #)

{-# INLINE bToSum #-}
bToSum :: B -> UbxB
bToSum (B1 i1 i2 i3 i4 i5) = (# (# i1, i2, i3, i4, i5 #) | #)
bToSum (B2 f) = (# | f #)

data C = C UbxB UbxB UbxB

mkC :: B -> C
mkC b = C (bToSum b) (bToSum b) (bToSum b)


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

module Main where

import GHC.Prim
import GHC.Types

-- Code generator used to fail with illegal instruction errors when Float# is
-- involved.

toInt :: (# Int# | Float# #) -> Int#
toInt (# i | #) = i
toInt (# | f #) = let !(I# i) = ceiling (F# f) in i

toFloat :: (# Int# | Float# #) -> Float#
toFloat (# i | #) = let !(F# f) = fromIntegral (I# i) in f
toFloat (# | f #) = f

data D = D { f1 :: (# Int# | Float# #) }

instance Show D where
  show (D (# i | #)) = "D " ++ show (I# i)
  show (D (# | f #)) = "D " ++ show (F# f)

main :: IO ()
main = do
    !(F# f) <- readLn
    print (I# (toInt (# | f #)))

    !(I# i) <- readLn
    print (F# (toFloat (# i | #)))

    print (D (# | f #))
    print (D (# i | #))


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

module Main where

import GHC.Prim
import GHC.Types

import Data.Void (Void)
import System.Mem (performMajorGC)

showAlt0 :: (# Void# | (# #) | () #) -> String
showAlt0 (# | (# #) | #) = "(# | (# #) | #)"
showAlt0 (# | | () #) = "(# | | () #)"

showAlt1 :: (# Void | Float# #) -> String
showAlt1 (# _ | #) = "(# Void | #)"
showAlt1 (# | f #) = "(# | " ++ show (F# f) ++ "# #)"

data D = D { f1 :: (# Void# | (# #) | () #)
           , f2 :: (# Void | Float# #)
           }

showD :: D -> String
showD (D f1 f2) = showAlt0 f1 ++ "\n" ++ showAlt1 f2

main :: IO ()
main = do
    putStrLn (showAlt0 (# | (# #) | #))
    putStrLn (showAlt0 (# | | () #))
    putStrLn (showAlt1 (# undefined | #))
    putStrLn (showAlt1 (# | 8.1# #))
    putStrLn (showD (D (# | (# #) | #) (# | 1.2# #)))
    performMajorGC


{-# LANGUAGE UnboxedSums #-}

module Lib where

-- No spaces needed in the type syntax
type T = (#Int|Bool|String#)

-- Term syntax needs spaces, otherwise we parser bars as sections
-- for ||, ||| etc.
--
-- t1 :: T
-- t1 = (# 10 | | #)


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

-- Nesting sums and tuples is OK

module Main where

import GHC.Prim
import GHC.Types

import System.Mem (performMajorGC)

type S_T_T a b c d = (# (# a , b #) | (# c , d #) #)
type S_S_S a b c d = (# (# a | b #) | (# c | d #) #)

show_stt :: (Show a, Show b, Show c, Show d) => S_T_T a b c d -> String
show_stt (# (# a, b #) | #) = show a ++ show b
show_stt (# | (# c, d #) #) = show c ++ show d

show_sss :: (Show a, Show b, Show c, Show d) => S_S_S a b c d -> String
show_sss (# (# a | #) | #) = show a
show_sss (# (# | b #) | #) = show b
show_sss (# | (# c | #) #) = show c
show_sss (# | (# | d #) #) = show d

main :: IO ()
main = do
    putStrLn (show_stt stt)
    putStrLn (show_sss sss)
    performMajorGC
  where
    stt :: S_T_T Int Bool Float String
    stt = (# (# 123, True #) | #)

    sss :: S_S_S Int Bool Float String
    sss = (# | (# 1.2 | #) #)


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

module Main where

import GHC.Prim
import GHC.Types

type Either1 a b c = (# a | (# b, c #) #)

-- The bug disappears when this is inlined
{-# NOINLINE showEither1 #-}

showEither1 :: Either1 String Int Bool -> String
showEither1 (# left | #) = "Left " ++ show left
showEither1 (# | (# right1, right2 #) #) = "Right " ++ show right1 ++ " " ++ show right2

main :: IO ()
main = do
    -- This line used to print "Right -4611686018427359531 False"
    putStrLn (showEither1 e1_2)
  where
    -- boxed types only
    e1_2 :: Either1 String Int Bool
    e1_2 = (# | (# 10, True #) #)


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

module Main where

import GHC.Prim
import GHC.Types

type Sum1 = (# (# Int#, Int #) | (# Int#, Int# #) | (# Int, Int# #) #)

{-# NOINLINE showSum1 #-}
showSum1 :: Sum1 -> String
showSum1 (# p1 | | #) = showP1 p1
showSum1 (# | p2 | #) = showP2 p2
showSum1 (# | | p3 #) = showP3 p3

{-# NOINLINE showP1 #-}
showP1 :: (# Int#, Int #) -> String
showP1 (# i1, i2 #) = show (I# i1) ++ show i2

{-# NOINLINE showP2 #-}
showP2 :: (# Int#, Int# #) -> String
showP2 (# i1, i2 #) = show (I# i1) ++ show (I# i2)

{-# NOINLINE showP3 #-}
showP3 :: (# Int, Int# #) -> String
showP3 (# i1, i2 #) = show i1 ++ show (I# i2)

main :: IO ()
main = do
    putStrLn (showSum1 s1)
    putStrLn (showSum1 s2)
    putStrLn (showSum1 s3)
  where
    s1, s2, s3 :: Sum1
    s1 = (# (# 123#, 456 #) | | #)
    s2 = (# | (# 876#, 543# #) | #)
    s3 = (# | | (# 123, 456# #) #)


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

module Main where

type UbxBool = (# (# #) | (# #) #)

{-# NOINLINE packBool #-}
packBool :: UbxBool -> Bool
packBool (# _ | #) = True
packBool (# | _ #) = False

{-# NOINLINE unpackBool #-}
unpackBool :: Bool -> UbxBool
unpackBool True  = (# (# #) | #)
unpackBool False = (# | (# #) #)

{-# NOINLINE showUbxBool #-}
showUbxBool :: UbxBool -> String
showUbxBool b = show (packBool b)

main :: IO ()
main = do
  putStrLn (showUbxBool (unpackBool True))
  putStrLn (showUbxBool (unpackBool False))
  putStrLn (show (packBool (# (# #) | #)))
  putStrLn (show (packBool (# | (# #) #)))


module Main where

import BasicTypes
import GHC
import GhcMonad
import Outputable
import RepType
import TysPrim
import TysWiredIn
import UniqSet
import Unique

import qualified Control.Exception as E
import Control.Monad
import System.Environment (getArgs)
import System.IO

assert :: Bool -> String -> SDoc -> IO ()
assert False tn msg = pprPanic tn msg
assert True  _  _   = return ()

main :: IO ()
main = do
    [libdir] <- getArgs
    runGhc (Just libdir) $ liftIO $ do
      -- need to initialize the monad to initialize static flags etc.
      sequence_ [ uniq_tests, layout_tests ]

-- Make sure sum datacon/tycon uniques are really uniq
uniq_tests :: IO ()
uniq_tests = do
    let tycons   = map sumTyCon [2 .. 20]
        datacons = [ sumDataCon alt arity | arity <- [ 2 .. 20 ]
                                          , alt   <- [ 1 .. arity ] ]

        us = mkUniqSet (map getUnique tycons)
               `unionUniqSets` mkUniqSet (map getUnique datacons)

    assert (sizeUniqSet us == length tycons + length datacons)
           "uniq_tests"
           (text "Sum cons/tycons have same uniques.")

layout_tests :: IO ()
layout_tests = sequence_
    [ layout1, layout2, layout3, layout4, layout5, enum_layout ]
  where
    assert_layout tn tys layout =
      let
        layout_ret = ubxSumRepType (map typePrimRep tys)
      in
        assert (layout_ret == layout)
               tn
               (text "Unexpected sum layout." $$
                text "Alts:           " <+> ppr tys $$
                text "Expected layout:" <+> ppr layout $$
                text "Actual layout:  " <+> ppr layout_ret)

    ubxtup = mkTupleTy Unboxed

    layout1 =
      assert_layout "layout1"
        [ ubxtup [ intTy, intPrimTy ]
        , ubxtup [ intPrimTy, intTy ] ]
        [ WordSlot, PtrSlot, WordSlot ]

    layout2 =
      assert_layout "layout2"
        [ ubxtup [ intTy ]
        , intTy ]
        [ WordSlot, PtrSlot ]

    layout3 =
      assert_layout "layout3"
        [ ubxtup [ intTy, intPrimTy, intTy, intPrimTy ]
        , ubxtup [ intPrimTy, intTy, intPrimTy, intTy ] ]
        [ WordSlot, PtrSlot, PtrSlot, WordSlot, WordSlot ]

    layout4 =
      assert_layout "layout4"
        [ ubxtup [ floatPrimTy, floatPrimTy ]
        , ubxtup [ intPrimTy, intPrimTy ] ]
        [ WordSlot, WordSlot, WordSlot, FloatSlot, FloatSlot ]

    layout5 =
      assert_layout "layout5"
        [ ubxtup [ intPrimTy, intPrimTy ]
        , ubxtup [ floatPrimTy, floatPrimTy ] ]
        [ WordSlot, WordSlot, WordSlot, FloatSlot, FloatSlot ]

    enum_layout =
      assert_layout "enum"
        (replicate 10 (ubxtup []))
        [ WordSlot ]


{-# LANGUAGE UnboxedSums, MagicHash #-}

module Lib (flip, getInt) where

import GHC.Exts
import Prelude (Int)

{-# NOINLINE flip #-}
flip :: (# Int | Int# #) -> (# Int# | Int #)
flip (# i | #) = (# | i #)
flip (# | i #) = (# i | #)

{-# NOINLINE getInt #-}
getInt :: (# Int# | Int #) -> Int
getInt (# i | #) = I# i
getInt (# | i #) = i


{-# LANGUAGE UnboxedSums #-}

module Main where

import Lib

import Prelude (print, IO)

main :: IO ()
main = do
    print (getInt (flip (# 123 | #)))


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

import FastString

import Control.Concurrent
import Control.DeepSeq
import Control.Exception
import Control.Monad
import Data.ByteString (ByteString)
import Data.ByteString.Builder
import qualified Data.ByteString.Char8 as Char
import Data.ByteString.Lazy (toStrict)
import Data.List
import Data.Monoid
import qualified Data.Sequence as Seq
import Data.Time
import GHC.Conc
import System.IO
import System.Random
import Text.Printf

data Options = Options
  { optThreads :: Int   -- ^ the number of threads to run concurrently
  , optRepeat :: Int    -- ^ how many times do we create the same 'FastString'
  , optCount :: Int     -- ^ the total number of different 'FastString's
  , optPrefix :: Int    -- ^ the length of prefix in each 'FastString'
  }

defOptions :: Options
defOptions = Options
  { optThreads = 8
  , optRepeat = 16
  , optCount = 10000
  , optPrefix = 0
  }

run :: [[ByteString]] -> (ByteString -> Int) -> IO Int
run jobs op = do
  mvars <- forM ([0 ..] `zip` jobs) $ \(i, job) -> do
    mvar <- newEmptyMVar
    forkOn i $ do
      uniq <- evaluate $ force $ maximum $ map op job
      putMVar mvar uniq
    return mvar
  uniqs <- mapM takeMVar mvars
  evaluate $ force $ maximum uniqs - 603979775

summary :: IO [[[a]]] -> IO Int
summary getTable = do
  table <- getTable
  evaluate $ force $ length $ concat $ concat table

timeIt :: String -> IO a -> IO a
timeIt name io = do
  before <- getCurrentTime
  ret <- io
  after <- getCurrentTime
  hPrintf stderr "%s: %.2fms\n" name
    (realToFrac $ diffUTCTime after before * 1000 :: Double)
  return ret

main :: IO ()
main = do
  seed <- randomIO
  let Options{..} = defOptions
      shuffle (i:is) s
        | Seq.null s = []
        | otherwise = m: shuffle is (l <> r)
        where
          (l, m Seq.:< r) = Seq.viewl <$> Seq.splitAt (i `rem` Seq.length s) s
      inputs =
        shuffle (randoms $ mkStdGen seed) $
        mconcat $ replicate optRepeat $
        Seq.fromFunction optCount $ \i -> toStrict $ toLazyByteString $
          byteString (Char.replicate optPrefix '_') <> intDec i
  jobs <- evaluate $ force $ transpose $
    map (take optThreads) $
    takeWhile (not . null) $
    iterate (drop optThreads) inputs
  setNumCapabilities (length jobs)
  -- The maximum unique may be greater than 'optCount'
  u <- timeIt "run" $ run jobs $ uniqueOfFS . mkFastStringByteString
  print $ optCount <= u && u <= min optThreads optRepeat * optCount
  -- But we should never have duplicate 'FastString's in the table
  n <- timeIt "summary" $ summary getFastStringTable
  print $ n == optCount


{-# OPTIONS_GHC -ddump-to-file #-}
{-# OPTIONS_GHC -fhpc -ddump-ticked -ddump-simpl-trace -ddump-tc #-}
{-# OPTIONS_GHC -ddump-types -ddump-core-stats #-}

module T15953 where

foo :: Int -> Int
foo 0 = 0
foo n = foo (n - 1)


module WarnMinimal where

class Fine a where
instance Fine Int

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

class Foo a where
  foo1 :: a
  foo2 :: a
  foo1 = foo2
  foo2 = foo1
  {-# MINIMAL foo1 | foo2 #-}

-- this should generate a warning
instance Foo Int where  -- WARNING LINE

-- this should generate no warning
instance Foo Char where
  foo1 = 'x'

-- nor should this
instance Foo Bool where
  foo2 = True

instance Foo Double where
  foo1 = 1
  foo2 = 2

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

class Monad' f where
  return' :: a -> f a
  fmap' :: (a -> b) -> f a -> f b
  join' :: f (f a) -> f a
  bind' :: f a -> (a -> f b) -> f b
  {-# MINIMAL return', (fmap',join' | bind') #-}
  fmap' f x = bind' x (return' . f)
  join' x = bind' x id
  bind' x f = join' (fmap' f x)

instance Monad' [] where
  return' = return
  fmap' = map
  join' = concat
  -- no warning

instance Monad' Maybe where
  return' = Just
  bind' = (>>=)
  -- no warning

instance Monad' IO where
  return' = return
  bind' = (>>=)
  fmap' = fmap
  join' = (>>= id)
  -- no warning

instance Monad' ((->) e) where  -- WARNING LINE
  return' = const
  fmap' = (.)
  -- warning!

newtype Id a = Id a
instance Monad' Id where  -- WARNING LINE
  fmap' f (Id x) = Id (f x)
  join' (Id x) = x
  -- warning!

newtype Id2 a = Id2 a
instance Monad' Id2 where  -- WARNING LINE
  fmap' f (Id2 x) = Id2 (f x)
  join' (Id2 x) = x
  bind' (Id2 x) f = f x
  -- warning!

newtype Id3 a = Id3 a
instance Monad' Id3 where  -- WARNING LINE

---------

-- incorrect minimal spec
class Cheater a where  -- WARNING LINE
  cheater :: a
  {-# MINIMAL #-} -- warning!

class Cheater2 a where
  _cheater2 :: a
  {-# MINIMAL #-} -- warning!

class Cheater3 a where  -- WARNING LINE
  cheater3, cheater3b :: a
  {-# MINIMAL cheater3 #-} -- warning!

---------

-- new style warning for classes without explicit spec
instance Num Bool where  -- WARNING LINE

class NoExplicit a where
  needed :: a
  _alsoNeeded :: a

instance NoExplicit Int where  -- WARNING LINE

---------
data Blarg = Blarg
class Eq' a where
  (===) :: a -> a -> Bool
  (/==) :: a -> a -> Bool
  x === y = not (x /== y)
  x /== y = not (x === y)
  {-# MINIMAL (===) | (/==) #-}
instance Eq' Blarg where  -- WARNING LINE


module WarnMinimalFail1 where

global :: Int
global = 0
{-# MINIMAL global #-} -- invalid, should only be used inside a class declaration


module WarnMinimalFail2 where

global :: Int
global = 0

class Foo a where
  local :: a
  {-# MINIMAL global #-}


{-# LANGUAGE DefaultSignatures #-}
module WarnMinimalFail3 where

class Parent a where
  parent :: a
  default parent :: Child a => a
  parent = child

class Parent a => Child a where
  child :: a
  child = parent
  {-# MINIMAL parent | child #-}
  -- we would like this to work, but it doesn't yet.


module DeprM {-# DEPRECATED "Here can be your menacing deprecation warning!" #-} where

f :: Int
f = 42


module A where

import DeprM -- here should be emitted deprecation warning

g :: Int
g = f


module MissingMod
where

import MissingMod1


{-# LANGUAGE MagicHash #-}
module Overflow where

import GHC.Exts

-- Overflow an 'Int#' expression
f x = let y :: Int#
          y = 10000000000000000000000000000000#
      in 9

-- Overflow an 'Int#' pattern
g :: Int# -> Bool
g 100000000000000000000000000# = True
g _ = False

-- Overflow an 'Int' expression
h :: Int
h = 1000000000000000000000000000000

-- Overflow an 'Int' pattern
i :: Int -> Int
i 100000000000000000000000000000000 = 0
i _ = 1

-- Underflow a 'Word' expression
j :: Word
j = -1

-- Underflow a 'Word' pattern
k :: Word -> Bool
k (-1) = True
k _ = False


-- Test purpose:
--
-- Ensure the plural "s" in warnings is only shown if there are more than
-- one entries

{-# OPTIONS_GHC -Wredundant-constraints #-}
{-# OPTIONS_GHC -Wtype-defaults #-}

module PluralS () where

-- Defaulting type classes

defaultingNum = 123 `seq` ()

defaultingNumAndShow = show 123

-- Redundant constraints

redundantNum :: (Num a, Num a) => a
redundantNum = 123

redundantMultiple :: (Num a, Show a, Num a, Eq a, Eq a) => a
redundantMultiple = 123


{-# OPTIONS_GHC -Wwarn-missing-signatues -Werror=incomplete-patterns #-}

foo () = ()


{-# LANGUAGE TypeOperators, TypeFamilies #-}
{-# OPTIONS -Wno-star-is-type #-}

module X (type (X.*)) where

type family (*) a b where { (*) a b = Either b a }


{-# OPTIONS_GHC -fwarn-missing-exported-signatures #-}

module Bug (Data.List.intercalate, x) where

import qualified Data.List

intercalate = True

x :: Bool
x = intercalate


{-# LANGUAGE NegativeLiterals #-}
module T10930 where

import Numeric.Natural

x = -123 :: Word
y = -123 :: Natural

w = [10..3] :: [Word]
z = [10..3] :: [Natural]


{-# LANGUAGE NegativeLiterals #-}
module T10930a where

import Numeric.Natural

x = [-10 .. -3] :: [Natural]
y = [-3 .. -10] :: [Natural]


module T11077 (module X, foo) where
import Data.List as X
foo = undefined


{-# LANGUAGE DeriveFunctor #-}
{-# OPTIONS_GHC -fwarn-noncanonical-monad-instances  #-}

-- | Test noncanonical-monad-instances warnings
module T11128 where

import Control.Applicative as A
import Control.Monad as M

----------------------------------------------------------------------------
-- minimal definition

data T0 a  = T0 a deriving Functor

instance A.Applicative T0 where
    pure   = T0
    (<*>)  = M.ap

instance M.Monad T0 where
    (>>=)  = undefined

----------------------------------------------------------------------------
-- trigger all 4 warnings

data T1 a  = T1 a deriving Functor

instance A.Applicative T1 where
    pure   = return
    (<*>)  = M.ap
    (*>)   = (M.>>)

instance M.Monad T1 where
    (>>=)  = undefined
    return = T1
    (>>)   = undefined

----------------------------------------------------------------------------
-- backward compat canonical definition

data T2 a  = T2 a deriving Functor

instance Applicative T2 where
    pure   = T2
    (<*>)  = ap
    (*>)   = undefined

instance M.Monad T2 where
    (>>=)  = undefined
    return = pure
    (>>)   = (*>)


{-# LANGUAGE DeriveFunctor #-}
{-# OPTIONS_GHC -Wnoncanonical-monadfail-instances  #-}

-- | Test noncanonical-monadfail-instances warnings
module T11128b where

import Control.Applicative as A
import Control.Monad as M
import Control.Monad.Fail as MF

----------------------------------------------------------------------------
-- minimal definition

data T0 a  = T0 a deriving Functor

instance A.Applicative T0 where
    pure   = T0
    (<*>)  = M.ap

instance M.Monad T0 where
    (>>=)  = undefined

instance MF.MonadFail T0 where
    fail   = error "fail"

----------------------------------------------------------------------------
-- trigger all 2 warnings

data T1 a  = T1 a deriving Functor

instance A.Applicative T1 where
    pure   = return
    (<*>)  = M.ap
    (*>)   = (M.>>)

instance M.Monad T1 where
    (>>=)  = undefined
    return = T1
    (>>)   = undefined
    fail   = error "fail"

instance MF.MonadFail T1 where
    fail   = M.fail

----------------------------------------------------------------------------
-- backward compat canonical definition

data T2 a  = T2 a deriving Functor

instance Applicative T2 where
    pure   = T2
    (<*>)  = ap
    (*>)   = undefined

instance M.Monad T2 where
    (>>=)  = undefined
    return = pure
    (>>)   = (*>)
    fail   = MF.fail

instance MF.MonadFail T2 where
    fail   = error "fail"

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


{-# LANGUAGE MagicHash #-}
module T15460 where

import GHC.Int

main :: IO ()
main = do
   let x = I# (0xfffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff#)
   print x


module T2526 (foo) where

-- This should generate a warning
foo = 1

-- This should not
bar = 2


module T9178 where

import T9178DataType

instance Show T9178_Type where
         show _ = undefined


module T9178DataType where

data T9178_Type


module T9230 where

test :: Monad m => m ()
test = do
	return ()


{-# OPTIONS_GHC -Wmissing-signatures -Werror=incomplete-patterns #-}
module Werror01 where

-- this should generate missing-signatures, but not incomplete-patterns
foo () = ()


{-# OPTIONS_GHC -Wmissing-signatures -Werror -Wwarn=missing-signatures #-}
module Werror02 where

-- this should generate missing-signatures warning
foo () = ()


module T10637 where

import {-# SOURCE #-} A ()
data B = B


module A where

class A a where
  has :: a


module B where

class B a where
  has :: a


module Base (AClass(..), BClass()) where

import Extends (BClass ())

class AClass a where
  has :: a


module Extends where

class BClass b where
  has :: b


module Main where

-- Previously GHC was printing this warning:
--
--   Main.hs:5:1: Warning:
--       The import of â€˜A.hasâ€™ from module â€˜Aâ€™ is redundant
--
--   Main.hs:6:1: Warning:
--       The import of â€˜B.hasâ€™ from module â€˜Bâ€™ is redundant

import A (A (has))
import B (B (has))

data Blah = Blah

instance A Blah where
  has = Blah

instance B Blah where
  has = Blah

main :: IO ()
main = return ()


module Main where

import Base
import Extends

-- Previously GHC was giving this false positive:
--
--   T10890_1.hs:4:1: Warning:
--       The import of â€˜Extendsâ€™ is redundant
--         except perhaps to import instances from â€˜Extendsâ€™
--       To import instances alone, use: import Extends()

data Bar = Bar

instance AClass Bar where
  has = Bar

instance BClass Bar where
  has = Bar

main :: IO ()
main = return ()


module T10890_2 where

-- Previously GHC was printing this warning:
--
--   Main.hs:5:1: Warning:
--       The import of â€˜A.hasâ€™ from module â€˜Aâ€™ is redundant
--
--   Main.hs:6:1: Warning:
--       The import of â€˜B.hasâ€™ from module â€˜Bâ€™ is redundant

import T10890_2A (A (has))
import T10890_2B (B (has))

data Blah = Blah

instance A Blah where
  has = Blah


module T10890_2A where

class A a where
  has :: a


module T10890_2B where

class B a where
  has :: a


module AltMain(alt_main) where

import Main

alt_main :: IO ()
alt_main = Main.main


module Main(main) where

import M1 ()

main :: IO ()
main = return ()


module CaretDiagnostics1 where

main :: IO ()
main = do
  10000000000000000000000000000000000000 +
    2 +
      (3 :: Int)
  pure ("this is not an IO" + (            ))

  where

    _ = case id of
      "Î³Î·Î¾" -> (
        ) '0'

fÃ³o :: Int
fÃ³o = ()

tabby :: Int
tabby =  	()

tabby2 :: Int
tabby2 =		()


module CaretDiagnostics2 where

Ó&lËå5kÍ


{-# OPTIONS_GHC -Wmissing-signatures -Werror=incomplete-patterns #-}
module WerrorFail where

-- this should generate incomplete-patterns warning
foo :: Maybe a -> ()
foo Nothing = ()


{-# OPTIONS_GHC -Wall
                -Werror=incomplete-patterns
                -Werror=missing-fields #-}

module Werror03 where

data Rec = Rec
  { f1 :: Int
  , f2 :: Int
  } deriving (Show)

data S = C1 Int | C2 Int

-- incomplete pattern
sInt s = case s of
           C1 i -> i

-- missing field
printRec = print Rec{ f1 = 1 }


{-# LANGUAGE NoMonadFailDesugaring, KindSignatures #-}

module WCompatWarningsOnOff where

import qualified Data.Semigroup as Semi

monadFail :: Monad m => m a
monadFail = do
    Just _ <- undefined
    undefined

(<>) = undefined -- Semigroup warnings

-- -fwarn-noncanonical-monoid-instances
newtype S = S Int

instance Semi.Semigroup S where
  (<>) = mappend

instance Monoid S where
  S a `mappend` S b = S (a+b)
  mempty = S 0

-- -fwarn-star-is-type
b :: (Bool :: *)
b = True


-- Test purpose:
-- Ensure that using -Wno-compat does not switch on warnings

{-# OPTIONS_GHC -Wno-compat #-}
{-# LANGUAGE CPP #-}
#include "Template.hs"


-- Test purpose:
-- Ensure that -Wcompat switches on the right warnings

{-# OPTIONS_GHC -Wcompat -Wno-error=compat #-}
{-# LANGUAGE CPP #-}
#include "Template.hs"


-- Test purpose:
-- Ensure that -Wno-compat disables a previously set -Wcompat

{-# OPTIONS_GHC -Wcompat -Wno-compat #-}
{-# LANGUAGE CPP #-}
#include "Template.hs"


module Main (main) where

import Distribution.Simple

main :: IO ()
main = defaultMain


module Main (main) where

import System.IO

main = hPutStr stderr ""


{-# OPTIONS -cpp #-}
{-# LANGUAGE LambdaCase #-}
module Main where

import Control.Concurrent (forkIO, threadDelay)
import Control.Concurrent.MVar (putMVar, takeMVar, newEmptyMVar)
import Control.Monad
import Control.Exception
import Data.Maybe (isNothing)
import System.Environment (getArgs)
import System.Exit
import System.IO (hPutStrLn, stderr)

#if !defined(mingw32_HOST_OS)
import System.Posix hiding (killProcess)
import System.IO.Error hiding (try,catch)
#endif

#if defined(mingw32_HOST_OS)
import System.Process
import WinCBindings
import Foreign
import System.Win32.DebugApi
import System.Win32.Types
import System.Win32.Console.CtrlHandler
#endif

main :: IO ()
main = do
  args <- getArgs
  case args of
      [secs,cmd] ->
          case reads secs of
          [(secs', "")] -> run secs' cmd
          _ -> die ("Can't parse " ++ show secs ++ " as a number of seconds")
      _ -> die ("Bad arguments " ++ show args)

run :: Int -> String -> IO ()
#if !defined(mingw32_HOST_OS)
run secs cmd = do
        m <- newEmptyMVar
        mp <- newEmptyMVar
        installHandler sigINT (Catch (putMVar m Nothing)) Nothing
        forkIO $ do threadDelay (secs * 1000000)
                    putMVar m Nothing
        forkIO $ do ei <- try $ do pid <- systemSession cmd
                                   return pid
                    putMVar mp ei
                    case ei of
                       Left _ -> return ()
                       Right pid -> do
                           r <- getProcessStatus True False pid
                           putMVar m r
        ei_pid_ph <- takeMVar mp
        case ei_pid_ph of
            Left e -> do hPutStrLn stderr
                                   ("Timeout:\n" ++ show (e :: IOException))
                         exitWith (ExitFailure 98)
            Right pid -> do
                r <- takeMVar m
                case r of
                  Nothing -> do
                        killProcess pid
                        exitWith (ExitFailure 99)
                  Just (Exited r) -> exitWith r
                  Just (Terminated s) -> raiseSignal s
                  Just _ -> exitWith (ExitFailure 1)

systemSession cmd =
 forkProcess $ do
   createSession
   executeFile "/bin/sh" False ["-c", cmd] Nothing
   -- need to use exec() directly here, rather than something like
   -- System.Process.system, because we are in a forked child and some
   -- pthread libraries get all upset if you start doing certain
   -- things in a forked child of a pthread process, such as forking
   -- more threads.

killProcess pid = do
  ignoreIOExceptions (signalProcessGroup sigTERM pid)
  checkReallyDead 10
  where
    checkReallyDead 0 = hPutStrLn stderr "checkReallyDead: Giving up"
    checkReallyDead (n+1) =
      do threadDelay (3*100000) -- 3/10 sec
         m <- tryJust (guard . isDoesNotExistError) $
                 getProcessStatus False False pid
         case m of
            Right Nothing -> return ()
            Left _ -> return ()
            _ -> do
              ignoreIOExceptions (signalProcessGroup sigKILL pid)
              checkReallyDead n

ignoreIOExceptions :: IO () -> IO ()
ignoreIOExceptions io = io `catch` ((\_ -> return ()) :: IOException -> IO ())

#else
run secs cmd =
    let escape '\\' = "\\\\"
        escape '"'  = "\\\""
        escape c    = [c]
        cmd' = "sh -c \"" ++ concatMap escape cmd ++ "\"" in
    alloca $ \p_startupinfo ->
    alloca $ \p_pi ->
    withTString cmd' $ \cmd'' ->
    do job <- createJobObjectW nullPtr nullPtr
       b_info <- setJobParameters job
       unless b_info $ errorWin "setJobParameters"

       ioPort <- createCompletionPort job
       when (ioPort == nullPtr) $ errorWin "createCompletionPort, cannot continue."

       -- We're explicitly turning off handle inheritance to prevent misc handles
       -- from being inherited by the child. Notable we don't want the I/O Completion
       -- Ports and Job handles to be inherited. So we mark them as non-inheritable.
       setHandleInformation job    cHANDLE_FLAG_INHERIT 0
       setHandleInformation ioPort cHANDLE_FLAG_INHERIT 0

       -- Now create the process suspended so we can add it to the job and then resume.
       -- This is so we don't miss any events on the receiving end of the I/O port.
       let creationflags = cCREATE_SUSPENDED
       b <- createProcessW nullPtr cmd'' nullPtr nullPtr True
                           creationflags
                           nullPtr nullPtr p_startupinfo p_pi
       unless b $ errorWin "createProcessW"

       pi <- peek p_pi
       b_assign <- assignProcessToJobObject job (piProcess pi)
       unless b_assign $ errorWin "assignProcessToJobObject, cannot continue."

       let handleInterrupt action =
               action `onException` terminateJobObject job 99
           handleCtrl _ = do
               terminateJobObject job 99
               closeHandle ioPort
               closeHandle job
               exitWith (ExitFailure 99)
               return True

       withConsoleCtrlHandler handleCtrl $
           handleInterrupt $ do
              resumeThread (piThread pi)
              -- The program is now running
              let handle = piProcess pi
              let millisecs = secs * 1000
              rc <- waitForJobCompletion job ioPort (fromIntegral millisecs)
              closeHandle ioPort

              if not rc
                then do terminateJobObject job 99
                        closeHandle job
                        exitWith (ExitFailure 99)
                else alloca $ \p_exitCode ->
                      do terminateJobObject job 0
                         -- Ensured it's all really dead.
                         closeHandle job
                         r <- getExitCodeProcess handle p_exitCode
                         if r
                           then peek p_exitCode >>= \case
                                   0 -> exitWith ExitSuccess
                                   e -> exitWith $ ExitFailure (fromIntegral e)
                           else errorWin "getExitCodeProcess"
#endif


{-# LANGUAGE RankNTypes #-}

import Data.Data
import Data.List
import GHC
import DynFlags
import Outputable
import ApiAnnotation
import System.Environment( getArgs )
import System.Exit
import qualified Data.Map as Map
import qualified Data.Set as Set

main::IO()
main = do
  args <- getArgs
  case args of
   [libdir,fileName] -> testOneFile libdir fileName
   _ -> putStrLn "invoke with the libdir and a file to parse."

testOneFile :: FilePath -> String -> IO ()
testOneFile libdir fileName = do
       let modByFile m =
             case ml_hs_file $ ms_location m of
               Nothing -> False
               Just fn -> fn == fileName
       ((anns,_cs),p) <- runGhc (Just libdir) $ do
                        dflags <- getSessionDynFlags
                        _ <- setSessionDynFlags dflags
                        addTarget Target { targetId = TargetFile fileName Nothing
                                         , targetAllowObjCode = True
                                         , targetContents = Nothing }
                        _ <- load LoadAllTargets
                        graph <- getModuleGraph
                        let modSum =
                              case filter modByFile (mgModSummaries graph) of
                                [x] -> x
                                xs -> error $ "Can't find module, got:"
                                  ++ show (map (ml_hs_file . ms_location) xs)
                        p <- parseModule modSum
                        return (pm_annotations p,p)

       let sspans = Set.fromList $ getAllSrcSpans (pm_parsed_source p)

           exploded = [((kw,ss),[anchor])
                      | ((anchor,kw),sss) <- Map.toList anns,ss <- sss]

           exploded' = Map.toList $ Map.fromListWith (++) exploded

           problems' = filter (\(_,anchors)
                               -> not (any (\a -> Set.member a sspans) anchors))
                              exploded'

           problems'' = filter (\((a,_),_) -> a /= AnnEofPos) problems'

           -- Check that every annotation location in 'vs' appears after
           -- the start of the enclosing span 's'
           comesBefore ((s,k),vs) = not $ all ok vs
             where
               ok v = (k == AnnEofPos) || (srcSpanStart s <= srcSpanStart v)

           precedingProblems = filter comesBefore $ Map.toList anns

       putStrLn "---Unattached Annotation Problems (should be empty list)---"
       putStrLn (intercalate "\n" [pp $ Map.fromList $ map fst problems''])
       putStrLn "---Ann before enclosing span problem (should be empty list)---"
       putStrLn (showAnnsList precedingProblems)
       putStrLn "---Annotations-----------------------"
       putStrLn "-- SrcSpan the annotation is attached to, AnnKeywordId,"
       putStrLn "--    list of locations the keyword item appears in"
       -- putStrLn (intercalate "\n" [showAnns anns])
       putStrLn (showAnns anns)
       if null problems'' && null precedingProblems
          then exitSuccess
          else exitFailure

    where
      getAllSrcSpans :: (Data t) => t -> [SrcSpan]
      getAllSrcSpans ast = everything (++) ([] `mkQ` getSrcSpan) ast
        where
          getSrcSpan :: SrcSpan -> [SrcSpan]
          getSrcSpan ss = [ss]

showAnns :: Map.Map ApiAnnKey [SrcSpan] -> String
showAnns anns = showAnnsList $ Map.toList anns

showAnnsList :: [(ApiAnnKey, [SrcSpan])] -> String
showAnnsList annsList = "[\n" ++ (intercalate ",\n"
   $ map (\((s,k),v)
              -> ("((" ++ pp s ++ "," ++ show k ++"), " ++ pp v ++ ")"))
   annsList)
    ++ "\n]\n"

pp :: (Outputable a) => a -> String
pp a = showPpr unsafeGlobalDynFlags a

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

-- Copied from syb for the test

-- | Generic queries of type \"r\",
--   i.e., take any \"a\" and return an \"r\"
--
type GenericQ r = forall a. Data a => a -> r

-- | Make a generic query;
--   start from a type-specific case;
--   return a constant otherwise
--
mkQ :: ( Typeable a
       , Typeable b
       )
    => r
    -> (b -> r)
    -> a
    -> r
(r `mkQ` br) a = case cast a of
                        Just b  -> br b
                        Nothing -> r

-- | Summarise all nodes in top-down, left-to-right order
everything :: (r -> r -> r) -> GenericQ r -> GenericQ r

-- Apply f to x to summarise top-level node;
-- use gmapQ to recurse into immediate subterms;
-- use ordinary foldl to reduce list of intermediate results

everything k f x = foldl k (f x) (gmapQ (everything k f) x)


{-# LANGUAGE ScopedTypeVariables #-}

import Data.List
import SrcLoc
import GHC hiding (moduleName)
import HsDumpAst
import DynFlags
import Outputable hiding (space)
import System.Environment( getArgs )
import System.Exit
import System.FilePath

import qualified Data.Map        as Map

usage :: String
usage = unlines
    [ "usage: check-ppr (libdir) (file)"
    , ""
    , "where libdir is the GHC library directory (e.g. the output of"
    , "ghc --print-libdir) and file is the file to parse."
    ]

main :: IO()
main = do
  args <- getArgs
  case args of
   [libdir,fileName] -> testOneFile libdir fileName
   _ -> putStrLn usage

testOneFile :: FilePath -> String -> IO ()
testOneFile libdir fileName = do
       p <- parseOneFile libdir fileName
       let
         origAst = showSDoc unsafeGlobalDynFlags
                     $ showAstData BlankSrcSpan (pm_parsed_source p)
         pped    = pragmas ++ "\n" ++ pp (pm_parsed_source p)
         anns    = pm_annotations p
         pragmas = getPragmas anns

         newFile = dropExtension fileName <.> "ppr" <.> takeExtension fileName
         astFile = fileName <.> "ast"
         newAstFile = fileName <.> "ast.new"

       writeFile astFile origAst
       writeFile newFile pped

       p' <- parseOneFile libdir newFile

       let newAstStr :: String
           newAstStr = showSDoc unsafeGlobalDynFlags
                         $ showAstData BlankSrcSpan (pm_parsed_source p')
       writeFile newAstFile newAstStr

       if origAst == newAstStr
         then do
           -- putStrLn "ASTs matched"
           exitSuccess
         else do
           putStrLn "AST Match Failed"
           putStrLn "\n===================================\nOrig\n\n"
           putStrLn origAst
           putStrLn "\n===================================\nNew\n\n"
           putStrLn newAstStr
           exitFailure

parseOneFile :: FilePath -> FilePath -> IO ParsedModule
parseOneFile libdir fileName = do
       let modByFile m =
             case ml_hs_file $ ms_location m of
               Nothing -> False
               Just fn -> fn == fileName
       runGhc (Just libdir) $ do
         dflags <- getSessionDynFlags
         let dflags2 = dflags `gopt_set` Opt_KeepRawTokenStream
         _ <- setSessionDynFlags dflags2
         addTarget Target { targetId = TargetFile fileName Nothing
                          , targetAllowObjCode = True
                          , targetContents = Nothing }
         _ <- load LoadAllTargets
         graph <- getModuleGraph
         let
           modSum = case filter modByFile (mgModSummaries graph) of
                     [x] -> x
                     xs -> error $ "Can't find module, got:"
                              ++ show (map (ml_hs_file . ms_location) xs)
         parseModule modSum

getPragmas :: ApiAnns -> String
getPragmas anns = pragmaStr
  where
    tokComment (L _ (AnnBlockComment s)) = s
    tokComment (L _ (AnnLineComment  s)) = s
    tokComment _ = ""

    comments = case Map.lookup noSrcSpan (snd anns) of
      Nothing -> []
      Just cl -> map tokComment $ sortLocated cl
    pragmas = filter (\c -> isPrefixOf "{-#" c ) comments
    pragmaStr = intercalate "\n" pragmas

pp :: (Outputable a) => a -> String
pp a = showPpr unsafeGlobalDynFlags a