{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE DataKinds, PolyKinds #-}
module T14728a where

import Data.Functor.Identity
import Data.Kind

class C (a :: Type) where
  type T a (x :: a) :: Type
  type U z :: a

instance C () where
  type T () '() = Bool

deriving instance C (Identity a)

f :: T (Identity ()) ('Identity '())
f = True


{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE DataKinds, PolyKinds #-}
module T14728b where

import Data.Functor.Identity
import Data.Kind

class C (a :: Type) where
  type U z :: a

instance C () where
  type U z = '()

deriving instance C (Identity a)


{-# LANGUAGE DeriveAnyClass #-}
module T14916 where

import Data.Coerce
import Data.Typeable

data A = MkA deriving ((~) A)
data B = MkB deriving (Coercible B)


{-# LANGUAGE TypeFamilies, GeneralizedNewtypeDeriving #-}

module T1496 where

data family Z :: * -> *

newtype instance Z Int = ZI Double
newtype instance Z Moo = ZM (Int,Int)

newtype Moo = Moo Int deriving(IsInt)
class IsInt t where
    isInt :: c Int -> c t

instance IsInt Int where isInt = id

main = case isInt (ZI 4.0) of ZM tu -> print tu


{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE DataKinds, PolyKinds #-}
module T15073 where

import T15073a

newtype Foo a = MkFoo a
  deriving P


{-# LANGUAGE UnboxedTuples #-}
module T15073a where

class P a where
  p :: a -> (# a #)


module T1830_1 where

import Language.Haskell.TH.Syntax (Lift)

data Foo a = Foo a deriving Lift


{-# OPTIONS_GHC -XDeriveDataTypeable -XStandaloneDeriving #-}

-- Test Trac #2394

module Foo where

import Data.Data(Data)

deriving instance (Data a,Data b) => Data (a->b)


{-# LANGUAGE MagicHash, DeriveDataTypeable #-}
module T2700 where

import GHC.Prim

import Data.Data
import Data.Typeable

data Foo = MkFoo Int#
           deriving (Typeable, Data)


{-# LANGUAGE TypeFamilies #-}
-- Test Trac #2851

module T2851 where

type family F a :: *

data D a = D (F a)
    deriving (Show)


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

module T3101 where

type family F a :: *

data Boom = Boom (forall a. a -> F a)
  deriving Show


{-# LANGUAGE GeneralizedNewtypeDeriving, MultiParamTypeClasses, FlexibleInstances, FunctionalDependencies, FlexibleContexts, UndecidableInstances, StandaloneDeriving #-}
module T3621 where

-- This one is ok, even though the deriving clause mentions 'a'
-- which is not a parameter of 'T'
class C a b
instance C a S
data S = MkS

newtype T = MkT S deriving( C a )

-- But this one fails, and should fail
class (Monad m) => MonadState s m | m -> s where
  state :: (s -> (a, s)) -> m a

newtype State s a = State { runState :: s -> (a, s) }
instance Functor (State s) where {}
instance Applicative (State s) where {}
instance Monad (State s) where {}
instance MonadState s (State s) where {}

newtype WrappedState s a = WS { runWS :: State s a }
   deriving (Functor, Applicative, Monad, MonadState state)
--   deriving (Monad)

deriving instance (MonadState state (State s))
      => MonadState state (WrappedState s)

-- ASSERT error
-- deriving instance (MonadState state (State s), Monad (WrappedState s))
--      => MonadState s (WrappedState s)

-- We try
--   instance MonadState state (State state a)
--         => MonadState state (WrappedState state a)
--
-- Superclass needs (Monad (WrappedState state a))


{-# LANGUAGE StandaloneDeriving #-}
-- {-# LANGUAGE GeneralizedNewtypeDeriving #-}

import Data.Monoid

newtype DecodeMap e = DecodeMap [e]

deriving instance Monoid (DecodeMap e)


{-# LANGUAGE StandaloneDeriving #-}

class C a
instance C Int

newtype T = T Int
deriving instance C T


{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
module T4083 where

data family F a
newtype instance F [a] = Maybe a

class C a where
  data D a

deriving instance C (Maybe a) => C (F [a])


{-# LANGUAGE GADTs, StandaloneDeriving #-}

module T4528 where

data Foo a where
   A, B :: Foo Int
   C :: Foo Bool

deriving instance Enum (Foo a)
deriving instance Bounded (Foo a)


{-# LANGUAGE RankNTypes, ScopedTypeVariables, StandaloneDeriving, GADTs, GeneralizedNewtypeDeriving, DeriveDataTypeable #-}

module Main where

import Data.Typeable

data Expr a where
    Lit :: Typeable a => a -> Expr a

class A a where
    mk :: a

class (Typeable a, A a) => B a where
    mkExpr :: Expr a
    mkExpr = Lit mk

-- dfunAE
instance B a => A (Expr a) where
    mk = mkExpr

-- dfunAB
instance A Bool where
    mk = True

newtype BOOL = BOOL Bool
  deriving (Typeable, A)

instance B Bool
deriving instance B BOOL   --dfunBB

showType :: forall a . Expr a -> String
showType (Lit _) = show (typeOf (undefined :: a))

test1 = showType (mk     :: Expr BOOL) -- Prints "Bool" (wrong?)
test2 = showType (Lit mk :: Expr BOOL) -- Prints "Main.BOOL" (correct)

main = do { print test1; print test2 }


{-# LANGUAGE MultiParamTypeClasses, UndecidableInstances #-}
module Bug where
class A a oops
data D d = D d

instance A a oops => Read (D a)
-- Actually this instance is ambiguous
-- and is now rightly rejected

data E e = E (D e) deriving Read

instance A Int Bool


{-# LANGUAGE MagicHash #-}
module T5478 where

import GHC.Exts

data Foo = Foo0 ByteArray#  deriving Show


{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-- | We use newtype to create an isomorphic type to Int
-- with a reversed Ord dictionary. We now use the MinList
-- API of MinList to create a new MinList. Then we use newtype
-- deriving to convert the newtype MinList to an Int
-- MinList. This final result breaks the invariants of
-- MinList which shouldn't be possible with the exposed
-- API of MinList.
module T5498 where

data MinList a = MinList a [a]

newMinList :: Ord a => a -> MinList a
newMinList n = MinList n []

insertMinList :: Ord a => MinList a -> a -> MinList a
insertMinList s@(MinList m xs) n | n > m     = MinList m (n:xs)
                                 | otherwise = s

printIntMinList :: MinList Int -> IO ()
printIntMinList (MinList min xs)
  = putStrLn $ "MinList Int :: MinList " ++ show min ++ " " ++ show xs

class IntIso t where
    intIso :: c t -> c Int

instance IntIso Int where
    intIso = id

newtype Down a = Down a deriving (Eq, IntIso)

instance Ord a => Ord (Down a) where
    compare (Down a) (Down b) = compare b a

fine :: MinList (Down Int)
fine = foldl (\x y -> insertMinList x $ Down y)
             (newMinList $ Down 0) [-1,-2,-3,-4,1,2,3,4]

bad :: MinList Int
bad = intIso fine


{-# LANGUAGE TypeFamilies, DeriveFunctor #-}
module T5686 where

data U a = U (G a) deriving Functor

class A a where
   type G a


module T5922 where

data Proposition = Proposition deriving (show)


{-# LANGUAGE GeneralizedNewtypeDeriving, TypeFamilies #-}
module T6147 where

data family T a
data instance T Int = T_Int Int

class C a where
  foo :: a -> T a

instance C Int where
  foo = T_Int

newtype Foo = Foo Int deriving(C)


{-# LANGUAGE GeneralizedNewtypeDeriving, GADTs #-}

module T7148 where

data SameType a b where
  Refl :: SameType a a

coerce :: SameType a b -> a -> b
coerce Refl = id

trans :: SameType a b -> SameType b c -> SameType a c
trans Refl Refl = Refl

sameUnit :: SameType () ()
sameUnit = Refl

class IsoUnit a where
  iso1 :: SameType () b -> SameType a b
  iso2 :: SameType b () -> SameType b a

instance IsoUnit () where
  iso1 = id
  iso2 = id

newtype Tagged a b = Tagged b deriving IsoUnit

sameTagged :: SameType (Tagged a b) (Tagged a' b') -> SameType a a'
sameTagged Refl = Refl

unsafe' :: SameType (Tagged a ()) (Tagged a' ())
unsafe' = (iso1 sameUnit) `trans` (iso2 sameUnit)

unsafe :: SameType a b
unsafe = sameTagged unsafe'

--once again inferred type is a -> b
unsafeCoerce = coerce unsafe


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

module T7148a where

import Control.Monad.ST
data Proxy a = Proxy
type family Result a b

class Convert a where
  coerce :: Proxy b -> a -> Result a b

newtype SAFE a = SAFE a
type instance Result (SAFE a) b = a

instance Convert (SAFE a) where
  coerce _ (SAFE a) = a

newtype IS_NO_LONGER a = IS_NO_LONGER a deriving Convert
type instance Result (IS_NO_LONGER a) b = b

--infered type is
unsafeCoerce :: forall a b. a -> b
unsafeCoerce = coerce (Proxy :: Proxy b) . IS_NO_LONGER . SAFE

--use it safely
id' :: a -> a
id' = unsafeCoerce

--segfault (with high probability)
crash :: segfault
crash = unsafeCoerce . tail . tail . tail . unsafeCoerce $ True

--time for side effects
unsafePerformIO :: IO a -> a
unsafePerformIO x = runST $ unsafeCoerce x


module T7401_fail where

data D deriving Eq


{-# LANGUAGE MultiParamTypeClasses, StandaloneDeriving #-}
module T7959 where

class A
deriving instance A
data B deriving A


{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeFamilyDependencies #-}
{-# LANGUAGE UndecidableInstances #-}
module T8165_fail where

import Data.Kind

class C (a :: k) where
  type T k :: Type

instance C Int where
  type T Type = Int

newtype MyInt = MyInt Int
  deriving C

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

class D a where
  type S a = r | r -> a

instance D Int where
  type S Int = Char

newtype WrappedInt = WrapInt Int
  deriving D


{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE TypeFamilies #-}
module T8165_fail2 where

class C a where
  type T a

newtype Loop = MkLoop Loop
  deriving C


{-# LANGUAGE GeneralizedNewtypeDeriving, ConstrainedClassMethods #-}

module T8851 where

import Control.Applicative

class Parsing m where
  notFollowedBy :: (Monad m, Show a) => m a -> m ()

data Parser a
instance Parsing Parser where
  notFollowedBy = undefined

instance Functor Parser where
  fmap = undefined
instance Applicative Parser where
  pure = undefined
  (<*>) = undefined
instance Monad Parser where
  return = undefined
  (>>=) = undefined

newtype MyParser a = MkMP (Parser a)
  deriving Parsing


{-# LANGUAGE ConstraintKinds, GeneralizedNewtypeDeriving #-}
module T8984 where

class C a where
    app :: a (a Int)

newtype N cat a b = MkN (cat a b)  deriving( C )
-- The newtype coercion is   N cat ~R cat


{-# LANGUAGE DeriveFunctor #-}
module T9071_2 where

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

newtype K1 a b = K1 a
newtype F1 a = F1 (Mu (K1 a)) deriving Functor


{-# LANGUAGE DeriveFunctor #-}
module T9071 where

import T9071a

newtype K a b = K a
newtype F a = F (Mu (K a)) deriving Functor


module T9071a where

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


{-# LANGUAGE GeneralizedNewtypeDeriving #-}

import Control.Applicative

newtype Foo a = Foo (a -> a) deriving Applicative


import Control.Applicative

newtype Foo a = Foo (a -> a) deriving Applicative


module T9687 where
import Data.Typeable

instance Typeable (a,b,c,d,e,f,g,h)


{-# LANGUAGE DeriveFunctor, DeriveFoldable #-}

module Main where

import Prelude hiding (sum)
import Data.Foldable

-- Derive Foldable for a simple data type

data List a = Nil | Cons a (List a)
    deriving (Functor,Foldable,Show)

someList = Cons 1 (Cons 1 (Cons 2 (Cons 3 Nil)))

main = print (sum someList)


{-# LANGUAGE DeriveFunctor #-}

module Main where

-- Derive functor for a simple data type

data List a = Nil | Cons a (List a)
    deriving (Functor,Show)

someList   = Cons 1 (Cons 1 (Cons 2 (Cons 3 Nil)))
doubleList = fmap (*2) someList

test1 = do
    putStr "normal:  " >> print someList
    putStr "double:  " >> print doubleList

-- Derive functor for a data type with functions and tuples

data ReaderWriter r w a = RW { runRW :: r -> (a,w) }
    deriving (Functor)

data Cont r a = Cont { runCont :: (a -> r) -> r }
    deriving (Functor)

test2 = do
    let rw = RW (\r -> ("something",r*3))
    putStr "normal:  " >> print (runRW rw 123)
    putStr "reverse: " >> print (runRW (fmap reverse rw) 456)
    let five = Cont ($ 5)
    putStr "normal:  " >> runCont five print
    putStr "double:  " >> runCont (fmap (*2) five) print

-- Derive functor in such a way that we need a constraint

newtype Compose f g a = Compose (f (g a))
    deriving (Functor,Show)

listOfLists = Compose [[1,2,3],[7,8,9]]

test3 = do
    putStr "normal:  " >> print listOfLists
    putStr "double:  " >> print (fmap (*2) listOfLists)

-- All tests

main = do
    test1
    test2
    test3


-- Test newtype derived instances

newtype Age = MkAge Int deriving (Eq, Show)

instance Num Age where
  (+) (MkAge a) (MkAge b) = MkAge (a+b)
  (*)         = undefined
  negate      = undefined
  abs         = undefined
  signum      = undefined
  fromInteger = undefined

main = print (MkAge 3 + MkAge 5)


-- !!! Deriving Show/Read for type with labelled fields.
--     (based on a Hugs bug report.)
module Main(main) where

data Options =
   Options { s :: OptionKind }
   deriving (Show, Read)

data OptionKind =
   SpecialOptions { test :: Int }
   deriving (Show, Read)

x = Options{s=SpecialOptions{test=42}}

main = do
  print x
  print ((read (show x))::Options)


-- !!! Deriving Show/Read for nullary constructors.
module Main(main) where

data A = B | C deriving ( Show, Read )

data Opt = N | Y A deriving (Show, Read)

x = Y B

{-
 If the Haskell report's specification of how Show instances
 are to be derived is followed to the letter, the code for
 a nullary constructor would put parens around the constructor
 when (showsPrec 10) is used. This would cause

      Y A

 to be showed as

      Y (A)

 Overkill, so ghc's derived Show code treats nullary
 constructors specially.
-}

main = do
  print x
  print ((read (show x))::Opt)
  print ((read "Y (B)")::Opt)


module Main where

data Hash = Hash{ (#) :: Int }
 deriving (Show, Read)

main =
  do print s
     print (read s :: Hash)
 where
  s = show (Hash 3)


module Main where

{-
  If a fixity declaration hasn't been supplied for
  an operator, it is defaulted to being "infixl 9".

  OLD:   The derived Read instances for data types containing
         left-assoc constructors produces code that causes
         non-termination if you use 'read' to evaluate them
         ( (head (reads x)) is cool tho.)

          ==> The inferred assoc for :++ below left & the derived
          Read instance should fail to terminate (with ghc-4.xx,
          this is exemplified by having the stack overflow.)

  NEW: the new H98 spec says that we ignore associativity when
       parsing, so it terminates fine
-}
-- infixl 9 :++
data T = T1 |  T :++ T  deriving (Eq,Show, Read)

t :: T
t = read "T1"

main = do
  print ((fst (head (reads "T1"))) :: T)
  print t


-- !!! Show/Read deriving example given in the Haskell Report.
module Main(main) where

infix 4 :^:
data Tree a
  =  Leaf a  | (Tree a) :^: (Tree a)
     deriving (Show, Read)

val1 :: Tree Int
val1 = Leaf 2

val2 :: Tree Int
val2 = Leaf 2 :^: Leaf (-1)

main = do
  print val1
  print val2

  print ((read (show val1))::Tree Int)
  print ((read (show val2))::Tree Int)
  print ((read (show val1))::Tree Integer)
  print ((read (show val2))::Tree Integer)

{- What you'll want
instance (Show a) => Show (Tree a) where

        showsPrec d (Leaf m) = showParen (d >= 10) showStr
          where
             showStr = showString "Leaf " . showsPrec 10 m

        showsPrec d (u :^: v) = showParen (d > 4) showStr
          where
             showStr = showsPrec 5 u .
                       showString " :^: " .
                       showsPrec 5 v

instance (Read a) => Read (Tree a) where

        readsPrec d r =  readParen (d > 4)
                         (\r -> [(u:^:v,w) |
                                 (u,s) <- readsPrec 5 r,
                                 (":^:",t) <- lex s,
                                 (v,w) <- readsPrec 5 t]) r

                      ++ readParen (d > 9)
                         (\r -> [(Leaf m,t) |
                                 ("Leaf",s) <- lex r,
                                 (m,t) <- readsPrec 10 s]) r
-}


module Main( main ) where
-- This one crashed Hugs98

data X = X | X :\ X  deriving Show

main = putStrLn (show (X :\ X))


-- !!! Check that -funbox-strict-fields doesn't mess up deriving (can't be in an options pragma, it's in the Makefile)
-- !!!  (it did in 4.04)

module Main( main ) where

data X = X !Int deriving Eq

main = putStrLn (show (X 2 == X 2))


-- !!! Check the Read instance for Array
-- [Not strictly a 'deriving' issue]

module Main( main ) where
import Data.Array

bds :: ((Int,Int),(Int,Int))
bds = ((1,4),(2,5))

type MyArr = Array (Int,Int) Int

a :: MyArr
a = array bds [ ((i,j), i+j) | (i,j) <- range bds ]

main = do { putStrLn (show a) ;
            let { b :: MyArr ;
                  b = read (show a) } ;
            putStrLn (show b)
          }


module Main where

data Test = Test { field :: Int } deriving (Eq,Show,Read)

main = putStrLn $
       if read (show (Test {field=(-1)})) == Test (-1)
       then "works" else "not"

-- The point here is that if 'show' generates
--      Test { field=-1 }
-- the lexer things the '=-' is one lexeme, which does not work


-- Tests some simple deriving stuff, and built-in instances

module Main( main ) where

data Command = Commit (Maybe String) | Foo | Baz Bool | Boz Int
             deriving (Read,Show)

type T = ([Command], [Command], [Command])
val :: T
val = ([Commit Nothing, Commit (Just "foo")],
       [Foo, Baz True],
       [Boz 3, Boz (-2)])

main = do { print val  ;
            print ((read (show val)) :: T) }


-- Tests readings of record syntax

module Main where

data Foo = Foo { x :: Baz, y :: Maybe Int } deriving (Read,Show)

infix 0 :%%
data Baz = Int :%% Int deriving( Read,Show)

main = print (read "Foo { x = 1 :%% 2, y = Just 4 }" :: Foo)


-- This test makes sure that the derivied instance for
--      Eq A
-- "sees" the non-derived instance for
--      Eq B
--
-- In a version of GHC 5.05, this didn't happen, because the
-- deriving mechanism looked through A's rep-type and found Int

module Main where

newtype B = MkB Int
instance Eq B where
  (MkB 1) == (MkB 2) = True     -- Non-standard equality
  (MkB a) == (MkB b) = False

newtype A = MkA B deriving( Eq )

main = print (MkA (MkB 1) == MkA (MkB 2))
-- Should say "True", because of B's non-standard instance


-- This one gave the wrong answer with ghci 5.02.3 (and 5.02.2)

module Main where

infixr 3 :*
infixr 2 :+

data RE a = RE a :+ RE a
          | RE a :* RE a
          | Cat  [RE a]
          | Star (RE a)
          | Plus (RE a)
          | Opt  (RE a)
          | Comp (RE a)
          | Empty
          | Str  [a]
            deriving (Show, Eq, Ord)

main = print (Str "ab" == (Str "a" :+ Str "b"))


-- The leading underscore killed GHC 5.04

module Main where

data Obj = Obj {_id, p1, p2::Int} deriving (Show, Read)

main = print (show (read "Obj {_id=1,p1=10,p2=20}" :: Obj))


-- Run with -funbox-strict-fields
-- Bug in GHC 5.04.3

module Main where

data Foo = Foo Int String
data Bar = Bar Int Foo

instance Ord Bar where
    compare (Bar i _) (Bar j _) = compare i j

instance Eq Bar where
    (Bar i _) == (Bar j _) = i == j

data Zot = Zot !Bar !String deriving (Ord,Eq)

main = putStrLn "Success"


{-# LANGUAGE MagicHash #-}

-- Test Show on unboxed types

module Main where
import GHC.Base

data Foo = MkFoo Int# Float# Int deriving( Show )

main = print (MkFoo 3# 4.3# 2)


-- Test Show on unboxed types

module Main where

data Foo = Int `MkFoo` Int deriving( Read, Show )

main = do { print (MkFoo 4 5)
          ; print (read "3 `MkFoo` 5" :: Foo) }


{-# LANGUAGE GeneralizedNewtypeDeriving #-}

-- Tests newtype deriving with
-- a non-type constructor in the representation

module Main where

newtype Wrap m a = Wrap { unWrap :: m a }
    deriving (Functor, Applicative, Monad, Eq)

foo :: Int -> Wrap IO a -> Wrap IO ()
foo 0 a = return ()
foo n a = do { a; foo (n-1) a }

main = do { unWrap (foo 3 (Wrap (putChar 'x'))); putChar '\n' }


-- A  nasty deriving test
-- Note the "T2 T1 { f1=3 }" part!

module Main where

infix 4 :%%
data T = Int :%% T
         | T1 { f1 :: Int }
         | T2 T
        deriving( Show, Read )

main = print (read "3 :%% T2 T1 { f1=3 }" :: T)

{- Here's the parser that is produced

import GHC.Read
import Text.ParserCombinators.ReadPrec
import Text.Read

instance Read T where
  readPrec =
    parens
    ( prec 4 (
        do x           <- step readPrec
           Symbol ":%%" <- lexP
           y           <- step readPrec
           return (x :%% y))
      +++
      prec (appPrec+1) (
        do Ident "T1" <- lexP
           Punc "{" <- lexP
           Ident "f1" <- lexP
           Punc "=" <- lexP
           x          <- reset readPrec
           Punc "}" <- lexP
           return (T1 { f1 = x }))
      +++
      prec appPrec (
        do Ident "T2" <- lexP
           x          <- step readPrec
           return (T2 x))
    )

appPrec = 10::Int
-}


module Main where

class Show a => Foo a where
  op :: a -> a

newtype Moose = MkMoose () deriving (Show, Eq, Ord)

newtype Noose = MkNoose () deriving (Ord)

instance Eq Noose where
  a == b = False        -- Non-standard!

f :: Ord a => a -> Bool
f x = x==x

main = do print (MkNoose () == MkNoose ())      -- Eq Noose
          print (f (MkNoose ()))                -- via Ord Noose
          print (MkMoose () == MkMoose ())      -- Eq Moose
          print (f (MkMoose ()))                -- via Ord Moose
          putStrLn (show (MkMoose ()))          -- Should not use the show () method


{-# LANGUAGE DeriveDataTypeable #-}

module Main where

-- GHC 6.4.1 output "testz" in z-encoded form!

import Data.Generics

data TestZ = TestZ { testz :: Int }
             deriving (Show, Read, Eq, Data, Typeable)

main = print $ constrFields . toConstr $ TestZ { testz = 2 }


{-# LANGUAGE MagicHash #-}
module Main where

import GHC.Prim

data P = Positives Int# Float# Double# Char# Word# deriving Show
data N = Negatives Int# Float# Double# deriving Show

main = do
  print $ Positives 42# 4.23# 4.23## '4'# 4##
  print $ Negatives -4# -4.0# -4.0##


{-# LANGUAGE DeriveFoldable, GADTs, StandaloneDeriving #-}
module Main where

class (a ~ Int) => Foo a
instance Foo Int

data A a where
  A1 :: Ord a            => a        -> A a
  A2 ::                     Int      -> A Int
  A3 :: b ~ Int          => b        -> A Int
  A4 :: a ~ Int          => Int      -> A a
  A5 :: a ~ Int          => a        -> A a
  A6 :: (a ~ b, b ~ Int) => Int -> b -> A a
  A7 :: Foo a            => Int -> a -> A a

deriving instance Foldable A

data HK f a where
  HK1 :: f a -> HK f (f a)
  HK2 :: f a -> HK f a

deriving instance Foldable f => Foldable (HK f)

one :: Int
one = 1

main :: IO ()
main = do
  mapM_ (print . foldr (+) one)
    [ A1 one
    , A2 one
    , A3 one
    , A4 one
    , A5 one
    , A6 one one
    , A7 one one
    ]
  mapM_ (print . foldr mappend Nothing)
    [ HK1 (Just "Hello")
    , HK2 (Just (Just "World"))
    ]


{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Main where

newtype MyMaybe a = MyMaybe (Maybe a)
  deriving (Functor, Show)

main :: IO ()
main = print $ fmap (+1) $ MyMaybe $ Just (10 :: Int)


{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE StandaloneDeriving #-}
module Main where

import Data.Proxy

class C a where
  c :: proxy a -> Int
  c _ = 42

instance C Int where
  c _ = 27

newtype Foo = MkFoo Int
  deriving          Eq
  deriving anyclass C
deriving newtype instance Show Foo

main :: IO ()
main = do
  print $ MkFoo 100
  print $ c (Proxy :: Proxy Foo)


{-# LANGUAGE MagicHash #-}
module Main where

data T  a = MkT  { runT  :: a, (##)  :: a } deriving (Read, Show)
data T# a = MkT# { runT# :: a, (###) :: a } deriving (Read, Show)

t1, t2 :: T Int
t1 = MkT (-1) 1
t2 = read $ show t1

t1#, t2# :: T# Int
t1# = MkT# (-1) 1
t2# = read $ show t1#

main :: IO ()
main = do
  print t2
  print t2#


-- Trac #2529
-- The example below successfully performed the {{{show}}}, but {{{reads}}}
-- returns an empty list. It fails in both GHCi and GHC. It succeeds if you
-- replaces the infix symbol with a name.

module Main where

data A = (:<>:) { x :: Int, y :: Int } deriving (Read, Show)

t :: A
t = 1 :<>: 2

s :: String
s = show t

r :: [(A,String)]
r = reads s

main :: IO ()
main = do putStrLn s
          putStrLn (show r)


{-# LANGUAGE RankNTypes, DeriveDataTypeable #-}

module Main where

import Data.Generics hiding (ext2Q)

data MyMaybe a = MyNothing | MyJust a deriving (Data, Typeable)

test1 :: ()
test1 = undefined `ext1Q` (\ (Just _) -> ()) $ Just ()

test1' :: ()
test1' = undefined `ext1Q` (\ (MyJust _) -> ()) $ MyJust ()

newtype Q r a = Q { unQ :: a -> r }

ext2Q :: (Data d, Typeable t)
      => (d -> q) -> (forall d1 d2. (Data d1, Data d2) => t d1 d2 -> q)
      -> d -> q
ext2Q def ext arg =
  case dataCast2 (Q ext) of
    Just (Q ext') -> ext' arg
    Nothing       -> def arg

data MyPair a b = MyPair a b deriving (Data, Typeable)

test2 :: ()
test2 = undefined `ext2Q` (\(_,_) -> ()) $ ((),())

test2' :: ()
test2' = undefined `ext2Q` (\(MyPair _ _) -> ()) $ MyPair () ()

main = do { print test1; print test1'; print test2; print test2' }


module Main where

data T = (:=:) {- | (:!=:) -} deriving (Show,Read)

main
 = do  putStrLn ("show (:=:) = " ++ show (:=:))
       putStrLn ("read (show (:=:)) :: T = " ++
                  show (read (show (:=:)) :: T))


-- Crashed older GHCs when loaded into GHCi

module Main where

data T a = A | B | C deriving( Enum, Show )

main = print [A ..]


{-# LANGUAGE MagicHash #-}

module Main where

data T = T1# | T2# Int deriving( Read, Show )

foo :: [T]
foo = read "[ T1#, T2# 4, T2# 5 ]"
main = print foo


{-# LANGUAGE EmptyDataDecls, StandaloneDeriving #-}
module Main where

data Z
deriving instance Eq Z

g :: Z
g = g

main :: IO ()
main = print (g == g)


{-# LANGUAGE GADTs #-}

module Main where

infix 5 :*:
data T a where
  (:*:) :: Int -> a -> T a
  (:+:) :: Char -> T a -> T a
  deriving( Show )

 -- The Show should print (:*:) infix, but (:+:) prefix,
 -- since it lacks a fixity declaration

main = print ('x' :+: (3 :*: True))


{-# LANGUAGE EmptyDataDeriving #-}
module Main where

import Data.Function

data Foo
  deriving (Eq, Ord, Read, Show)

foo1 :: Foo
foo1 = fix id

foo2 :: Foo
foo2 = let x = y
           y = x
        in y

main :: IO ()
main = do
  print (foo1 ==        foo2)
  print (foo1 `compare` foo2)


{-# LANGUAGE StandaloneDeriving #-}
module Main where

data A
deriving instance Read A
deriving instance Show A

main = print (read "[]" :: [A])
-- Should successfully read the empty list


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

module Main where

data Foo = MkFoo
data Bar = MkBar Foo deriving Show

main = do { print True; print (MkBar MkFoo) }


{-# LANGUAGE StandaloneDeriving #-}
module Main where

import T9830a

deriving instance (Show a, Show b) => Show (ADT a b)

main :: IO ()
main = do
    putStrLn $ "Prec 6:  " ++ showsPrec 6  ("test" :?: "show") ""
    putStrLn $ "Prec 7:  " ++ showsPrec 7  ("test" :?: "show") ""
    putStrLn $ "Prec 9:  " ++ showsPrec 9  ("test" :?: "show") ""
    putStrLn $ "Prec 10: " ++ showsPrec 10 ("test" :?: "show") ""


module T9830a where

infixr 6 :?:
data ADT a b = a :?: b deriving (Eq, Ord, Read)


-- !!! ds001 -- simple function and pattern bindings
--
-- this tests ultra-simple function and pattern bindings (no patterns)

module ShouldCompile where

-- simple function bindings

f x = x

g x y z = f z

j w x y z = g w x z

h x y = f y
  where
    f a b = a

-- simple pattern bindings

a = b

b = f

c = c


-- !!! ds002 -- overlapping equations and guards
--
-- this tests "overlapping" variables and guards

module ShouldCompile where

f x = x
f y = y
f z = z

g x y z | True = f z
        | True = f z
        | True = f z
g x y z | True = f z
        | True = f z
        | True = f z


-- !!! ds003 -- list, tuple, lazy, as patterns
--
module ShouldCompile where

f []            y        True  = []
f x             a@(y,ys) ~z    = []
f (x:x1:x2:x3)  ~(y,ys)  z     = []
f x             y        True  = []


-- !!! ds004 -- nodups from SLPJ p 79
--
module ShouldCompile where

-- SLPJ, p 79
nodups []                   = []
nodups [x]                  = [x]
nodups (y:x:xs) | y == x    = nodups (x:xs)
                | True      = y : nodups (x:xs)


-- !!! ds005 -- mappairs from SLPJ Ch 5'
--
-- this simply tests a "typical" example

module ShouldCompile where

-- from SLPJ, p 78
mappairs f []     ys     = []
mappairs f (x:xs) []     = []
mappairs f (x:xs) (y:ys) = f x y : mappairs f xs ys

-- from p 80
mappairs' f []     ys     = []
mappairs' f x      []     = []
mappairs' f (x:xs) (y:ys) = f x y : mappairs' f xs ys


-- !!! ds006 -- v | True = v+1 | False = v (dead code elim)
--
module ShouldCompile where

v | True  = v + 1
  | False = v


-- !!! ds007 -- simple local bindings

module ShouldCompile where

w = a where a = y
            y = []


-- !!! ds008 -- free tyvars on RHSs
--
-- these tests involve way-cool TyApps

module ShouldCompile where

f x = []

g x = (f [],[],[],[])

h x = g (1::Int)


-- !!! ds009 -- simple list comprehensions

module ShouldCompile where

f xs = [ x | x <- xs ]

g xs ys zs = [ (x,y,z) | x <- xs, y <- ys, z <- zs, True ]

h xs ys = [ [x,y] | x <- xs, y <- ys, False ]

i xs = [ x | all@(x,y) <- xs, all == ([],[]) ]

j xs = [ (a,b) | (a,b,c,d) <- xs ]


-- !!! ds011 -- uses of "error"

module ShouldCompile where

f = error []

g = error ""

h = error "\""

i = error "foo"


-- !!! ds015 -- lambdas
--
module ShouldCompile where

f x = ( \ x -> x ) x

g x y = ( \ x y -> y x ) ( \ x -> x ) x

h x y = ( \ (x:xs) -> x ) x


-- !!! ds016 -- case expressions
--
module ShouldCompile where

f x y z =
    case ( x ++ x ++ x ++ x ++ x ) of
        []      -> []
        [a]     -> error "2"
        [a,b,c] ->
                    case ( (y,z,y,z) ) of
--                    (True, _, False, _) | True == False -> z
--                    (True, _, False, _) | True == False -> z
                      _ -> z

        (a:bs)  -> error "4"


-- !!! ds017 -- let expressions
--
module ShouldCompile where

f x y z
  = let
        a = x : []
        b = x : a
        c = y (let d = (z, z) in d)
        result = (c, b)
    in
        result


-- !!! ds018 -- explicit lists and tuples (with disabled LARGE tuples!)
--
module ShouldCompile where

-- exprs

f x y z = [x,y,z,x,y,z]
f2 x y  = []

g1 x y  = ()

{- Although GHC *should* provide arbitrary tuples, it currently doesn't
   and probably won't in the near future, so this test is only a reminder.

g x y z = (x,y,z,x,y,z,
           x,y,z,x,y,z,
           x,y,z,x,y,z,
           x,y,z,x,y,z,
           x,y,z,x,y,z,
           x,y,z,x,y,z,
           x,y,z,x,y,z,
           x,y,z,x,y,z,
           x,y,z,x,y,z,
           x,y,z,x,y,z,
           x,y,z,x,y,z,
           x,y,z,x,y,z,
           x,y,z,x,y,z,
           x,y,z,x,y,z,
           x,y,z,x,y,z,
           x,y,z,x,y,z,
           x,y,z,x,y,z,
           x,y,z,x,y,z,
           x,y,z,x,y,z,
           x,y,z,x,y,z,
           x,y,z,x,y,z,
           x,y,z,x,y,z,
           x,y,z,x,y,z,
           x,y,z,x,y,z,
           x,y,z,x,y,z) -- hey, we love big tuples
-}

-- pats

fa [a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z] = x

fb [] = []

{- See above
ga (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z,
    aa,ab,ac,ad,ae,af,ag,ah,ai,aj,ak,al,am,
    an,ao,ap,aq,ar,as,at,au,av,aw,ax,ay,az) = x
-}

gb () x = x
gb2 ()  = ()

-- need to think of some better ones...


-- !!! ds019 -- mixed var and uni-constructor pats

module ShouldCompile where

f (a,b,c) i     o = []
f d       (j,k) p = []
f (e,f,g) l     q = []
f h       (m,n) r = []


-- !!! ds021 -- hairier uses of guards

module ShouldCompile where

f x y z | x == y     = []
        | x /= z     = []
        | True       = []
        | False      = []


-- !!! ds023 -- overloading eg from section 9.2
--
module ShouldCompile where

f x     = g (x == x) x
g b x   = abs (f x)
--g b x = (f x) + (f x)


-- !!! ds024 -- correct types on ConPatOuts

-- do all the right types get stuck on all the
-- Nils and Conses?

module ShouldCompile where

f x = [[], []]

g x = ([], [], [])


-- !!! ds025 -- overloaded assoc -- AbsBinds

module ShouldCompile where

ehead xs loc | null xs = error ("4"++loc)
             | True = head xs

assoc key lst loc
   = if (null res) then error ("1"++loc++"2"++(show key))
                   else (ehead res "3")
     where res = [ val | (key',val) <- lst, key==key']

assocMaybe :: (Eq a) => a -> [(a,b)] -> Maybe b
assocMaybe key lst
 = if (null res) then Nothing else (Just (head res))
   where res =  [ val | (key',val) <- lst, key==key']


-- !!! ds026 -- classes -- incl. polymorphic method

module ShouldCompile where

class Foo a where
  op :: a -> a

class Foo a => Boo a where
  op1 :: a -> a

class Boo a => Noo a where
  op2 :: (Eq b) => a -> b -> a

f x y = op (op2 x y)


-- !!! ds027 -- simple instances
--
module ShouldCompile where

data Foo = Bar | Baz

instance Eq Foo where
  Bar == Baz = True
  Bar /= Baz = False


-- !!! ds028: failable pats in top row

module ShouldCompile where

-- when the first row of pats doesn't have convenient
-- variables to grab...

mAp f []        = []
mAp f (x:xs)    = f x : mAp f xs

True  |||| _    =  True
False |||| x    =  x


-- !!! ds029: pattern binding with guards (dubious but valid)
--

module ShouldCompile where

f x = y
    where (y,z) | y < z     = (0,1)
                | y > z     = (1,2)
                | True      = (2,3)


-- !!! ds030: checks that types substituted into binders
--
module ShouldCompile where

f x = case x of [] -> (3::Int) ; _ -> (4::Int)


module ShouldCompile where

foldPair :: (a->a->a,b->b->b) -> (a,b) -> [(a,b)] -> (a,b)
foldPair fg       ab [] = ab
foldPair fg@(f,g) ab ((a,b):abs) = (f a u,g b v)
                       where (u,v) = foldPair fg ab abs


-- !!! recursive funs tangled in an AbsBind

module ShouldCompile where

flatten :: Int          -- Indentation
        -> Bool         -- True => just had a newline
        -> Float        -- Current seq to flatten
        -> [(Int,Float)]-- Work list with indentation
        -> String

flatten n nlp 0.0 seqs = flattenS nlp seqs
flatten n nlp 1.0 seqs = flatten n nlp 1.1 ((n,1.2) : seqs)

flattenS :: Bool -> [(Int, Float)] -> String
flattenS nlp [] = ""
flattenS nlp ((col,seq):seqs) = flatten col nlp seq seqs


-- !!! getting top-level dependencies right
--
module ShouldCompile where

f1 x = g1 x
g1 y = y

g2 y = y
f2 x = g2 x

f3 x = g3 x
g3 y = f3 y

g4 y = f4 y
f4 x = g4 x


-- !!! mutually-recursive methods in an instance declaration
--
module ShouldCompile where

class Foo a where
    op1 :: a -> a
    op2 :: a -> a

instance Foo Int where
    op1 x = op2 x
    op2 y = op1 y


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

import GHC.Exts

data CList = CNil | CCons Int# CList

mk :: Int# -> CList
mk n = case isTrue# (n ==# 0#) of
       False -> CNil
       _     -> CCons 1# (mk (n -# 1#))

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

main = putStr (case len4_twice of
            8# -> "bingo\n"
            _  -> "oops\n")
  where
    list4       = mk 4#
    !len4       = clen list4
    !len4_twice = len4 +# len4


{-
From dmc@minster.york.ac.uk Tue Mar 10 17:15:20 1992
Via: uk.ac.york.minster; Tue, 10 Mar 92 17:15:14 GMT
Message-Id: <swordfish.700247842@minster.york.ac.uk>
From: dmc@minster.york.ac.uk
To: partain
Date:       10 Mar 1992 17:17:21 GMT

Will,

I have just started using Haskell at York and have found a compilation
error in the code below which disappears when the last line is
commented out
-}

{-# LANGUAGE NPlusKPatterns #-}

module ShouldCompile where

--brack :: (Eq a) => a -> a -> [a] -> ([a],[a])
--brack open close = brack' open close (1 :: Int)

brack' :: (Eq a) => a -> a -> Int -> [a] -> ([a],[a])
brack' open close 0 xs = ([],xs)
brack' open close (n+1) [] = ([],[])
brack' open close (n+1) (h:t) | h == open = ([],[])

{-
Is this something I have done wrong or a fault with the compiler?

Cheers
Dave

-----------------------------------------------------------------------
David Cattrall                  Telephone +44 904 432777
Department of Computer Science
University of York              JANET:  dmc@uk.ac.york.minster
YORK Y01 5DD
United Kingdom                  UUNET:  uucp!ukc!minster!dmc
-----------------------------------------------------------------------
-}

-- and this was Kevin's idea, subsequently...

kh (n+2) x | x > n = x * 2
kh (x+1) (m+1) = m


-- !!! AbsBinds with tyvars, no dictvars, but some dict binds
--
module ShouldCompile where

f x y = (fst (g y x), x+(1::Int))
g x y = (fst (f x y), y+(1::Int))


-- !!! Jon Hill reported a bug in desugaring this in 0.09
-- !!! (recursive with n+k patts)
--

{-# LANGUAGE NPlusKPatterns #-}

module ShouldCompile where

takeList :: Int -> [a] -> [a]
takeList 0     _      = []
takeList (n+1) []     = []
takeList (n+1) (x:xs) = x : takeList n xs


-- !!! make sure correct type applications get put in
-- !!!   when (:) is saturated.

module ShouldCompile where

f = (:)


{-# LANGUAGE NPlusKPatterns #-}

module ShouldCompile where

-- !!! Another bug in overloaded n+k patts
--

main  = print ((4::Int) ^^^^ (6::Int))

(^^^^)          :: (Num a, Integral b) => a -> b -> a
x ^^^^ 0                =  1
x ^^^^ (n+1)    =  f x n x
                   where f _ 0 y = y
                         f x n y = g x n  where
                                   g x n | even n  = g (x*x) (n `quot` 2)
                                         | otherwise = f x (n-1) (x*y)
_ ^^^^ _                = error "(^^^^){Prelude}: negative exponent"


{-# LANGUAGE DatatypeContexts #-}
{- In 2.05 this one crashed with

        Fail: "basicTypes/Id.lhs", line 990: incomplete pattern(s)
                to match in function "dataConFieldLabels"

   Reason: dsExpr (RecordCon ...) didn't extract
           the constructor properly.
-}

module ShouldCompile where

data Eq a => Foo a = Foo { x :: a }

foo :: Eq a => Foo a
foo = Foo{}


-- !!! Guard on a tuple pattern, broke 4.01 due to the
-- !!! special handling of unboxed tuples in desugarer.
module ShouldCompile where

f :: Int -> (Int,Int)
f x =
  case f x of
    (a,b) | a > 0 -> f (x-1)


-- !!! Checking the exhaustiveness of constructor
-- !!! with labelled fields.
module ShouldCompile where

data E = B { a,b,c,d,e,f :: Bool }

bug x =
 case x of
  B _ _ _ _ True False    -> undefined
  B {e=True, f=False}     -> undefined
  B {a=a,f=False,e=False} -> undefined


-- !!! Use of empty record patterns for constructors
-- !!! that don't have any labelled fields. According
-- !!! to the report, this isn't illegal.
module ShouldCompile where

data F = F Int Int
       | G

isF F{} = True
isF _   = False


{-# LANGUAGE NPlusKPatterns #-}

-- !!! N-plus-K pattern in binding

-- From: Andreas Marth
-- Sent: Monday, June 07, 1999 5:02 PM
-- To: glasgow-haskell-bugs@majordomo.haskell.org
-- Subject: compiler-bug

module ShouldCompile where

erroR :: Int
erroR = n where
                (n+1,_) = (5,2)

-- Produced a -dcore-lint error in the desugarer output
-- (Was a missing case in DsHsSyn.collectTypedPatBinders)


module ShouldCompile where

-- Strict field unpacking tests: compile with -O -funbox-strict-fields.

-- test 1: simple unboxed int field
data T = T !Int
t (T i) = i + 1

-- test 2: mutual recursion (should back off from unboxing either field)
data R = R !S
data S = S !R

r (R s) = s

-- test 3: multi-level unboxing
data A = A Int !B Int
data B = B !Int

f = A 1 (B 2) 1
g (A x (B y) z) = A x (B (y+2)) z
h (A x (B y) z) = y + 2

-- test 4: flattening nested tuples
data C = C !(Int,Int)
j (C (a,b)) = a + b

-- test 5: polymorphism, multiple strict fields
data D a b = D Int !(a,b) !(E Int)
data E a = E a
k (D a (b,c) (E d)) = a + b + c + d

-- test 6: records
data F a b = F { x :: !Int, y :: !(Float,Float), z :: !(a,b) }
l F{x = a} = a
m (F a b c) = a
n F{z = (a,b)} = a

-- test 7: newtypes
newtype G a b = G (F a b)
data H a b = H !Int !(G a b) !Int
o (H y (G (F{ x=x })) z) = x + z


-- !!! Nullary rec-pats for constructors that hasn't got any labelled
-- !!! fields is legal Haskell, and requires extra care in the desugarer.
module ShouldCompile where

data X = X Int [Int]

f :: X -> Int
f (X _ []) = 0
f X{}      = 1


-- !!! newtypes with a labelled field.
module ShouldCompile where

newtype Foo = Foo { x :: Int } deriving (Eq)

f :: Foo -> Foo -> Int
f a b = x a + x b


{-# LANGUAGE RankNTypes #-}

module ShouldCompile where

data Q = Q {f :: forall a. a -> a}
g1 = f
g2 x = f x
g3 x y = f x y


{-# OPTIONS -fwarn-incomplete-patterns #-}
module ShouldCompile where

-- should *not* produce a warning about non-exhaustive patterns
lazyZip:: [a] -> [b] -> [(a, b)]
lazyZip []     _       = []
lazyZip (x:xs) ~(y:ys) = (x, y):lazyZip xs ys


{-# OPTIONS -fwarn-unused-binds #-}
module ShouldCompile() where

-- should warn about unused f, even though f is used in itself
f = f


-- fails core-lint in 6.2
module ShouldCompile where

newtype Foo = Foo [Foo]
newtype Bar = Bar Foo

unBar :: Bar -> Foo
unBar (Bar x) = x


{-# LANGUAGE ExistentialQuantification, DeriveDataTypeable #-}

-- This module requires quite trick desugaring,
-- because of the context in the existentials
-- It broke a pre 6.4 GHC

module Foo where

   import Data.Data

   data Item = forall a. (Data a) => Leaf Bool a
             | forall a. (Data a) => Branch Bool a Int Int
             deriving (Typeable)

   instance Data Item where
       gfoldl k z (Leaf b v) = z (Leaf b) `k` v
       gfoldl k z (Branch b v a1 a2) = z (\x -> Branch b x a1 a2) `k` v
       gunfold _ _ _ = error "urk"
       toConstr (Leaf _ _) = leafConstr
       toConstr (Branch _ _ _ _) = branchConstr
       dataTypeOf _ = itemDataType

   itemDataType = mkDataType "Subliminal.Item" [leafConstr, branchConstr]
   leafConstr = mkConstr itemDataType "Leaf" [] Prefix
   branchConstr = mkConstr itemDataType "Branch" [] Prefix


-- Check overlap in n+k patterns

{-# LANGUAGE NPlusKPatterns #-}

module Foo where

g :: Int -> Int
g (x+1) = x
g y     = y
g _     = 0     -- Overlapped

h :: Int -> Int
h (x+1) = x
h _     = 0     -- Not overlapped


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

import Data.Word
import GHC.Ptr
import GHC.Exts

f# :: Int# -> (# Char#, Int# #)
f# a# = (# '\0'#, a#  #)

g :: Int -> (Char, Int)
g (I# a#) = ( C# c#, I# b# )
  where !(# c#, b# #) = f# a#


-- Test overlapping pattern warnings

module ShouldCompile where

f x = case x of
        Just (~1) -> 0
        Just _    -> 1  -- This one cannot match
        Nothing   -> 2


{-# OPTIONS -fwarn-incomplete-patterns #-}

-- Test for incomplete-pattern warnings
-- None should cause a warning

module ShouldCompile where

-- These ones gave bogus warnings in 6.2

data D = D1 { f1 :: Int } | D2

-- Use pattern matching in the argument
f :: D -> D
f  d1@(D1 {f1 = n}) = d1 { f1 = f1 d1 + n } -- Warning here
f  d = d

-- Use case pattern matching
g :: D -> D
g  d1 = case d1 of
           D1 { f1 = n } -> d1 { f1 = n + 1 } -- Warning here also
           D2            -> d1

-- These ones were from Neil Mitchell
-- no warning
ex1 x = ss
    where (_s:ss) = x

-- no warning
ex2 x = let (_s:ss) = x in ss

--    Warning: Pattern match(es) are non-exhaustive
--             In a case alternative: Patterns not matched: []
ex3 x = case x of ~(_s:ss) -> ss


{-# OPTIONS_GHC -Wall #-}

module ShouldCompile where

f :: String -> Int
f x | null x    = 1
    | otherwise = 2

-- Should not give a non-exhaustive-patterns error
-- See Trac #1759


{-# OPTIONS_GHC -Wall #-}
{-# LANGUAGE ViewPatterns #-}

module ShouldCompile where

f :: Int -> Int
f ((+1) -> 1) = 5
f _           = 3

-- Should not give an overlapping-patterns or non-exhaustive-patterns error
-- See Trac #2395


{-# OPTIONS_GHC -fwarn-incomplete-uni-patterns #-}
{-# LANGUAGE Strict #-}
module DsStrictWarn where

-- should warn about non-exhaustive pattern match
w :: String -> String
w x = let (_:_) = x in "1"


{-# LANGUAGE GADTs #-}

module Gadt where

data T a where
   T1 :: T Int
   T2 :: T a
   T3 :: T Bool

f :: T Int -> Bool
f T1 = True
f T2 = False

g :: T Bool -> Bool
g T2 = True
g T3 = False

h :: T a -> Bool
h T1 = True
h T2 = False


{-# LANGUAGE NoImplicitPrelude #-}
{-# OPTIONS_GHC -O #-}
module T10251 where

data D = D
data E = E

class Storable a where
    poke2 :: a -> E
instance Storable D where
    poke2 = poke2 -- undefined

class Foo a where
instance Foo D where

class (Foo t, Storable t) => FooStorable t where

instance FooStorable D where
    {-# SPECIALIZE instance FooStorable D #-}

{-# SPECIALIZE bug :: D -> E #-}

bug
  :: FooStorable t
  => t
  -> E
bug = poke2
{-
sf 9160 # ghc -c -fforce-recomp -Wall B.hs

ghc: panic! (the 'impossible' happened)
  (GHC version 7.10.1 for x86_64-unknown-linux):
        Template variable unbound in rewrite rule
  $fFooStorableD_XU
  [$fFooStorableD_XU]
  [$fFooStorableD_XU]
  []
  []

Please report this as a GHC bug:  http://www.haskell.org/ghc/reportabug
-}


main :: IO ()
main = do
  return $ let a = "hello" in a
  return ()


{-# LANGUAGE ScopedTypeVariables, TypeFamilies #-}

module Main where

{- ghc-7.8.4 and ghc-7.10.2 showed a confusing warning:

T10767.hs:43:1: Warning:
    RULE left-hand side too complicated to desugar
      Optimised lhs: case cobox_aWY
                     of _ [Occ=Dead] { GHC.Types.Eq# cobox ->
                     genLength @ Int $dSpecList_aWX
                     }
      Orig lhs: case cobox_aWY of cobox_aWY { GHC.Types.Eq# cobox ->
                genLength @ Int $dSpecList_aWX
                }
-}

import Data.Proxy
import Data.Kind (Type)

class SpecList a where
    type List a :: Type

    slCase      :: List a -> b -> (a -> List a -> b) -> b

data IntList
  = ILNil
  | ILCons {-# UNPACK #-} !Int IntList
  deriving (Show)

instance SpecList Int where
  type List Int = IntList

  slCase ILNil        n _  = n
  slCase (ILCons i t) _ c  = c i t

fromList :: [Int] -> IntList
fromList []      = ILNil
fromList (h : t) = ILCons h (fromList t)

lst1 :: IntList
lst1 = fromList [1..10]

{-# SPECIALIZE genLength :: Proxy Int -> List Int -> Int #-}
genLength :: forall a . SpecList a => Proxy a -> List a -> Int
genLength p lst = slCase lst 0 (\(_ :: a) tail -> 1 + genLength p tail)

main :: IO ()
main = print (genLength (Proxy :: Proxy Int) lst1)


{-# LANGUAGE Strict #-}

main :: IO ()
main = print $ let x = undefined in True


{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -O #-}

module T12944 () where

import Data.Kind (Type)

class AdditiveGroup v where
  (^+^) :: v -> v -> v
  negateV :: v -> v
  (^-^) :: v -> v -> v
  v ^-^ v' = v ^+^ negateV v'

class AdditiveGroup v => VectorSpace v where
  type Scalar v :: Type
  (*^) :: Scalar v -> v -> v

data Poly1 a = Poly1 a a

data IntOfLog poly a = IntOfLog !a !(poly a)

instance Num a => AdditiveGroup (Poly1 a) where
    {-# INLINE (^+^) #-}
    {-# INLINE negateV #-}
    Poly1 a b ^+^ Poly1 a' b' = Poly1 (a + a') (b + b')
    negateV (Poly1 a b) = Poly1 (negate a) (negate b)

instance (AdditiveGroup (poly a), Num a) => AdditiveGroup (IntOfLog poly a) where
    {-# INLINE (^+^) #-}
    {-# INLINE negateV #-}
    IntOfLog k p ^+^ IntOfLog k' p' = IntOfLog (k + k') (p ^+^ p')
    negateV (IntOfLog k p) = IntOfLog (negate k) (negateV p)
    {-# SPECIALISE instance Num a => AdditiveGroup (IntOfLog Poly1 a) #-}
        -- This pragmas casued the crash

instance (VectorSpace (poly a), Scalar (poly a) ~ a, Num a) => VectorSpace (IntOfLog poly a) where
    type Scalar (IntOfLog poly a) = a
    s *^ IntOfLog k p = IntOfLog (s * k) (s *^ p)


{-# LANGUAGE TypeFamilies #-}

{-# OPTIONS_GHC -O #-}

module T12950 where

class C a where
  type TF a; m :: a -> TF a

instance C Int where
  type TF Int = String; m = show

overloaded :: C a => a -> (a,TF a)
{-# INLINABLE overloaded #-}
overloaded a = (a,m a)

{-# SPECIALIZE overloaded :: Int -> (Int,TF Int) #-}


{-# LANGUAGE BangPatterns #-}
module T13043 (foo, bar) where

import Data.IORef (IORef, newIORef, readIORef, writeIORef)
import System.IO.Unsafe (unsafePerformIO)

{-# NOINLINE scServerState #-}
scServerState :: SCServerState
scServerState = unsafePerformIO (return undefined)

data SCServerState = SCServerState
     { scServer_socket :: IORef (Maybe Int)
     }

foo :: IO Int
foo = do
   let !_ = scServerState
   readIORef (scServer_socket scServerState) >>= \xs -> case xs of
      Nothing -> do
         s <- undefined
         writeIORef (scServer_socket scServerState) (Just s)
         return s
      Just s -> return s

bar :: IO ()
bar = do
   let !_ = scServerState
   return ()


module T13208 where

f x = let g = \x -> x in g True


{-# LANGUAGE BangPatterns #-}
module T13215 where

newtype F = F Int

foo !(F {}) = ()


module T13257 where

  import Data.Int

  int8 = -128 :: Int8
  word = -1 :: Word


module T13290 where

data Foo = Bar Int Char | Baz Char

{-# RULES
"BarBaz" Bar 0 'a' = Baz 'b'
 #-}


-- !!! T13870 -- missing-fields warnings for recprd-construction

module ShouldCompile where

import Data.Functor.Identity

test1 :: Maybe Int
test1 = Just{}

test2 :: Maybe Int
test2 = Nothing{}

test3 :: Identity Int
test3 = Identity{}


{-# LANGUAGE PatternSynonyms #-}
{-# OPTIONS_GHC -Wincomplete-patterns #-}
{-# LANGUAGE GADTs #-}
module T14135 where

data Foo a where
  Foo1 :: a -> Foo a
  Foo2 :: Int -> Foo Int

pattern MyFoo2 :: (a ~ Int) => Int -> Foo a
pattern MyFoo2 i = Foo2 i

{-# COMPLETE Foo1, MyFoo2 #-}

f :: Foo a -> a
f (Foo1 x) = x


main :: IO ()
main = do
   case 0::Int of
      0 -> putStrLn "A"
      1 -> putStrLn "B"
      _ -> putStrLn "C"

   case 0::Int of
      0 -> putStrLn "A"
      1 -> putStrLn "B"
      2 -> putStrLn "C"

   case 0::Integer of
      0 -> putStrLn "A"
      1 -> putStrLn "B"
      _ -> putStrLn "C"

   case 0::Integer of
      0 -> putStrLn "A"
      1 -> putStrLn "B"
      2 -> putStrLn "C"

   case 0::Integer of
      1 -> putStrLn "B"
      2 -> putStrLn "C"

   case 3::Integer of
      1 -> putStrLn "B"
      2 -> putStrLn "C"


main :: IO ()
main = do
   case "foo" of
      ('f':_)     -> putStrLn "A"
      ('f':'o':_) -> putStrLn "B"
      "bar"       -> putStrLn "C"

   case "foo" of
      "foo" -> putStrLn "A"
      "bar" -> putStrLn "B"
      "baz" -> putStrLn "C"


{-# LANGUAGE OverloadedStrings #-}

import qualified Data.ByteString as B

main :: IO ()
main = do
   case "foo" of
      ('f':_)     -> putStrLn "A"
      ('f':'o':_) -> putStrLn "B"
      "bar"       -> putStrLn "C"

   case "foo" of
      "foo" -> putStrLn "A"
      "bar" -> putStrLn "B"
      "baz" -> putStrLn "C"

   case ("foo" :: B.ByteString) of
      "foo" -> putStrLn "A"
      "bar" -> putStrLn "B"
      "baz" -> putStrLn "C"


{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE TypeFamilies #-}

module T14547 where

class Foo f where
        type It f
        foo :: [It f] -> f

data List a = Empty | a :! List a deriving Show

instance Foo (List a) where
        type It (List a) = a
        foo [] = Empty
        foo (x : xs) = x :! foo xs


{-# LANGUAGE MultiWayIf #-}

module T14773a where

foo :: Bool -> Int
foo b = if | b -> 1

bar :: Bool -> Int
bar b = if | b         -> 1
           | otherwise -> 2


module T14773b where

b :: Bool
(Just b) | False = Nothing

c :: Bool
(Just c) | False = Nothing
         | True = Just True


-- Desugarer outputs of this program when compiled with and without -XStrict
-- should be the same because this program has only one binder (`a` in function
-- `primitive`), but the binder is annotated with a laziness annotation, so
-- -XStrict should have no effect on that binder.
--
-- Derived methods are also effected by -XStrict, but in our case we derive via
-- GND which just generates coercions like
--
--     instance Functor m => Functor (StateT s m) where
--       fmap
--         = coerce
--             @(forall (a_aJ2 :: TYPE LiftedRep) (b_aJ3 :: TYPE LiftedRep).
--               a_aJ2 -> b_aJ3
--               -> StateT s_aDW m_aDX a_aJ2 -> StateT s_aDW m_aDX b_aJ3)
--             @(forall (a_aJ2 :: TYPE LiftedRep) (b_aJ3 :: TYPE LiftedRep).
--               a_aJ2 -> b_aJ3
--               -> StateT s_aDW m_aDX a_aJ2 -> StateT s_aDW m_aDX b_aJ3)
--             fmap
--
-- So really -XStrict shouldn't have any effect on this program.

{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MagicHash                  #-}
{-# LANGUAGE MultiParamTypeClasses      #-}
{-# LANGUAGE TypeFamilies               #-}
{-# LANGUAGE UnboxedTuples              #-}

module K where

import qualified Control.Monad.State.Strict as S
import Control.Monad.Trans
import GHC.Exts

class Monad m => PrimMonad m where
  type PrimState m
  primitive :: (State# (PrimState m) -> (# State# (PrimState m), a #)) -> m a

newtype StateT s m a = StateT (S.StateT s m a)
  deriving (Functor, Applicative, Monad, MonadTrans)

instance PrimMonad m => PrimMonad (StateT s m) where
  type PrimState (StateT s m) = PrimState m
  primitive ~a = lift (primitive a) ; {-# INLINE primitive #-}


{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -Wall #-}

-- Pattern-match overlap warnings with view patterns
module T2395 where

foo :: Int -> Int
foo (even -> True) = 4
foo _              = 5

bar :: (a, (Int,Int)) -> Int
bar (snd -> (x,y)) = x+y   -- Cannot fail, hence overlap warning should
bar _              = 6     -- for second pattern


-- Trac #2409

module ShouldCompile where

 f :: Int -> Int
 f _ | () `seq` False = undefined
     | otherwise = error "XXX"

 g :: Int -> Int
 g _ | () `seq` False = undefined
     | otherwise = error "XXX"


{-# LANGUAGE TypeOperators, GADTs, EmptyCase #-}
module T2431 where

data a :~: b where
  Refl :: a :~: a

absurd :: Int :~: Bool -> a
absurd x = case x of {}


-- Trac #3263.  New kind of warning on ignored monadic bindings

module T3263 where

nullM :: IO ()
nullM = return ()

nonNullM :: IO Int
nonNullM = return 10

-- No warning
t1 = do
  nonNullM

-- No warning
t2 = nonNullM

-- No warning
t3 = do
  nullM
  nonNullM

-- Warning
t4 = do
  nonNullM
  nullM

-- No warning
t5 = do
  _ <- nonNullM
  nullM

-- Warning
t6 = mdo
  nonNullM
  nullM


-- Trac #3263.  New kind of warning on monadic bindings that discard a monadic result

module T3263 where

import Control.Monad.Fix

-- No warning
t1 :: Monad m => m Int
t1 = do
  return 10

-- No warning
t2 :: Monad m => m (m Int)
t2 = return (return 10)

-- No warning
t3 :: Monad m => m (m Int)
t3 = do
  return 10
  return (return 10)

-- Warning
t4 :: forall m. Monad m => m Int
t4 = do
  return (return 10 :: m Int)
  return 10

-- No warning
t5 :: forall m. Monad m => m Int
t5 = do
  _ <- return (return 10 :: m Int)
  return 10

-- Warning
t6 :: forall m. MonadFix m => m Int
t6 = mdo
  return (return 10 :: m Int)
  return 10


{-# LANGUAGE ViewPatterns,DeriveDataTypeable #-}
module T4371 where

import Data.Typeable

data E1 = E1 deriving Typeable
data E2 = E2 deriving Typeable

f :: Typeable a => a-> ()
f x = case x of
  (cast -> Just E1) -> ()
  (cast -> Just E2) -> ()


{-# LANGUAGE ViewPatterns, ExistentialQuantification #-}
{-# OPTIONS_GHC -fwarn-incomplete-patterns #-}

-- None of these should give incomplete-pattern warnings

module T4439 where

data Moo = Moo (Char -> Int)
spqr (Moo _) = undefined
foo (id -> Moo _) = undefined

data Exists = forall a. Exists (a -> Int)
bar (Exists _) = undefined
baz (id -> Exists _) = undefined


{-# OPTIONS -fwarn-identities #-}

-- Test warnings about identities

module T4488 where

-- ok1 :: Int -> Float
ok1 x = fromIntegral x

warn1 :: Int -> Int
warn1 x = fromIntegral x

ok4 :: Int -> Integer
ok4 x = toInteger x

warn4 :: Integer -> Integer
warn4 x = toInteger x

ok5 :: Float -> Rational
ok5 x = toRational x

warn5 :: Rational -> Rational
warn5 x = toRational x

-- ok6 :: Float -> Rational
ok6 x = realToFrac x

warn6 :: Float -> Float
warn6 x = realToFrac x


module T4870 where

import T4870a

data D = D

instance C D where
  c x = x

{-# SPECIALIZE f :: D #-}


module T4870a where

class C a where c :: a -> a

{-# INLINABLE f #-}
f :: (C a) => a
f = c f


{-# LANGUAGE MultiParamTypeClasses #-}

module T5001 where

import T5001a

data T = T

instance Comorphism Float Int Char T


{-# LANGUAGE MultiParamTypeClasses #-}

module T5001a (Comorphism(..)) where

class Show a => Comorphism a b c d where
    map_sentence :: a -> b -> c -> Result d
    map_sentence = f

f :: Comorphism a b c d => a -> b -> c -> Result d
f x _ _ = fatal_error ("Unsupported sentence translation " ++ show x)

data Result a = Result String

fatal_error :: String -> Result a
fatal_error s = Result s


{-# LANGUAGE OverloadedStrings #-}
module BadWarning where

data MyString = MyString String

f1 (MyString "a") = undefined
f1 (MyString "bb") = undefined
f1 _ = undefined

f2 (MyString "aa") = undefined
f2 (MyString "bb") = undefined
f2 _ = undefined

-- Genuine overlap here!
f3(MyString ('a':_)) = undefined
f3 (MyString "a") = undefined
f3 _ = undefined


-- Trac #5252
-- Killed 7.03 when compiled witout -O,
-- because it could not see that x had a product type
-- but MkS still unpacked it

module T5252 where
import T5252a

blah :: S -> T
blah (MkS x _) = x


module T5252a( S(..), T ) where

data T = MkT Int Int

data S = MkS {-# UNPACK #-}!T Int


module T5252Take2 where
import qualified T5252Take2a as M

write_message :: M.WriteMessage -> IO Bool
write_message (M.WriteMessage _) = return True


{-# OPTIONS_GHC -funbox-strict-fields #-}

module T5252Take2a ( WriteMessage(..) , WriteDevice ) where

import qualified Data.ByteString as ByteString

data WriteMessage = WriteMessage !WriteDevice
newtype WriteDevice = WriteDevice ByteString.ByteString


{-# OPTIONS_GHC -fwarn-incomplete-uni-patterns #-}
module T5455 where

-- No error message for this one:
-- the pattern will never be demanded

w :: String -> String
w x = let (_:_) = x in "1"

-- We should get just one error message here

w2 :: String -> String
w2 x2 = let (a:as) = x2 in (a:a:as)


{-# LANGUAGE EmptyCase #-}
{-# OPTIONS_GHC -fwarn-incomplete-patterns #-}

module T7669 where

data Void

foo :: Void -> ()
foo x = case x of {}
-- Should not get incomplete-pattern warning


{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -fwarn-unused-do-bind #-}
module T8470 where

data User
type family MethodResult ev
type instance MethodResult User = ()
type EventResult a = MethodResult a

foo = do undefined :: IO (EventResult User)
         return ()


{-# LANGUAGE Strict #-}
module Main where

main = let False = True
       in return ()


{-# LANGUAGE LambdaCase #-}

module Main where

f = curry $ \case (Just x,  Left y)            -> Just (x, y)
                  (Nothing, Right y) | y == 99 -> Just (0, "99")
                  _                            -> Nothing

main = print $ [ f (Just 1) (Left "Y") == Just (1, "Y")
               , f (Just 1) (Right 99) == Nothing
               , f Nothing  (Right 99) == Just (0, "99")
               , f Nothing  (Right 9)  == Nothing
               , f Nothing  (Left "Y") == Nothing ]


{-# LANGUAGE MultiWayIf #-}

module Main where

import Data.List (isSuffixOf)
import Control.Exception

errMsg = "Non-exhaustive guards in multi-way if\n"
table  = [(1, "one"), (100, "hundred")]

f t x = if | l <- length t, l > 2, l < 5 -> "length is 3 or 4"
           | Just y <- lookup x t -> y
           | False -> "impossible"
           | null t -> "empty"

main = do
  print $ [ f table 1   == "one"
          , f table 100 == "hundred"
          , f [] 1      == "empty"
          , f [undefined, undefined, undefined] (undefined :: Bool) ==
              "length is 3 or 4"
          , f ((0, "zero") : table) 100 == "length is 3 or 4"
          ]
  r <- try $ evaluate $ f table 99
  print $ case r of
    Left (PatternMatchFail s) | errMsg `isSuffixOf` s -> True
    _                                                 -> False


{-      Check that list comprehensions can be written
        in do-notation. This actually broke 2.02, with
        a pattern match failure in dsListComp!
-}

module Main where

main = putStrLn (show theList)
theList = do x <- [1..3]
             y <- [1..3]
             return (x,y)


{- Tests let-expressions in do-statements -}

module Main( main ) where

foo = do
        putStr "a"
        let x = "b" in putStr x
        putStr "c"

main = do
         putStr "a"
         foo
         let x = "b" in putStrLn x


-- Tests match on empty field lists

module Main where

data Person     =  Female {firstName, lastName :: String}
                |  Male   {firstName, lastName :: String}
                deriving (Show)

isFemale (Female{})   =  True
isFemale (Male{})     =  False

main = print (isFemale (Female {firstName = "Jane", lastName = "Smith"}))


-- Test n+k patterns

{-# LANGUAGE NPlusKPatterns #-}

module Main where

f (n+1) = n

g :: Int -> Int
g (n+4) = n

main = print (f 3)      >>
       print (g 9)


{-

From: Olaf Chitil <chitil@Informatik.RWTH-Aachen.DE>

It is a problem with 0.29 (which we use for compiling 2.01), it is gone
in 2.01.

        f :: Eq a => a -> [b] -> [b] -> Bool
        f a [] [] = (a==a)
        main = print (f True "" "Hallo")

when run after compilation with 0.29 you get:
Fail: "test.hs", line 6: incomplete pattern(s) to match in function "ds.d5b4"

while 2.01 gives you as desired
Fail: In pattern-matching: function f{-aYw-}; at test.hs, line 6

The problem is the dictionary, because for the program

        f :: a -> [b] -> [b] -> Bool
        f a [] [] = True
        main = print (f True "" "Hallo")

0.29 gives the function name "f" as well.

So it's ok in 2.01, but why did you change the form of the error messages?
"incomplete pattern(s) to match" is more informative then "In pattern-matching"!
I even prefer the order of information in the 0.29 error messages.

May I finally repeat that in my opinion the compiler should warn about
incomplete patterns during compilation. However, I suppose the
incomplete patterns are just recognised by the desugarer which does
not produce error messages any more.

-}

module Main where

f :: Eq a => a -> [b] -> [b] -> Bool
f a [] [] = (a==a)

main = print (f True "" "Hallo")


{-
Date: Tue, 20 May 1997 05:10:04 GMT
From: Tomasz Cholewo <tjchol01@mecca.spd.louisville.edu>

ghc-2.03 cannot compile the following code, which I think is correct
according to the Report

        data X = A {a :: Int} | B {a :: Int}

The error message is:

    Conflicting definitions for:  a
        Defined at bug4.lhs:2
        Defined at bug4.lhs:2

In addition the following snippet

        data X = A {a :: Int}
        y = let A {a} = x
            in a

fails with:

    bug4.lhs:4:5: Not a valid LHS on input: "in"
-}
--module Main(main) where

data X = A {a :: Int} | B {a :: Int}

f x = let A {a=a} = x
      in a

main = print (f (A {a = 3}))


data T = C Int

unpick (C i) = i + 1

main = print (unpick (C{}))


-- !!! Double irrefutable pattern (bug in Hugs98, 29/8/2001)
main = print (case (1,2) of ~(~(2,x)) -> x)


-- !!! Test that 'negate' is used properly to construct negative literals

main = print (minusTwo,trueOrFalse)

minusTwo = -2::N

trueOrFalse =
    case minusTwo of
      -2 -> True
      _ -> False

data N = Negate N | FromInteger Integer deriving (Eq,Show)

instance Num N where
  negate = Negate
  fromInteger = FromInteger


-- Check that pattern match failure in do-notation
-- is reflected by calling the monadic 'fail', not by a
-- runtime exception

{-# LANGUAGE NoMonadFailDesugaring #-}
{-# OPTIONS -Wno-missing-monadfail-instances #-}

import Control.Monad
import Data.Maybe

test :: (MonadPlus m) => [a] -> m Bool
test xs
  =   do
        (_:_) <- return xs
                -- Should fail here
        return True
    `mplus`
        -- Failure in LH arg should trigger RH arg
      do
        return False

main :: IO ()
main
  = do  let x = fromJust (test [])
        putStrLn (show x)


-- Test desugaring of mutual recursion of many functions
-- which generated a big-tuple link error in GHC 6.0

module Main where

a1 :: (Num a, Eq a) => a -> a

a1 x | x==0 = x
a1 x = 1 + k8 (x-1)

a2 x = 1 + a1 x
a3 x = 1 + a2 x
a4 x = 1 + a3 x
a5 x = 1 + a4 x
a6 x = 1 + a5 x
a7 x = 1 + a6 x
a8 x = 1 + a7 x

b1 x = 1 + a8 x
b2 x = 1 + b1 x
b3 x = 1 + b2 x
b4 x = 1 + b3 x
b5 x = 1 + b4 x
b6 x = 1 + b5 x
b7 x = 1 + b6 x
b8 x = 1 + b7 x

c1 x = 1 + b8 x
c2 x = 1 + c1 x
c3 x = 1 + c2 x
c4 x = 1 + c3 x
c5 x = 1 + c4 x
c6 x = 1 + c5 x
c7 x = 1 + c6 x
c8 x = 1 + c7 x

d1 x = 1 + c8 x
d2 x = 1 + d1 x
d3 x = 1 + d2 x
d4 x = 1 + d3 x
d5 x = 1 + d4 x
d6 x = 1 + d5 x
d7 x = 1 + d6 x
d8 x = 1 + d7 x

e1 x = 1 + d8 x
e2 x = 1 + e1 x
e3 x = 1 + e2 x
e4 x = 1 + e3 x
e5 x = 1 + e4 x
e6 x = 1 + e5 x
e7 x = 1 + e6 x
e8 x = 1 + e7 x

f1 x = 1 + e8 x
f2 x = 1 + f1 x
f3 x = 1 + f2 x
f4 x = 1 + f3 x
f5 x = 1 + f4 x
f6 x = 1 + f5 x
f7 x = 1 + f6 x
f8 x = 1 + f7 x

g1 x = 1 + f8 x
g2 x = 1 + g1 x
g3 x = 1 + g2 x
g4 x = 1 + g3 x
g5 x = 1 + g4 x
g6 x = 1 + g5 x
g7 x = 1 + g6 x
g8 x = 1 + g7 x

h1 x = 1 + g8 x
h2 x = 1 + h1 x
h3 x = 1 + h2 x
h4 x = 1 + h3 x
h5 x = 1 + h4 x
h6 x = 1 + h5 x
h7 x = 1 + h6 x
h8 x = 1 + h7 x

k1 x = 1 + h8 x
k2 x = 1 + k1 x
k3 x = 1 + k2 x
k4 x = 1 + k3 x
k5 x = 1 + k4 x
k6 x = 1 + k5 x
k7 x = 1 + k6 x
k8 x = 1 + k7 x

main = print (a1 3)


{-# LANGUAGE UnboxedTuples #-}

-- This one killed GHC 6.4.1, because the pattern match on the
-- unboxed tuple generates a failure case, which defeated the
-- rather fragile code in the desugarer
-- See DsExpr.lhs, the HsCase case

module Main where

foo xs ys = case (# null xs, null ys #) of
              (# True, False #) -> "One"
              (# False, True #) -> "Two"

main :: IO ()
main = print (foo [] "ok")


{-# LANGUAGE UnboxedTuples #-}

module Main where

import Debug.Trace

{-# NOINLINE f #-}
f :: a -> b -> (# a,b #)
f x y = x `seq` y `seq` (# x,y #)

g :: Int -> Int -> Int
g v w = case f v w of
          (# a,b #) -> a+b

main = print (g (trace "one" 1) (trace "two" 2))
-- The args should be evaluated in the right order!


{-# OPTIONS_GHC -XRecordWildCards -XNamedFieldPuns #-}

-- This is a very partial test of the record-wildcard extension
-- but better than nothing

module Main where

data T = C { x :: Int, y :: Int }
       | D { x :: Int, b :: Bool }

select :: T -> Int
select = x

f :: (T,T) -> Int
f v = let (C {..}, d) = v in Main.x d

mkC a =
    let x = a + 1
        y = a * 2
    in  C{..}

sumC C{..} = x + y

foo x b =
    let y = x+1
    in  (C{..}, let x = 100 in D{..})

bar a =
    let (C{..}, d) = a
    in  (x + y + Main.x d, let D{..} = d in b)

main = do
    print $ sumC $ mkC 10
    print $ bar $ foo 5 True


-- Tests grouping WITH a using clause but WITHOUT a by clause

{-# OPTIONS_GHC -XTransformListComp #-}

module Main where

import Data.List(inits)

main = putStrLn (show output)
  where
    output = [ x
             | y <- [1..3]
             , x <- "hello"
             , then group using inits ]


-- Tests grouping WITH a by clause

{-# OPTIONS_GHC -XTransformListComp #-}

module Main where

import GHC.Exts(the,groupWith)

main = putStrLn (show output)
  where
    output = [ (the dept, sum salary, name)
             | (dept, salary, name) <- [("A", 1, "Bob"), ("B", 2, "Fred"), ("A", 5, "Jim"), ("A", 9, "Jim")]
             , then group by dept using groupWith ]


-- Test grouping with both a using and a by clause

{-# OPTIONS_GHC -XTransformListComp #-}

module Main where

import Data.List(groupBy)
import GHC.Exts(the)

groupRuns :: Eq b => (a -> b) -> [a] -> [[a]]
groupRuns f = groupBy (\x y -> f x == f y)

main = putStrLn (show output)
  where
    output = [ (the x, product y)
             | x <- ([1, 1, 1, 2, 2, 1, 3])
             , y <- [4..6]
             , then group by x using groupRuns ]


-- Test transform WITHOUT a by clause

{-# OPTIONS_GHC -XTransformListComp #-}

module Main where

main = putStrLn (show output)
  where
    output = [ x
             | x <- [1..10]
             , then take 5 ]


-- Tests transform WITH a by clause

{-# OPTIONS_GHC -XTransformListComp #-}

module Main where

import Data.List(takeWhile)

main = putStrLn (show output)
  where
    output = [ (x * 10) + y
             | x <- [1..4]
             , y <- [1..4]
             , then takeWhile by (x + y) < 4]


-- Transformation stress test

{-# OPTIONS_GHC -XTransformListComp #-}

module Main where

import Data.List(takeWhile)
import GHC.Exts(sortWith)

employees = [ ("Simon", "MS", 80)
            , ("Erik", "MS", 100)
            , ("Phil", "Ed", 40)
            , ("Gordon", "Ed", 45)
            , ("Paul", "Yale", 60)]

main = putStrLn (show output)
  where
    output = [ (dept, salary)
             | (name, dept, salary) <- employees
             , then sortWith by salary
             , then filter by salary > 50
             , then take 1 ]


-- Transformation and grouping stress test

{-# OPTIONS_GHC -XTransformListComp #-}

module Main where

import GHC.Exts(sortWith, the, groupWith)

employees = [ ("Simon", "MS", 80)
            , ("Erik", "MS", 100)
            , ("Phil", "Ed", 40)
            , ("Gordon", "Ed", 45)
            , ("Paul", "Yale", 60) ]

main = putStrLn (show can_still_use_group_function) >> putStrLn (show output)
  where
    output = [ (the dept, map sum salary, (show x) ++ " and " ++ (show y))
             | (name, dept, salary) <- employees
             , then group by dept using groupWith
             , x <- [1, 2, 3]
             , y <- [4, 5, 6]
             , then sortWith by sum salary
             , then take 4
             , then group using replicate 2 ]
    group = const "my group function called!"
    can_still_use_group_function = group "Mississippi"


{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE StaticPointers       #-}

import Data.Typeable
import GHC.StaticPtr

main = putStr $ unlines $ map show names
  where
    names =
      [ staticPtrInfo $ static g
      , staticPtrInfo $ (static id :: StaticPtr (Int -> Int))
      , staticPtrInfo $ (p0 :: StaticPtr (Int -> Int))
      , staticPtrInfo $ (static method :: StaticPtr (Char -> Int))
      , staticPtrInfo $ (static t_field :: StaticPtr (T Int -> Int))
      ]

g :: Int -> Int
g = id

p0 :: Typeable a => StaticPtr (a -> a)
p0 = static (\x -> x)

data T a = T { t_field :: a }
  deriving Typeable

class C1 a where
  method :: a -> Int

instance C1 Char where
  method = const 0


{-# LANGUAGE Strict #-}
{-# OPTIONS_GHC -fno-warn-unused-binds #-}
module Main where

import Debug.Trace

f0 a = "fun"
f0' ~a = "fun2"

f1 ~n =
  case n of
    a -> "case"
f1' ~n =
  case n of
    ~a -> "case2"

f2 = \a -> "lambda"
f2' = \ ~a -> "lambda2"

newtype Age = MkAge Int

f4, f4' :: Age -> String
f4 (MkAge a) = "newtype"
f4' ~(MkAge a) = "newtype2"

main :: IO ()
main = mapM_ (\(what,f) -> putStrLn (f (v what))) fs
  where fs =
          [("fun",f0 )
          ,("fun lazy",f0')
          ,("case",f1)
          ,("case lazy",f1')
          ,("lambda",f2)
          ,("lambda lazy",f2')
          ,("newtype",(\ ~i -> f4 (MkAge i)))
          ,("newtype lazy",(\ ~i -> f4' (MkAge i)))]
        v n = trace ("evaluated in " ++ n) 1


{-# LANGUAGE ScopedTypeVariables, StrictData, GADTs #-}

-- | Tests the StrictData LANGUAGE pragma.
module Main where

import qualified Control.Exception as E
import System.IO.Unsafe (unsafePerformIO)

data Strict a = S a
data Strict2 b = S2 !b
data Strict3 c where
  S3 :: c -> Strict3 c

data UStrict = US {-# UNPACK #-} Int

data Lazy d = L ~d
data Lazy2 e where
  L2 :: ~e -> Lazy2 e

main :: IO ()
main =
  do print (isBottom (S bottom))
     print (isBottom (S2 bottom))
     print (isBottom (US bottom))
     print (isBottom (S3 bottom))
     putStrLn ""
     print (not (isBottom (L bottom)))
     print (not (isBottom (L2 bottom)))
     print (not (isBottom (Just bottom))) -- sanity check

------------------------------------------------------------------------
-- Support for testing for bottom

bottom :: a
bottom = error "_|_"

isBottom :: a -> Bool
isBottom f = unsafePerformIO $
  (E.evaluate f >> return False) `E.catches`
    [ E.Handler (\(_ :: E.ArrayException)   -> return True)
    , E.Handler (\(_ :: E.ErrorCall)        -> return True)
    , E.Handler (\(_ :: E.NoMethodError)    -> return True)
    , E.Handler (\(_ :: E.NonTermination)   -> return True)
    , E.Handler (\(_ :: E.PatternMatchFail) -> return True)
    , E.Handler (\(_ :: E.RecConError)      -> return True)
    , E.Handler (\(_ :: E.RecSelError)      -> return True)
    , E.Handler (\(_ :: E.RecUpdError)      -> return True)
    ]


{-# LANGUAGE Strict #-}
module Main where

import Debug.Trace

main = let False = trace "no binders" False -- evaluated

           a :: a -> a
           a = trace "polymorphic" id -- evaluated

           f :: Eq a => a -> a -> Bool
           f = trace "overloaded" (==) -- not evaluated

           xs :: [Int]
           xs = (trace "recursive" (:) 1 xs) -- evaluated
       in return ()


-- Transformation and grouping stress test

{-# OPTIONS_GHC -XMonadComprehensions -XTransformListComp #-}

module Main where

import GHC.Exts(sortWith, the, groupWith)

employees = [ ("Simon", "MS", 80)
            , ("Erik", "MS", 100)
            , ("Phil", "Ed", 40)
            , ("Gordon", "Ed", 45)
            , ("Paul", "Yale", 60) ]

main = putStrLn (show can_still_use_group_function) >> putStrLn (show output)
  where
    output = [ (the dept, map sum salary, (show x) ++ " and " ++ (show y))
             | (name, dept, salary) <- employees
             , then group by dept using groupWith
             , x <- [1, 2, 3]
             , y <- [4, 5, 6]
             , then sortWith by sum salary
             , then take 4
             , then group using replicate 2 ]
    group = const "my group function called!"
    can_still_use_group_function = group "Mississippi"


-- Transformation stress test

{-# OPTIONS_GHC -XMonadComprehensions -XTransformListComp #-}

module Main where

import Data.List(takeWhile)
import GHC.Exts(sortWith)

employees = [ ("Simon", "MS", 80)
            , ("Erik", "MS", 100)
            , ("Phil", "Ed", 40)
            , ("Gordon", "Ed", 45)
            , ("Paul", "Yale", 60)]

main = putStrLn (show output)
  where
    output = [ (dept, salary)
             | (name, dept, salary) <- employees
             , then sortWith by salary
             , then filter by salary > 50
             , then take 1 ]


-- Test transform WITHOUT a by clause

{-# OPTIONS_GHC -XMonadComprehensions -XTransformListComp #-}

module Main where

main = putStrLn (show output)
  where
    output = [ x
             | x <- [1..10]
             , then take 5 ]


-- Test grouping with both a using and a by clause

{-# OPTIONS_GHC -XMonadComprehensions -XTransformListComp #-}

module Main where

import Data.List(groupBy)
import GHC.Exts(the)

groupRuns :: Eq b => (a -> b) -> [a] -> [[a]]
groupRuns f = groupBy (\x y -> f x == f y)

main = putStrLn (show output)
  where
    output = [ (the x, product y)
             | x <- ([1, 1, 1, 2, 2, 1, 3])
             , y <- [4..6]
             , then group by x using groupRuns ]


-- Tests transform WITH a by clause

{-# OPTIONS_GHC -XMonadComprehensions -XTransformListComp #-}

module Main where

import Data.List(takeWhile)

main = putStrLn (show output)
  where
    output = [ (x * 10) + y
             | x <- [1..4]
             , y <- [1..4]
             , then takeWhile by (x + y) < 4]


-- Tests grouping WITH a by clause

{-# OPTIONS_GHC -XMonadComprehensions -XTransformListComp #-}

module Main where

import GHC.Exts(the, groupWith)

main = putStrLn (show output)
  where
    output = [ (the dept, sum salary, name)
             | (dept, salary, name) <- [("A", 1, "Bob"), ("B", 2, "Fred"), ("A", 5, "Jim"), ("A", 9, "Jim")]
             , then group by dept using groupWith]


testF :: Float -> Bool
testF x = x == 0 && not (isNegativeZero x)

testD :: Double -> Bool
testD x = x == 0 && not (isNegativeZero x)

main :: IO ()
main = do print $ testF (-0.0)
          print $ testD (-0.0)


{-# LANGUAGE Strict #-}

module Main where

main = do
  ~a <- return (error "don't error here!")
  b <- return (error "error here!") -- this binding should be strict
  print "should never reach here"


{-# LANGUAGE BangPatterns #-}

module Main where

main :: IO ()
main = let !_ = (undefined :: ()) in print 2


{-# LANGUAGE BangPatterns #-}

module Main where

-- This should fail evern though y is unused
f x = let !(Just (Just y)) = Just undefined in True

main = print (f False)


{-# LANGUAGE GADTs, RankNTypes, ScopedTypeVariables, Strict, TypeApplications
             #-}

import Data.Typeable

zero :: forall x. Typeable x => Maybe x
zero = do
    Refl <- eqT @Int @x
    pure 0

main :: IO ()
main = print (zero @())


{-# LANGUAGE BangPatterns #-}
module Main where

import GHC.Base

-- In Trac #12595 a bogus desugaring led (bizarrely)
-- to a top-level binding maxInt = maxInt
-- This test just checks that doesn't happen again

main = print (let !x = maxInt in even x)


module Main where

-- Main.hs
import GHC.Stack

main :: IO ()
main = do
  foo 23 42
  (`foo` 23) 42

foo :: HasCallStack => Int -> Int -> IO ()
foo _ _ = print (length . getCallStack $ callStack)


{-# LANGUAGE ScopedTypeVariables #-}
-- Test Trac #246

module Main where

import Control.Exception

data T = T { x :: Bool, y :: Bool }

f (T { y=True, x=True }) = "Odd"
f _                      = "OK"

g (T { x=True, y=True }) = "Odd2"
g _                      = "Odd3"

funny = T { x = undefined, y = False }

main = do { print (f funny)  -- Should work, because we test
                             -- y first, which fails, and falls
                             -- through to "OK"

          ; Control.Exception.catch
                  (print (g funny))        -- Should fail, because we test
                  (\(_::SomeException) -> print "caught")   -- x first, and hit "undefined"
          }


{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE OverloadedStrings #-}
module Main where
import Data.String

-- {{{ Num literals
newtype N = N Int deriving (Show,Eq)

instance Num N where
  fromInteger 0 = error "0"
  fromInteger 1 = N 0
  fromInteger _ = N 1

f x = case x of
        1 -> False
        0 -> True

g x = case x of
        1 -> False
        _ -> case x of
              0 -> True
              _ -> error "No match"

testNum = do
  print $ g (N 0)
  print $ f (N 0)

-- }}}

-- {{{ IsString literals
newtype S = S String deriving Eq

instance IsString S where
  fromString []    = error "[]"
  fromString (_:_) = S "."

fs x = case x of
        "." -> False
        ""  -> True

gs x = case x of
        "." -> False
        _   -> case x of
                 "" -> True
                 _  -> error "No match"

testIsString = do
  print $ gs (S ".")
  print $ fs (S ".")

-- }}}

main = do { testNum; testIsString }


{-# OPTIONS_GHC -XOverloadedStrings #-}
module Main where

import Data.String

instance IsString Int where
         fromString x = 1337

f :: Int -> String
f "hello" = "correct"
f _       = "false"

main = do print $ f 1337
          print $ f 1338


{-# LANGUAGE DoRec #-}

module Main where

main = do { x <- foo; print x }
foo :: IO Int
foo = do rec
             a1 <- return a2
             a2 <- return a3
             a3 <- return a4
             a4 <- return a5
             a5 <- return b1

             b1 <- return b2
             b2 <- return b3
             b3 <- return b4
             b4 <- return b5
             b5 <- return c1

             c1 <- return c2
             c2 <- return c3
             c3 <- return c4
             c4 <- return c5
             c5 <- return d1

             d1 <- return d2
             d2 <- return d3
             d3 <- return d4
             d4 <- return d5
             d5 <- return a1x

             a1x <- return a2x
             a2x <- return a3x
             a3x <- return a4x
             a4x <- return a5x
             a5x <- return b1x

             b1x <- return b2x
             b2x <- return b3x
             b3x <- return b4x
             b4x <- return b5x
             b5x <- return c1x

             c1x <- return c2x
             c2x <- return c3x
             c3x <- return c4x
             c4x <- return c5x
             c5x <- return d1x

             d1x <- return d2x
             d2x <- return d3x
             d3x <- return d4x
             d4x <- return d5x
             d5x <- return a1y

             a1y <- return a2y
             a2y <- return a3y
             a3y <- return a4y
             a4y <- return a5y
             a5y <- return b1y

             b1y <- return b2y
             b2y <- return b3y
             b3y <- return b4y
             b4y <- return b5y
             b5y <- return c1y

             c1y <- return c2y
             c2y <- return c3y
             c3y <- return c4y
             c4y <- return c5y
             c5y <- return d1y

             d1y <- return d2y
             d2y <- return d3y
             d3y <- return d4y
             d4y <- return d5y
             d5y <- return a1z

             a1z <- return a2z
             a2z <- return a3z
             a3z <- return a4z
             a4z <- return a5z
             a5z <- return b1z

             b1z <- return b2z
             b2z <- return b3z
             b3z <- return b4z
             b4z <- return b5z
             b5z <- return c1z

             c1z <- return c2z
             c2z <- return c3z
             c3z <- return c4z
             c4z <- return c5z
             c5z <- return d1z

             d1z <- return d2z
             d2z <- return d3z
             d3z <- return d4z
             d4z <- return d5z
             d5z <- return 1

         return a4


{-# LANGUAGE BangPatterns #-}

module Main where

main = print (case Nothing of
                  !(~(Just x)) -> "ok"
                  Nothing   -> "bad")


compareDouble :: Double -> Double -> Ordering
compareDouble x y =
       case (isNaN x, isNaN y) of
       (True, True)   -> EQ
       (True, False)  -> LT
       (False, True)  -> GT
       (False, False) ->
          -- Make -0 less than 0
          case (x == 0, y == 0, isNegativeZero x, isNegativeZero y) of
          (True, True, True, False) -> LT
          (True, True, False, True) -> GT
          _                         -> x `compare` y

main = do
    let l = [-0, 0]
    print [ (x, y, compareDouble x y) | x <- l, y <- l ]


{-# LANGUAGE BangPatterns #-}
module Main where
import Debug.Trace

newtype N = N Int

f0 :: N -> Int
f0 n = case n of
  !(N _) -> 0

f1 :: N -> Int
f1 n = n `seq` case n of
  N _ -> 0

f2 :: N -> Int
f2 n = case n of
  !(N {}) -> 0

f3 :: N -> Int
f3 n = n `seq` case n of
  N {} -> 0

main = do
  print $ f0 (trace "evaluated f0" (N 1))
  print $ f1 (trace "evaluated f1" (N 1))

  print $ f2 (trace "evaluated f2" (N 1))
  print $ f3 (trace "evaluated f3" (N 1))


module Main where

import Digraph

main = mapM_ print
  [ test001
  , test002
  , test003
  , test004
  ]

-- These check that the result of SCCs doesn't depend on the order of the key
-- type (Int here).

test001 = testSCC [("a", 1, []), ("b", 2, []), ("c", 3, [])]

test002 = testSCC [("a", 2, []), ("b", 3, []), ("c", 1, [])]

test003 = testSCC [("b", 1, []), ("c", 2, []), ("a", 3, [])]

test004 = testSCC [("b", 2, []), ("c", 3, []), ("a", 1, [])]

testSCC = flattenSCCs . stronglyConnCompFromEdgedVerticesOrd . map toNode
  where
    toNode (a, b, c) = DigraphNode a b c


module A where

-- This is a repro for the issue where to fingerprint a record, field labels
-- were pulled from FastStringEnv in the order of Uniques which are known
-- to have arbitrary order - see Note [Unique Determinism] in Unique.

data B = C
  { e :: ()
  , d :: ()
  }


module A () where

-- This checks that the order of dictionary binds doesn't depend on the
-- order of Uniques.
-- Consider succ from Enum, it requires Num Int and Eq Int. The order of
-- let binds used to depend on the order of Uniques. Consider:
--
--  let $dEq = GHC.Classes.$fEqInt in
--  let $$dNum = GHC.Num.$fNumInt in ...
--
--  vs
--
--  let $dNum = GHC.Num.$fNumInt in
--  let $dEq = GHC.Classes.$fEqInt in ...

data B = C
  deriving (Enum)

f :: Int -> Int
f n
  | n >= 0 = 0
  | otherwise = 0


{-# LANGUAGE TypeOperators, StarIsType
           , DataKinds
           , PolyKinds
           , TypeFamilies
           , GADTs
           , UndecidableInstances
           , RankNTypes
           , ScopedTypeVariables
  #-}

{-# OPTIONS_GHC -Wall #-}
{-# OPTIONS_GHC -Werror #-}
{-# OPTIONS_GHC -O1 -fspec-constr #-}

{-

With reversed order of allocated uniques the type variables would be in
wrong order:

*** Core Lint errors : in result of SpecConstr ***
determ004.hs:88:12: warning:
    [in body of lambda with binder m_azbFg :: a_afdP_azbON]
    @ (a_afdP_azbON :: BOX) is out of scope
*** Offending Program ***

...

Rec {
$s$wsFoldr1_szbtK
  :: forall (m_azbFg :: a_afdP_azbON)
            (x_azbOM :: TyFun
                          a_afdP_azbON (TyFun a_afdP_azbON a_afdP_azbON -> *)
                        -> *)
            (a_afdP_azbON :: BOX)
            (ipv_szbwN :: a_afdP_azbON)
            (ipv_szbwO :: [a_afdP_azbON]).
     R:Sing[]z (ipv_szbwN : ipv_szbwO)
     ~R# Sing (Apply (Apply (:$) ipv_szbwN) ipv_szbwO)
     -> Sing ipv_szbwO
     -> Sing ipv_szbwN
     -> (forall (t_azbNM :: a_afdP_azbON).
         Sing t_azbNM -> Sing (Apply x_azbOM t_azbNM))
     -> Sing
          (Apply
             (Apply Foldr1Sym0 x_azbOM)
             (Let1627448493XsSym4 x_azbOM m_azbFg ipv_szbwN ipv_szbwO))
[LclId,
 Arity=4,
 Str=<L,U><L,U><L,U><C(S(C(S))),C(U(1*C1(U)))>]
$s$wsFoldr1_szbtK =
  \ (@ (m_azbFg :: a_afdP_azbON))
    (@ (x_azbOM :: TyFun
                     a_afdP_azbON (TyFun a_afdP_azbON a_afdP_azbON -> *)
                   -> *))
    (@ (a_afdP_azbON :: BOX))
    (@ (ipv_szbwN :: a_afdP_azbON))
    (@ (ipv_szbwO :: [a_afdP_azbON]))
    (sg_szbtL
       :: R:Sing[]z (ipv_szbwN : ipv_szbwO)
          ~R# Sing (Apply (Apply (:$) ipv_szbwN) ipv_szbwO))
    (sc_szbtM :: Sing ipv_szbwO)
    (sc_szbtN :: Sing ipv_szbwN)
    (sc_szbtP
       :: forall (t_azbNM :: a_afdP_azbON).
          Sing t_azbNM -> Sing (Apply x_azbOM t_azbNM)) ->
    case (SCons
            @ a_afdP_azbON
            @ (ipv_szbwN : ipv_szbwO)
            @ ipv_szbwO
            @ ipv_szbwN
            @~ (<ipv_szbwN : ipv_szbwO>_N
                :: (ipv_szbwN : ipv_szbwO) ~# (ipv_szbwN : ipv_szbwO))
            sc_szbtN
            sc_szbtM)
         `cast` (sg_szbtL
                 ; TFCo:R:Sing[]z[0] <a_afdP_azbON>_N <Let1627448493XsSym4
                                                         x_azbOM m_azbFg ipv_szbwN ipv_szbwO>_N
                 :: R:Sing[]z (ipv_szbwN : ipv_szbwO)
                    ~R# R:Sing[]z
                          (Let1627448493XsSym4 x_azbOM m_azbFg ipv_szbwN ipv_szbwO))
    of wild_XD {
      SNil dt_dzbxX ->
        (lvl_szbwi @ a_afdP_azbON)
        `cast` ((Sing
                   (Sym (TFCo:R:Foldr1[2] <a_afdP_azbON>_N <x_azbOM>_N)
                    ; Sym
                        (TFCo:R:Apply[]kFoldr1Sym1l_afe2[0]
                           <a_afdP_azbON>_N <'[]>_N <x_azbOM>_N)
                    ; (Apply
                         (Sym
                            (TFCo:R:Apply(->)(->)Foldr1Sym0l[0] <a_afdP_azbON>_N <x_azbOM>_N))
                         (Sym dt_dzbxX))_N))_R
                :: Sing (Apply ErrorSym0 "Data.Singletons.List.foldr1: empty list")
                   ~R# Sing
                         (Apply
                            (Apply Foldr1Sym0 x_azbOM)
                            (Let1627448493XsSym4 x_azbOM m_azbFg ipv_szbwN ipv_szbwO)));
      SCons @ n_azbFh @ m_XzbGe dt_dzbxK _sX_azbOH
            ds_dzbyu [Dmd=<S,1*U>] ->
        case ds_dzbyu
             `cast` (TFCo:R:Sing[]z[0] <a_afdP_azbON>_N <n_azbFh>_N
                     :: Sing n_azbFh ~R# R:Sing[]z n_azbFh)
        of wild_Xo {
          SNil dt_dzbxk ->
            (lvl_szbw1 @ a_afdP_azbON @ m_XzbGe)
            `cast` ((Sing
                       (Sym (TFCo:R:Foldr1[0] <a_afdP_azbON>_N <m_XzbGe>_N <x_azbOM>_N)
                        ; Sym
                            (TFCo:R:Apply[]kFoldr1Sym1l_afe2[0]
                               <a_afdP_azbON>_N <'[m_XzbGe]>_N <x_azbOM>_N)
                        ; (Apply
                             (Sym
                                (TFCo:R:Apply(->)(->)Foldr1Sym0l[0] <a_afdP_azbON>_N <x_azbOM>_N))
                             ((<m_XzbGe>_N ': Sym dt_dzbxk)_N ; Sym dt_dzbxK))_N))_R
                    :: Sing m_XzbGe
                       ~R# Sing
                             (Apply
                                (Apply Foldr1Sym0 x_azbOM)
                                (Let1627448493XsSym4 x_azbOM m_azbFg ipv_szbwN ipv_szbwO)));
          SCons @ ipv_XzbxR @ ipv_XzbyV ipv_szbwM ipv_szbwL ipv_szbwK ->
            case (sc_szbtP @ m_XzbGe _sX_azbOH)
                 `cast` (TFCo:R:Sing(->)f[0]
                           <a_afdP_azbON>_N <a_afdP_azbON>_N <Apply x_azbOM m_XzbGe>_N
                         :: Sing (Apply x_azbOM m_XzbGe)
                            ~R# R:Sing(->)f (Apply x_azbOM m_XzbGe))
            of wild_X3X { SLambda ds_XzbBr [Dmd=<C(S),1*C1(U)>] ->
            (ds_XzbBr
               @ (Foldr1 x_azbOM (ipv_XzbyV : ipv_XzbxR))
               (($wsFoldr1_szbuc
                   @ a_afdP_azbON
                   @ x_azbOM
                   @ (Let1627448493XsSym4 x_azbOM m_XzbGe ipv_XzbyV ipv_XzbxR)
                   sc_szbtP
                   ((SCons
                       @ a_afdP_azbON
                       @ (ipv_XzbyV : ipv_XzbxR)
                       @ ipv_XzbxR
                       @ ipv_XzbyV
                       @~ (<ipv_XzbyV : ipv_XzbxR>_N
                           :: (ipv_XzbyV : ipv_XzbxR) ~# (ipv_XzbyV : ipv_XzbxR))
                       ipv_szbwL
                       ipv_szbwK)
                    `cast` (Sym (TFCo:R:Sing[]z[0] <a_afdP_azbON>_N) (Sym
                                                                        (TFCo:R:Apply[][]:$$i[0]
                                                                           <a_afdP_azbON>_N
                                                                           <ipv_XzbxR>_N
                                                                           <ipv_XzbyV>_N)
                                                                      ; (Apply
                                                                           (Sym
                                                                              (TFCo:R:Applyk(->):$l[0]
                                                                                <a_afdP_azbON>_N
                                                                                <ipv_XzbyV>_N))
                                                                           <ipv_XzbxR>_N)_N)
                            :: R:Sing[]z (ipv_XzbyV : ipv_XzbxR)
                               ~R# Sing (Apply (Apply (:$) ipv_XzbyV) ipv_XzbxR))))
                `cast` ((Sing
                           ((Apply
                               (TFCo:R:Apply(->)(->)Foldr1Sym0l[0] <a_afdP_azbON>_N <x_azbOM>_N)
                               <Let1627448493XsSym4 x_azbOM m_XzbGe ipv_XzbyV ipv_XzbxR>_N)_N
                            ; TFCo:R:Apply[]kFoldr1Sym1l_afe2[0]
                                <a_afdP_azbON>_N
                                ((Apply
                                    (TFCo:R:Applyk(->):$l[0] <a_afdP_azbON>_N <ipv_XzbyV>_N)
                                    <ipv_XzbxR>_N)_N
                                 ; TFCo:R:Apply[][]:$$i[0]
                                     <a_afdP_azbON>_N <ipv_XzbxR>_N <ipv_XzbyV>_N)
                                <x_azbOM>_N))_R
                        :: Sing
                             (Apply
                                (Apply Foldr1Sym0 x_azbOM)
                                (Let1627448493XsSym4 x_azbOM m_XzbGe ipv_XzbyV ipv_XzbxR))
                           ~R# Sing (Foldr1Sym2 x_azbOM (ipv_XzbyV : ipv_XzbxR)))))
            `cast` ((Sing
                       ((Apply
                           <Apply x_azbOM m_XzbGe>_N
                           (Sym
                              (TFCo:R:Apply[]kFoldr1Sym1l_afe2[0]
                                 <a_afdP_azbON>_N <ipv_XzbyV : ipv_XzbxR>_N <x_azbOM>_N)
                            ; (Apply
                                 (Sym
                                    (TFCo:R:Apply(->)(->)Foldr1Sym0l[0]
                                       <a_afdP_azbON>_N <x_azbOM>_N))
                                 (Sym
                                    (TFCo:R:Apply[][]:$$i[0]
                                       <a_afdP_azbON>_N <ipv_XzbxR>_N <ipv_XzbyV>_N)
                                  ; (Apply
                                       (Sym
                                          (TFCo:R:Applyk(->):$l[0] <a_afdP_azbON>_N <ipv_XzbyV>_N))
                                       <ipv_XzbxR>_N)_N))_N))_N
                        ; Sym
                            (TFCo:R:Foldr1[1]
                               <a_afdP_azbON>_N
                               <ipv_XzbxR>_N
                               <ipv_XzbyV>_N
                               <m_XzbGe>_N
                               <x_azbOM>_N)
                        ; Sym
                            (TFCo:R:Apply[]kFoldr1Sym1l_afe2[0]
                               <a_afdP_azbON>_N <m_XzbGe : ipv_XzbyV : ipv_XzbxR>_N <x_azbOM>_N)
                        ; (Apply
                             (Sym
                                (TFCo:R:Apply(->)(->)Foldr1Sym0l[0] <a_afdP_azbON>_N <x_azbOM>_N))
                             ((<m_XzbGe>_N ': Sym ipv_szbwM)_N ; Sym dt_dzbxK))_N))_R
                    :: Sing
                         (Apply
                            (Apply x_azbOM m_XzbGe)
                            (Foldr1Sym2 x_azbOM (ipv_XzbyV : ipv_XzbxR)))
                       ~R# Sing
                             (Apply
                                (Apply Foldr1Sym0 x_azbOM)
                                (Let1627448493XsSym4 x_azbOM m_azbFg ipv_szbwN ipv_szbwO)))
            }
        }
    }
...
-}

module List (sFoldr1) where

import Data.Kind (Type)

data Proxy t

data family Sing (a :: k)

data TyFun (a :: Type) (b :: Type)

type family Apply (f :: TyFun k1 k2 -> Type) (x :: k1) :: k2

data instance Sing (f :: TyFun k1 k2 -> Type) =
  SLambda { applySing :: forall t. Sing t -> Sing (Apply f t) }

type SingFunction1 f = forall t. Sing t -> Sing (Apply f t)

type SingFunction2 f = forall t. Sing t -> SingFunction1 (Apply f t)
singFun2 :: Proxy f -> SingFunction2 f -> Sing f
singFun2 _ f = SLambda (\x -> SLambda (f x))

data (:$$) (j :: a) (i :: TyFun [a] [a])
type instance Apply ((:$$) j) i = (:) j i

data (:$) (l :: TyFun a (TyFun [a] [a] -> Type))
type instance Apply (:$) l = (:$$) l
data instance Sing (z :: [a])
  = z ~ '[] =>
    SNil
  | forall (m :: a)
           (n :: [a]). z ~ (:) m n =>
    SCons (Sing m) (Sing n)

data ErrorSym0 (t1 :: TyFun k1 k2)

type Let1627448493XsSym4 t_afee t_afef t_afeg t_afeh = Let1627448493Xs t_afee t_afef t_afeg t_afeh

type Let1627448493Xs f_afe9
                     x_afea
                     wild_1627448474_afeb
                     wild_1627448476_afec =
    Apply (Apply (:$) wild_1627448474_afeb) wild_1627448476_afec
type Foldr1Sym2 (t_afdY :: TyFun a_afdP (TyFun a_afdP a_afdP -> Type)
                           -> Type)
                (t_afdZ :: [a_afdP]) =
    Foldr1 t_afdY t_afdZ
data Foldr1Sym1 (l_afe3 :: TyFun a_afdP (TyFun a_afdP a_afdP -> Type)
                           -> Type)
                (l_afe2 :: TyFun [a_afdP] a_afdP)
type instance Apply (Foldr1Sym1 l_afe3) l_afe2 = Foldr1Sym2 l_afe3 l_afe2

data Foldr1Sym0 (l_afe0 :: TyFun (TyFun a_afdP (TyFun a_afdP a_afdP
                                                -> Type)
                                  -> Type) (TyFun [a_afdP] a_afdP -> Type))
type instance Apply Foldr1Sym0 l = Foldr1Sym1 l

type family Foldr1 (a_afe5 :: TyFun a_afdP (TyFun a_afdP a_afdP
                                            -> Type)
                              -> Type)
                   (a_afe6 :: [a_afdP]) :: a_afdP where
  Foldr1 z_afe7 '[x_afe8] = x_afe8
  Foldr1 f_afe9 ((:) x_afea ((:) wild_1627448474_afeb wild_1627448476_afec)) = Apply (Apply f_afe9 x_afea) (Apply (Apply Foldr1Sym0 f_afe9) (Let1627448493XsSym4 f_afe9 x_afea wild_1627448474_afeb wild_1627448476_afec))
  Foldr1 z_afew '[] = Apply ErrorSym0 "Data.Singletons.List.foldr1: empty list"

sFoldr1 ::
  forall a_afdP.
  forall (x :: TyFun a_afdP (TyFun a_afdP a_afdP -> Type) -> Type)
         (y :: [a_afdP]).
  Sing x
  -> Sing y -> Sing (Apply (Apply Foldr1Sym0 x) y)
sFoldr1 _ (SCons _sX SNil) = undefined
sFoldr1 sF (SCons sX (SCons sWild_1627448474 sWild_1627448476))
  = let
      lambda_afeC ::
        forall f_afe9 x_afea wild_1627448474_afeb wild_1627448476_afec.
        Sing f_afe9
        -> Sing x_afea
           -> Sing wild_1627448474_afeb
              -> Sing wild_1627448476_afec
                 -> Sing (Apply (Apply Foldr1Sym0 f_afe9) (Apply (Apply (:$) x_afea) (Apply (Apply (:$) wild_1627448474_afeb) wild_1627448476_afec)))
      lambda_afeC f_afeD x_afeE wild_1627448474_afeF wild_1627448476_afeG
        = let
            sXs ::
              Sing (Let1627448493XsSym4 f_afe9 x_afea wild_1627448474_afeb wild_1627448476_afec)
            sXs
              = applySing
                  (applySing
                     (singFun2 (undefined :: Proxy (:$)) SCons) wild_1627448474_afeF)
                  wild_1627448476_afeG
          in
            applySing
              (applySing f_afeD x_afeE)
              (applySing
                 (applySing (singFun2 (undefined :: Proxy Foldr1Sym0) sFoldr1) f_afeD)
                 sXs)
    in lambda_afeC sF sX sWild_1627448474 sWild_1627448476
sFoldr1 _ SNil = undefined


module A (
  ) where

-- This reproduces the issue where type variables would be lifted out in
-- different orders. Compare:
--
-- lvl =
--   \ (@ (c :: * -> *)) (@ (t :: * -> *)) ->
--     undefined
--     @ ((forall d. Data d => c (t d))
--        -> Maybe (c Node))
--     (some Callstack thing)
--
-- $cdataCast1 =
--   \ (@ (c :: * -> *)) (@ (t :: * -> *)) _ [Occ=Dead] ->
--     lvl @ c @ t
--
-- vs
--
-- lvl =
--   \ (@ (t :: * -> *)) (@ (c :: * -> *)) ->
--     undefined
--     @ ((forall d. Data d => c (t d))
--        -> Maybe (c Node))
--     (some Callstack thing)
--
-- $cdataCast1 =
--   \ (@ (c :: * -> *)) (@ (t :: * -> *)) _ [Occ=Dead] ->
--     lvl @ t @ c

import Data.Data

data Node = Node (Maybe Int) [Node]

instance Data Node where

  gfoldl = gfoldl
  gunfold = gunfold
  toConstr = toConstr
  dataTypeOf = dataTypeOf

  dataCast1 _ = undefined
  dataCast2 = dataCast2

  gmapT = gmapT
  gmapQl = gmapQl
  gmapQr = gmapQr
  gmapQ = gmapQ
  gmapQi = gmapQi
  gmapM = gmapM
  gmapMp = gmapMp
  gmapMo = gmapMo