data Tree a = Leaf | Node a !(Tree a) !(Tree a)

{-

This should produce a walker with unboxed integers.

Bad:

Rec {
go_r1us
  :: GHC.Types.Int -> Main.Tree GHC.Types.Int -> GHC.Types.Int
[GblId, Arity=2, Caf=NoCafRefs, Str=SS]
go_r1us =
  \ (z_aeS :: GHC.Types.Int) (ds_dmD :: Main.Tree GHC.Types.Int) ->
    case ds_dmD of _ {
      Main.Leaf -> z_aeS;
      Main.Node a1_aeU l_aeV r_aeW ->
        case go_r1us z_aeS l_aeV of _ { GHC.Types.I# ipv_snn ->
        case a1_aeU of _ { GHC.Types.I# y_anh ->
        go_r1us (GHC.Types.I# (GHC.Prim.+# ipv_snn y_anh)) r_aeW
        }
        }
    }
end Rec }

Good:

Rec {
$wgo_r2fS
  :: GHC.Prim.Int# -> Main.Tree GHC.Types.Int -> GHC.Prim.Int#
[GblId, Arity=2, Caf=NoCafRefs, Str=<L,U><S,1*U>]
$wgo_r2fS =
  \ (ww_s2eZ :: GHC.Prim.Int#) (w_s2eW :: Main.Tree GHC.Types.Int) ->
    case w_s2eW of _ [Occ=Dead] {
      Main.Leaf -> ww_s2eZ;
      Main.Node a1_aqv l_aqw r_aqx ->
        case $wgo_r2fS ww_s2eZ l_aqw of ww1_s2f3 { __DEFAULT ->
        case a1_aqv of _ [Occ=Dead] { GHC.Types.I# y_aTz ->
        $wgo_r2fS (GHC.Prim.+# ww1_s2f3 y_aTz) r_aqx
        }
        }
    }
end Rec }

-}

-- Strict, pre-order fold.
fold' :: (a -> b -> a) -> a -> Tree b -> a
fold' f = go
  where
    go z Leaf = z
    go z (Node a l r) = let z'  = go z l
                            z'' = f z' a
                        in z' `seq` z'' `seq` go z'' r

sumTree :: Int -> Tree Int -> Int
sumTree = fold' (+)

tree = Node 0 (Node 0 Leaf Leaf) (Node 0 Leaf Leaf)

main = sum [sumTree n tree | n <- [0..1000]] `seq` return ()


-- In 6.13 this stack overflowed

module Main (main) where

main :: IO ()
main = let n = 1000000
       in print $ integrate n (1 / fromIntegral n)

integrate :: Int -> Double -> Double
integrate n h = h * (sum (map area [1..n]))
    where area :: Int -> Double
          area i = let x = h * (fromIntegral i - 0.5)
                   in 4 / (1 + x*x)


{-# LANGUAGE BangPatterns #-}

module Main where

data Tree = Leaf !Int | Fork !Tree !Tree deriving Show

fullTree 0 = Leaf 1
fullTree n = let t = fullTree (n - 1) in Fork t t

flatListNaive (Leaf n)   = [n]
flatListNaive (Fork a b) = flatListNaive a ++ flatListNaive b

flatListCons t = flat t []
  where
  flat (Leaf n)   ns = n : ns
  flat (Fork a b) ns = flat a (flat b ns)

flatListCons2 t = flat t []
  where
  flat (Leaf n)   = \ns -> n : ns
  flat (Fork a b) = \ns -> flat a (flat b ns)

flatListCons3 t = flat t []
  where
  flat (Leaf n)   = (n :)
  flat (Fork a b) = flat a . flat b

flatDList (Leaf n)   = (n :)
flatDList (Fork a b) = flatDList a . flatDList b

sumList l = loop 0 l
  where loop !c [] = c
        loop !c (h:t) = loop (c + h) t

sumDList l = loop 0 (l [])
  where loop !c []      = c
        loop !c (h : t) = loop (c + h) t

main = print $ sumList  $ flatListCons  $ fullTree 26


{-# LANGUAGE BangPatterns #-}

module Main where

data Tree = Leaf !Int | Fork !Tree !Tree deriving Show

fullTree 0 = Leaf 1
fullTree n = let t = fullTree (n - 1) in Fork t t

flatListNaive (Leaf n)   = [n]
flatListNaive (Fork a b) = flatListNaive a ++ flatListNaive b

flatListCons t = flat t []
  where
  flat (Leaf n)   ns = n : ns
  flat (Fork a b) ns = flat a (flat b ns)

flatListCons2 t = flat t []
  where
  flat (Leaf n)   = \ns -> n : ns
  flat (Fork a b) = \ns -> flat a (flat b ns)

flatListCons3 t = flat t []
  where
  flat (Leaf n)   = (n :)
  flat (Fork a b) = flat a . flat b

flatDList (Leaf n)   = (n :)
flatDList (Fork a b) = flatDList a . flatDList b

sumList l = loop 0 l
  where loop !c [] = c
        loop !c (h:t) = loop (c + h) t

sumDList l = loop 0 (l [])
  where loop !c []      = c
        loop !c (h : t) = loop (c + h) t

main = print $ sumList  $ flatListCons2 $ fullTree 26


{-# LANGUAGE BangPatterns #-}

module Main where

data Tree = Leaf !Int | Fork !Tree !Tree deriving Show

fullTree 0 = Leaf 1
fullTree n = let t = fullTree (n - 1) in Fork t t

flatListNaive (Leaf n)   = [n]
flatListNaive (Fork a b) = flatListNaive a ++ flatListNaive b

flatListCons t = flat t []
  where
  flat (Leaf n)   ns = n : ns
  flat (Fork a b) ns = flat a (flat b ns)

flatListCons2 t = flat t []
  where
  flat (Leaf n)   = \ns -> n : ns
  flat (Fork a b) = \ns -> flat a (flat b ns)

flatListCons3 t = flat t []
  where
  flat (Leaf n)   = (n :)
  flat (Fork a b) = flat a . flat b

flatDList (Leaf n)   = (n :)
flatDList (Fork a b) = flatDList a . flatDList b

sumList l = loop 0 l
  where loop !c [] = c
        loop !c (h:t) = loop (c + h) t

sumDList l = loop 0 (l [])
  where loop !c []      = c
        loop !c (h : t) = loop (c + h) t

main = print $ sumList  $ flatListCons3 $ fullTree 26


-- Compile with O2; SpecConstr should fire nicely
-- and eliminate all allocation in inner loop

module Main where

foo :: Int -> Maybe (Double,Double) -> Double
foo _ Nothing      = 0
foo 0 (Just (x,y)) = x+y
foo n (Just (x,y)) = let r = f x y in r `seq` foo (n-1) (Just r)
  where
    f x y | x <= y    = (x,y)
          | otherwise = (y,x)

main = print (foo 1000000 (Just (1,2)))


module Main (main) where

import qualified Data.ByteString as S
import qualified Data.ByteString.Lazy as L
import Data.ByteString.Internal (inlinePerformIO)
import qualified Data.ByteString.Internal as S
import Data.Semigroup
import Data.Monoid
import Foreign
import System.IO.Unsafe

newtype Builder = Builder {
        runBuilder :: (Buffer -> [S.ByteString]) -> Buffer -> [S.ByteString]
    }

instance Semigroup Builder where
    (<>) = append
    {-# INLINE (<>) #-}

instance Monoid Builder where
    mempty  = empty
    {-# INLINE mempty #-}
    mconcat = foldr mappend mempty
    {-# INLINE mconcat #-}

empty :: Builder
empty = Builder (\ k b -> b `seq` k b)
{-# INLINE empty #-}

singleton :: Word8 -> Builder
singleton = writeN 1 . flip poke
{-# INLINE singleton #-}

append :: Builder -> Builder -> Builder
append (Builder f) (Builder g) = Builder (f . g)
{-# INLINE [0] append #-}

-- Our internal buffer type
data Buffer = Buffer {-# UNPACK #-} !(ForeignPtr Word8)
                     {-# UNPACK #-} !Int                -- offset
                     {-# UNPACK #-} !Int                -- used bytes
                     {-# UNPACK #-} !Int                -- length left

-- | /O(1)./ Pop the 'S.ByteString' we have constructed so far, if any,
-- yielding a new chunk in the result lazy 'L.ByteString'.
flush :: Builder
flush = Builder $ \ k buf@(Buffer p o u l) ->
    if u == 0
      then k buf
      else S.PS p o u : k (Buffer p (o+u) 0 l)

-- | /O(n)./ Extract a lazy 'L.ByteString' from a 'Builder'.
-- The construction work takes place if and when the relevant part of
-- the lazy 'L.ByteString' is demanded.
--
toLazyByteString :: Builder -> L.ByteString
toLazyByteString m = L.fromChunks $ unsafePerformIO $ do
    buf <- newBuffer defaultSize
    return (runBuilder (m `append` flush) (const []) buf)
{-# INLINE toLazyByteString #-}

defaultSize :: Int
defaultSize = 32 * k - overhead
    where k = 1024
          overhead = 2 * sizeOf (undefined :: Int)

-- | Sequence an IO operation on the buffer
unsafeLiftIO :: (Buffer -> IO Buffer) -> Builder
unsafeLiftIO f =  Builder $ \ k buf -> inlinePerformIO $ do
    buf' <- f buf
    return (k buf')
{-# INLINE unsafeLiftIO #-}

-- | Get the size of the buffer
withSize :: (Int -> Builder) -> Builder
withSize f = Builder $ \ k buf@(Buffer _ _ _ l) -> runBuilder (f l) k buf

-- | Ensure that there are at least @n@ many bytes available.
ensureFree :: Int -> Builder
ensureFree n = n `seq` withSize $ \ l ->
    if n <= l then empty else
        flush `append` unsafeLiftIO (const (newBuffer (max n defaultSize)))
{-# INLINE [0] ensureFree #-}

-- | Ensure that @n@ many bytes are available, and then use @f@ to write some
-- bytes into the memory.
writeN :: Int -> (Ptr Word8 -> IO ()) -> Builder
writeN n f = ensureFree n `append` unsafeLiftIO (writeNBuffer n f)
{-# INLINE [0] writeN #-}

writeNBuffer :: Int -> (Ptr Word8 -> IO ()) -> Buffer -> IO Buffer
writeNBuffer n f (Buffer fp o u l) = do
    withForeignPtr fp (\p -> f (p `plusPtr` (o+u)))
    return (Buffer fp o (u+n) (l-n))
{-# INLINE writeNBuffer #-}

newBuffer :: Int -> IO Buffer
newBuffer size = do
    fp <- S.mallocByteString size
    return $! Buffer fp 0 0 size
{-# INLINE newBuffer #-}

-- Merge buffer bounds checks.
{-# RULES
"append/writeN" forall a b (f::Ptr Word8 -> IO ())
                           (g::Ptr Word8 -> IO ()) ws.
    append (writeN a f) (append (writeN b g) ws) =
        append (writeN (a+b) (\p -> f p >> g (p `plusPtr` a))) ws

"writeN/writeN" forall a b (f::Ptr Word8 -> IO ())
                           (g::Ptr Word8 -> IO ()).
    append (writeN a f) (writeN b g) =
        writeN (a+b) (\p -> f p >> g (p `plusPtr` a))

"ensureFree/ensureFree" forall a b .
    append (ensureFree a) (ensureFree b) = ensureFree (max a b)
 #-}

-- Test case

-- Argument must be a multiple of 4.
test :: Int -> Builder
test 0 = mempty
test n = singleton 1 `mappend`
         (singleton 2 `mappend`
          (singleton 3 `mappend`
           (singleton 4 `mappend` test (n-4))))

main = print $ L.length $ toLazyByteString $ test 10000000


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

import Data.Array.Base (unsafeRead, unsafeWrite)
import Data.Array.ST
import Data.Array.Unboxed
import Control.Monad.ST

main = print (divisorCounts 1000000 ! 342)

isqrt :: Int -> Int
isqrt n = floor (sqrt $ fromIntegral n)

divisorCounts :: Int -> UArray Int Int
divisorCounts n = runSTUArray $ do
    let !rt = isqrt n
    darr <- newArray (0,n) 1 :: ST s (STUArray s Int Int)
    let inc i = unsafeRead darr i >>= \k -> unsafeWrite darr i (k+1)
        note step i
            | i > n     = return ()
            | otherwise = do
                inc i
                note step (i+step)
        count j
            | j > rt    = return ()
            | otherwise = do
                note (2*j) (j*j)
                count (j+2)
    note 2 4
    count 3
    return darr


import Control.Concurrent
import Control.Monad

main :: IO ()
main = do t <- forkIO (x >> x)
          threadDelay 1000000
          killThread t
          putStrLn "Done"

x :: IO ()
x = forever yield


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

-- Test that the rewrite rules for small exponents fire (#5237).
-- If they don't fire, this will allocate much.

fun :: Double -> Double
fun x = go 0 1.0
  where
    go !acc z
      | x < z   = acc
      | otherwise = go (acc + 1/z^4) (z+1.0)

main :: IO ()
main = print (fun 1e7)


main :: IO ()
main = do writeFile "T5536.data" (replicate 10000000 'a')
          readFile "T5536.data" >>= putStr


module Main where
-- See Trac #5549
-- The issue here is allocating integer constants inside a loop

lcs3 :: Eq a => [a] -> [a] -> [a]
lcs3 a b = fst $ aux (a, length a) (b, length b)
  where
    aux (_,0) _ = ([],0)
    aux _ (_,0) = ([],0)
    aux (a@(ha:as),la) (b@(hb:bs), lb)
      | ha == hb  = let (s,n) = aux (as,la-1) (bs,lb-1) in (ha : s, n+1)
      | otherwise =
        let (sa,na) = aux (as,la-1) (b,lb)
            (sb,nb) = aux (a,la) (bs,lb-1) in
        if na > nb then (sa,na) else (sb,nb)

f :: Integer -> Integer -> Integer
f acc 0 = acc
f acc n = g (acc + 1) (n-1)

g :: Integer -> Integer -> Integer
g acc 0 = acc
g acc n = f (acc -1) (n-1)

main = do putStrLn . show $ f 0 100000000
          putStrLn . show $ lcs3 [1..20] [10..20]


{-# LANGUAGE GADTs #-}
module Main where

data T t a where
  T :: (Foldable t, Eq a) => t a -> T t a

{-# NOINLINE go #-}
go :: T [] a -> Int -> Int
go (T _) i = foldr (+) 0 [1..i]

main = print (go (T [1::Int]) 20000)


import Data.List

{-
This should get a worker that takes three arguments.

bad:

Rec {
$we_r1z8
  :: (GHC.Types.Int, GHC.Types.Int)
     -> GHC.Prim.Int# -> (# GHC.Types.Int, GHC.Types.Int #)
[GblId, Arity=2, Caf=NoCafRefs, Str=S(AA)L]
$we_r1z8 =
  \ (w_s1yf :: (GHC.Types.Int, GHC.Types.Int))
    (ww_s1yi :: GHC.Prim.Int#) ->
    case GHC.Prim.># ww_s1yi 10 of _ {
      GHC.Types.False -> $we_r1z8 w_s1yf (GHC.Prim.+# ww_s1yi 1);
      GHC.Types.True ->
        case w_s1yf of _ { (ww2_s1yp, ww3_s1yq) ->
        (# ww2_s1yp, ww3_s1yq #)
        }
    }
end Rec }

Good:

Rec {
$we_r2qK
  :: GHC.Types.Int
     -> GHC.Types.Int
     -> GHC.Prim.Int#
     -> (# GHC.Types.Int, GHC.Types.Int #)
[GblId, Arity=3, Caf=NoCafRefs, Str=<L,U><L,U><L,U>]
$we_r2qK =
  \ (ww_s2pS :: GHC.Types.Int)
    (ww1_s2pT :: GHC.Types.Int)
    (ww2_s2pX :: GHC.Prim.Int#) ->
    case GHC.Prim.tagToEnum# @ GHC.Types.Bool (GHC.Prim.># ww2_s2pX 10)
    of _ [Occ=Dead] {
      GHC.Types.False ->
        $we_r2qK ww_s2pS ww1_s2pT (GHC.Prim.+# ww2_s2pX 1);
      GHC.Types.True -> (# ww_s2pS, ww1_s2pT #)
    }
end Rec }

-}

e :: (Int, Int) -> Int -> (Int, Int)
e x y = x `seq` if y > 10
        then x
        else e x (y + 1)

main = foldr (seq) 0 [e (n,0) 0| n <- [0..10000]] `seq` return ()


{-# LANGUAGE BangPatterns #-}
module Main where

import qualified Data.ByteString as S
import Data.IORef
import Control.Monad

makeBs :: Int -> S.ByteString
makeBs n = S.replicate n (fromIntegral n)

doStuff :: IORef [S.ByteString] -> Int -> IO ()
doStuff ref n = do
    let !bs = makeBs n
    modifyIORef ref (bs:)
{-# NOINLINE doStuff #-}

undo :: IORef [S.ByteString] -> IO ()
undo ref = do
    h <- atomicModifyIORef ref (\(x:xs) -> (xs,x))
    S.length h `seq` return ()

main = do
    ref <- newIORef [S.empty]
    let fn n = do
        doStuff ref n
        when (rem 5 n /= 0 ) $ undo ref

    mapM_ fn (take 5000000 $ cycle [1..100])
    var <- readIORef ref
    print $ length var


{-# LANGUAGE DeriveFunctor, DeriveFoldable #-}
module Main where

import Prelude hiding (foldr)
import Data.Foldable

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

mkList :: Int -> List Int
mkList 0 = Nil
mkList n = Cons n (mkList (n-1))

main :: IO ()
main = print $ foldr (\x y -> y) "end" (mkList n)
  where n = 40000
  -- Increase this to increase the difference between good and bad
  -- Eg 6000 takes a lot longer
  -- The biggest difference is not allocation or bytes used,
  -- but execution time!


module Main where

import Data.Int
import System.Environment

bitcount x = if x > 0
    then let (d,m) = divMod x 2 in  bitcount d + m
    else 0

main = print $ sum  $ map bitcount
       [ 0 :: Int64 .. 2^20 - 1 ]


{-# LANGUAGE TypeFamilies #-}
module Main where
data family Foo a

data instance Foo Int = FooInt Int Int

foo :: Foo Int -> Int
foo (FooInt a 0) = 0
foo (FooInt a b) = foo (FooInt a (b-1))

main :: IO ()
main = foo (FooInt 0 10000) `seq` return ()


{-# LANGUAGE ExistentialQuantification #-}
module Main where

import T7797a

data Box = forall a. (Size a) => Box a a

box = Box (go 10000000) (go 10000000) where
  go :: Int -> [Int]
  go 0 = []
  go n = 1 : go (n - 1)
{-# NOINLINE box #-}

main = print $ case box of
  Box l r -> size l r


module T7797a where

class Size t where
  size :: t -> t -> Int
  burg :: t -> t

instance (Ord a, Num a) => Size [a] where
  {-# SPECIALISE instance Size [Int] #-}
  size (x:xs) (y:ys) | x+y > 4   = size xs ys
                     | otherwise = size xs ys
  size _ _ = 0
  burg = error "urk"


{-# LANGUAGE BangPatterns #-}

main :: IO ()
main = print $ ack 4 1

ack :: Int -> Int -> Int
ack 0 !n = n+1
ack m  0 = ack (m-1) 1
ack m  n = ack (m-1) $ ack m (n-1)


module Main where

norm ::  [Double] -> Double
norm = sqrt . sum . map (\x -> x*x)

main :: IO ()
main = print (norm (enumFromTo 0 10000000) > 100)


{-# LANGUAGE MagicHash #-}

module Main (f, main) where

import GHC.Exts(Ptr(..))
import Foreign.Ptr

-- We should be able to inline this function.
f :: Ptr Int -> Int -> Int
f =
  let x = "foo"#
  in \p n -> n + (Ptr x `minusPtr` p)

main :: IO ()
main = print $ x `mod` 2 == (x + 4) `mod` 2
  where
    x = go (10000::Int) 4
    go 0 a = a
    go n a = go (n-1) (f nullPtr a)


-- This test allocates a lot more if length is
-- not a good consumer

module Main where
import System.Environment (getArgs)

foo :: Int -> Int
foo n = sum [ length [i..n] | i <- [1..n] ]

main = do { [arg] <- getArgs
          ; print (foo (read arg)) }


-- | The fusion helper for @enumFromThenTo \@Int@ had multiple
-- occurences of @c@, which made the simplifier refuse to inline it.
-- The new implementation for @efdtInt{Up,Dn}FB@ only have a single
-- occurence of @c@ which the simplifier inlines unconditionally.
module Main  (main) where

import Control.Monad (when, forM_)
import GHC.ST

nop :: Monad m => a -> m ()
nop _ = return ()
{-# NOINLINE nop #-}

-- This is the baseline, using @enumFromTo@ which already had only a
-- single occurence of @c@.
f :: Int -> ST s ()
f n =
    do
      forM_ [2..n] $ \p -> do
        let isPrime = p == (p - 1)
        when isPrime $
          forM_ [p + p, p + p + p .. n] $ \k ->  do
            nop k
{-# NOINLINE f #-}

g :: Int -> ST s ()
g n =
    do
      forM_ [2,3..n] $ \p -> do
        -- This do block should be too big to get inlined multiple times.
        -- Pad with @nop@s as necessary if this doesn't reproduce anymore.
        let isPrime = p == (p - 1)
        when isPrime $
          forM_ [p + p, p + p + p .. n] $ \k ->  do
            nop k
{-# NOINLINE g #-}

main :: IO ()
main = do
  -- runST (f 40000000) `seq` return ()
  runST (g 40000000) `seq` return ()


module Main where

import Data.Typeable

f :: Typeable a => Int -> a -> TypeRep
f 0 a = typeOf a
f n a = f (n-1) [a]

main = print (f 50000 () == f 50001 ())


-- Tests that `last` successfully fuses.

main :: IO ()
main = print $ last $ filter odd $ [1::Int ..10000000]


import Data.List

main :: IO ()
main = print $ length $ show (foldl' (*) 1 [1..100000] :: Integer)


module Main (main) where

import T2762A

main :: IO ()
main = do
          let content1 = concat (replicate 1000000 "1x") ++ "0"
          let i1 = fst $ input content1
          view i1

          let content2 = concat (replicate 1000001 "1y") ++ "0"
          let i2 = fst $ input content2
          view i2

view :: [Char] -> IO ()
view [] = return ()
view (i : is) = i `seq` view is


module T2762A (input) where

class InputOutput a where
    input :: String -> (a, String)

instance InputOutput Char where
    input (x : bs) = (x, bs)

instance InputOutput a => InputOutput [a] where
    input ('0':bs) = ([], bs)
    input ('1':bs) = case input bs of
                     (x, bs') ->
                         case input bs' of
                         ~(xs, bs'') -> (x : xs, bs'')


module Main (main) where

 import Foreign
 import Control.Concurrent

 -- always space-leaks with 6.12.x and -fno-state-hack, see #4018
 {-
 always :: Monad m => m a -> m b
 always a = a >> always a
 -}
 always :: Monad m => m a -> m b
 always a = do
     _ <- a
     always a

 spawner :: IO ()
 spawner = always $ do
     forkIO $ always $ allocaBytes 4 $ \p -> return ()
     -- putStrLn "Delaying"
     threadDelay 1000000

 main :: IO ()
 main = do
     -- putStrLn "Spawning"
     forkIO spawner
     -- putStrLn "Delaying main"
     threadDelay 3000000


module T4029b where

data A01 = A01 deriving (Eq,Ord,Show,Read)
data A02 = A02 deriving (Eq,Ord,Show,Read)
data A03 = A03 deriving (Eq,Ord,Show,Read)
data A04 = A04 deriving (Eq,Ord,Show,Read)
data A05 = A05 deriving (Eq,Ord,Show,Read)
data A06 = A06 deriving (Eq,Ord,Show,Read)
data A07 = A07 deriving (Eq,Ord,Show,Read)
data A08 = A08 deriving (Eq,Ord,Show,Read)
data A09 = A09 deriving (Eq,Ord,Show,Read)
data A10 = A10 deriving (Eq,Ord,Show,Read)
data A11 = A11 deriving (Eq,Ord,Show,Read)
data A12 = A12 deriving (Eq,Ord,Show,Read)
data A13 = A13 deriving (Eq,Ord,Show,Read)
data A14 = A14 deriving (Eq,Ord,Show,Read)
data A15 = A15 deriving (Eq,Ord,Show,Read)
data A16 = A16 deriving (Eq,Ord,Show,Read)
data A17 = A17 deriving (Eq,Ord,Show,Read)
data A18 = A18 deriving (Eq,Ord,Show,Read)
data A19 = A19 deriving (Eq,Ord,Show,Read)
data A20 = A20 deriving (Eq,Ord,Show,Read)


module Main (main) where

import System.Environment (getArgs)

mkText :: Int -> Int -> Char -> String
mkText ll ln c =
    unlines $ [replicate k c | k <- [ll .. ll+ln]]

main :: IO ()
main = do
    args <- getArgs
    let (ll, ln, c) =
          case args of
            (a1:a2:a3:_) -> (read a1, read a2, head a3)
            (a1:a2:_)    -> (read a1, read a2, 'a')
            (a1:_)       -> (read a1, 3, 'b')
            _            -> (100000, 5, 'c')
    mapM_ (print . length) (lines $ mkText ll ln c)


module FrontendPlugin where

import GhcPlugins
import qualified GHC
import GHC              ( Ghc, LoadHowMuch(..) )

import DriverPipeline hiding ( hsc_env )
import DriverPhases
import System.Exit
import Control.Monad
import Data.List

frontendPlugin :: FrontendPlugin
frontendPlugin = defaultFrontendPlugin {
        frontend = doMake
    }

-- Copypasted from ghc/Main.hs
doMake :: [String] -> [(String,Maybe Phase)] -> Ghc ()
doMake opts srcs  = do
    liftIO $ print opts
    let (hs_srcs, non_hs_srcs) = partition haskellish srcs

        haskellish (f,Nothing) =
          looksLikeModuleName f || isHaskellUserSrcFilename f || '.' `notElem` f
        haskellish (_,Just phase) =
          phase `notElem` [ As True, As False, Cc, Cobjc, Cobjcxx, CmmCpp, Cmm
                          , StopLn]

    hsc_env <- GHC.getSession

    -- if we have no haskell sources from which to do a dependency
    -- analysis, then just do one-shot compilation and/or linking.
    -- This means that "ghc Foo.o Bar.o -o baz" links the program as
    -- we expect.
    if (null hs_srcs)
       then liftIO (oneShot hsc_env StopLn srcs)
       else do

    o_files <- mapM (\x -> liftIO $ compileFile hsc_env StopLn x)
                 non_hs_srcs
    dflags <- GHC.getSessionDynFlags
    let dflags' = dflags { ldInputs = map (FileOption "") o_files
                                      ++ ldInputs dflags }
    _ <- GHC.setSessionDynFlags dflags'

    targets <- mapM (uncurry GHC.guessTarget) hs_srcs
    GHC.setTargets targets
    ok_flag <- GHC.load LoadAllTargets

    when (failed ok_flag) (liftIO $ exitWith (ExitFailure 1))
    return ()


module HomePackagePlugin where

import GhcPlugins

plugin :: Plugin
plugin = defaultPlugin {
        installCoreToDos = install
    }

install :: [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo]
install _options todos = do
    return $ (CoreDoPluginPass "String replacement" $ bindsOnlyPass stringReplacementPass) : todos

stringReplacementPass :: [CoreBind] -> CoreM [CoreBind]
stringReplacementPass binds = return $ map replaceInBind binds

replaceInBind :: CoreBind -> CoreBind
replaceInBind (NonRec b e) = NonRec b (replaceInExpr e)
replaceInBind (Rec bes) = Rec [(b, replaceInExpr e) | (b, e) <- bes]

replaceInExpr :: CoreExpr -> CoreExpr
replaceInExpr (Var x) = Var x
replaceInExpr (Lit (LitString _)) = mkStringLit "Hello From The Plugin" -- The payload
replaceInExpr (Lit l) = Lit l
replaceInExpr (Lam b e) = Lam b (replaceInExpr e)
replaceInExpr (App e1 e2) = App (replaceInExpr e1) (replaceInExpr e2)
replaceInExpr (Let bi e) = Let (replaceInBind bi) (replaceInExpr e)
replaceInExpr (Tick t e) = Tick t (replaceInExpr e)
replaceInExpr (Cast e co) = Cast (replaceInExpr e) co
replaceInExpr (Case e b ty alts) = Case (replaceInExpr e) b ty (map replaceInAlt alts)
replaceInExpr (Type ty) = Type ty

replaceInAlt :: CoreAlt -> CoreAlt
replaceInAlt (ac, bs, e) = (ac, bs, replaceInExpr e)


module LinkerTicklingPlugin where

import GhcPlugins
import DynFlags

plugin :: Plugin
plugin = defaultPlugin {
        installCoreToDos = install
    }

-- This tests whether plugins are linking against the *running* GHC or a new
-- instance of it. If it is a new instance (settings unsafeGlobalDynFlags) won't
-- have been initialised, so we'll get a GHC panic here:
install :: [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo]
install _options todos = settings unsafeGlobalDynFlags `seq` return todos


module MetaRemoveHelper where

import Language.Haskell.TH

clear :: Q [Dec] -> Q [Dec]
clear _ = return []


-- Intended to test that the plugins have basic functionality --
--  * Can modify the program
--  * Get to see command line options
module Main where

main = do
    putStrLn "Program Started"
    putStrLn "Program Ended"


{-# OPTIONS_GHC -fplugin Simple.RemovePlugin #-}
{-# OPTIONS_GHC -fplugin-opt Simple.RemovePlugin:map #-}
{-# OPTIONS_GHC -fplugin-opt Simple.RemovePlugin:typecheck #-}
-- testing that the plugin can alter the parsed representation
module PluginFilteredExport where

map :: ()
map = ()


-- Intended to test that the plugins have basic functionality --
--  * Can modify the program
--  * Get to see command line options
module Main where

import Simple.DataStructures

{-# ANN theMessage (ReplaceWith "Right") #-}
{-# NOINLINE theMessage #-}
theMessage = "Wrong"

main = do
    putStrLn "Program Started"
    putStrLn theMessage
    putStrLn "Program Ended"


-- Just used to test that badly typed plugins raise an error
module Main where
-- The contents of this file are actually irrelevant

main = return ()


-- Just used to test that we correctly handle non-existent plugins
module Main where
-- The contents of this file are actually irrelevant

main = return ()


-- Tests home-package plugins from command line
module Main where

main :: IO ()
main = putStrLn "Hello From The Program"


{-# OPTIONS_GHC -fplugin HomePackagePlugin #-}

-- Tests home-package plugins from OPTIONS pragma
module Main where

main :: IO ()
main = putStrLn "Hello From The Program"


{-# OPTIONS_GHC -fplugin LinkerTicklingPlugin #-}

module Main where

main :: IO ()
main = return ()


module Main where

{-# NOINLINE x #-}
x = "foo"

main = putStrLn (show x)


-- Tests a plugin added with TH.addCorePlugin
{-# LANGUAGE TemplateHaskell #-}
module Main where

import Simple.DataStructures
import Language.Haskell.TH.Syntax

do addCorePlugin "Simple.Plugin"
   return []

{-# ANN theMessage (ReplaceWith "Right") #-}
{-# NOINLINE theMessage #-}
theMessage = "Wrong"

main = do
    putStrLn "Program Started"
    putStrLn theMessage
    putStrLn "Program Ended"


{-# OPTIONS_GHC -fplugin-opt Simple.SourcePlugin:a #-}
{-# LANGUAGE TemplateHaskell, QuasiQuotes #-}
module B where

import QuasiQuotation

$(return [])

x = [stringify|x|]


{-# OPTIONS_GHC -fplugin Simple.SourcePlugin #-}
module A where


{-# OPTIONS_GHC -fplugin Simple.RemovePlugin #-}
{-# OPTIONS_GHC -fplugin-opt Simple.RemovePlugin:map #-}
{-# OPTIONS_GHC -fplugin-opt Simple.RemovePlugin:parse #-}
-- testing that the plugin can alter the parsed representation
module A where

map x = ()

x = map show [1,2,3]


module A where

import PluginFilteredExport

x = map show [1,2,3]


{-# OPTIONS_GHC -fplugin Simple.RemovePlugin #-}
{-# OPTIONS_GHC -fplugin-opt Simple.RemovePlugin:map #-}
{-# OPTIONS_GHC -fplugin-opt Simple.RemovePlugin:interface #-}
module A where
-- test if a definition can be removed from loaded interface

map :: ()
map = ()

x :: ()
x = map


{-# OPTIONS_GHC -fplugin Simple.RemovePlugin #-}
{-# OPTIONS_GHC -fplugin-opt Simple.RemovePlugin:clear #-}
{-# OPTIONS_GHC -fplugin-opt Simple.RemovePlugin:meta #-}
{-# LANGUAGE TemplateHaskell #-}
-- testing that the plugin can alter the evaluated splice
module A where

import MetaRemoveHelper

$(clear [d| a = () |])

x = a


module QuasiQuotation where

import Language.Haskell.TH
import Language.Haskell.TH.Quote

stringify :: QuasiQuoter
stringify =  QuasiQuoter { quoteExp = return . LitE . StringL
                         , quotePat = return . LitP . StringL
                         , quoteType = return . LitT . StrTyLit
                         , quoteDec = const (return [])
                         }


module Main where
main = print "Hello world!"


module Main where

import Avail
import Control.Monad.IO.Class
import DynFlags
  (getDynFlags, parseDynamicFlagsCmdLine, defaultFatalMessager, defaultFlushOut)
import GHC
import GHC.Fingerprint.Type
import HsDecls
import HsDoc
import HsExpr
import HsExtension
import HsImpExp
import HscTypes
import Outputable
import Plugins
import System.Environment
import TcRnTypes

import Simple.SourcePlugin (plugin)

main = do
  libdir:args <- getArgs
  defaultErrorHandler defaultFatalMessager defaultFlushOut $ do
    runGhc (Just libdir) $ do
      dflags <- getSessionDynFlags
      -- liftIO $ print args
      -- (dflags,_,_)
      --     <- parseDynamicFlagsCmdLine dflags (map noLoc args)
      -- we need to LinkInMemory otherwise `setTarget [] >> load LoadAllTargets`
      -- below will fail.
      setSessionDynFlags dflags { ghcLink = LinkInMemory}

      -- Start with a pure plugin, this should trigger recomp.
      liftIO $ putStrLn "==pure.0"
      loadWithPlugins [StaticPlugin $ PluginWithArgs plugin0_pure []]

      -- The same (or a different) pure plugin shouldn't trigger recomp.
      liftIO $ putStrLn "==pure.1"
      loadWithPlugins [StaticPlugin $ PluginWithArgs plugin0_pure []]

      -- Next try with a fingerprint plugin, should trigger recomp.
      liftIO $ putStrLn "==fp0.0"
      loadWithPlugins [StaticPlugin $ PluginWithArgs plugin_fp0 []]

      -- With the same fingerprint plugin, should not trigger recomp.
      liftIO $ putStrLn "==fp0.1"
      loadWithPlugins [StaticPlugin $ PluginWithArgs plugin_fp0 []]

      -- Change the plugin fingerprint, should trigger recomp.
      liftIO $ putStrLn "==fp1"
      loadWithPlugins [StaticPlugin $ PluginWithArgs plugin_fp1 []]

      -- TODO: this currently doesn't work, patch pending
      -- -- Even though the plugin is now pure we should still recomp since we
      -- -- used a potentially impure plugin before
      -- liftIO $ putStrLn "pure.2"
      -- loadWithPlugins [StaticPlugin $ PluginWithArgs plugin0_pure []]

  where
    loadWithPlugins the_plugins = do
      -- first unload (like GHCi :load does)
      GHC.setTargets []
      _ <- GHC.load LoadAllTargets

      target <- guessTarget "static-plugins-module.hs" Nothing
      setTargets [target]

      dflags <- getSessionDynFlags
      setSessionDynFlags dflags { staticPlugins = the_plugins
                                , outputFile = Nothing }
      load LoadAllTargets

plugin_fp0   =
  plugin { pluginRecompile = \_ -> pure $ MaybeRecompile $ Fingerprint 0 0 }
plugin_fp1   =
  plugin { pluginRecompile = \_ -> pure $ MaybeRecompile $ Fingerprint 0 1 }
plugin0_pure =
  plugin { pluginRecompile = \_ -> pure $ NoForceRecompile }


module T10294 where

import SayAnnNames

{-# ANN foo SomeAnn #-}
foo :: ()
foo = ()


module T10294a where

import SayAnnNames
import Data.Data

baz :: Constr
baz = toConstr SomeAnn


module Main where

import T10420a

import RuleDefiningPlugin

{-# NOINLINE x #-}
x = "foo"

main = putStrLn (show x)


{-# OPTIONS_GHC -fplugin RuleDefiningPlugin #-}
module T10420a where


{-# OPTIONS -fplugin Simple.Plugin  #-}

module T12567a where


{-# OPTIONS_GHC -fplugin T16104_Plugin #-}

main :: IO ()
main = return ()


{-# LANGUAGE DeriveDataTypeable #-}
module SayAnnNames (plugin, SomeAnn(..)) where
import GhcPlugins
import Control.Monad (unless)
import Data.Data

data SomeAnn = SomeAnn deriving (Data, Typeable)

plugin :: Plugin
plugin = defaultPlugin {
  installCoreToDos = install
  }

install :: [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo]
install _ todo = do
  return (CoreDoPluginPass "Say name" pass : todo)

pass :: ModGuts -> CoreM ModGuts
pass g = do
          dflags <- getDynFlags
          mapM_ (printAnn dflags g) (mg_binds g) >> return g
  where printAnn :: DynFlags -> ModGuts -> CoreBind -> CoreM CoreBind
        printAnn dflags guts bndr@(NonRec b _) = do
          anns <- annotationsOn guts b :: CoreM [SomeAnn]
          unless (null anns) $ putMsgS $
            "Annotated binding found: " ++  showSDoc dflags (ppr b)
          return bndr
        printAnn _ _ bndr = return bndr

annotationsOn :: Data a => ModGuts -> CoreBndr -> CoreM [a]
annotationsOn guts bndr = do
  anns <- getAnnotations deserializeWithData guts
  return $ lookupWithDefaultUFM anns [] (varUnique bndr)


import Distribution.Simple
main = defaultMain


{-# LANGUAGE CPP #-}
module Common where

import GhcPlugins

install :: [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo]
install options todos = do
    putMsgS $ "Simple Plugin Passes Queried"
    putMsgS $ "Got options: " ++ unwords options

    -- Create some actual passes to continue the test.
    return $ CoreDoPluginPass "Main pass" mainPass
             : todos

mainPass :: ModGuts -> CoreM ModGuts
mainPass guts = do
#if defined(RUN2)
    putMsgS "Simple Plugin Pass Run 2"
#else
    putMsgS "Simple Plugin Pass Run"
#endif
    return guts


module FingerprintPlugin where

import GhcPlugins
import Common

plugin :: Plugin
plugin = defaultPlugin {
    installCoreToDos = install,
    pluginRecompile = flagRecompile
  }


module ImpurePlugin where

import GhcPlugins
import Common

plugin :: Plugin
plugin = defaultPlugin {
    installCoreToDos = install,
    pluginRecompile = impurePlugin
  }


module PurePlugin where

import GhcPlugins
import Common

plugin :: Plugin
plugin = defaultPlugin {
    installCoreToDos = install,
    pluginRecompile  = purePlugin
  }


import Distribution.Simple

main = defaultMain


module RuleDefiningPlugin where

import GhcPlugins

{-# RULES "unsound" forall x. show x = "SHOWED" #-}

plugin :: Plugin
plugin = defaultPlugin


module Simple.BadlyTypedPlugin where

plugin :: Int
plugin = 1


{-# LANGUAGE DeriveDataTypeable #-}

module Simple.DataStructures where

import Data.Data
import Data.Typeable

data ReplaceWith = ReplaceWith String
                 deriving (Data, Typeable)


{-# LANGUAGE TemplateHaskell #-}

module Simple.Plugin(plugin) where

import UniqFM
import GhcPlugins
import qualified ErrUtils

-- For annotation tests
import Simple.DataStructures

import Control.Monad
import Data.Monoid
import Data.Dynamic
import qualified Language.Haskell.TH as TH

plugin :: Plugin
plugin = defaultPlugin {
    installCoreToDos = install,
    pluginRecompile  = purePlugin
  }

install :: [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo]
install options todos = do
    putMsgS $ "Simple Plugin Passes Queried"
    putMsgS $ "Got options: " ++ unwords options

    -- Create some actual passes to continue the test.
    return $ CoreDoPluginPass "Main pass" mainPass
             : todos

findNameBinds :: String -> [CoreBind] -> First Name
findNameBinds target = mconcat . map (findNameBind target)

findNameBind :: String -> CoreBind -> First Name
findNameBind target (NonRec b e) = findNameBndr target b
findNameBind target (Rec bes) = mconcat (map (findNameBndr target . fst) bes)

findNameBndr :: String -> CoreBndr -> First Name
findNameBndr target b
  = if getOccString (varName b) == target
    then First (Just (varName b))
    else First Nothing

mainPass :: ModGuts -> CoreM ModGuts
mainPass guts = do
    putMsgS "Simple Plugin Pass Run"
    anns <- getAnnotations deserializeWithData guts
    bindsOnlyPass (mapM (changeBind anns Nothing)) guts

changeBind :: UniqFM [ReplaceWith] -> Maybe String -> CoreBind -> CoreM CoreBind
changeBind anns mb_replacement (NonRec b e) = changeBindPr anns mb_replacement b e >>= (return . uncurry NonRec)
changeBind anns mb_replacement (Rec bes) = liftM Rec $ mapM (uncurry (changeBindPr anns mb_replacement)) bes

changeBindPr :: UniqFM [ReplaceWith] -> Maybe String -> CoreBndr -> CoreExpr -> CoreM (CoreBndr, CoreExpr)
changeBindPr anns mb_replacement b e = do
    case lookupWithDefaultUFM anns [] b of
        [] -> do
                e' <- changeExpr anns mb_replacement e
                return (b, e')
        [ReplaceWith replace_string] -> do
                e' <- changeExpr anns (Just replace_string) e
                return (b, e')
        _ -> do dflags <- getDynFlags
                error ("Too many change_anns on one binder:" ++ showPpr dflags b)

changeExpr :: UniqFM [ReplaceWith] -> Maybe String -> CoreExpr -> CoreM CoreExpr
changeExpr anns mb_replacement e = let go = changeExpr anns mb_replacement in case e of
        Lit (LitString _) -> case mb_replacement of
                Nothing -> return e
                Just replacement -> do
                        putMsgS "Performing Replacement"
                        return $ Lit (LitString (bytesFS (mkFastString replacement)))
        App e1 e2 -> liftM2 App (go e1) (go e2)
        Lam b e -> liftM (Lam b) (go e)
        Let bind e -> liftM2 Let (changeBind anns mb_replacement bind) (go e)
        Case e b ty alts -> liftM4 Case (go e) (return b) (return ty) (mapM (changeAlt anns mb_replacement) alts)
        Cast e coerce -> liftM2 Cast (go e) (return coerce)
        Tick t e -> liftM (Tick t) (go e)
        _ -> return e

changeAlt :: UniqFM [ReplaceWith] -> Maybe String -> CoreAlt -> CoreM CoreAlt
changeAlt anns mb_replacement (con, bs, e) = liftM (\e' -> (con, bs, e')) (changeExpr anns mb_replacement e)


{-# LANGUAGE TypeFamilies, FlexibleContexts #-}
module Simple.RemovePlugin where

import Control.Monad.IO.Class
import Data.List (intercalate)
import Plugins
import Bag
import HscTypes
import TcRnTypes
import HsExtension
import HsExpr
import Outputable
import SrcLoc
import HsSyn
import HsBinds
import OccName
import RdrName
import Name
import Avail

plugin :: Plugin
plugin = defaultPlugin { parsedResultAction = parsedPlugin
                       , typeCheckResultAction = typecheckPlugin
                       , spliceRunAction = metaPlugin'
                       , interfaceLoadAction = interfaceLoadPlugin'
                       }

parsedPlugin :: [CommandLineOption] -> ModSummary -> HsParsedModule
                  -> Hsc HsParsedModule
parsedPlugin [name, "parse"] _ pm
  = return $ pm { hpm_module = removeParsedBinding name (hpm_module pm) }
parsedPlugin _ _ pm = return pm

removeParsedBinding :: String -> Located (HsModule GhcPs)
                         -> Located (HsModule GhcPs)
removeParsedBinding name (L l m)
  = (L l (m { hsmodDecls = filter (notNamedAs name) (hsmodDecls m) } ))
  where notNamedAs name (L _ (ValD _ (FunBind { fun_id = L _ fid })))
          = occNameString (rdrNameOcc fid) /= name
        notNamedAs _ _ = True

typecheckPlugin :: [CommandLineOption] -> ModSummary -> TcGblEnv -> TcM TcGblEnv
typecheckPlugin [name, "typecheck"] _ tc
  = return $ tc { tcg_exports = filter (availNotNamedAs name) (tcg_exports tc)
                , tcg_binds = filterBag (notNamedAs name) (tcg_binds tc)
                }
  where notNamedAs name (L _ FunBind { fun_id = L _ fid })
          = occNameString (getOccName fid) /= name
        notNamedAs name (L _ AbsBinds { abs_binds = bnds })
          = all (notNamedAs name) bnds
        notNamedAs _ (L _ b) = True
typecheckPlugin _ _ tc = return tc

metaPlugin' :: [CommandLineOption] -> LHsExpr GhcTc -> TcM (LHsExpr GhcTc)
metaPlugin' [name, "meta"] (L _ (HsApp noExt (L l (HsVar _ (L _ id))) e))
  | occNameString (getOccName id) == name
  = return e
metaPlugin' _ meta = return meta

interfaceLoadPlugin' :: [CommandLineOption] -> ModIface -> IfM lcl ModIface
interfaceLoadPlugin' [name, "interface"] iface
  = return $ iface { mi_exports = filter (availNotNamedAs name)
                                         (mi_exports iface)
                   }
interfaceLoadPlugin' _ iface = return iface

availNotNamedAs :: String -> AvailInfo -> Bool
availNotNamedAs name avail
  = occNameString (getOccName (availName avail)) /= name


module Simple.SourcePlugin where

import Control.Monad.IO.Class
import Data.List (intercalate)
import Data.Maybe (isJust)
import Plugins
import HscTypes
import TcRnTypes
import HsExtension
import Avail
import HsExpr
import Outputable
import HsImpExp
import HsDecls
import HsDoc

plugin :: Plugin
plugin = defaultPlugin { parsedResultAction = parsedPlugin
                       , typeCheckResultAction = typecheckPlugin
                       , spliceRunAction = metaPlugin'
                       , interfaceLoadAction = interfaceLoadPlugin'
                       , renamedResultAction = renamedAction
                       }

parsedPlugin :: [CommandLineOption] -> ModSummary -> HsParsedModule
                  -> Hsc HsParsedModule
parsedPlugin opts _ pm
  = do liftIO $ putStrLn $ "parsePlugin(" ++ intercalate "," opts ++ ")"
       return pm

renamedAction :: [CommandLineOption]
                    -> TcGblEnv -> HsGroup GhcRn
                    -> TcM (TcGblEnv, HsGroup GhcRn)
renamedAction _ env grp
  = do liftIO $ putStrLn "typeCheckPlugin (rn)"
       return (env, grp)

typecheckPlugin :: [CommandLineOption] -> ModSummary -> TcGblEnv -> TcM TcGblEnv
typecheckPlugin _ _ tc
  = do liftIO $ putStrLn "typeCheckPlugin (tc)"
       return tc

metaPlugin' :: [CommandLineOption] -> LHsExpr GhcTc -> TcM (LHsExpr GhcTc)
metaPlugin' _ meta
  = do liftIO $ putStrLn $ "metaPlugin: " ++ (showSDocUnsafe $ ppr meta)
       return meta

interfaceLoadPlugin' :: [CommandLineOption] -> ModIface -> IfM lcl ModIface
interfaceLoadPlugin' _ iface
  = do liftIO $ putStrLn $ "interfacePlugin: "
                              ++ (showSDocUnsafe $ ppr $ mi_module iface)
       return iface


module Simple.TrustworthyPlugin (plugin) where

import GhcPlugins
import TcRnMonad

plugin :: Plugin
plugin = defaultPlugin
  { renamedResultAction = keepRenamedSource
  , typeCheckResultAction = printHaskellSafeMode
  }
  where
    printHaskellSafeMode _ ms tcg = liftIO $ do
      let dflags = ms_hspp_opts ms
      safe <- finalSafeMode dflags tcg
      print $ gopt Opt_PluginTrustworthy dflags
      putStrLn $ showPpr dflags safe
      return tcg


{-# LANGUAGE TemplateHaskell #-}

module T16104_Plugin (plugin) where

import GhcPlugins
import Data.Bits

plugin :: Plugin
plugin = defaultPlugin {installCoreToDos = install}
  where install _ todos = return (test : todos)

        test = CoreDoPluginPass "Test" check

        check :: ModGuts -> CoreM ModGuts
        check m = do mbN <- thNameToGhcName 'complement
                     case mbN of
                       Just _  -> liftIO $ putStrLn "Found complement!"
                       Nothing -> error "Failed to locate complement"

                     return m


{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# OPTIONS_GHC -Wall #-}
module Simple where

pattern Foo :: ()
pattern Foo = ()

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

data A = B | C | D

{-#Â COMPLETE Foo #-}
{-#Â COMPLETE B,C #-}
{-#Â COMPLETE B #-}

b :: A -> A
b B = B
b C = C


{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# OPTIONS_GHC -Wall #-}
module Empty where

pattern Foo :: ()
pattern Foo = ()

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


{-# OPTIONS_GHC -Wall #-}
module Module where

import Completesig03A

foo :: A -> ()
foo A = ()


module Completesig03A where

data A = A | B

{-#Â COMPLETE A #-}


-- Test that a COMPLETE pragma over constructors of different types fails.
module TyMismatch where

data E = L | R

{-# COMPLETE Just, L #-}


{-# OPTIONS_GHC -Wall #-}
module Completesig05 where

-- Matching against multiple arguments

data T = A | B | C
data S = D | E | F

{-# COMPLETE A, B #-}
{-# COMPLETE D #-}

match :: T -> S -> ()
match A D = ()
match B D = ()


{-#Â OPTIONS_GHC -Wall #-}
module Completesig06 where

-- Some non-exhaustive examples

data T = A | B | C
data S = D | E | F

{-# COMPLETE A, B #-}
{-# COMPLETE D #-}

m1 :: T -> ()
m1 A = ()

m2 :: T -> ()
m2 B = ()
m2 C = ()

m3 :: T -> ()
m3 C = ()

m4 :: T -> S -> ()
m4 A E = ()
m4 A F = ()
m4 B F = ()
m4 B E = ()

m5 :: T -> S -> ()
m5 C D = ()


{-# OPTIONS_GHC -Wall #-}
module Completesig07 where

-- Some overlapping examples

data T = A | B | C
data S = D | E | F

{-# COMPLETE A, B #-}
{-# COMPLETE D #-}

m1 :: T -> ()
m1 A = ()
m1 A = ()
m1 B = ()

m2 :: T -> S -> ()
m2 A D = ()
m2 B D = ()
m2 A D = ()

m3 :: T -> ()
m3 C = ()
m3 C = ()


{-# OPTIONS_GHC -Wall #-}
module Completesig08 where

-- Some redundant examples

data T = A | B | C
data S = D | E | F

{-# COMPLETE A, B #-}
{-# COMPLETE D #-}

m1 :: T -> ()
m1 A = ()
m1 B = ()
m1 C = ()

m2 :: T -> S -> ()
m2 A D = ()
m2 B D = ()
m2 C D = ()

m3 :: T -> S -> ()
m3 A D = ()
m3 B D = ()
m3 A E = ()
m3 A F = ()

m4 :: S -> ()
m4 D = ()
m4 E = ()


{-# OPTIONS_GHC -Wall #-}
module Completesig08 where

-- Nested matching

data T = A S | B
data S = D | E

{-# COMPLETE A #-}
{-# COMPLETE D #-}

m1 :: T -> ()
m1 (A D) = ()


{-# OPTIONS_GHC -Wall #-}
module Completesig10 where

-- Multiple competing COMPLETE sigs AHHH!!

data T = A | B | C | D | E

{-# COMPLETE A,B #-}
{-# COMPLETE C,D #-}

-- Completely overlapping
m1 :: T -> ()
m1 A = ()
m1 B = ()
m1 C = ()
m1 D = ()

-- Incomplete overlap
m2 :: T -> ()
m2 B = ()
m2 D = ()

-- Redundant incomplete overlap
m3 :: T -> ()
m3 B = ()
m3 C = ()
m3 D = ()

-- One matches

m4 :: T -> ()
m4 C = ()
m4 D = ()


{-# OPTIONS_GHC -Wall #-}
{-# LANGUAGE PatternSynonyms #-}
module Completesig11 where

data T = A | B | C
{-# COMPLETE A,B #-}
{-# COMPLETE A,C #-}

pattern BS :: T
pattern BS = B
{-# COMPLETE A,BS #-}

m1  :: T -> ()
m1 A = ()


{-# LANGUAGE GADTs, PatternSynonyms #-}
{-# OPTIONS_GHC -Wall #-}
module Completesig11 where
data G a where
  G1' :: G Int
  G2' :: G Bool

pattern G1 :: () => (a ~ Int) => G a
pattern G1 = G1'

pattern G2 :: () => (a ~ Bool) => G a
pattern G2 = G2'

{-# COMPLETE G1, G2 #-}

fa :: G a -> Int   -- exhaustive function
fa G1 = 1
fa G2 = 2

fb :: G Int -> Int -- exhaustive function
fb G1 = 1
-- fb G2 = 2       -- inaccessible clause


{-# LANGUAGE GADTs #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -Wall #-}
module Completesig11 where

class LL f where
  go :: f a -> ()

instance LL [] where
  go _ = ()

pattern T :: LL f => f a
pattern T <- (go -> ())

{-# COMPLETE T :: [] #-}

foo :: [a] -> Int
foo T = 5


{-# OPTIONS_GHC -Wall #-}
module Completesig11 where

data A = A | B

{-#Â COMPLETE A, B #-}

foo :: A -> ()
foo A = ()
foo B = ()
foo A = ()


{-# OPTIONS_GHC -Wall #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ViewPatterns #-}
module Completesig15 where

class C f where
  foo :: f a -> ()

pattern P :: C f => f a
pattern P <- (foo -> ())

{-#Â COMPLETE P #-}


{-# LANGUAGE GADTs #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeInType #-}
{-# LANGUAGE TypeOperators #-}
{-# OPTIONS_GHC -Wincomplete-patterns #-}
module T14059a where

data SBool (z :: Bool) where
  SFalse :: SBool False
  STrue  :: SBool True

pattern STooGoodToBeTrue :: forall (z :: Bool). ()
                         => z ~ True
                         => SBool z
pattern STooGoodToBeTrue = STrue
{-# COMPLETE SFalse, STooGoodToBeTrue #-}

wibble :: SBool z -> Bool
wibble STrue = True

wobble :: SBool z -> Bool
wobble STooGoodToBeTrue = True


{-# LANGUAGE GADTs #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE PolyKinds #-}

module T14253 where

import GHC.Exts
import Data.Kind

data TypeRep (a :: k) where
    Con :: TypeRep (a :: k)
    TrFun   :: forall (r1 :: RuntimeRep) (r2 :: RuntimeRep)
                      (a :: TYPE r1) (b :: TYPE r2).
               TypeRep a
            -> TypeRep b
            -> TypeRep (a -> b)

pattern Fun :: forall k (fun :: k). ()
            => forall (r1 :: RuntimeRep) (r2 :: RuntimeRep)
                      (arg :: TYPE r1) (res :: TYPE r2).
               (k ~ Type, fun ~~ (arg -> res))
            => TypeRep arg
            -> TypeRep res
            -> TypeRep fun
pattern Fun arg res <- TrFun arg res

data Dynamic where
    Dynamic :: forall a. TypeRep a -> a -> Dynamic

-- Adding this results in failure
{-# COMPLETE Con #-}

dynApply :: Dynamic -> Dynamic -> Maybe Dynamic
-- Changing TrFun to Fun also results in failure
dynApply (Dynamic (Fun ta tr) f) (Dynamic ta' x) = undefined
dynApply _ _ = Nothing


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

-- Check some predefined types
module EmptyCase001 where

-- Non-exhaustive with *infinite* inhabitants
f1 :: Int -> a
f1 = \case

-- Non-exhaustive. Since a string is just a list of characters
-- (that is, an algebraic type), we have [] and (_:_) as missing.
f2 :: String -> a
f2 x = case x of {}

-- Non-exhaustive (do not unfold the alternatives)
f3 :: Char -> a
f3 x = case x of {}


{-# OPTIONS_GHC -fwarn-incomplete-patterns  #-}
{-# LANGUAGE EmptyCase, LambdaCase          #-}
{-# LANGUAGE GADTs, TypeFamilies            #-}

-- Check some newtypes, in combination with GADTs and TypeFamilies
module EmptyCase002 where

import Data.Kind (Type)

newtype T = MkT H
newtype G = MkG T
newtype H = MkH G

-- Exhaustive but it cannot be detected.
f1 :: T -> a
f1 = \case

data A

data B = B1 | B2

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

data D :: Type -> Type -> Type where
  D1 :: D Int  Bool
  D2 :: D Bool Char

type family E (a :: Type) :: Type where
  E Int  = Bool
  E Bool = Char

newtype T1 a = MkT1 a
newtype T2 b = MkT2 b

-- Exhaustive
f2 :: T1 A -> z
f2 = \case

-- Non-exhaustive. Missing cases: MkT1 B1, MkT1 B2
f3 :: T1 B -> z
f3 = \case

-- Non-exhaustive. Missing cases: MkT1 False, MkT1 True
f4 :: T1 (E Int) -> z
f4 = \case

-- Non-exhaustive. Missing cases: MkT1 (MkT2 (MkT1 D2))
f5 :: T1 (T2 (T1 (D (E Int) (E (E Int))))) -> z
f5 = \case

-- Exhaustive. Not an EmptyCase but good to have for
-- comparison with the example above
f6 :: T1 (T2 (T1 (D (E Int) (E (E Int))))) -> ()
f6 = \case MkT1 (MkT2 (MkT1 D2)) -> ()


{-# OPTIONS_GHC -fwarn-incomplete-patterns      #-}
{-# LANGUAGE EmptyCase, LambdaCase              #-}
{-# LANGUAGE TypeFamilies, UndecidableInstances #-}

-- Check some type families and type synonyms
module EmptyCase003 where

import Data.Kind (Type)

type family A (a :: Type) :: Type

-- Conservatively considered non-exhaustive (A a missing),
-- since A a does not reduce to anything.
f1 :: A a -> a -> b
f1 = \case

data Void

type family B (a :: Type) :: Type
type instance B a = Void

-- Exhaustive
f2 :: B a -> b
f2 = \case

type family C (a :: Type) :: Type
type instance C Int  = Char
type instance C Bool = Void

-- Non-exhaustive (C a missing, no info about `a`)
f3 :: C a -> a -> b
f3 = \case

-- Non-exhaustive (_ :: Char missing): C Int rewrites
-- to Char (which is trivially inhabited)
f4 :: C Int -> a
f4 = \case

-- Exhaustive: C Bool rewrites to Void
f5 :: C Bool -> a
f5 = \case

-- type family D (a :: Type) :: Type
-- type instance D x = D x -- non-terminating
--
-- -- Exhaustive but *impossible* to detect that, since rewriting
-- -- D Int does not terminate (the checker should loop).
-- f6 :: D Int -> a
-- f6 = \case

data Zero
data Succ n

type TenC n = Succ (Succ (Succ (Succ (Succ
             (Succ (Succ (Succ (Succ (Succ n)))))))))

type Ten = TenC Zero

type Hundred = TenC (TenC (TenC (TenC (TenC
              (TenC (TenC (TenC (TenC (TenC Zero)))))))))

type family E (n :: Type) (a :: Type) :: Type
type instance E Zero     b = b
type instance E (Succ n) b = E n b

-- Exhaustive (10 rewrites)
f7 :: E Ten Void -> b
f7 = \case

-- Exhaustive (100 rewrites)
f8 :: E Hundred Void -> b
f8 = \case

type family Add (a :: Type) (b :: Type) :: Type
type instance Add Zero     m = m
type instance Add (Succ n) m = Succ (Add n m)

type family Mult (a :: Type) (b :: Type) :: Type
type instance Mult Zero     m = Zero
type instance Mult (Succ n) m = Add m (Mult n m)

type Five = Succ (Succ (Succ (Succ (Succ Zero))))
type Four = Succ (Succ (Succ (Succ Zero)))

-- Exhaustive (80 rewrites)
f9 :: E (Mult Four (Mult Four Five)) Void -> a
f9 = \case

-- This gets killed on my dell
--
-- -- Exhaustive (390625 rewrites)
-- f10 :: E (Mult (Mult (Mult Five Five)
--                      (Mult Five Five))
--                (Mult (Mult Five Five)
--                      (Mult Five Five)))
--          Void -> a
-- f10 = \case


{-# OPTIONS_GHC -fwarn-incomplete-patterns #-}
{-# LANGUAGE GADTs, KindSignatures, EmptyCase, LambdaCase #-}

-- Check some GADTs
module EmptyCase004 where

import Data.Kind (Type)

data A :: Type -> Type where
  A1 :: A Int
  A2 :: A Bool

-- Non-exhaustive: Missing A2
f1 :: A Bool -> a
f1 = \case

-- Non-exhaustive: missing both A1 & A2
f2 :: A a -> b
f2 = \case

-- Exhaustive
f3 :: A [a] -> b
f3 = \case

data B :: Type -> Type -> Type where
  B1 :: Int -> B Bool Bool
  B2 ::        B Int  Bool

-- Non-exhaustive: missing (B1 _)
g1 :: B a a -> b
g1 x = case x of

-- Non-exhaustive: missing both (B1 _) & B2
g2 :: B a b -> c
g2 = \case

-- Exhaustive
g3 :: B Char a -> b
g3 = \case

-- NOTE: A lambda-case always has ONE scrutinee and a lambda case refers
-- always to the first of the arguments. Hence, the following warnings are
-- valid:

-- Non-exhaustive: Missing both A1 & A2
h1 :: A a -> A a -> b
h1 = \case

h2 :: A a -> B a b -> ()
h2 A1 = \case -- Non-exhaustive, missing B2
h2 A2 = \case -- Non-exhaustive, missing (B1 _)


{-# OPTIONS_GHC -fwarn-incomplete-patterns #-}
{-# LANGUAGE TypeFamilies, EmptyCase, LambdaCase #-}
{-# LANGUAGE UndecidableInstances #-}

-- Check some DataFamilies, warning appearance and other stuff
module EmptyCase005 where

data Void

newtype Void2 = Void2 Void
data    Void3 = Void3 Void

-- Exhaustive
f1 :: Void2 -> Bool
f1 x = case x of {}
-- > f1 undefined
-- *** Exception: Prelude.undefined
--
-- > f1 (Void2 undefined)
-- *** Exception: Prelude.undefined

-- Non-exhaustive: missing (Void3 _)
f2 :: Void3 -> Bool
f2 x = case x of {}
-- > f2 undefined
-- *** Exception: Prelude.undefined
--
-- > f2 (Void3 undefined)
-- *** Exception: Void.hs:31:7-10: Non-exhaustive patterns in case

newtype V1 = V1 Void
newtype V2 = V2 V1
newtype V3 = V3 V2
newtype V4 = V4 V3

-- Exhaustive
f3 :: V4 -> Bool
f3 x = case x of {}
-- > v undefined
-- *** Exception: Prelude.undefined
--
-- > v (V4 undefined)
-- *** Exception: Prelude.undefined
--
-- > v (V4 (V3 undefined))
-- *** Exception: Prelude.undefined
--
-- > v (V4 (V3 (V2 undefined)))
-- *** Exception: Prelude.undefined
--
-- > v (V4 (V3 (V2 (V1 undefined))))
-- *** Exception: Prelude.undefined

-- Exhaustive
type family A a
type instance A Bool = V4

f4 :: A Bool -> Bool
f4 x = case x of {}

data family T a

data instance T () = T1 | T2

-- Non-exhaustive: missing both T1 & T2
f5 :: T () -> Bool
f5 x = case x of {}

newtype instance T Bool = MkTBool Bool

-- Non-exhaustive: missing both (MkTBool True) & (MkTBool False)
f6 :: T Bool -> Bool
f6 x = case x of {}

newtype instance T Int = MkTInt Char

-- Non-exhaustive: missing (MkTInt _)
f7 :: T Int -> Bool
f7 x = case x of {}

newtype V = MkV Bool

type family F a
type instance F Bool = V

type family G a
type instance G Int = F Bool

-- Non-exhaustive: missing MkV True & MkV False
f8 :: G Int -> Bool
f8 x = case x of {}

type family H a
type instance H Int  = H Bool
type instance H Bool = H Char

-- Non-exhaustive: missing (_ :: H Char)
-- (H Int), (H Bool) and (H Char) are all the same and stuck, but we want to
-- show the latest rewrite, that is, (H Char) and not (H Int) or (H Bool).
f9 :: H Int -> Bool
f9 x = case x of {}


{-# OPTIONS_GHC -fwarn-incomplete-patterns #-}
{-# LANGUAGE GADTs, KindSignatures, EmptyCase, LambdaCase #-}

-- Check interaction between Newtypes and GADTs
module EmptyCase006 where

import Data.Kind (Type)

data GA :: Type -> Type where
  MkGA1 :: GA Int
  MkGA2 :: GA a -> GA [a]
  MkGA3 :: GA (a,a)

newtype Foo1 a = Foo1 (GA a)

-- Non-exhaustive. Missing: Foo1 MkGA1
f01 :: Foo1 Int -> ()
f01 = \case

-- Exhaustive
f02 :: Foo1 (Int, Bool) -> ()
f02 = \case

-- Non-exhaustive. Missing: Foo1 MkGA1, Foo1 (MkGA2 _), Foo1 MkGA3
f03 :: Foo1 a -> ()
f03 = \case

-- Exhaustive
f04 :: Foo1 () -> ()
f04 = \case


{-# OPTIONS_GHC -fwarn-incomplete-patterns #-}
{-# LANGUAGE TypeFamilies, EmptyCase, LambdaCase #-}

-- Check interaction between Newtypes and Type Families
module EmptyCase007 where

import Data.Kind (Type)

type family FA a :: Type -- just an open type family
type instance FA Int     = (Char, Bool)
type instance FA Char    = Char
type instance FA [a]     = [FA a]
type instance FA (a,b,b) = Void1

newtype Foo2 a = Foo2 (FA a)

data Void1

-- Non-exhaustive. Missing: (_ :: Foo2 a) (no info about a)
f05 :: Foo2 a -> ()
f05 = \case

-- Non-exhaustive. Missing: (_ :: Foo2 (a, a)) (does not reduce)
f06 :: Foo2 (a, a) -> ()
f06 = \case

-- Exhaustive (reduces to Void)
f07 :: Foo2 (Int, Char, Char) -> ()
f07 = \case

-- Non-exhaustive. Missing: Foo2 (_, _)
f08 :: Foo2 Int -> ()
f08 = \case

-- Non-exhaustive. Missing: Foo2 _
f09 :: Foo2 Char -> ()
f09 = \case

-- Non-exhaustive. Missing: (_ :: Char)
-- This is a more general trick: If the warning gives you a constructor form
-- and you don't know what the type of the underscore is, just match against
-- the constructor form, and the warning you'll get will fill the type in.
f09' :: Foo2 Char -> ()
f09' (Foo2 x) = case x of {}

-- Non-exhaustive. Missing: Foo2 [], Foo2 (_:_)
f10 :: Foo2 [Int] -> ()
f10 = \case


{-# OPTIONS_GHC -fwarn-incomplete-patterns #-}
{-# LANGUAGE TypeFamilies, GADTs, EmptyCase, LambdaCase #-}

-- Check interaction between Newtypes and DataFamilies
module EmptyCase008 where

import Data.Kind (Type)

data family DA a

newtype Foo3 a = Foo3 (DA a)

data instance DA Int = MkDA1 Char | MkDA2

-- Non-exhaustive. Missing: MkDA1 Char, MkDA2
f11 :: Foo3 Int -> ()
f11 = \case

-- Non-exhaustive. (no info about a)
f12 :: Foo3 a -> ()
f12 = \case

data instance DA () -- Empty data type

-- Exhaustive.
f13 :: Foo3 () -> ()
f13 = \case

-- ----------------
data family DB a :: Type -> Type

data instance DB Int a where
  MkDB1 :: DB Int ()
  MkDB2 :: DB Int Bool

newtype Foo4 a b = Foo4 (DB a b)

-- Non-exhaustive. Missing: Foo4 MkDB1
f14 :: Foo4 Int () -> ()
f14 = \case

-- Exhaustive
f15 :: Foo4 Int [a] -> ()
f15 = \case

-- Non-exhaustive. Missing: (_ :: Foo4 a b) (no information about a or b)
f16 :: Foo4 a b -> ()
f16 = \case

data instance DB Char Bool -- Empty data type

-- Exhaustive (empty data type)
f17 :: Foo4 Char Bool -> ()
f17 = \case


{-# OPTIONS_GHC -fwarn-incomplete-patterns #-}
{-# LANGUAGE TypeFamilies, GADTs, EmptyCase, LambdaCase #-}

-- Arrow Kind, Newtypes, GADTs, DataFamilies
module EmptyCase009 where

import Data.Kind (Type)

data family DB a :: Type -> Type

data instance DB Int a where
  MkDB1 :: DB Int ()
  MkDB2 :: DB Int Bool

data instance DB Char Bool -- Empty data type

newtype Bar f = Bar (f Int)

-- Non-exhaustive. Missing: (_ :: Bar f)
f17 :: Bar f -> ()
f17 x = case x of {}

-- Exhaustive (Bar (DB Int) ~ DB Int Int, incompatible with both MkDB1 & MkDB2)
f18 :: Bar (DB Int) -> ()
f18 x = case x of {}

data instance DB () a where
  MkDB1_u :: DB () ()
  MkDB2_u :: DB () Int

-- Non-exhaustive. Missing: Bar MkDB2_u
f19 :: Bar (DB ()) -> ()
f19 = \case

data GB :: Type -> Type where
  MkGB1 :: Int -> GB ()
  MkGB2 :: GB (a,a)
  MkGB3 :: GB b

-- Non-exhaustive. Missing: Bar MkGB3
f20 :: Bar GB -> ()
f20 = \case


{-# OPTIONS_GHC -fwarn-incomplete-patterns #-}
{-# LANGUAGE TypeFamilies, GADTs, PolyKinds, DataKinds
           , EmptyCase, LambdaCase #-}

-- Newtypes, PolyKinds, DataKinds, GADTs, DataFamilies
module EmptyCase010 where

import Data.Kind (Type)

newtype Baz (f :: k -> Type) (a :: k) = Baz (f a)

data T = T1 | T2 T | T3 T T | T4 () -- only promoted

data GC :: T -> Type where
  MkGC1 :: GC 'T1
  MkGC2 :: T -> GC (T4 '())

-- Exhaustive: GC ('T2 'T1) is not strictly inhabited
f21 :: Baz GC ('T2 'T1) -> ()
f21 = \case

-- Non-exhaustive. Missing: Baz MkGC1, Baz (MkGC2 _)
f22 :: Baz GC a -> ()
f22 = \case

-- Non-exhaustive. Missing: Baz MkGC1
f23 :: Baz GC 'T1 -> ()
f23 = \case

data GD :: (Type -> Type) -> Type where
  MkGD1 :: GD Maybe
  MkGD2 :: GD []
  MkGD3 :: GD f

-- Non-exhaustive. Missing: Baz MkGD1, Baz MkGD3
f24 :: Baz GD Maybe -> ()
f24 = \case

-- Non-exhaustive. Missing: Baz MkGD3
f25 :: Baz GD (Either Int) -> ()
f25 x = case x of {}

-- Non-exhaustive. Missing: Baz MkGD1, Baz MkGD2, Baz MkGD3
f26 :: Baz GD f -> ()
f26 = \case

data family DC a :: Type -> Type

data instance DC () Int -- Empty type

-- Exhaustive
f27 :: Baz (DC ()) Int -> ()
f27 = \case

-- Non-exhaustive. Missing: _ :: Baz (DC ()) a (a is unknown)
f28 :: Baz (DC ()) a -> ()
f28 = \case

data instance DC Bool a where
  MkDC1 :: DC Bool Int
  MkDC2 :: DC Bool [a]

-- Exhaustive. (DC Bool Char) is not strictly inhabited
f29 :: Baz (DC Bool) Char -> ()
f29 = \case

-- Non-exhaustive. Missing: Baz MkDC2
f30 :: Baz (DC Bool) [Int] -> ()
f30 = \case

-- Non-exhaustive. Missing: Baz f a (a and f unknown (and the kind too))
f31 :: Baz f a -> ()
f31 x = case x of {}


{-# LANGUAGE TypeFamilies, GADTs #-}
{-# OPTIONS_GHC -fwarn-incomplete-patterns -fwarn-overlapping-patterns #-}

module PMC001 where

data family T a

data instance T [a] where
  MkT1 :: T [Int]
  MkT2 :: Char -> T [Char]
  MkT3 :: T [a]

f :: T [a] -> T [a] -> Bool
f MkT1     MkT1     = True
f (MkT2 _) (MkT2 _) = True
f MkT3     MkT3     = True

g :: T [a] -> T [a] -> Bool
g x y
  | MkT1     <- x, MkT1     <- y = True
  | (MkT2 _) <- x, (MkT2 _) <- y = True
  | MkT3     <- x, MkT3     <- y = True


{-# OPTIONS_GHC -fwarn-incomplete-patterns -fwarn-overlapping-patterns #-}

module PMC002 where

f :: [a] -> Bool
f []              = True
f x  | (_:_) <- x = False -- exhaustive


{-# OPTIONS_GHC -fwarn-incomplete-patterns -fwarn-overlapping-patterns #-}

module PMC003 where

f :: Bool -> Bool -> ()
f _    False = ()
f True False = ()
f _    _     = ()


{-# OPTIONS_GHC -fwarn-incomplete-patterns -fwarn-overlapping-patterns #-}
{-# LANGUAGE GADTs #-}

module PMC004 where

data F a where
  F1 :: F Int
  F2 :: F Bool

data G a where
  G1 :: G Int
  G2 :: G Char

h :: F a -> G a -> ()
h F1 G1 = ()
h _  G1 = ()


{-# OPTIONS_GHC -fwarn-incomplete-patterns -fwarn-overlapping-patterns #-}
{-# LANGUAGE GADTs #-}

module PMC005 where

data T a where
  TList :: T [a]
  TBool :: T Bool

foo :: T c -> T c -> ()
foo TList _     = ()
foo _     TList = ()


{-# OPTIONS_GHC -fwarn-incomplete-patterns -fwarn-overlapping-patterns #-}

module PMC006 where

len :: [a] -> Int
len xs = case xs of
           []     -> 0
           (_:ys) -> case () of
                       () | (_:_) <- xs -> 1 + len ys

-- -- we would like these to work too but they don't yet
--
-- len :: [a] -> Int
-- len [] = 0
-- len xs = case xs of
--            (_:ys) -> 1 + len ys
--
-- len :: [a] -> Int
-- len xs = case xs of
--            [] -> 0
--            ys -> case ys of
--                    (_:zs) -> 1 + len zs


{-# OPTIONS_GHC -fwarn-incomplete-patterns -fwarn-overlapping-patterns #-}
{-# LANGUAGE OverloadedStrings #-}

module PMC007 where

-- overloaded
f "ab" = ()
f "ac" = ()

-- non-overloaded
g :: String -> ()
g "ab" = ()
g "ac" = ()

-- non-overloaded due to type inference
h :: String -> ()
h s = let s' = s
      in  case s' of
            "ab" -> ()
            "ac" -> ()


{-# OPTIONS_GHC -fwarn-incomplete-patterns  #-}
{-# LANGUAGE EmptyCase #-}
{-# LANGUAGE GADTs, DataKinds #-}

module Test where

-- Non-exhaustive (missing True & False)
test :: Bool -> Int
test a = case a of

data Void

-- Exhaustive
absurd :: Void -> a
absurd a = case a of {}

data Nat = Zero | Succ Nat

data Fin n where
  FZ ::          Fin (Succ n)
  FS :: Fin n -> Fin (Succ n)

-- Exhaustive
f :: Fin Zero -> a
f x = case x of {}


{-# OPTIONS_GHC -Woverlapping-patterns -Wincomplete-patterns #-}
{-# OPTIONS_GHC -fmax-pmcheck-iterations=10000000 #-}

module T11195 where

import TyCoRep
import Coercion
import Type hiding( substTyVarBndr, substTy, extendTCvSubst )
import TcType       ( exactTyCoVarsOfType )
import CoAxiom
import VarSet
import VarEnv
import Pair
import InstEnv

type NormalCo    = Coercion
type NormalNonIdCo = NormalCo  -- Extra invariant: not the identity
type SymFlag = Bool
type ReprFlag = Bool

chooseRole :: ReprFlag -> Role -> Role
chooseRole = undefined

wrapRole :: ReprFlag -> Role -> Coercion -> Coercion
wrapRole = undefined

wrapSym :: SymFlag -> Coercion -> Coercion
wrapSym = undefined

optForAllCoBndr :: LiftingContext -> Bool
                -> TyVar -> Coercion -> (LiftingContext, TyVar, Coercion)
optForAllCoBndr = undefined

opt_trans :: InScopeSet -> NormalCo -> NormalCo -> NormalCo
opt_trans = undefined

opt_univ :: LiftingContext -> SymFlag -> UnivCoProvenance -> Role
         -> Type -> Type -> Coercion
opt_univ = undefined

opt_co3 :: LiftingContext -> SymFlag -> Maybe Role
        -> Role -> Coercion -> NormalCo
opt_co3 = undefined

opt_co2 :: LiftingContext -> SymFlag -> Role -> Coercion -> NormalCo
opt_co2 = undefined

compatible_co :: Coercion -> Coercion -> Bool
compatible_co = undefined

etaTyConAppCo_maybe = undefined
etaAppCo_maybe = undefined
etaForAllCo_maybe = undefined

matchAxiom = undefined
checkAxInstCo = undefined
isAxiom_maybe = undefined
isCohLeft_maybe = undefined
isCohRight_maybe = undefined

opt_transList :: InScopeSet -> [NormalCo] -> [NormalCo] -> [NormalCo]
opt_transList is = zipWith (opt_trans is)

opt_trans_rule :: InScopeSet -> NormalNonIdCo -> NormalNonIdCo -> Maybe NormalCo
opt_trans_rule is in_co1@(NthCo r1 d1 co1) in_co2@(NthCo r2 d2 co2)
  | d1 == d2
  , co1 `compatible_co` co2 = undefined

opt_trans_rule is in_co1@(LRCo d1 co1) in_co2@(LRCo d2 co2)
  | d1 == d2
  , co1 `compatible_co` co2 = undefined

-- Push transitivity inside instantiation
opt_trans_rule is in_co1@(InstCo co1 ty1) in_co2@(InstCo co2 ty2)
  | ty1 `eqCoercion` ty2
  , co1 `compatible_co` co2 = undefined

opt_trans_rule is in_co1@(UnivCo p1 r1 tyl1 _tyr1)
                  in_co2@(UnivCo p2 r2 _tyl2 tyr2)
  | Just prov' <- opt_trans_prov p1 p2 = undefined
  where
    -- if the provenances are different, opt'ing will be very confusing
    opt_trans_prov UnsafeCoerceProv UnsafeCoerceProv
      = Just UnsafeCoerceProv
    opt_trans_prov (PhantomProv kco1) (PhantomProv kco2)
      = Just $ PhantomProv $ opt_trans is kco1 kco2
    opt_trans_prov (ProofIrrelProv kco1) (ProofIrrelProv kco2)
      = Just $ ProofIrrelProv $ opt_trans is kco1 kco2
    opt_trans_prov (PluginProv str1) (PluginProv str2)
      | str1 == str2 = Just p1
    opt_trans_prov _ _ = Nothing

-- Push transitivity down through matching top-level constructors.
opt_trans_rule is in_co1@(TyConAppCo r1 tc1 cos1)
                  in_co2@(TyConAppCo r2 tc2 cos2)
  | tc1 == tc2 = undefined

opt_trans_rule is in_co1@(AppCo co1a co1b) in_co2@(AppCo co2a co2b)
  = undefined

-- Eta rules
opt_trans_rule is co1@(TyConAppCo r tc cos1) co2
  | Just cos2 <- etaTyConAppCo_maybe tc co2 = undefined

opt_trans_rule is co1 co2@(TyConAppCo r tc cos2)
  | Just cos1 <- etaTyConAppCo_maybe tc co1 = undefined

opt_trans_rule is co1@(AppCo co1a co1b) co2
  | Just (co2a,co2b) <- etaAppCo_maybe co2 = undefined

opt_trans_rule is co1 co2@(AppCo co2a co2b)
  | Just (co1a,co1b) <- etaAppCo_maybe co1 = undefined

-- Push transitivity inside forall
opt_trans_rule is co1 co2
  | ForAllCo tv1 eta1 r1 <- co1
  , Just (tv2,eta2,r2) <- etaForAllCo_maybe co2 = undefined

  | ForAllCo tv2 eta2 r2 <- co2
  , Just (tv1,eta1,r1) <- etaForAllCo_maybe co1 = undefined

  where
  push_trans tv1 eta1 r1 tv2 eta2 r2 = undefined

-- Push transitivity inside axioms
opt_trans_rule is co1 co2
  | Just (sym, con, ind, cos1) <- co1_is_axiom_maybe
  , True <- sym
  , Just cos2 <- matchAxiom sym con ind co2
  , let newAxInst = AxiomInstCo con ind
                      (opt_transList is (map mkSymCo cos2) cos1)
  , Nothing <- checkAxInstCo newAxInst
  = undefined

  -- TrPushAxR
  | Just (sym, con, ind, cos1) <- co1_is_axiom_maybe
  , False <- sym
  , Just cos2 <- matchAxiom sym con ind co2
  , let newAxInst = AxiomInstCo con ind (opt_transList is cos1 cos2)
  , Nothing <- checkAxInstCo newAxInst
  = undefined

  -- TrPushSymAxL
  | Just (sym, con, ind, cos2) <- co2_is_axiom_maybe
  , True <- sym
  , Just cos1 <- matchAxiom (not sym) con ind co1
  , let newAxInst = AxiomInstCo con ind
                      (opt_transList is cos2 (map mkSymCo cos1))
  , Nothing <- checkAxInstCo newAxInst
  = undefined

  -- TrPushAxL
  | Just (sym, con, ind, cos2) <- co2_is_axiom_maybe
  , False <- sym
  , Just cos1 <- matchAxiom (not sym) con ind co1
  , let newAxInst = AxiomInstCo con ind (opt_transList is cos1 cos2)
  , Nothing <- checkAxInstCo newAxInst
  = undefined

  -- TrPushAxSym/TrPushSymAx
  | Just (sym1, con1, ind1, cos1) <- co1_is_axiom_maybe
  , Just (sym2, con2, ind2, cos2) <- co2_is_axiom_maybe
  , con1 == con2
  , ind1 == ind2
  , sym1 == not sym2
  , let branch = coAxiomNthBranch con1 ind1
        qtvs = coAxBranchTyVars branch ++ coAxBranchCoVars branch
        lhs  = coAxNthLHS con1 ind1
        rhs  = coAxBranchRHS branch
        pivot_tvs = exactTyCoVarsOfType (if sym2 then rhs else lhs)
  , all (`elemVarSet` pivot_tvs) qtvs
  = undefined
  where
    co1_is_axiom_maybe = isAxiom_maybe co1
    co2_is_axiom_maybe = isAxiom_maybe co2
    role = coercionRole co1 -- should be the same as coercionRole co2!

opt_trans_rule is co1 co2
  | Just (lco, lh) <- isCohRight_maybe co1
  , Just (rco, rh) <- isCohLeft_maybe co2
  , (coercionType lh) `eqType` (coercionType rh)
  = undefined

opt_trans_rule _ co1 co2        -- Identity rule
  | (Pair ty1 _, r) <- coercionKindRole co1
  , Pair _ ty2 <- coercionKind co2
  , ty1 `eqType` ty2
  = undefined

opt_trans_rule _ _ _ = Nothing


module T11245 where

foo x = do
  let a | Just i <- x
        , odd i
        = True

        | Nothing <- x
        = False

  print x
  print a


{-# LANGUAGE RankNTypes #-}
module Hang where
import Control.Monad
import Data.Char

data Event
  = EventBeginDocument
  | EventEndDocument
  | EventBeginDoctype
  | EventEndDoctype
  | EventInstruction
  | EventBeginElement
  | EventEndElement
  | EventContent Content
  | EventComment
  | EventCDATA

data Content
  = ContentText String
  | ContentEntity String

peek :: Monad m => Consumer a m (Maybe a)
peek = undefined

type Consumer i m r = forall o. ConduitM i o m r

tag :: forall m a b c o . Monad m =>
    ConduitM Event o m (Maybe c)
tag = do
    _ <- dropWS
    return undefined
  where
-- Add this and it works
--     dropWS :: Monad m => ConduitM Event o m (Maybe Event)
    dropWS = do
-- Swap these two lines and it works
        -- let x = undefined
        x <- peek
        let isWS =
                case x of
                    -- Remove some of these and it works
                    Just EventBeginDocument -> True
                    Just EventEndDocument -> True
                    Just EventBeginDoctype{} -> True
                    Just EventEndDoctype -> True
                    Just EventInstruction{} -> True
                    Just EventBeginElement{} -> False
                    Just EventEndElement{} -> False
                    Just (EventContent (ContentText t))
                        | all isSpace t -> True
                        | otherwise -> False
                    Just (EventContent ContentEntity{}) -> False
                    Just EventComment{} -> True
                    Just EventCDATA{} -> False
                    Nothing -> False
        if isWS then dropWS else return x

-- Inlined Instances

instance Functor (ConduitM i o m) where
    fmap f (ConduitM c) = ConduitM $ \rest -> c (rest . f)

instance Applicative (ConduitM i o m) where
    pure x = ConduitM ($ x)
    {-# INLINE pure #-}
    (<*>) = ap
    {-# INLINE (<*>) #-}

instance Monad (ConduitM i o m) where
    return = pure
    ConduitM f >>= g = ConduitM $ \h -> f $ \a -> unConduitM (g a) h

instance Monad m => Functor (Pipe l i o u m) where
    fmap = liftM
    {-# INLINE fmap #-}

instance Monad m => Applicative (Pipe l i o u m) where
    pure = Done
    {-# INLINE pure #-}
    (<*>) = ap
    {-# INLINE (<*>) #-}

instance Monad m => Monad (Pipe l i o u m) where
    return = pure
    {-# INLINE return #-}

    HaveOutput p c o >>= fp = HaveOutput (p >>= fp)            c          o
    NeedInput p c    >>= fp = NeedInput  (p >=> fp)            (c >=> fp)
    Done x           >>= fp = fp x
    PipeM mp         >>= fp = PipeM      ((>>= fp) `liftM` mp)
    Leftover p i     >>= fp = Leftover   (p >>= fp)            i

newtype ConduitM i o m r = ConduitM
    { unConduitM :: forall b.
                    (r -> Pipe i i o () m b) -> Pipe i i o () m b
    }

data Pipe l i o u m r =
    HaveOutput (Pipe l i o u m r) (m ()) o
  | NeedInput (i -> Pipe l i o u m r) (u -> Pipe l i o u m r)
  | Done r
  | PipeM (m (Pipe l i o u m r))
  | Leftover (Pipe l i o u m r) l


import System.Environment

-- This covers #11303, wherein the pattern checker would explode
-- when it encountered patterns sharing a prefix.

main :: IO ()
main = do
  args <- getArgs
  print $ case head args of
                      "--primop-primop-info"  -> "turtle"
                      "--primop-tag" -> "asdf"
                      "--primop-list"  -> "casdhf"
                      "--primop-vector-uniques"  -> "this"
                      "--primop-vector-tys"  -> "is"
                      "--primop-vector-tys-exports"  -> "silly"
                      "--primop-vector-tycons"  -> "hmmm"
                      "--primop-vector-turtles"  -> "hmmm"
                      "--primop-vector-plugs"  -> "hmmm"
                      "--primop-vector-caps"  -> "hmmm"
                      "--primop-vector-wires"  -> "hmmm"
                      "--primop-vector-tornado"  -> "hmmm"
                      "--primop-vector-tomato"  -> "hmmm"
                      "--primop-vector-maps"  -> "hmmm"
                      "--primop-vector-paper"  -> "hmmm"
                      "--make-haskell-wrappers" -> "123512"
                      "--make-haskell-source"  -> "as;dg"
                      "--make-latex-doc" -> "adghiw"
                      _ -> error "Should not happen, known_args out of sync?"


{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -Wincomplete-patterns -Woverlapping-patterns #-}

module T11303b where

data family Letter a

data instance Letter a = A | B | C | D | E | F | G | H | I | J

f :: [Letter a] -> Int
f = foldl go 0
  where
    go n letter = n + n'
      where
        n' = case letter of
                  A -> 0
                  B -> 1
                  C -> 2
                  D -> 3
                  E -> 4
                  F -> 5
                  G -> 6
                  H -> 7
                  I -> 8
                  J -> 9


{-# LANGUAGE Haskell2010 #-}
{-# OPTIONS_GHC -Woverlapping-patterns -Wincomplete-patterns #-}

module T11374 where

data Type   = TCon TCon [Type]
            | TUser String [Type] Type
            | TRec [(String,Type)]
            deriving (Show,Eq,Ord)

data TCon   = TC TC
            | TF TFun
            deriving (Show,Eq,Ord)

data TC     = TCNum Integer
            | TCInf
            | TCBit
            | TCSeq
            | TCFun
            | TCTuple Int
            deriving (Show,Eq,Ord)

data TFun   = TCAdd
            | TCSub
            | TCMul
            | TCDiv
            | TCMod
            | TCLg2
            | TCExp
            | TCWidth
            | TCMin
            | TCMax
            | TCLenFromThen
            | TCLenFromThenTo
            deriving (Show, Eq, Ord, Bounded, Enum)

simpFinTy :: Type -> Maybe [Type]
simpFinTy ty = case ty of
    TCon (TC (TCNum _)) _ -> Just []

    TCon (TF tf) [t1]
      | TCLg2    <- tf -> Just [t1]
      | TCWidth  <- tf -> Just [t1]

    TCon (TF tf) [t1,t2]
      | TCAdd <- tf -> Just [t1, t2]
      | TCSub <- tf -> Just [t1]
      | TCMul <- tf -> Just [t1, t2]
      | TCDiv <- tf -> Just [t1]
      | TCMod <- tf -> Just []
      | TCExp <- tf -> Just [t1, t2]
      | TCMin <- tf -> Nothing
      | TCMax <- tf -> Just [t1, t2]

    TCon (TF tf) [_,_,_]
      | TCLenFromThen   <- tf -> Just []
      | TCLenFromThenTo <- tf -> Just []

    _ -> Nothing


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

module T11984 where

data family Sing (a :: k)

data Schema = Sch [Bool]

data instance Sing (x :: Schema) where
  SSch :: Sing x -> Sing ('Sch x)

data instance Sing (x :: [k]) where
  SNil :: Sing '[]
  SCons :: Sing a -> Sing b -> Sing (a ': b)

data G a where
  GCons :: G ('Sch (a ': b))

eval :: G s -> Sing s -> ()
eval GCons s =
        case s of
          -- SSch SNil -> undefined
          SSch (SCons _ _) -> undefined


module T12957 where

data A = N | A { b :: Bool }
f = case [] of (_:_) -> case () of
                          a -> undefined


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

-- The original test case for Trac #12957

module T12957a where

data T = A | B

data Fields (t :: T) where
  BFields :: { list :: [()] } -> Fields 'B

  AFields :: Fields 'A

  EmptyFields :: Fields t

emptyA :: Fields 'A
emptyA = AFields

data S t = S { sFields :: Fields t }

f :: () -> S 'A
f a = (S EmptyFields) { sFields = emptyA { list = [ a ] } }


{-# language EmptyCase #-}
module T14086 where
import Data.Kind

f :: Type -> Int
f x = case x of


{-# Language GADTs #-}
module T14098 where

data App f a where
  App :: f a -> App f (Maybe a)

data Ty a where
  TBool :: Ty Bool
  TInt  :: Ty Int

data T f a where
  C :: T Ty (Maybe Bool)

f1 :: T f a -> App f a -> ()
f1 C (App TBool) = ()

f2 :: T f a -> App f a -> ()
f2 C (App x)
  | TBool <- x
  = ()

g :: T f a -> App f a -> ()
g C (App x) = case x of
                TBool -> ()


{-# LANGUAGE EmptyCase #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeInType #-}
{-# OPTIONS_GHC -Wall #-}
module T14813 where

import Data.Kind
import Data.Void

data SBool (z :: Bool) where
  SFalse :: SBool 'False
  STrue  :: SBool 'True

type family F (b :: Bool) (a :: Type) :: Type where
  F 'True  a = a
  F 'False _ = Void

dispatch :: forall (b :: Bool) (a :: Type). SBool b -> F b a -> a
dispatch STrue  x = x
dispatch SFalse x = case x of {}

type family G a
type instance G Int = Void

fun :: i ~ Int => G i -> a
fun x = case x of {}


{-# LANGUAGE EmptyCase #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
module T15305 where

import Data.Void

-- Example 1

data (:+:) f g a = Inl !(f a) | Inr !(g a)

data A
data B

data Foo l where
  Foo :: Foo A

data Bar l where
  Bar :: Bar B

type Sig = Foo :+: Bar

fun :: Sig B -> Int
fun (Inr Bar) = 1

-- Example 2

data GhcPass c
type family XXHsImplicitBndrs x
type instance XXHsImplicitBndrs (GhcPass _) = Void

data HsImplicitBndrs pass
  = UsefulConstructor
  | XHsImplicitBndrs !(XXHsImplicitBndrs pass)

fun2 :: HsImplicitBndrs (GhcPass pass) -> ()
fun2 UsefulConstructor = ()

fun2' :: (p ~ GhcPass pass) => HsImplicitBndrs p -> ()
fun2' UsefulConstructor = ()

-- Example 3

data Abyss = MkAbyss !Abyss

stareIntoTheAbyss :: Abyss -> a
stareIntoTheAbyss x = case x of {}
{-
Alas, this function is marked non-exhaustive, since the way GHC solves
NonVoid constraints at the moment isn't sophisticated enough to handle
recursive strict argument types like MkAbyss exhibits. Maybe some day.
-}


{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE TypeOperators #-}
{-# OPTIONS_GHC -Wincomplete-patterns #-}
module T15385 where

import Data.Type.Equality

data T a where
  TInt  :: T Int
  TBool :: T Bool

f1, f2 :: a :~: Int -> T a -> ()
f1 eq t
  | Refl <- eq
  = case t of
      TInt -> ()
f2 eq t
  = if |  Refl <- eq
       -> case t of
            TInt -> ()


{-# LANGUAGE EmptyCase #-}
{-# LANGUAGE GADTs #-}
module T15450 where

f :: (Int ~ Bool) => Bool -> a
f x = case x of {}

g :: (Int ~ Bool) => Bool -> a
g x = case x of True -> undefined


{-# LANGUAGE EmptyCase #-}
{-# OPTIONS -Wincomplete-patterns #-}
module T15584 where

import Data.Void

data V = MkV !Void
data    S1 = MkS1 !V
newtype S2 = MkS2 V

s1 :: S1 -> a
s1 x = case x of {}

s2 :: S2 -> a
s2 x = case x of {}


{-# OPTIONS_GHC -fwarn-incomplete-patterns -fwarn-overlapping-patterns #-}
{-# LANGUAGE GADTs #-}

module T2006 where

data Expr a vs where
    EPrim   :: String -> a -> Expr a vs
    EVar    :: Expr a (a,vs)

interpret :: Expr a () -> a
interpret (EPrim _ a) = a
-- interpret EVar = error "unreachable"


{-# OPTIONS_GHC -fwarn-incomplete-patterns -fwarn-overlapping-patterns #-}

module T2204 where

f :: String -> Int
f "01" = 0

g :: Int -> Int
g 0 = 0


{-# LANGUAGE PatternGuards #-}
{-# OPTIONS_GHC -fwarn-incomplete-patterns -fwarn-overlapping-patterns #-}

module T3078 where

data T = A Int | B Int

funny :: T -> Int
funny t = n
    where
      n | A x <- t = x
        | B x <- t = x


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

module T322 where

instance (Num a) => Num (Maybe a) where
  (Just a) + (Just b) = Just (a + b)
  _ + _ = Nothing

  (Just a) - (Just b) = Just (a - b)
  _ - _ = Nothing

  (Just a) * (Just b) = Just (a * b)
  _ * _ = Nothing

  negate (Just a) = Just (negate a)
  negate _ = Nothing

  abs (Just a) = Just (abs a)
  abs _ = Nothing

  signum (Just a) = Just (signum a)
  signum _ = Nothing

  fromInteger = Just . fromInteger

f :: Maybe Int -> Int
f 1       = 1
f Nothing = 2
f _       = 3


{-# OPTIONS_GHC -XGADTs -fwarn-incomplete-patterns -fwarn-overlapping-patterns #-}

module T366 where

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

exhaustive :: T Char -> Char
exhaustive C1 = ' '


{-# LANGUAGE GADTs #-}
{-# OPTIONS_GHC -fwarn-incomplete-patterns -fwarn-overlapping-patterns #-}

module T3927 where

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

-- f1 is exhaustive
f1 :: T a -> T a -> Bool
f1 T1 T1 = True
f1 T2 T2 = False


{-# OPTIONS_GHC -fwarn-incomplete-patterns -fwarn-overlapping-patterns #-}
{-# LANGUAGE GADTs, TypeFamilies #-}

module T3927a where

type family F a
type instance F a = ()

data Foo a where
  FooA :: Foo ()
  FooB :: Foo Int

f :: a -> Foo (F a) -> () -- F a can only be () so only FooA is accepted
f _ FooA = ()


{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE UndecidableSuperClasses #-}
{-# OPTIONS_GHC -fwarn-incomplete-patterns -fwarn-overlapping-patterns #-}

module T3927b where

import Data.Kind (Type, Constraint)
import Data.Proxy

data Message

data SocketType = Dealer | Push | Pull

data SocketOperation = Read | Write

type family Restrict (a :: SocketOperation) (as :: [SocketOperation]) :: Constraint where
    Restrict a (a ': as) = ()
    Restrict x (a ': as) = Restrict x as
    Restrict x '[] = ("Error!" ~ "Tried to apply a restricted type!")

type family Implements (t :: SocketType) :: [SocketOperation] where
    Implements Dealer = ['Read, Write]
    Implements Push = '[Write]
    Implements Pull = '[ 'Read]

data SockOp :: SocketType -> SocketOperation -> Type where
    SRead :: SockOp sock 'Read
    SWrite :: SockOp sock Write

data Socket :: SocketType -> Type where
    Socket :: proxy sock
           -> (forall op . Restrict op (Implements sock) => SockOp sock op -> Operation op)
           -> Socket sock

type family Operation (op :: SocketOperation) :: Type where
    Operation 'Read = IO Message
    Operation Write = Message -> IO ()

class Restrict 'Read (Implements t) => Readable t where
    readSocket :: Socket t -> Operation 'Read
    readSocket (Socket _ f) = f (SRead :: SockOp t 'Read)

instance Readable Dealer

type family Writable (t :: SocketType) :: Constraint where
    Writable Dealer = ()
    Writable Push = ()

dealer :: Socket Dealer
dealer = Socket (Proxy :: Proxy Dealer) f
  where
    f :: Restrict op (Implements Dealer) => SockOp Dealer op -> Operation op
    f SRead = undefined
    f SWrite = undefined

push :: Socket Push
push = Socket (Proxy :: Proxy Push) f
  where
    f :: Restrict op (Implements Push) => SockOp Push op -> Operation op
    f SWrite = undefined
-- Seeing that this pattern match is exhaustive
-- requires a reasonably vigorous effort on given
-- superclass expansion.

pull :: Socket Pull
pull = Socket (Proxy :: Proxy Pull) f
  where
    f :: Restrict op (Implements Pull) => SockOp Pull op -> Operation op
    f SRead = undefined

foo :: IO Message
foo = readSocket dealer


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

module T4139 where

data F a where
  FInt :: F Int
  FBool :: F Bool

class Baz a where
  baz :: F a -> G a
instance Baz Int where
  baz _ = GInt
instance Baz Bool where
  baz _ = GBool

data G a where
  GInt :: G Int
  GBool :: G Bool

bar :: Baz a => F a -> ()
bar a@(FInt) =
  case baz a of
    GInt -> ()
    -- GBool -> ()
bar _ = ()


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

module T6124 where

newtype A = MkA Int
newtype B = MkB Char

data T a where
    A :: T A
    B :: T B

f :: T A -> A
f A = undefined


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

module T7669 where

data Void

foo :: Void -> ()
foo x = case x of {}


{-# LANGUAGE DataKinds, KindSignatures, GADTs, TypeFamilies #-}
{-# OPTIONS_GHC -fwarn-incomplete-patterns -fwarn-overlapping-patterns #-}

module T8970 where

import Data.Kind (Type)

data K = Foo
       | Bar

data D1 :: K -> Type where
    F1 :: D1 Foo
    B1 :: D1 Bar

class C (a :: K -> Type) where
    data D2 a :: K -> Type
    foo :: a k -> D2 a k -> Bool

instance C D1 where
    data D2 D1 k where
              F2 :: D2 D1 Foo
              B2 :: D2 D1 Bar
    foo F1 F2 = True
    foo B1 B2 = True


{-# LANGUAGE OverloadedLists #-}
{-# OPTIONS_GHC -fwarn-incomplete-patterns -fwarn-overlapping-patterns #-}

module T9951 where

f :: [a] -> ()
f x = case x of
  [] -> ()
  (_:_) -> ()


{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -fwarn-incomplete-patterns -fwarn-overlapping-patterns #-}

module T9951b where

f :: String -> Bool
f "ab" = True


{-# LANGUAGE RankNTypes, KindSignatures #-}

module Foo where

import Data.Proxy

-- Should be illegal without PolyKinds
f :: forall k (a :: k). Proxy a
f = f


-- From the blog post Fun With XPolyKinds : Polykinded Folds
--   http://www.typesandotherdistractions.com/2012/02/fun-with-xpolykinds-polykinded-folds.html

{-
In the following, I will write a polykinded version of the combinators
fold and unfold, along with three examples: folds for regular
datatypes (specialized to kind Type), folds for nested datatypes
(specialized to kind Type -> Type), and folds for mutually recursive data
types (specialized to the product kind (Type, Type)). The approach should
generalise easily enough to things such as types indexed by another
kind (e.g. by specializing to kind Nat -> Type, using the XDataKinds
extension), or higher order nested datatypes (e.g. by specializing to
kind (Type -> Type) -> (Type -> Type)).

The following will compile in the new GHC 7.4.1 release. We require
the following GHC extensions:
-}

{-# LANGUAGE GADTs #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
module Main where

import Data.Kind (Type)

{- The basic fold and unfold combinators can be written as follows:

fold phi = phi . fmap (fold phi) . out
unfold psi = in . fmap (unfold psi) . psi

The idea now is to generalize these combinators by working over
different categories. We can capture the basic operations in a
category with a typeclass: -}

class Category hom where
  ident :: hom a a
  compose :: hom a b -> hom b c -> hom a c

{- A category has two operations: an identity morphism for every
object, and for every two compatible morphisms, the composition of
those morphisms.

In earlier versions of GHC, the type hom would have been specialized
to kind Type -> Type -> Type, but with the new PolyKinds extension, hom is
polykinded, and the Category typeclass can be instantiated to k -> k
-> Type for any kind k. This means that in addition to all of the
Category instances that we could have written before, we can now write
instances of Category for type constructors, type constructor
constructors, etc.

Here is the instance for the category Hask of Haskell types. Objects
are Haskell types and morphisms are functions between types. The
identity is the regular polymorphic identity function id, and
composition is given by the (flipped) composition operator (.) -}

instance Category (->) where
  ident = id
  compose = flip (.)

{- Another example is the category of type constructors and natural
transformations. A natural transformation is defined as follows: -}

newtype Nat f g = Nat { nu :: (forall a. f a -> g a) }

{- Here is the Category instance for natural transformations. This
time the type hom is inferred to have kind (Type -> Type) -> (Type -> Type) ->
Type. Identity and composition are both defined pointwise. -}

instance Category (Nat :: (Type -> Type) -> (Type -> Type) -> Type) where
  ident = Nat id
  compose f g = Nat (nu g . nu f)

{- Let's define a type class which will capture the idea of a fixed point
in a category. This generalizes the idea of recursive types in Hask: -}

class Rec hom f t where
  _in :: hom (f t) t
  out :: hom t (f t)

{- The class Rec defines two morphisms: _in, which is the constructor of
the fixed point type t, and out, its destructor.

The final piece is the definition of a higher order functor, which
generalizes the typeclass Functor: -}

class HFunctor hom f where
  hmap :: hom a b -> hom (f a) (f b)

{- Note the similarity with the type signature of the function fmap ::
(Functor f) => (a -> b) -> f a -> f b. Indeed, specializing hom to
(->) in the definition of HFunctor gives back the type signature of
fmap.

Finally, we can define folds and unfolds in a category. The
definitions are as before, but with explicit composition, constructors
and destructors replaced with the equivalent type class methods, and
hmap in place of fmap: -}

fold :: (Category hom, HFunctor hom f, Rec hom f rec) => hom (f t) t -> hom rec t
fold phi = compose out (compose (hmap (fold phi)) phi)

unfold :: (Category hom, HFunctor hom f, Rec hom f rec) => hom t (f t) -> hom t rec
unfold phi = compose phi (compose (hmap (unfold phi)) _in)

-- Now for some examples.

-- The first example is a regular recursive datatype of binary leaf
-- trees. The functor FTree is the base functor of this recursive type:

data FTree a b = FLeaf a | FBranch b b
data Tree a = Leaf a | Branch (Tree a) (Tree a)

-- An instance of Rec shows the relationship between the defining functor
-- and the recursive type itself:

instance Rec (->) (FTree a) (Tree a) where
  _in (FLeaf a) = Leaf a
  _in (FBranch a b) = Branch a b
  out (Leaf a) = FLeaf a
  out (Branch a b) = FBranch a b

-- FTree is indeed a functor, so it is also a HFunctor:

instance HFunctor (->) (FTree a) where
  hmap f (FLeaf a) = FLeaf a
  hmap f (FBranch a b) = FBranch (f a) (f b)

-- These instances are enough to define folds and unfolds for this
-- type. The following fold calculates the depth of a tree:

depth :: Tree a -> Int
depth = (fold :: (FTree a Int -> Int) -> Tree a -> Int) phi where
  phi :: FTree a Int -> Int
  phi (FLeaf a) = 1
  phi (FBranch a b) = 1 + max a b

-- The second example is a fold for the nested (or non-regular)
-- datatype of complete binary leaf trees. The higher order functor
-- FCTree defines the type constructor CTree as its fixed point:

data FCTree f a = FCLeaf a | FCBranch (f (a, a))
  -- FCTree :: (Type -> Type) -> Type -> Type

data CTree a = CLeaf a | CBranch (CTree (a, a))

-- Again, we define type class instances for HFunctor and Rec:

instance HFunctor Nat FCTree where
  hmap (f :: Nat (f :: Type -> Type) (g :: Type -> Type)) = Nat ff where
    ff :: forall a. FCTree f a -> FCTree g a
    ff (FCLeaf a) = FCLeaf a
    ff (FCBranch a) = FCBranch (nu f a)

instance Rec Nat FCTree CTree where
  _in = Nat inComplete where
    inComplete (FCLeaf a) = CLeaf a
    inComplete (FCBranch a) = CBranch a
  out = Nat outComplete where
    outComplete(CLeaf a) = FCLeaf a
    outComplete(CBranch a) = FCBranch a

-- Morphisms between type constructors are natural transformations, so we
-- need a type constructor to act as the target of the fold. For our
-- purposes, a constant functor will do:

data K a b = K a  -- K :: forall k. Type -> k -> Type

-- And finally, the following fold calculates the depth of a complete binary leaf tree:

cdepth :: CTree a -> Int
cdepth c = let (K d) = nu (fold (Nat phi)) c in d where
  phi :: FCTree (K Int) a -> K Int a
  phi (FCLeaf a) = K 1
  phi (FCBranch (K n)) = K (n + 1)

{- The final example is a fold for the pair of mutually recursive
datatype of lists of even and odd lengths. The fold will take a list
of even length and produce a list of pairs.

We cannot express type constructors in Haskell whose return kind is
anything other than Type, so we cheat a little and emulate the product
kind using an arrow kind Choice -> Type, where Choice is a two point
kind, lifted using the XDataKinds extension: -}

data Choice = Fst | Snd

-- A morphism of pairs of types is just a pair of morphisms. For
-- technical reasons, we represent this using a Church-style encoding,
-- along with helper methods, as follows:

newtype PHom h1 h2 p1 p2 = PHom { runPHom :: forall r. (h1 (p1 Fst) (p2 Fst) -> h2 (p1 Snd) (p2 Snd) -> r) -> r }

mkPHom f g = PHom (\h -> h f g)
fstPHom p = runPHom p (\f -> \g -> f)
sndPHom p = runPHom p (\f -> \g -> g)

-- Now, PHom allows us to take two categories and form the product category:

instance (Category h1, Category h2) => Category (PHom h1 h2) where
  ident = mkPHom ident ident
  compose p1 p2 = mkPHom (compose (fstPHom p1) (fstPHom p2)) (compose (sndPHom p1) (sndPHom p2))

-- We can define the types of lists of even and odd length as
-- follows. Note that the kind annotation indicates the appearance of the
-- kind Choice -> Type:

data FAlt :: Type -> (Choice -> Type) -> Choice -> Type where
  FZero :: FAlt a p Fst
  FSucc1 :: a -> (p Snd) -> FAlt a p Fst
  FSucc2 :: a -> (p Fst) -> FAlt a p Snd

data Alt :: Type -> Choice -> Type where
  Zero :: Alt a Fst
  Succ1 :: a -> Alt a Snd -> Alt a Fst
  Succ2 :: a -> Alt a Fst -> Alt a Snd

deriving instance Show a => Show (Alt a b)

-- Again, we need to define instances of Rec and HFunctor:

instance Rec (PHom (->) (->)) (FAlt a) (Alt a) where
  _in = mkPHom f g where
    f,g :: FAlt a (Alt a) s -> Alt a s
    f FZero = Zero
    f (FSucc1 a b) = Succ1 a b
    g (FSucc2 a b) = Succ2 a b

  out = mkPHom f g where
    f,g :: Alt a s -> FAlt a (Alt a) s
    f Zero = FZero
    f (Succ1 a b) = FSucc1 a b
    g (Succ2 a b) = FSucc2 a b

instance HFunctor (PHom (->) (->)) (FAlt a) where
  hmap p = mkPHom hf hg where
    hf FZero = FZero
    hf (FSucc1 a x) = FSucc1 a (sndPHom p x)
    hg (FSucc2 a x) = FSucc2 a (fstPHom p x)

-- As before, we create a target type for our fold, and this time a type synonym as well:

data K2 :: Type -> Type -> Choice -> Type where
  K21 :: a -> K2 a b Fst
  K22 :: b -> K2 a b Snd

type PairUpResult a = K2 [(a, a)] (a, [(a, a)])

-- At last, here is the fold pairUp, taking even length lists to lists of pairs:

pairUp :: Alt a Fst -> [(a, a)]
pairUp xs = let (K21 xss) = (fstPHom (fold (mkPHom phi psi))) xs in xss
 where
   phi :: FAlt y (K2 v (r,[(y,r)])) s -> K2 [(y,r)] (y,z) s
   phi FZero                       = K21 []
   phi (FSucc1 x1 (K22 (x2, xss))) = K21 ((x1, x2):xss)

   psi :: FAlt y (K2 z w) s -> K2 [x] (y,z) s
   psi (FSucc2 x (K21 xss)) = K22 (x, xss)

main = print (Succ1 (0::Int) $ Succ2 1 $ Succ1 2 $ Succ2 3 $ Succ1 4 $ Succ2 5 Zero)


module KindVType where

-- test printing of "type" in output, not "kind"

import Data.Proxy

foo :: Proxy Maybe
foo = (Proxy :: Proxy Int)


-- From a blog post: http://www.jonmsterling.com/posts/2012-01-12-unifying-monoids-and-monads-with-polymorphic-kinds.html

-------------------- FUNCTIONAL DEPENDENCY VERSION ----------------

{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances, FlexibleContexts #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE UnicodeSyntax #-}

module Main where
import Control.Monad (Monad(..), join, ap)
import Data.Monoid (Monoid(..))
import Data.Semigroup (Semigroup(..))

-- First we define the type class Monoidy:

class Monoidy to comp id m | m to â†’ comp id where
  munit :: id `to` m
  mjoin :: (m `comp` m) `to` m

-- We use functional dependencies to help the typechecker understand that
-- m and ~> uniquely determine comp (times) and id.
--
-- This kind of type class would not have been possible in previous
-- versions of GHC; with the new kind system, however, we can abstract
-- over kinds!2 Now, letâ€™s create types for the additive and
-- multiplicative monoids over the natural numbers:

newtype Sum a = Sum a deriving Show
newtype Product a = Product a deriving Show
instance Num a â‡’ Monoidy (â†’) (,) () (Sum a) where
  munit _ = Sum 0
  mjoin (Sum x, Sum y) = Sum $ x + y
instance Num a â‡’ Monoidy (â†’) (,) () (Product a) where
  munit _ = Product 1
  mjoin (Product x, Product y) = Product $ x * y

-- It will be slightly more complicated to make a monadic instance with
-- Monoidy. First, we need to define the identity functor, a type for
-- natural transformations, and a type for functor composition:

data Id Î± = Id { runId :: Î± } deriving Functor

-- A natural transformation (Î›â€†f g Î±.â€†(f Î±)â€„â†’â€„(g Î±)) may be encoded in Haskell as follows:

data NT f g = NT { runNT :: âˆ€ Î±. f Î± â†’ g Î± }

-- Functor composition (Î›â€†f g Î±.â€†f (g Î±)) is encoded as follows:

data FC f g Î± = FC { runFC :: f (g Î±) }

-- Now, let us define some type T which should be a monad:

data Wrapper a = Wrapper { runWrapper :: a } deriving (Show, Functor)
instance Monoidy NT FC Id Wrapper where
  munit = NT $ Wrapper . runId
  mjoin = NT $ runWrapper . runFC

-- With these defined, we can use them as follows:

test1 = do { print (mjoin (munit (), Sum 2))
                 -- Sum 2
           ; print (mjoin (Product 2, Product 3))
                 -- Product 6
           ; print (runNT mjoin $ FC $ Wrapper (Wrapper "hello, world"))
                 -- Wrapper {runWrapper = "hello, world" }
           }

-- We can even provide a special binary operator for the appropriate monoids as follows:

(<+>) :: Monoidy (â†’) (,) () m â‡’ m â†’ m â†’ m
(<+>) = curry mjoin

test2 = print (Sum 1 <+> Sum 2 <+> Sum 4)  -- Sum 7

-- Now, all the extra wrapping that Haskell requires for encoding this is
-- rather cumbersome in actual use. So, we can give traditional Monad and
-- Monoid instances for instances of Monoidy:

instance Monoidy (â†’) (,) () m â‡’ Semigroup m where
  (<>) = curry mjoin

instance Monoidy (â†’) (,) () m â‡’ Monoid m where
  mempty = munit ()

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

-- instance (Functor m, Monoidy NT FC Id m) â‡’ Monad m where
instance Monad Wrapper where
   return x = runNT munit $ Id x
   x >>= f = runNT mjoin $ FC (f `fmap` x)

-- And so the following works:

test3
 = do { print (mappend mempty (Sum 2))
             -- Sum 2
      ; print (mappend (Product 2) (Product 3))
             -- Product 6
      ; print (join $ Wrapper $ Wrapper "hello")
             -- Wrapper {runWrapper = "hello" }
      ; print (Wrapper "hello, world" >>= return)
             -- Wrapper {runWrapper = "hello, world" }
      }

main = test1 >> test2 >> test3