{-# LANGUAGE GADTs #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ViewPatterns #-}
module T13750a where

import Data.Kind (Type)
import Unsafe.Coerce

type family AnyT :: Type where {}
type family AnyList :: [Type] where {}

newtype NP (xs :: [Type]) = NP [AnyT]

data IsNP (xs :: [Type]) where
  IsNil  :: IsNP '[]
  IsCons :: x -> NP xs -> IsNP (x ': xs)

isNP :: NP xs -> IsNP xs
isNP (NP xs) =
  if null xs
    then unsafeCoerce IsNil
    else unsafeCoerce (IsCons (head xs) (NP (tail xs)))

pattern Nil :: () => (xs ~ '[]) => NP xs
pattern Nil <- (isNP -> IsNil)
  where
    Nil = NP []

pattern (:*) :: () => (xs' ~ (x ': xs)) => x -> NP xs -> NP xs'
pattern x :* xs <- (isNP -> IsCons x xs)
  where
    x :* NP xs = NP (unsafeCoerce x : xs)
infixr 5 :*

data NS (xs :: [[Type]]) = NS !Int (NP AnyList)

data IsNS (xs :: [[Type]]) where
  IsZ :: NP x -> IsNS (x ': xs)
  IsS :: NS xs -> IsNS (x ': xs)

isNS :: NS xs -> IsNS xs
isNS (NS i x)
  | i == 0    = unsafeCoerce (IsZ (unsafeCoerce x))
  | otherwise = unsafeCoerce (IsS (NS (i - 1) x))

pattern Z :: () => (xs' ~ (x ': xs)) => NP x -> NS xs'
pattern Z x <- (isNS -> IsZ x)
  where
    Z x = NS 0 (unsafeCoerce x)

pattern S :: () => (xs' ~ (x ': xs)) => NS xs -> NS xs'
pattern S p <- (isNS -> IsS p)


import System.Exit
import Control.Monad.Trans.State.Strict

eval :: Int -> State Int a -> a
eval p = fst . flip runState p

advance :: Int -> State Int ()
advance = modify' . (+)

loc :: State Int Int
loc = get

emit1 :: State Int ()
emit1 = advance 1

emitN :: Int -> State Int ()
-- adding in the 0 case, breaks with HEAD. 8.2.1 is fine with it.
-- emitN 0 = advance 0
emitN 0 = pure ()
emitN n = advance n

align8 :: State Int ()
align8 = do
  bits <- (`mod` 8) <$> loc
  emitN (8 - bits)

main :: IO ()
main = do
  let p = eval 0 (emit1 >> align8 >> loc)
  putStrLn $ show p
  if p == 8
    then putStrLn "OK" >> exitSuccess
    else putStrLn "FAIL" >> exitFailure


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

module Main where

import Control.Monad (forM_, liftM)
import qualified Data.Vector.Generic         as G
import qualified Data.Vector.Generic.Mutable as M
import qualified Data.Vector.Primitive as P
import qualified Data.Vector.Unboxed         as U
import qualified Data.Vector.Unboxed.Mutable as MU
import GHC.Exts

vec :: U.Vector Moebius
vec = U.singleton Moebius0

main :: IO ()
main = print $ U.head vec == U.head vec

data Moebius = Moebius0 | Moebius1 | Moebius2
  deriving (Eq)

fromMoebius :: Moebius -> Int
fromMoebius Moebius0 = 0
fromMoebius Moebius1 = 1
fromMoebius Moebius2 = 2

toMoebius :: Int -> Moebius
toMoebius (I# i#) = tagToEnum# i#

newtype instance U.MVector s Moebius = MV_Moebius (P.MVector s Int)
newtype instance U.Vector    Moebius = V_Moebius  (P.Vector    Int)

instance U.Unbox Moebius

instance M.MVector U.MVector Moebius where
  basicLength (MV_Moebius v) = M.basicLength v
  basicUnsafeSlice i n (MV_Moebius v) = MV_Moebius $ M.basicUnsafeSlice i n v
  basicOverlaps (MV_Moebius v1) (MV_Moebius v2) = M.basicOverlaps v1 v2
  basicUnsafeNew n = MV_Moebius `liftM` M.basicUnsafeNew n
  basicInitialize (MV_Moebius v) = M.basicInitialize v
  basicUnsafeReplicate n x = MV_Moebius `liftM` M.basicUnsafeReplicate n (fromMoebius x)
  basicUnsafeRead (MV_Moebius v) i = toMoebius `liftM` M.basicUnsafeRead v i
  basicUnsafeWrite (MV_Moebius v) i x = M.basicUnsafeWrite v i (fromMoebius x)
  basicClear (MV_Moebius v) = M.basicClear v
  basicSet (MV_Moebius v) x = M.basicSet v (fromMoebius x)
  basicUnsafeCopy (MV_Moebius v1) (MV_Moebius v2) = M.basicUnsafeCopy v1 v2
  basicUnsafeMove (MV_Moebius v1) (MV_Moebius v2) = M.basicUnsafeMove v1 v2
  basicUnsafeGrow (MV_Moebius v) n = MV_Moebius `liftM` M.basicUnsafeGrow v n

instance G.Vector U.Vector Moebius where
  basicUnsafeFreeze (MV_Moebius v) = V_Moebius `liftM` G.basicUnsafeFreeze v
  basicUnsafeThaw (V_Moebius v) = MV_Moebius `liftM` G.basicUnsafeThaw v
  basicLength (V_Moebius v) = G.basicLength v
  basicUnsafeSlice i n (V_Moebius v) = V_Moebius $ G.basicUnsafeSlice i n v
  basicUnsafeIndexM (V_Moebius v) i = toMoebius `liftM` G.basicUnsafeIndexM v i
  basicUnsafeCopy (MV_Moebius mv) (V_Moebius v) = G.basicUnsafeCopy mv v
  elemseq _ = seq


{-# OPTIONS -O -g #-}
main = print (4, "foo")


{-# OPTIONS_GHC -g1 -O #-}
import System.Environment
summap :: (Int -> Int) -> (Int -> Int)
summap f n = f 10
{-# NOINLINE summap #-}

main = do
  n <- length `fmap` getArgs
  print $ summap (+ n) n


module Main (main) where

import T14965_Sep

main :: IO ()
main = print $ cc bb

bb :: Sep
bb = catSep b1 b2

b1 :: Sep
b1 = Sep [] ["foo"] []

b2 :: Sep
b2 = Sep [] ["bar"] []


module T14965_Sep where

data Sep = Sep
  { bugVanishesWithoutThis :: [()]
  , middle :: [String]
  , orThis :: [()]
  }

catSep :: Sep -> Sep -> Sep
catSep (Sep a b c) (Sep x y z) = Sep (a ++ x) (b ++ y) (c ++ z)

cc :: Sep -> Bool
cc boost = elem "foo" $ middle boost


{-# OPTIONS_GHC -O #-}
-- Bug only showed up with optimisation on

module Main where

import qualified Control.Exception as Exception

main :: IO ()
main = do
    unserialize
    putStrLn "all is well"

unserialize :: IO Char
unserialize =
    if definitelyTrue
        then do
            return 'a'
        else do
            Exception.evaluate (error "wrong place")

{-# NOINLINE definitelyTrue #-}
definitelyTrue :: Bool
definitelyTrue = True


module Main where

import GHC.Enum

data XXX = AL | AK | AZ | AR | CA | CO | CT | DE | FL
    deriving (Enum, Bounded, Show)

data Z = Y | X XXX deriving( Show )

instance Enum Z where
  fromEnum Y     = 0
  fromEnum (X s) = 1 + fromEnum s
  toEnum 0   = Y
  toEnum i   = X (toEnum (i - 1))

instance Bounded Z where
  minBound = Y
  maxBound = X maxBound

main = print [ succ (x :: Z) | x <- [minBound .. pred maxBound] ]


module Main (main) where

data T = MkT !Bool

f :: T -> Bool
f _ = False
{-# NOINLINE f #-}

{-# RULES "non-det" [1] forall x. f (MkT x) = x #-}

main :: IO ()
main = print (f (MkT True))
-- Prints `True` if the rule fires, or `False` is the wrapper for `MkT` inlines
-- in phase 2, preventing the rule from being triggered in phase 1.


module Main (main) where

data T = MkT !Bool

f :: Bool -> IO ()
f _ = putStrLn "The rule triggered before case-of-known-constructor could take effect (bad!)"
{-# NOINLINE f #-}

g :: IO ()
g = putStrLn "Case-of-known-constructor triggered (good!)"

{-# RULES "non-det" [~0] f True = g #-}

main :: IO ()
main =
  case MkT True of
    MkT x -> f x
-- What we want to see is case-of-known-constructor triggering before phase 0
-- (when the wrapper for MkT is allowed to be inlined). If it is, then the rule
-- will see `f True` and trigger, and `g` will be run. If it isn't then `f True`
-- will only appear at phase 0, when the rule cannot trigger, hence `f` will be
-- run.


{-# LANGUAGE GADTs, ExplicitForAll #-}
module Main (main) where

import GHC.Exts

newtype Age a b where
  Age :: forall b a. Int -> Age a b

data T a = MkT a

{-# NOINLINE foo #-}
foo :: (Int -> Age Bool Char) -> String
foo _ = "bad (RULE should have fired)"

{-# RULES "foo/coerce" [1] foo coerce = "good" #-}

main = putStrLn (foo Age)


{-# LANGUAGE MagicHash #-}

import GHC.Exts
import Unsafe.Coerce

newtype Age = Age Int

foo :: [Int] -> [Int]
foo = map id
fooAge :: [Int] -> [Age]
fooAge = map Age
fooCoerce :: [Int] -> [Age]
fooCoerce = map coerce
fooUnsafeCoerce :: [Int] -> [Age]
fooUnsafeCoerce = map unsafeCoerce

same :: a -> b -> IO ()
same x y = case reallyUnsafePtrEquality# (unsafeCoerce x) y of
    1# -> putStrLn "yes"
    _  -> putStrLn "no"

main = do
    let l = [1,2,3]
    same (foo l) l
    same (fooAge l) l
    same (fooCoerce l) l
    same (fooUnsafeCoerce l) l


{-# OPTIONS_GHC -O -ddump-rules #-}

-- Trac #2486
--
-- The thing to look for here is that specialisations for fib and tak
-- at both Int and Double are indeed generated; hence -ddump-rules

module Main where

import System.Environment
import Numeric

main = do
    n <- getArgs >>= readIO . head
    let m  = n-1
        a  = 27 + fromIntegral n
    putStr $
       line "Ack" [3,n]       (ack 3 n)                     show ++
       line "Fib" [a]         (fib a             :: Double) (\n -> showFFloat (Just 1) n []) ++
       line "Tak" [3*m,2*m,m] (tak (3*m) (2*m) m :: Int)    show ++
       line "Fib" [3]         (fib 3             :: Int)    show ++
       line "Tak" [3,2,1]     (tak 3 2 1         :: Double) show
    where
       line pre a r f = pre ++ "(" ++ csv f a "" ++ "): " ++ f r ++ "\n"
       csv f [a]   s  = s ++ f a
       csv f (a:b) s  = s ++ f a ++ "," ++ csv f b s

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))

fib :: (Num a, Ord a) => a -> a
fib     n = if n >= 2 then fib  (n-1) + fib  (n-2) else 1

tak :: (Num a, Ord a) => a -> a -> a -> a
tak x y z = if y < x then tak (tak (x-1) y z) (tak (y-1) z x) (tak (z-1) x y) else z


module Main where

data X = X ()

{-# NOINLINE newX #-}
newX :: () -> IO X
newX n = do
    let {-# NOINLINE value #-}
        value = n
    return (X value)

main = do
    x <- newX (error "Why?")
    case x of
        X _ -> return ()


{-# LANGUAGE BangPatterns #-}

-- See Trac #3403: interaction of pattern match failure and CPR
-- The point is that this should run in constant space, with no
-- stack growth.  In GHC 6.10 the tail call optimisation didn't work.

module Main (main) where

import qualified Data.Set as Set
import Data.Set (Set)

data Result = Result !S1 !S2

type S1 = Set ()
type S2 = Set ()

input :: [[(Int, ())]]
input = replicate 1000 (replicate 400 (100, ()))

main :: IO ()
main = do let Result s1 s2 = doAll Set.empty Set.empty () input
          print $ Set.size s1
          print $ Set.size s2

doAll :: S1 -> S2 -> () -> [[(Int, ())]] -> Result
doAll !s1 !s2 !_    [] = Result s1 s2
doAll !s1 !s2 !unit ([] : xs) = doAll s1 s2 unit xs
doAll !s1 !s2 !unit (((t, _) : x1) : x2 : xs)
 | t >= 99999 = doAll s1 s2 unit (x1 : x2 : xs)
doAll !s1 !s2 !unit (((_, ()) : x) : xs)
    = doAll s1 s2 unit (x : xs)


{-# LANGUAGE BangPatterns #-}
{-# OPTIONS_GHC -O2 #-}

-- Trac #3437
-- When we do SpecConstr on 'go', we want the specialised
-- function to *still* be strict in k.  Otherwise we get
-- a bad space leak!

-- The test is run with +RTS -M10m to limit the amount of heap
-- It should run in constant space, but if the function isn't
-- strict enough it'll run out of heap

module Main where

go :: [Int] -> [Int] -> [Int]
go (0:xs) !k = k
go (n:xs) !k = go (n-1 : xs) (k ++ k)

main = print (go [100000000] [])


{-
    Copyright 2009 Mario Blazevic

    This file is part of the Streaming Component Combinators (SCC) project.

    The SCC project is free software: you can redistribute it and/or
    modify it under the terms of the GNU General Public License as
    published by the Free Software Foundation, either version 3 of the
    License, or (at your option) any later version.

    SCC is distributed in the hope that it will be useful, but WITHOUT
    ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
    or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public
    License for more details.

    You should have received a copy of the GNU General Public License
    along with SCC.  If not, see <http://www.gnu.org/licenses/>.
-}

-- | Module "Trampoline" defines the pipe computations and their basic building blocks.

{-# LANGUAGE ScopedTypeVariables, Rank2Types, MultiParamTypeClasses,
             TypeFamilies, KindSignatures, FlexibleContexts, NoMonadFailDesugaring,
             FlexibleInstances, OverlappingInstances, UndecidableInstances
 #-}

{-   Somewhere we get:

  Wanted: AncestorFunctor (EitherFunctor a (TryYield a)) d
  This should not reduce because of overlapping instances

  If it (erroneously) does reduce, via dfun2 we get
  Wanted: Functor (EitherFunctor a (TryYield a)
          Functor d'
          Functor d
          d ~ EitherFunctor d' s
          AncestorFunctor (EitherFunctor a (TryYield a) d'

  And that gives an infinite loop in the type checker!
-}

module Main where

import Data.Kind (Type)
import Control.Monad (liftM, liftM2, when, ap)
import Control.Monad.Fail (MonadFail(fail))
-- import Control.Monad.Identity

import Debug.Trace (trace)

-------------
class (Functor a, Functor d) => AncestorFunctor a d where
   liftFunctor :: a x -> d x

-- dfun 1
instance Functor a => AncestorFunctor a a where
   liftFunctor = trace "liftFunctor id" . id

-- dfun 2
instance ( Functor a
         , Functor d'
         , Functor d
         , d ~ EitherFunctor d' s
         , AncestorFunctor a d')
      => AncestorFunctor a d where
   liftFunctor = LeftF . (trace "liftFunctor other" . liftFunctor :: a x -> d' x)

-------------
newtype Identity a = Identity { runIdentity :: a }

instance Functor Identity where
    fmap = liftM

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

instance Monad Identity where
    return a = Identity a
    m >>= k  = k (runIdentity m)

newtype Trampoline m s r = Trampoline {bounce :: m (TrampolineState m s r)}
data TrampolineState m s r = Done r | Suspend! (s (Trampoline m s r))

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

instance (Monad m, Functor s) => Applicative (Trampoline m s) where
  pure  = return
  (<*>) = ap

instance (Monad m, Functor s) => Monad (Trampoline m s) where
   return x = Trampoline (return (Done x))
   t >>= f = Trampoline (bounce t >>= apply f)
      where apply f (Done x) = bounce (f x)
            apply f (Suspend s) = return (Suspend (fmap (>>= f) s))

instance (Monad m, Functor s) => MonadFail (Trampoline m s) where
  fail = error

data Yield x y = Yield! x y
instance Functor (Yield x) where
   fmap f (Yield x y) = trace "fmap yield" $ Yield x (f y)

data Await x y = Await! (x -> y)
instance Functor (Await x) where
   fmap f (Await g) = trace "fmap await" $ Await (f . g)

data EitherFunctor l r x = LeftF (l x) | RightF (r x)
instance (Functor l, Functor r) => Functor (EitherFunctor l r) where
   fmap f v = trace "fmap Either" $
              case v of
                LeftF l  -> trace "fmap LeftF" $ LeftF (fmap f l)
                RightF r -> trace "fmap RightF" $ RightF (fmap f r)

type TryYield x = EitherFunctor (Yield x) (Await Bool)

suspend :: (Monad m, Functor s) => s (Trampoline m s x) -> Trampoline m s x
suspend s = Trampoline (return (Suspend s))

yield :: forall m x. Monad m => x -> Trampoline m (Yield x) ()
yield x = suspend (Yield x (return ()))

await :: forall m x. Monad m => Trampoline m (Await x) x
await = suspend (Await return)

tryYield :: forall m x. Monad m => x -> Trampoline m (TryYield x) Bool
tryYield x = suspend (LeftF (Yield x (suspend (RightF (Await return)))))

canYield :: forall m x. Monad m => Trampoline m (TryYield x) Bool
canYield = suspend (RightF (Await return))

liftBounce :: Monad m => m x -> Trampoline m s x
liftBounce = Trampoline . liftM Done

fromTrampoline :: Monad m => Trampoline m s x -> m x
fromTrampoline t = bounce t >>= \(Done x)-> return x

runTrampoline :: Monad m => Trampoline m Maybe x -> m x
runTrampoline = fromTrampoline

coupleNestedFinite :: (Functor s, Monad m) =>
                      Trampoline m (EitherFunctor s (TryYield a)) x
                   -> Trampoline m (EitherFunctor s (Await (Maybe a))) y -> Trampoline m s (x, y)
coupleNestedFinite t1 t2 =
   trace "bounce start" $
   liftBounce (liftM2 (,) (bounce t1) (bounce t2))
   >>= \(s1, s2)-> trace "bounce end" $
                   case (s1, s2)
                   of (Done x, Done y) -> return (x, y)
                      (Done x, Suspend (RightF (Await c2))) -> coupleNestedFinite (return x) (c2 Nothing)
                      (Suspend (RightF (LeftF (Yield _ c1))), Done y) -> coupleNestedFinite c1 (return y)
                      (Suspend (RightF (LeftF (Yield x c1))), Suspend (RightF (Await c2))) -> coupleNestedFinite c1 (c2 $ Just x)
                      (Suspend (RightF (RightF (Await c1))), Suspend s2@(RightF Await{})) -> coupleNestedFinite (c1 True) (suspend s2)
                      (Suspend (RightF (RightF (Await c1))), Done y) -> coupleNestedFinite (c1 False) (return y)
                      (Suspend (LeftF s), Done y) -> suspend (fmap (flip coupleNestedFinite (return y)) s)
                      (Done x, Suspend (LeftF s)) -> suspend (fmap (coupleNestedFinite (return x)) s)
                      (Suspend (LeftF s1), Suspend (LeftF s2)) -> suspend (fmap (coupleNestedFinite $ suspend $ LeftF s1) s2)
                      (Suspend (LeftF s1), Suspend (RightF s2)) -> suspend (fmap (flip coupleNestedFinite (suspend $ RightF s2)) s1)
                      (Suspend (RightF s1), Suspend (LeftF s2)) -> suspend (fmap (coupleNestedFinite (suspend $ RightF s1)) s2)

local :: forall m l r x. (Monad m, Functor r) => Trampoline m r x -> Trampoline m (EitherFunctor l r) x
local (Trampoline mr) = Trampoline (liftM inject mr)
   where inject :: TrampolineState m r x -> TrampolineState m (EitherFunctor l r) x
         inject (Done x) = Done x
         inject (Suspend r) = Suspend (RightF $ fmap local r)

out :: forall m l r x. (Monad m, Functor l) => Trampoline m l x -> Trampoline m (EitherFunctor l r) x
out (Trampoline ml) = Trampoline (liftM inject ml)
   where inject :: TrampolineState m l x -> TrampolineState m (EitherFunctor l r) x
         inject (Done x) = Done x
         inject (Suspend l) = Suspend (LeftF $ fmap out l)

liftOut :: forall m a d x. (Monad m, Functor a, AncestorFunctor a d) => Trampoline m a x -> Trampoline m d x
liftOut (Trampoline ma) = trace "liftOut" $ Trampoline (liftM inject ma)
   where inject :: TrampolineState m a x -> TrampolineState m d x
         inject (Done x) = Done x
         inject (Suspend a) = trace "inject suspend" $ Suspend (liftFunctor $ trace "calling fmap" $
                              fmap liftOut (trace "poking a" a))

data Sink (m :: Type -> Type) a x =
   Sink   {put :: forall d. (AncestorFunctor (EitherFunctor a (TryYield x)) d) => x -> Trampoline m d Bool,
           canPut :: forall d. (AncestorFunctor (EitherFunctor a (TryYield x)) d) => Trampoline m d Bool}
newtype Source (m :: Type -> Type) a x =
   Source {get :: forall d. (AncestorFunctor (EitherFunctor a (Await (Maybe x))) d) => Trampoline m d (Maybe x)}

pipe :: forall m a x r1 r2. (Monad m, Functor a) =>
        (Sink m a x -> Trampoline m (EitherFunctor a (TryYield x)) r1)
     -> (Source m a x -> Trampoline m (EitherFunctor a (Await (Maybe x))) r2) -> Trampoline m a (r1, r2)
pipe producer consumer = coupleNestedFinite (producer sink) (consumer source) where
   sink = Sink {put= liftOut . (local . tryYield :: x -> Trampoline m (EitherFunctor a (TryYield x)) Bool),
                canPut= liftOut (local canYield :: Trampoline m (EitherFunctor a (TryYield x)) Bool)} :: Sink m a x
   source = Source (liftOut (local await :: Trampoline m (EitherFunctor a (Await (Maybe x))) (Maybe x))) :: Source m a x

pipeProducer sink = do put sink 1
                       (c, d) <- pipe
                                    (\sink'-> do put sink' 2
                                                 put sink 3
                                                 put sink' 4
                                                 return 5)
                                    (\source'-> do Just n <- get source'
                                                   put sink n
                                                   put sink 6
                                                   return n)
                       put sink c
                       put sink d
                       return (c, d)

testPipe = print $
           runIdentity $
           runTrampoline $
           do (a, b) <- pipe
                           pipeProducer
                           (\source-> do Just n1 <- get source
                                         Just n2 <- get source
                                         Just n3 <- get source
                                         return (n1, n2, n3))
              return (a, b)

main = testPipe


{-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable #-}
module Main(main,f) where

import Data.List (isPrefixOf)
import Data.Dynamic
import Control.Exception as E

data Failure = Failure
    deriving (Show, Typeable)

instance Exception Failure

test = (E.throw Failure >> return ())
          `E.catch`
       (\(x::Failure) -> return ())

main :: IO ()
main = print =<< test

f :: Bool -> Bool -> Bool
f True = error "urk"
-- f False = \y -> y

{-
Uderlying cause: we call
          catch# thing handler
and expect that (thing state-token) will
    - either diverge/throw an exception
    - or return (# x,y #)
But it does neither: it returns a PAP, because
    thing = \p q. blah

In particular, 'thing = lvl_sxo' is
  lvl_sxc :: IO Any
  lvl_sxc = error "urk"

  lvl_sxo :: IO ()
    = lvl_sxc >> return ()

          -- inline (>>) --

    = (\(eta::S#). case lvl_sxc |> g1 eta of ...) |> g2
    where
      g1 :: IO Any ~ S# -> (# S#, Any #)
      g2 :: S# -> (# S#, () #) -> IO ()

          -- case-of-bottomming function --

    = (\ (eta::S#). lvl_sxc |> g1 |> ug3) |> g2
    where
      ug3(unsafe) :: S# -> (S#, Any) ~ (# S#, () #)

This is all fine.  But it's crucial that lvl_sxc actually diverges.
Do not eta-expand it to

   lvl_sxc :: IO Any
   lvl_sxc = \eta. error "urk" |> ug4
       where
         ug4(unsafe) :: S# -> (# S#, Any #) ~ IO Any

In contrast, if we had
   case x of
     True  -> \a -> 3
     False -> error "urk"
we can, and must, eta-expand the error

-}


module Main (main) where

import T3972A (Expr(E10), Token, spanning, getSpan)

import Control.Monad
import System.Exit
import System.IO

main :: IO ()
main = do h <- openFile "T3972.o" ReadMode
          s <- hFileSize h
          hClose h
          -- size is just under 8k on amd64/Linux in 6.13, but was
          -- around 3.5M in 6.12. Let's try >20k as the test for
          -- having regressed.
          when (s > 20000) $ do
              hPutStrLn stderr ("T3972.o is too big! " ++ show s)
              exitFailure

makeTupleOrExpr :: [Expr] -> Maybe Token -> Expr
makeTupleOrExpr [e] Nothing = e
makeTupleOrExpr es@(_:_) (Just t) = E10 (spanning es t)
makeTupleOrExpr es@(_:_) Nothing  = E10 (getSpan es)


module T3972A (Expr(..), Token(..), spanning, getSpan) where

class Span a where
   getSpan :: a -> SrcSpan

spanning :: (Span a, Span b) => a -> b -> SrcSpan
spanning x y = combineSrcSpans (getSpan x) (getSpan y)

instance Span a => Span [a] where
   getSpan [] = error "[]"
   getSpan [x] = getSpan x
   getSpan list@(x:_) = combineSrcSpans (getSpan x) (getSpan (last list))

data SrcSpan

  = SpanMultiLine
    { span_start_row    :: !Int
    , span_start_column :: !Int
    , span_end_row      :: !Int
    , span_end_column   :: !Int
    }

combineSrcSpans :: SrcSpan -> SrcSpan -> SrcSpan
combineSrcSpans start end
 = case row1 `compare` row2 of
     LT -> SpanMultiLine row1 col1 row2 col2
     _  -> SpanMultiLine row2 col2 row1 col1
  where
  row1 = startRow start
  col1 = startCol start
  row2 = endRow end
  col2 = endCol end

startRow :: SrcSpan -> Int
startRow (SpanMultiLine { span_start_row = row }) = row

endRow :: SrcSpan -> Int
endRow (SpanMultiLine { span_end_row = row }) = row

startCol :: SrcSpan -> Int
startCol (SpanMultiLine { span_start_column = col }) = col

endCol :: SrcSpan -> Int
endCol (SpanMultiLine { span_end_column = col }) = col

data Token
   = T10 { token_SrcSpan :: SrcSpan }
   | T11 { token_SrcSpan :: SrcSpan }
   | T12 { token_SrcSpan :: SrcSpan }
   | T13 { token_SrcSpan :: SrcSpan }
   | T14 { token_SrcSpan :: SrcSpan }
   | T15 { token_SrcSpan :: SrcSpan }
   | T16 { token_SrcSpan :: SrcSpan }
   | T17 { token_SrcSpan :: SrcSpan }
   | T18 { token_SrcSpan :: SrcSpan }
   | T19 { token_SrcSpan :: SrcSpan }
   | T20 { token_SrcSpan :: SrcSpan }
   | T21 { token_SrcSpan :: SrcSpan }
   | T22 { token_SrcSpan :: SrcSpan }
   | T23 { token_SrcSpan :: SrcSpan }
   | T24 { token_SrcSpan :: SrcSpan }

instance Span Token where
  getSpan = token_SrcSpan

data Expr
   = E10 { expr_SrcSpan :: SrcSpan }
   | E11 { expr_SrcSpan :: SrcSpan }
   | E12 { expr_SrcSpan :: SrcSpan }
   | E13 { expr_SrcSpan :: SrcSpan }
   | E14 { expr_SrcSpan :: SrcSpan }
   | E15 { expr_SrcSpan :: SrcSpan }
   | E16 { expr_SrcSpan :: SrcSpan }
   | E17 { expr_SrcSpan :: SrcSpan }
   | E18 { expr_SrcSpan :: SrcSpan }
   | E19 { expr_SrcSpan :: SrcSpan }
   | E20 { expr_SrcSpan :: SrcSpan }
   | E21 { expr_SrcSpan :: SrcSpan }
   | E22 { expr_SrcSpan :: SrcSpan }
   | E23 { expr_SrcSpan :: SrcSpan }
   | E24 { expr_SrcSpan :: SrcSpan }

instance Span Expr where
   getSpan = expr_SrcSpan


module Main where
import T3983_Foo
import T3983_Bar

main = catchX (foo False True) >>= print


{-# LANGUAGE DeriveDataTypeable #-}
module T3983_Bar where
import Data.Dynamic
import Control.Exception
import Control.Monad (unless)

type Assertion = IO ()

data X = X String deriving (Show, Typeable)

instance Exception X

throwX = throw.X

catchX action = do { action; return True; } `catches` [Handler (\(X _) -> return False)]


module T3983_Foo where

import Control.Monad (unless)
import Control.Exception
import T3983_Bar

foo :: Bool -> Bool -> IO ()
foo a b = unless a $ throwX (if b then "" else "")


f x = case x of
  x@True  -> \y -> x && y
  x@False -> \y -> x && y

main = putStrLn $ f (error "Correct") `seq` "Error"


-- This test exposes the bug in GHC 7.0.1 (and earlier)
-- which did the following rule rewrite:
--
--    f (let v = 2 in g v) (let v = 3 in g v)
--    --->  let v = 2 in let v = 3 in g v + g v
--
-- which is wrong because of the shadowing of v

module Main where
foo :: Int -> Int
{-# INLINE foo #-}
foo x = g (bar (x,x))

bar :: (Int,Int) -> Int
{-# NOINLINE bar #-}
bar (x,y) = x

baz :: Int -> Int
{-# NOINLINE baz #-}
baz x = x

f :: Int -> Int -> Int
{-# NOINLINE f #-}
f x y = x+y

g :: Int -> Int
{-# NOINLINE g #-}
g x = x

{-# RULES

 "f/g" [1] forall x y. f (g x) (g y) = x + y

 #-}

main = print $ f (foo (baz 1)) (foo (baz 2))
-- Should print 3
-- Bug means that it prints 4


{-# LANGUAGE UnicodeSyntax #-}
{-# LANGUAGE EmptyDataDecls #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE UndecidableInstances #-}

infixr 7 :*, .*
infix  8 :*:, .*.

data HNil
data Î± :* Î²
type HSingle Î± = Î± :* HNil
type Î± :*: Î² = Î± :* Î² :* HNil

data HList l where
  HNil  âˆ· HList HNil
  (:*) âˆ· Î± â†’ HList t â†’ HList (Î± :* t)

(.*) âˆ· Î± â†’ HList t â†’ HList (Î± :* t)
(.*) = (:*)

(.*.) âˆ· Î± â†’ Î² â†’ HList (Î± :*: Î²)
a .*. b = a .* b .* HNil

data First
data Next p

data HIndex i where
  First âˆ· HIndex First
  Next  âˆ· HIndex p â†’ HIndex (Next p)

class (l ~ (HHead l :* HTail l)) â‡’ HNonEmpty l where
  type HHead l
  type HTail l

instance HNonEmpty (h :* t) where
  type HHead (h :* t) = h
  type HTail (h :* t) = t

hHead âˆ· HNonEmpty l â‡’ HList l â†’ HHead l
hHead (h :* _) = h
hHead _        = undefined

hTail âˆ· HNonEmpty l â‡’ HList l â†’ HList (HTail l)
hTail (_ :* t) = t
hTail _        = undefined

data HFromWitness n l where
  HFromFirst âˆ· HFromWitness First l
  HFromNext  âˆ· (HNonEmpty l, HFromClass p (HTail l),
                HTail (HFrom (Next p) l) ~ HFrom (Next p) (HTail l))
             â‡’ HFromWitness (Next p) l

class HFromClass n l where
  type HFrom n l
  hFromWitness âˆ· HFromWitness n l

instance HFromClass First l where
  type HFrom First l = l
  hFromWitness = HFromFirst

instance (HNonEmpty l, HFromClass p (HTail l)) â‡’ HFromClass (Next p) l where
  type HFrom (Next p) l = HFrom p (HTail l)
  hFromWitness = case hFromWitness âˆ· HFromWitness p (HTail l) of
    HFromFirst â†’ HFromNext
    HFromNext  â†’ HFromNext

hFrom âˆ· âˆ€ n l . HFromClass n l â‡’ HIndex n â†’ HList l â†’ HList (HFrom n l)
hFrom First    l = l
hFrom (Next p) l = case hFromWitness âˆ· HFromWitness n l of
  HFromNext  â†’ hFrom p (hTail l)
  _          â†’ undefined

type HNth n l = HHead (HFrom n l)

hNth âˆ· âˆ€ n l . (HFromClass n l, HNonEmpty (HFrom n l))
     â‡’ HIndex n â†’ HList l â†’ HNth n l
hNth First l    = hHead l
hNth (Next p) l = case hFromWitness âˆ· HFromWitness n l of
  HFromNext â†’ hNth p (hTail l)
  _         â†’ undefined

main = putStrLn $ hNth (Next First) (0 .*. "Test")


module Main where

import T5441a

main = putStrLn (showNat Z)


module T5441a where

import Unsafe.Coerce (unsafeCoerce)
import GHC.Base (Any)

listmap :: (a -> b) -> [a] -> [b]
listmap f []       = []
listmap f (x : xs) = f x : listmap f xs

data Nat = Z | S Nat

{-# NOINLINE inject #-}
inject :: Nat -> Nat -> Nat
inject m i = i

{-# NOINLINE look #-}
look :: Nat -> String -> Char
look Z _ = '0'

showDigit :: Nat -> () -> Nat -> Char
showDigit base prf d = look (inject base d) ""

toDigits :: Nat -> Nat -> [Nat]
toDigits Z Z = [Z]

coe1 :: (Nat -> String) -> Any
coe1 = unsafeCoerce

coe2 :: Any -> (Nat -> String)
coe2 = unsafeCoerce

showInBase :: Nat -> Any
showInBase base
  = coe1 (\n -> listmap
                (showDigit base ())
                (toDigits base n))

showNat :: Nat -> String
showNat = coe2 (showInBase Z)


{-# LANGUAGE MagicHash #-}
module Main where

import GHC.Exts

data Var = TyVar !Int Bool Bool
         | TcTyVar Bool !Int Bool
         | Var Bool Bool !Int
         deriving (Show)

scrut :: Var -> (Bool, String)
scrut v = (True, case v of
    TcTyVar {} -> "OK"
    _ -> show v ++ show (case (case v of
                                 TyVar b _ _ -> b
                                 Var _ _ b -> b) of
                           I# x# -> if isTrue# (x# ==# 7#)
                                    then show (I# (x# +# 1#))
                                    else show (I# (x# +# 2#))))

main = putStrLn $ snd (scrut (TcTyVar True 1 False))


{-# OPTIONS_GHC -fpedantic-bottoms #-}
-- The pedantic-bottom flag makes GHC pickier about bottoms
-- See the ticket #5587

module Main(main) where

hiddenError = error "hidden error"

main = print $ seq (head (map (\a -> \b -> hiddenError) (hiddenError::[] Bool))) id [1]

{-  See notes in Trac #5587
f a b =  a
he = hiddenError::[Bool]
main = print $ seq (head (map f he)) id [1]

head (map f he)
= head (build (\cn. foldr (mapFB c f) n he))
= (\cn. foldr (mapFB c f) n he) (\x _ -> x) badHead
= foldr (mapFB (\x _ -> x) f) badHead he
= let go [] = badHead
       go (y:ys) = mapFB (\x _ -> x) f y (go ys)
   in go he
= let go []     = badHead
       go (y:ys) = mapFB (\x _ -> x) f y (go ys)
                 = (\x _. x) (f y) (go ys)
                 = f y
                 = \b. y
   in go he
-}


{-# LANGUAGE MagicHash #-}

module Main (main) where

import GHC.Base
import GHC.Integer.GMP.Internals

main :: IO ()
main = (encodeDouble 0 :: Double) `seq` return ()

{-# INLINE encodeDouble #-}
encodeDouble :: Integer -> Double
encodeDouble (S# _)   = D# 3.0##
encodeDouble (Jp# _)  = D# 4.0##
encodeDouble (Jn# _)  = D# 5.0##


module Main where

main = do { let a = \x -> seq undefined (+1)
          ; print $ (a `seq` a [] `seq` id) [0] }


module Main where

test = seq (seq id (\a -> undefined a))

main = print (test [0])


module Main where

-- Stack overflow if the tail recursion does not work

goInt :: Integer -> Integer -> Int
goInt 500 100000 = 0
goInt   x 100000 = goInt (x+1) 1
goInt   x      y = goInt x     (y+1)

main = print $ goInt 1 1


{-# LANGUAGE BangPatterns #-}

module Main where

-- Stack overflow if the tail recursion does not work out properly

incompleteBetaWorker :: Double -> Double
incompleteBetaWorker _ = loop 1 1 1 1
  where
    -- Constants
    eps = 1e-15
    -- Loop
    loop :: Double -> Int -> Double -> Double -> Double
    loop !psq !ns !term !betain
      | done           = betain'
      | ns > 10000000  = betain'
      | otherwise      = loop psq' (ns + 1) term' betain'
      where
        -- New values
        term'   = term
        betain' = betain
        psq'    = if ns < 0 then psq + 1 else psq
        -- This condition cause stack overflow
        done = db <= eps && db <= eps*betain' where db = abs term'
        -- With this it loops endlessly
        -- done = db <= eps * betain' where db = abs term'

main :: IO ()
main = print $ incompleteBetaWorker 0


{-# LANGUAGE ImplicitParams, RankNTypes #-}

module Main where

f :: (?x :: Int) => ((?x :: Int) => Int) -> Bool -> Int
f g False = g
f g True = let ?x = ?x + 1
           in f g False

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

main :: IO ()
main = print (let ?x = 0 in f h True)


{-# LANGUAGE MagicHash #-}

import GHC.Exts

newtype Age = Age Int

{-# NOINLINE myMap #-}
myMap f [] = []
myMap f (x:xs) = f x : myMap f xs

{-# RULES "map id2" myMap (\x -> x) = id #-}

mapId = myMap id
mapIdApp x = myMap id x

mapLamId = myMap (\x -> x)
mapLamIdApp x = myMap (\x -> x) x

same :: a -> a -> IO ()
same x y = case reallyUnsafePtrEquality# x y of
    1# -> putStrLn "yes"
    _  -> putStrLn "no"

main = do
    let l = [1,2,3]
    same (mapId l) l
    same (mapIdApp l) l
    same (mapLamId l) l
    same (mapLamIdApp l) l


{-# LANGUAGE DeriveDataTypeable #-}
module Main where
import Control.Exception (throwIO, Exception)
import Control.Monad (when)
import Data.Typeable (Typeable)

data Boom = Boom deriving (Show, Typeable)
instance Exception Boom

main = do
    args <- return []

    -- Should throw this exception.
    when (length args /= 1) (throwIO Boom)

    -- With -O, instead throws this one from head [].
    let n = read (head args)
    print (n :: Int)

    return ()


module Main where

newtype T a = MkT a

-- Trac #9128: we treated x as absent!!!!

f x = let {-# NOINLINE h #-}
          h = case x of MkT g -> g
      in
      h (h (h (h (h (h True)))))

main = print (f (MkT id))


{-# LANGUAGE MagicHash, UnboxedTuples #-}
module Main(main ) where

import GHC.IO (IO (..))
import GHC.Prim

writeB :: MutableArray# RealWorld Char -> IO ()
writeB arr# = IO $ \s0# -> (# writeArray# arr# 0# 'B' s0#, () #)

inlineWriteB :: MutableArray# RealWorld Char -> ()
inlineWriteB arr# =
    case f realWorld# of
        (# _, x #) -> x
  where
    IO f = writeB arr#

test :: IO Char
test = IO $ \s0# ->
  case newArray# 1# 'A' s0# of
    (# s1#, arr# #) ->
      case seq# (inlineWriteB arr#) s1# of
        (# s2#, () #) ->
          readArray# arr# 0# s2#

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


{-# LANGUAGE CPP #-}

#include "MachDeps.h"

#if __GLASGOW_HASKELL__ < 709
import GHC.Types
#endif

import StrictPrim
import Type
import Natural

main :: IO ()
main = do
    let (a, b) = (1234, 2345)
        (na, nb) = (mkSingletonNat a, mkSingletonNat b)
        nc = timesNatural na nb

    print $ fromNatural na
    print $ fromNatural nb
    print $ fromNatural nc
    checkEtaCount

checkEtaCount :: IO ()
checkEtaCount = do
    text <- readFile "Natural.dump-simpl"
    let etaCount = length . filter (== "eta") $ words text
    if etaCount > 0
        then error $ "Error : Eta count (" ++ show etaCount ++ ") should 0."
        else putStrLn "Test passed!"

mkSingletonNat :: Word -> Natural
mkSingletonNat x = runStrictPrim mkNat
  where
    mkNat :: StrictPrim s Natural
    mkNat = do
        marr <- newWordArray 1
        writeWordArray marr 0 x
        narr <- unsafeFreezeWordArray marr
        return $ Natural 1 narr

fromNatural :: Natural -> Word
fromNatural (Natural _ arr) = indexWordArray arr 0


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

module Natural where

import Prelude hiding (Integer, abs, sum)

import StrictPrim
import Type

{-# NOINLINE timesNatural #-}
timesNatural :: Natural -> Natural -> Natural
timesNatural (Natural !n1 !arr1) (Natural !n2 !arr2) =
    runStrictPrim $ do
        maxOutLen <- return (1 + n1 + n2)
        marr <- newWordArray maxOutLen
        len <- preLoop marr
        narr <- unsafeFreezeWordArray marr
        return $! Natural len narr
  where
    preLoop marr = do
        x <- indexWordArrayM arr1 0
        y <- indexWordArrayM arr2 0
        let (# cry, prod #) = timesWord2 x y
        writeWordArray marr 0 prod
        outerLoop1 1 marr 0 cry

    outerLoop1 !nx !marr !carryhi !carrylo
        | nx < n2 = do
            (cryhi, crylo, sum) <- innerLoop1xi nx 0 0 carryhi carrylo
            writeWordArray marr nx sum
            outerLoop1 (nx + 1) marr cryhi crylo
        | otherwise = outerLoop1a nx marr carryhi carrylo

    outerLoop1a !nx !marr !carryhi !carrylo
        | nx < n1 - 1 = do
            (cryhi, crylo, sum) <- innerLoop1yi nx 0 0 carryhi carrylo
            writeWordArray marr nx sum
            outerLoop1a (nx + 1) marr cryhi crylo
        | otherwise = outerLoop2 nx marr carryhi carrylo

    innerLoop1xi !xi !yi !carryhi !carrylo !sum
        | xi >= 0 = do
            x <- indexWordArrayM arr1 xi
            y <- indexWordArrayM arr2 yi
            let (# !cry0, !prod #) = timesWord2 x y
                (# !cry1, !sum1 #) = plusWord2 prod sum
                (# !tcryhi, !crylo #) = plusWord2C carrylo cry0 cry1
                !cryhi = plusWord carryhi tcryhi
            innerLoop1xi (xi - 1) (yi + 1) cryhi crylo sum1
        | otherwise = return $! (carryhi, carrylo, sum)

    innerLoop1yi !xi !yi !carryhi !carrylo !sum
        | yi < n2 = do
            x <- indexWordArrayM arr1 xi
            y <- indexWordArrayM arr2 yi
            let (# !cry0, !prod #) = timesWord2 x y
                (# !cry1, !sum1 #) = plusWord2 prod sum
                (# !tcryhi, !crylo #) = plusWord2C carrylo cry0 cry1
                !cryhi = plusWord carryhi tcryhi
            innerLoop1yi (xi - 1) (yi + 1) cryhi crylo sum1
        | otherwise = return $! (carryhi, carrylo, sum)

    outerLoop2 !nx !marr !carryhi !carrylo
        | nx < n1 + n2 - 1 = do
            (cryhi, crylo, sum)
                    <- innerLoop2 (n1 - 1) (nx - n1 + 1) 0 carryhi carrylo
            writeWordArray marr nx sum
            outerLoop2 (nx + 1) marr cryhi crylo
        | carrylo /= 0 = do
            writeWordArray marr nx carrylo
            return $! nx + 1
        | otherwise = return $! nx

    innerLoop2 !xi !yi !carryhi !carrylo !sum
        | yi < n2 = do
            x <- indexWordArrayM arr1 xi
            y <- indexWordArrayM arr2 yi
            let (# !cry0, !prod #) = timesWord2 x y
                (# !cry1, !sum1 #) = plusWord2 prod sum
                (# !tcryhi, !crylo #) = plusWord2C carrylo cry0 cry1
                !cryhi = plusWord carryhi tcryhi
            innerLoop2 (xi - 1) (yi + 1) cryhi crylo sum1
        | otherwise = return $! (carryhi, carrylo, sum)


{-# LANGUAGE BangPatterns, CPP, MagicHash, NoImplicitPrelude, RankNTypes,
    TypeFamilies, UnboxedTuples, UnliftedFFITypes #-}

module StrictPrim
    ( StrictPrim
    , PrimMonad (..)
    , runStrictPrim
    ) where

#if __GLASGOW_HASKELL__ < 709
import Control.Applicative
#endif

import GHC.Base

newtype StrictPrim s a
    = StrictPrim (State# s -> (# State# s, a #))

instance Applicative (StrictPrim s) where
    {-# INLINE pure #-}
    pure = return

    {-# INLINE (<*>) #-}
    (<*>) a b = do f <- a ; v <- b ; return $! (f $! v)

instance Functor (StrictPrim s) where
    {-# INLINE fmap #-}
    fmap !f (StrictPrim !m) = StrictPrim $ \ !s ->
        case m s of
            (# !new_s,!r #) -> (# new_s, f $! r #)

instance Monad (StrictPrim s) where
    {-# INLINE return #-}
    return !x = StrictPrim ( \ !s -> (# s, x #))

    {-# INLINE (>>) #-}
    (!m) >> (!k) = do { _ <- m ;  k }

    {-# INLINE (>>=) #-}
    (StrictPrim !m) >>= (!k) =
        StrictPrim ( \ !s ->
            case m s of
                (# new_s, r #) -> case k r of
                    StrictPrim k2 -> k2 new_s
            )

instance PrimMonad (StrictPrim s) where
    type PrimState (StrictPrim s) = s
    {-# INLINE primitive #-}
    primitive = StrictPrim

{-# INLINE runStrictPrim #-}
runStrictPrim :: (forall s. StrictPrim s a) -> a
runStrictPrim !st =
    case st of
        StrictPrim st_rep ->
            case st_rep realWorld# of
                (# _, !r #) -> r

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

#if __GLASGOW_HASKELL__ < 709
-- Grab this from Prelude (part of Base) because Base depends on this code.
($!) :: (a -> b) -> a -> b
f $! x  = let !vx = x in f vx
#endif


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

#include "MachDeps.h"

module Type where

import GHC.Prim
import GHC.Types

import StrictPrim

data Natural = Natural {-# UNPACK #-} !Int {-# UNPACK #-} !WordArray

data WordArray = WA ByteArray#
data MutableWordArray m = MWA (MutableByteArray# (PrimState m))

{-# INLINE newWordArray #-}
newWordArray :: (Monad m, PrimMonad m) => Int -> m (MutableWordArray m)
newWordArray !len = do
    let !(I# n#) = len * sizeOfWord
    primitive (\s# -> case newByteArray# n# s# of
                        (# s'#, arr# #) -> (# s'#, MWA arr# #))

{-# INLINE unsafeFreezeWordArray #-}
unsafeFreezeWordArray :: (Monad m, PrimMonad m)
                        => MutableWordArray m -> m WordArray
unsafeFreezeWordArray !(MWA arr#) =
    primitive (\s# -> case unsafeFreezeByteArray# arr# s# of
                        (# s'#, arr'# #) -> (# s'#, WA arr'# #))

{-# INLINE indexWordArray #-}
indexWordArray :: WordArray -> Int -> Word
indexWordArray !(WA arr#) (I# i#) =
    let w# = indexWordArray# arr# i# in W# w#

{-# INLINE indexWordArrayM #-}
indexWordArrayM :: Monad m => WordArray -> Int -> m Word
indexWordArrayM !(WA arr#) (I# i#) =
    let w# = indexWordArray# arr# i# in
    case W# w# of x -> return x

{-# INLINE writeWordArray #-}
writeWordArray :: (Monad m, PrimMonad m)
                        => MutableWordArray m -> Int -> Word -> m ()
writeWordArray !(MWA arr#) (I# i#) (W# x#) =
    primitive (\s# ->
        case writeWordArray# arr# i# x# s# of
            s'# -> (# s'#, () #))

{-# INLINE plusWord #-}
plusWord :: Word -> Word -> Word
plusWord (W# a) (W# b) =
    let !s = plusWord# a b
    in W# s

{-# INLINE plusWord2 #-}
plusWord2 :: Word -> Word -> (# Word, Word #)
plusWord2 (W# a) (W# b) =
    let (# !c, !s #) = plusWord2# a b
    in (# W# c, W# s #)

{-# INLINE plusWord2C #-}
plusWord2C :: Word -> Word -> Word -> (# Word, Word #)
plusWord2C (W# a) (W# b) (W# c) =
    let (# !c1, !s1 #) = plusWord2# a b
        (# !c2, !s2 #) = plusWord2# s1 c
        !carry = plusWord# c1 c2
    in (# W# carry, W# s2 #)

{-# INLINE timesWord2 #-}
timesWord2 :: Word -> Word -> (# Word, Word #)
timesWord2 (W# a) (W# b) =
    let (# !ovf, !prod #) = timesWord2# a b
    in (# W# ovf, W# prod #)

sizeOfWord :: Int
sizeOfWord = WORD_SIZE_IN_BITS `div` 8


module T13588 where

newtype T a = MkT a
f (x, y) = (MkT x, y)
{-# NOINLINE f #-}

bar x =
    let y = f (x,x) in
    let z = case y of (MkT x,y) -> (x,y) in
    (z,z)


import Debug.Trace

newtype Id a = Id a

unId True _ = Nothing -- make lazy
unId False (Just (Id x)) = (Just x)
unId False Nothing = Nothing
{-# NOINLINE unId #-}

val n = trace "evaluated once, as it should" (Just (Id n))
{-# NOINLINE val #-}

foo b n = unId b (val n)
{-# NOINLINE foo #-}

main = print (foo False 1)


{-# LANGUAGE TypeFamilies #-}
module Main where

main :: IO ()
main = do
  let f :: (Bool, Bool) -> (Bool, Bool) -> (Bool, Bool)
      f (True, False) (False, False) = (False, True)
      f _ _ = (True, False)
      ((i, b), v) = ((False,True),[(False,True),(False,False),(True,True),(True,False),(False,False),(False,True),(True,True),(True,True),(False,True),(True,False),(False,False),(True,True),(True,True),(False,False),(False,False),(False,True),(True,False),(True,False),(True,True),(True,True),(False,True),(True,False),(True,False),(True,True),(False,False),(True,True),(False,False),(True,False),(False,True),(True,True)])
  print $ foldlTest f (i, b) v

type FoldlTest a = (a -> a -> a) -> a -> [a] -> Bool

foldlTest :: FoldlTest (Bool, Bool)
foldlTest f (i, b) v =
  foldl f (i, b) v == foldl (\x -> f (unmodel x)) (i, b) v

class TestData a where
  type Model a
  unmodel :: Model a -> a

instance TestData Bool where
  type Model Bool = Bool
  unmodel = id

instance (Eq a, Eq b, TestData a, TestData b) => TestData (a,b) where
  type Model (a,b) = (Model a, Model b)
  unmodel (a,b) = (unmodel a, unmodel b)


{-# LANGUAGE MagicHash #-}
import GHC.Exts
import Unsafe.Coerce

foo :: Either Int a -> Either Bool a
foo (Right x) = Right x
foo _ = Left True
{-# NOINLINE foo #-}

bar :: a -> (Either Int a, Either Bool a)
bar x = (Right x, Right x)
{-# NOINLINE bar #-}

nested :: Either Int (Either Int a) -> Either Bool (Either Bool a)
nested (Right (Right x)) = Right (Right x)
nested _ = Left True
{-# NOINLINE nested #-}

-- CSE in a recursive group
data Tree x = T x (Either Int (Tree x)) (Either Bool (Tree x))
rec1 :: x -> Tree x
rec1 x =
    let t = T x r1 r2
        r1 = Right t
        r2 = Right t
    in t
{-# NOINLINE rec1 #-}

-- Not yet supported! (and tricky)
data Stream a b x = S x (Stream b a x)
rec2 :: x -> Stream a b x
rec2 x =
    let s1 = S x s2
        s2 = S x s1
    in s1
{-# NOINLINE rec2 #-}

test x = do
    let (r1,r2) = bar x
    (same $! r1) $! r2
    let r3 = foo r1
    (same $! r1) $! r3
    let (r4,_) = bar r1
    let r5 = nested r4
    (same $! r4) $! r5
    let (T _ r6 r7) = rec1 x
    (same $! r6) $! r7
    let s1@(S _ s2) = rec2 x
    (same $! s1) $! s2
{-# NOINLINE test #-}

main = test "foo"

same :: a -> b -> IO ()
same x y = case reallyUnsafePtrEquality# (unsafeCoerce x) y of
    1# -> putStrLn "yes"
    _  -> putStrLn "no"


module M where

{-# ANN myId "HLint: ignore" #-}
myId :: a -> a
myId x = x


-- Trac #2632

module MkData where

import Language.Haskell.TH

op :: Num v => v -> v -> v
op a b = a + b

decl1 = [d| func = 0 `op` 3 |]

decl2 = [d| op x y = x
            func = 0 `op` 3 |]


{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -fno-unbox-small-strict-fields #-}
                -- Makes f2 a bit more challenging

module Foo where

h :: Int -> Int -> Bool
h 0 y = y>0
h n y = h (n-1) y

-- The main point: all of these functions can have the CPR property

------- f1 -----------
-- x is used strictly by h, so it'll be available
-- unboxed before it is returned in the True branch

f1 :: Int -> Int
f1 x = case h x x of
        True  -> x
        False -> f1 (x-1)

------- f2 -----------
-- x is a strict field of MkT2, so we'll pass it unboxed
-- to $wf2, so it's available unboxed.  This depends on
-- the case expression analysing (a subcomponent of) one
-- of the original arguments to the function, so it's
-- a bit more delicate.

data T2 = MkT2 !Int Int

f2 :: T2 -> Int
f2 (MkT2 x y) | y>0       = f2 (MkT2 x (y-1))
              | y>1       = 1
              | otherwise = x

------- f3 -----------
-- h is strict in x, so x will be unboxed before it
-- is rerturned in the otherwise case.

data T3 = MkT3 Int Int

f1 :: T3 -> Int
f1 (MkT3 x y) | h x y     = f3 (MkT3 x (y-1))
              | otherwise = x

------- f4 -----------
-- Just like f2, but MkT4 can't unbox its strict
-- argument automatically, as f2 can

data family Foo a
newtype instance Foo Int = Foo Int

data T4 a = MkT4 !(Foo a) Int

f4 :: T4 Int -> Int
f4 (MkT4 x@(Foo v) y) | y>0       = f4 (MkT4 x (y-1))
                      | otherwise = v


module Test where
data Boolean = FF | TT
data Pair a b = MkPair a b
data LList alpha = Nill | Conss alpha (LList alpha)
data Nat = Zero | Succ Nat
data Tree x = Leaf x | Node (Tree x) (Tree x)
data A a = MkA a (A a)

append :: LList a -> LList a -> LList a
append  xs ys  = case xs of
                  Conss z zs  -> Conss z (append zs ys)
                  v -> ys


module Test where
fact :: Int -> Int
fact n = if n==0 then 2 else (fact n) * n


module Test where
data Fun = MkFun (Fun -> Fun)
data LList a = Nill | Conss a (LList a)

g :: Fun -> Fun
g f = f


module Test where
data Goo a = Gsimpl | Gcompl ([Goo a])
data Moo a b = Msimple | Mcompl (Moo b a)

idGoo :: Goo a -> Goo a
idGoo x = x

idMoo :: Moo a b -> Moo a b
idMoo x = x


-- !! TEST OF DEFACTORISATION FOR FUNCTIONS THAT DROP
-- !!             POLYMORPHIC VARIABLES

module Test where
data Boolean = FF | TT
data Pair a b = MkPair a b
data LList alpha = Nill | Conss alpha (LList alpha)
data Nat = Zero | Succ Nat
data Tree x = Leaf x | Node (Tree x) (Tree x)
data A a = MkA a (A a)

append :: LList a -> LList a -> LList a
append  xs ys  = case xs of
                  Nill -> ys
                  Conss z zs  -> Conss z (append zs ys)

-- The following function drops @b@.

flat :: Tree (Pair a b) -> LList a
flat t =  case t of
              Leaf (MkPair a b) -> Conss a Nill
              Node l r -> append (flat l) (flat r)

fl :: Boolean -> LList Boolean
fl x = flat (Leaf (MkPair TT Zero))


module Test where
data Boolean = FF | TT
data Pair a b = MkPair a b
data LList alpha = Nill | Conss alpha (LList alpha)
data Nat = Zero | Succ Nat
data Tree x = Leaf x | Node (Tree x) (Tree x)
data A a = MkA a (A a)

{-
map :: (a -> b) -> [a] -> [b]
map f xs = case xs of
             []     -> []
             (y:ys) -> (f y):(map f ys)

map_ide :: [[a]] -> [[a]]
map_ide = map (\x->x)
-}

my_id :: a -> a
my_id x = x

idNat :: Nat -> Nat
idNat x = x

idBool :: Boolean -> Boolean
idBool x = x

fun :: (a->b) -> a -> b
fun f x = g f
 where
  g f   = f x


-- This one killed GHC 6.4 because it bogusly attributed
-- the CPR property to the constructor T
-- Result: a mkWWcpr crash
-- Needs -prof -fprof-auto to show it up

module ShouldCompile where

newtype T a = T { unT :: a }

f = unT

test cs = f $ case cs of
                   [] -> T []
                   (x:xs) -> T $ test cs


module Test where
data Boolean = FF | TT
data Pair a b = MkPair a b
data LList alpha = Nill | Conss alpha (LList alpha)
data Nat = Zero | Succ Nat
data Tree x = Leaf x | Node (Tree x) (Tree x)
data A a = MkA a (A a)
{-
id :: a -> a
id x = x

idb :: Boolean -> Boolean
idb b = b

swap :: Pair a b -> Pair b a
swap t = case t of
           MkPair x y -> MkPair y x

bang :: A (A a) -> Boolean
bang x = case x of
           MkA y ys -> TT

neg :: Boolean -> Boolean
neg b = case b of
         FF -> TT
         TT -> FF

null :: LList x -> Boolean
null l = case l of
           Nill -> TT
           _ -> FF

loop :: Boolean -> a
loop b = loop b
-}
idl ::  LList a -> LList a
idl xs  = case xs of
           Conss y ys -> Conss y (idl ys)
           _ -> Nill
{-
idn :: Nat -> Nat
idn n = case n of
          Zero -> Zero
          Succ m -> Succ (idn m)

add :: Nat -> Nat -> Nat
add a b = case a of
            Zero -> b
            Succ c -> Succ (add c b)

length :: LList a -> Nat
length xs = case xs of
              Nill -> Zero
              Conss y ys  -> Succ(length ys)

before :: LList Nat -> LList Nat
before xs = case xs of
              Nill -> Nill
              Conss y ys -> case y of
                             Zero -> Nill
                             Succ n -> Conss y (before ys)

reverse :: LList a -> LList a
reverse rs = case rs of
               Nill -> Nill
               Conss y ys -> append (reverse ys) (Conss y Nill)

f :: Nat -> Nat
f n = case n of
        Zero -> Zero
        Succ m -> Succ (g m)

g :: Nat -> Nat
g n = case n of
       Zero -> Zero
       Succ m -> Succ (f m)

append :: LList a -> LList a -> LList a
append  xs ys  = case xs of
                  Nill -> ys
                  Conss z zs  -> Conss z (append zs ys)

flatten :: Tree alpha -> LList alpha
flatten t = case t of
              Leaf x   -> Conss x Nill
              Node l r -> append (flatten l) (flatten r)

sum :: Tree Nat -> Nat
sum t = case t of
          Leaf t   -> t
          Node l r -> add (sum l) (sum r)

suml :: LList Nat -> Nat
suml Nill = Zero
suml (Conss n ns) = add n (suml ns)

map :: (a -> b) -> LList a -> LList b
map f xs = case xs of
             Nill -> Nill
             Conss y ys -> Conss (f y) (map f ys)
-}


{-# LANGUAGE DatatypeContexts #-}
module ShouldSucceed where

{-# OPTIONS -O #-}

newtype Num a => Point2 a     = Point2 (a,a)

area2 :: Num a => Point2 a -> Point2 a -> Point2 a -> a
area2 (Point2 (px,py)) (Point2 (qx,qy)) (Point2 (rx,ry))
     = (px-qx) * (py-ry) - (py-qy) * (px-rx)


-- !!! Recursive newtypes
--      Needs -O
-- This one made GHC < 5.00.2 go into an
-- infinite loop in the strictness analysier

module Foo where

newtype V = MkV V

f :: V -> V
f (MkV v) = v


-- !!! THIS TEST IS FOR TYPE SYNONYMS AND FACTORISATION IN THEIR PRESENCE.

module Test where
data M a = A | B a (M a)
data L a = N | C a (Syn a)
type Syn b = L b

idL :: L (Syn c) -> L (Syn c)
idL N       = N
idL (C x l) = C x (idL l)

idM:: M (L (Syn x)) -> M (L (Syn x))
idM A       = A
idM (B x l) = B (idL x) (idM l)


{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE TypeFamilies #-}
module T10482 where

data family Foo a
data instance Foo (a, b) = FooPair !(Foo a) !(Foo b)
newtype instance Foo Int = Foo Int

foo :: Foo ((Int, Int), Int) -> Int -> Int
foo !f k =
  if k == 0 then 0
  else if even k then foo f (k-1)
  else case f of
    FooPair (FooPair (Foo n) _) _ -> n


{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -fno-unbox-small-strict-fields #-}
                -- Makes f2 a bit more challenging

-- Tests inspired by Note [CPR examples] in DmdAnal, and Trac #10482

module Foo where

h :: Int -> Int -> Bool
h 0 y = y>0
h n y = h (n-1) y

-- The main point: all of these functions can have the CPR property

------- f1 -----------
-- x is used strictly by h, so it'll be available
-- unboxed before it is returned in the True branch

f1 :: Int -> Int
f1 x = case h x x of
        True  -> x
        False -> f1 (x-1)

------- f2 -----------
-- x is a strict field of MkT2, so we'll pass it unboxed
-- to $wf2, so it's available unboxed.  This depends on
-- the case expression analysing (a subcomponent of) one
-- of the original arguments to the function, so it's
-- a bit more delicate.

data T2 = MkT2 !Int Int

f2 :: T2 -> Int
f2 (MkT2 x y) | y>0       = f2 (MkT2 x (y-1))
              | y>1       = 1
              | otherwise = x

------- f3 -----------
-- h is strict in x, so x will be unboxed before it
-- is rerturned in the otherwise case.

data T3 = MkT3 Int Int

f3 :: T3 -> Int
f3 (MkT3 x y) | h x y     = f3 (MkT3 x (y-1))
              | otherwise = x

------- f4 -----------
-- Just like f2, but MkT4 can't unbox its strict
-- argument automatically, as f2 can

data family Foo a
newtype instance Foo Int = Foo Int

data T4 a = MkT4 !(Foo a) Int

f4 :: T4 Int -> Int
f4 (MkT4 x@(Foo v) y) | y>0       = f4 (MkT4 x (y-1))
                      | otherwise = v


module T10694 where

-- The point here is that 'm' should NOT have the CPR property
-- Checked by grepping in the -ddump-simpl

-- Some nonsense so that the simplifier can't see through
-- to the I# constructor
pm :: Int -> Int -> (Int, Int)
pm x y = (l !! 0, l !! 1)
  where l = [x+y, x-y]
{-# NOINLINE pm #-}

m :: Int -> Int -> Int
m x y = case pm x y of
  (pr, mr) -> mr


module T11770 where

foo :: Int -> Int ->  Int
foo 10 c = 0
foo n c =
        -- Bar should not be marked as one-shot
    let bar :: Int -> Int
        bar n = n + c
        {-# NOINLINE bar #-}
    in bar n + foo (bar (n+1)) c


{-# LANGUAGE MagicHash #-}

module Foo( f ) where
import GHC.Prim

f True  = raise# True
f False = \p q -> raise# False


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

data X = A | B | C

data T = MkT !X Int# Int#

f (MkT x 0# _) = True
f (MkT x n  _)  = let v = case x of
                         A -> 1#
                         B -> 2#
                         C -> n
                  in f (MkT x v v)
 -- Tests evaluatedness for worker args


{-# LANGUAGE MagicHash  #-}
module T13077a where

import GHC.Exts

data X = A | B | C

data T = MkT !X Int# Int#

g :: Int -> T
g 0 = MkT A 1# 2#
g n = g (n-1)

boo :: Int -> T
boo k = case g k of
          MkT x n _ -> let v = case x of
                                  A -> 1#
                                  B -> 2#
                                  C -> n
                       in MkT x v v
  -- Tests evaluated-ness for CPR


{-# LANGUAGE MagicHash #-}

-- | Asserts that absent bindings of UnliftedRep are properly WWed
module Unlifted where

import GHC.Exts

fac :: Int -> Int
fac n = product [1..n]

data MMutVar s a = MMutVar (MutVar# s a) Int
mutVar :: MMutVar s a -> Int
mutVar (MMutVar _ n) = fac n
{-# NOINLINE mutVar #-}

data AArray a = AArray (Array# a) Int
array :: AArray a -> Int
array (AArray _ n) = fac n
{-# NOINLINE array #-}


module T16029 where

data S = MkS Int Int

g1 :: S -> Int -> Int
g1 (MkS x y) 0 = 0
g1 (MkS x y) n = g1 (MkS y x) (n-1)

data T = MkT !Int !Int
g2 :: T -> Int -> Int
g2 (MkT x y) 0 = 0
g2 (MkT x y) n = g2 (MkT y x) (n-1)


{-# OPTIONS_GHC -O2 #-}

-- Trac #1988: this one killed GHC 6.8.2
--              at least with -O2

module ShouldCompile where

newtype CFTree = CFTree (String, [CFTree])

prCFTree :: CFTree -> String
prCFTree (CFTree (_,trees)) = concatMap ps trees
    where ps t@(CFTree (_,[])) = prCFTree t


module T8037 where

import Unsafe.Coerce
import Foreign.C.Types
import System.IO.Unsafe

data D4 = D4 CInt CInt CInt
data Color3 = Color3 CInt CInt

crash :: D4 -> IO ()
crash x = color (unsafeCoerce x)

color :: Color3 -> IO ()
color (Color3 r g) = f (unsafePerformIO undefined) r g

foreign import ccall f :: CInt -> CInt -> CInt -> IO ()


module T8467 where

newtype Void = Void Void

data Decision a = Disproved (a -> Void)

bar :: Int -> Void
bar = \_ -> undefined

foo :: () -> Decision Int
foo _ = Disproved (\_ -> undefined)


module T8743 where

-- Without the following import, it does not fail
import T8743a ()

-- [()] required, () does not work.
class ToRow a where toRow :: a -> [()]

instance ToRow (Maybe a) where
    toRow Nothing  = [()]
    toRow (Just _) = [()]


module T8743a where

import {-# SOURCE #-} T8743 ()


{-# LANGUAGE CPP, LambdaCase, BangPatterns, MagicHash, TupleSections, ScopedTypeVariables #-}
{-# OPTIONS_GHC -w #-}  -- Suppress warnings for unimplemented methods

------------- WARNING ---------------------
--
-- This program is utterly bogus. It takes a value of type ()
-- and unsafe-coerces it to a function, and applies it.
-- This is caught by an ASSERT with a debug compiler.
--
-- See Trac #9208 for discussion
--
--------------------------------------------

{- | Evaluate Template Haskell splices on node.js,
     using pipes to communicate with GHCJS
 -}

-- module GHCJS.Prim.TH.Eval
module Eval (
         runTHServer
       ) where

import           Control.Applicative
import           Control.Monad
#if __GLASGOW_HASKELL__ >= 800
import           Control.Monad.Fail (MonadFail(fail))
#endif
import           Control.Monad.IO.Class (MonadIO (..))

import           Data.Binary
import           Data.Binary.Get
import           Data.ByteString          (ByteString)
import qualified Data.ByteString          as B
import qualified Data.ByteString.Lazy     as BL

import           GHC.Base                 (Any)

import qualified Language.Haskell.TH        as TH
import qualified Language.Haskell.TH.Syntax as TH

import           Unsafe.Coerce

data THResultType = THExp | THPat | THType | THDec

data Message
  -- | GHCJS compiler to node.js requests
  = RunTH THResultType ByteString TH.Loc
  -- | node.js to GHCJS compiler responses
  | RunTH' THResultType ByteString [TH.Dec] -- ^ serialized AST and additional toplevel declarations

instance Binary THResultType where
  put _ = return ()
  get   = return undefined

instance Binary Message where
  put _ = return ()
  get   = return undefined

data QState = QState

data GHCJSQ a = GHCJSQ { runGHCJSQ :: QState -> IO (a, QState) }

instance Functor GHCJSQ where
  fmap f (GHCJSQ s) = GHCJSQ $ fmap (\(x,s') -> (f x,s')) . s

instance Applicative GHCJSQ where
  f <*> a = GHCJSQ $ \s ->
    do (f',s')   <- runGHCJSQ f s
       (a', s'') <- runGHCJSQ a s'
       return (f' a', s'')
  pure x = GHCJSQ (\s -> return (x,s))

instance Monad GHCJSQ where
  (>>=) m f = GHCJSQ $ \s ->
    do (m', s')  <- runGHCJSQ m s
       (a,  s'') <- runGHCJSQ (f m') s'
       return (a, s'')
  return    = pure

#if __GLASGOW_HASKELL__ >= 800
instance MonadFail GHCJSQ where
  fail = undefined
#endif

instance MonadIO GHCJSQ where liftIO m = GHCJSQ $ \s -> fmap (,s) m
instance TH.Quasi GHCJSQ

-- | the Template Haskell server
runTHServer :: IO ()
runTHServer = void $ runGHCJSQ server QState
  where
    server = TH.qRunIO awaitMessage >>= \case
      RunTH t code loc -> do
        a <- TH.qRunIO $ loadTHData code
        runTH t a loc
      _ -> TH.qRunIO (putStrLn "warning: ignoring unexpected message type")

runTH :: THResultType -> Any -> TH.Loc -> GHCJSQ ()
runTH rt obj loc = do
  res <- case rt of
           THExp  -> runTHCode (unsafeCoerce obj :: TH.Q TH.Exp)
           THPat  -> runTHCode (unsafeCoerce obj :: TH.Q TH.Pat)
           THType -> runTHCode (unsafeCoerce obj :: TH.Q TH.Type)
           THDec  -> runTHCode (unsafeCoerce obj :: TH.Q [TH.Dec])
  TH.qRunIO (sendResult $ RunTH' rt res [])

runTHCode :: {- Binary a => -} TH.Q a -> GHCJSQ ByteString
runTHCode c = TH.runQ c >> return B.empty

loadTHData :: ByteString -> IO Any
loadTHData bs = return (unsafeCoerce ())

awaitMessage :: IO Message
awaitMessage = fmap (runGet get) (return BL.empty)

-- | send result back
sendResult :: Message -> IO ()
sendResult msg = return ()


module Test where
data LList t = Nill | Conss t (LList t)
data BBool = TTrue | FFalse

f Nill = TTrue
f (Conss a as) = FFalse


module Test where
a :: [a] -> [[a]]
a x = [x]


module Test where
data Boolean = FF | TT
data Pair a b = Mkpair a b
data LList alpha = Nill | Conss alpha (LList alpha)
data Nat = Zero | Succ Nat
data Tree t = Leaf t | Node (Tree t) (Tree t)
data A a = MkA a (A a)
data Foo baz = MkFoo (Foo (Foo baz))
{-
 append1 :: LList a -> LList a -> LList a
 append1 xs ys = append2 xs
   where
     append2 xs = case xs of
                    Nill -> ys
                    Conss x xs -> Conss x (append3 xs)
     append3 xs = case xs of
                    Nill -> ys
                    Conss x xs -> Conss x (append2 xs)

 loop :: a -> a
 loop x =  loop x

 hd :: LList b -> b
 hd Nill         = loop
 hd (Conss y ys) = y

 hdb :: LList (LList b) -> LList b
 hdb = hd

 append :: [a] -> [a] -> [a]
 append [] ys     = ys
 append (x:xs) ys = x:(append xs ys)

 f :: [a] -> [a]
 f y = append x (f y)
   where  x = append x (f y)
-}
app :: LList a -> LList a -> LList a
app Nill Nill = Nill
app  xs ys  = case xs of
                Nill -> ys
                Conss z zs  -> Conss z (app zs ys)
{-
 app :: LList a -> LList a -> LList a
 app  xs ys = case xs of
               Nill -> case ys of
                        Nill -> Nill
                        Conss u us -> ap
               Conss a as -> ap
  where ap = case xs of
              Nill -> ys
              Conss z zs  -> Conss z (app zs ys)

 app :: LList a -> LList a -> LList a
 app  xs ys = case xs of
               Nill -> case ys of
                        Nill -> Nill
                        Conss u us -> ap xs ys
               Conss a as -> ap xs ys

 ap xs ys = case xs of
              Nill -> ys
              Conss z zs  -> Conss z (app zs ys)

 ap :: LList a -> LList a -> LList a
 ap  xs ys  = case xs of
                 Nill -> ys
                 Conss z zs  -> Conss z (ap zs ys)

 app :: LList a -> LList a -> LList a
 app  xs ys = case xs of
               Nill -> case ys of
                        Nill -> Nill
                        Conss u us -> ap xs ys
               Conss a as -> ap xs ys
-}


-- Made the new demand analyser enter an absent arg
-- Reason: it thought 'a' was unused in g.

module Main where

-- Strictness: SS(AL) -> T
f True p@(x,y) = (p,y)
f False p@(x,y) = f y p

-- Easy to get the wrong strictness,
-- by thinking 'a' is absent
g True  a b = f False (a,b)
g False a b = g b a b

main = print (g True 'a' True)


-- This showed up an "entered-absent-arg" error in 5.02.1

module Main where

is_volatile :: [Int] -> (String,Int) -> Int
is_volatile [] (destVarName, destPtr)
        = error ("Variable not found: " ++ "(" ++ (show destPtr) ++ ") " ++ destVarName)
is_volatile (a:allWrites) (destVarName, destPtr)
  | a == destPtr    = a
  | otherwise = is_volatile allWrites (destVarName, destPtr)

main = print (is_volatile [] ("hello",2))


-- This module should run fine with an empty argument list
-- But it won't if the strictness analyser thinks that 'len' is use
-- strictly, which was the case in GHC 6.0

-- See the io_hack_reqd in DmdAnal.lhs

module Main where

import System.Environment
import System.Exit

main    = do
            args <- getArgs
            let len = read (head args) :: Int

            (if null args && useLazily len
                then putStrLn "ok" >> exitWith ExitSuccess
                else return () )

            print len

useLazily :: Int -> Bool
useLazily len = ([len,3,4] !! 1) == 3


module Main where

f 0 = 0
f x = x + g (x-1)

g 0 = 0
g x = x - f (x-1)

main = print (f 300)


{-# LANGUAGE BangPatterns #-}
module Main where

import Debug.Trace

data Machine = Machine (Int -> Machine) Int

main :: IO ()
main = (go 7 $ Machine (gstep (Array 99)) 8) `seq` return ()
  where
    go :: Int -> Machine -> Int
    go 0 (Machine _ done) = done
    go nq (Machine step _) = go (nq-1) $ step 0

gstep :: Array Int -> Int -> Machine
gstep m x = Machine (gstep m') (mindexA m)
  where
    !m' = adjustA x m

data Array a = Array a

adjustA :: (Show a) => Int ->  Array a -> Array a
adjustA i (Array t)
  | i < 0 = undefined i -- not just undefined!
  | otherwise = Array $ trace ("adj " ++ show t) $ t

mindexA :: Array a -> a
mindexA (Array v) = v


{-# OPTIONS_GHC -feager-blackholing #-}

module Main where

{-# NOINLINE foo #-}
foo :: Bool -> Int -> Int -> Int
foo True  _ x = 1
foo False _ x = x+1

{-# NOINLINE bar #-}
bar :: Int -> (Int,Int)
bar x = let y1 = x * 2
            y2 = x * 2
        in (foo False y1 y2,foo False y2 y1)

main = print (fst p + snd p)
  where
    p = bar 3


{-
   Test case for a problem where GHC had incorrect strictness
   information for foreign calls with lifted arguments
 -}
{-# OPTIONS_GHC -O0 #-}
module Main where

import T11076A
import Control.Exception
x :: Bool
x = error "OK: x has been forced"

main :: IO ()
main = print (testBool x) `catch`
          \(ErrorCall e) -> putStrLn e -- x should be forced


{-# OPTIONS_GHC -O #-}
{-# LANGUAGE MagicHash,
             ForeignFunctionInterface,
             UnliftedFFITypes,
             GHCForeignImportPrim,
             BangPatterns
  #-}
module T11076A where

import GHC.Exts
import Unsafe.Coerce

{-
   If the demand type for the foreign call argument is incorrectly strict,
   the bang pattern can be optimized out
 -}
testBool :: Bool -> Int
testBool !x = I# (cmm_testPrim (unsafeCoerce x))
{-# INLINE testBool #-}

foreign import prim "testPrim" cmm_testPrim :: Any -> Int#


module Main(main) where

import Control.Monad
import Control.Exception
import Control.Monad.Trans.Cont
import GHC.Exts

type RAW a = ContT () IO a

-- See https://ghc.haskell.org/trac/ghc/ticket/11555
catchSafe1, catchSafe2 :: IO a -> (SomeException -> IO a) -> IO a
catchSafe1 a b = lazy a `catch` b
catchSafe2 a b = join (evaluate a) `catch` b

-- | Run and then call a continuation.
runRAW1, runRAW2 :: RAW a -> (Either SomeException a -> IO ()) -> IO ()
runRAW1 m k = m `runContT` (k . Right) `catchSafe1` \e -> k $ Left e
runRAW2 m k = m `runContT` (k . Right) `catchSafe2` \e -> k $ Left e

{-# NOINLINE run1 #-}
run1 :: RAW ()-> IO ()
run1 rs = do
    runRAW1 rs $ \x -> case x of
        Left e -> putStrLn "CAUGHT"
        Right x -> return x

{-# NOINLINE run2 #-}
run2 :: RAW ()-> IO ()
run2 rs = do
    runRAW2 rs $ \x -> case x of
        Left e -> putStrLn "CAUGHT"
        Right x -> return x

main :: IO ()
main = do
    run1 $ error "MISSED"
    run2 $ error "MISSED"


-- If care is not taken when aborting a fixed-point iteration, wrong absentness
-- information escapes

-- Needs to be a product type
data Stream = S Int Stream

bar :: Int -> Stream -> Int
bar n s = foo n s
  where
    foo :: Int -> Stream -> Int
    foo 0 (S n s) = 0
    foo i (S n s) = n + foo (i-1) s
{-# NOINLINE bar #-}

baz :: Int -> Stream -> Int
baz 0 not_absent = 0
baz 1 not_absent = baz 2 not_absent
baz x not_absent = bar 1000 arg
  where
    arg = S 1 $ S 1 $ S 1 $ S 1 $ S 1 $ S 1 $ S 1 $ S 1 $ S 1 $ S 1 $ not_absent

bamf x = baz x (S x (error "This is good!"))
{-# NOINLINE bamf #-}

main :: IO ()
main = bamf 10 `seq` return ()


-- Needs to be a product type
data Stream = S Int Stream

-- a is wrongly recorded abstent if the non-lazy-fv from foo are thrown away.
bar :: Int -> Int -> Stream -> Int
bar a n s = foo n s
  where
    -- Non terminating local rec, strict in a
    foo :: Int -> Stream -> Int
    foo 0 (S n s) = a
    foo i (S n s) = a `seq` n + foo (i-1) s
{-# NOINLINE bar #-}

baz :: Int -> Int -> Int
baz 0 not_absent = 0
baz 1 not_absent = baz 2 not_absent
baz x not_absent = bar not_absent 1000 arg
  where
    arg = S 1 arg

bamf x = baz x (error "This is good!")
{-# NOINLINE bamf #-}

main :: IO ()
main = bamf 10 `seq` return ()


import Control.Exception

-- This should result in the "What" exception, not the undefined.
{-# NOINLINE f #-}
f :: Int -> Int -> IO Int
f x y | x>0       = throwIO (userError "What")
      | y>0       = return 1
      | otherwise = return 2

main = f 2 undefined >>= print


module Main where

import Control.Concurrent.STM
import Control.Concurrent.STM.TVar

chkLoop :: TVar String -> STM ()
chkLoop v = do
  val <- readTVar v
  if (length val == 2) then retry else return ()

main :: IO ()
main = do
  v <- newTVarIO "hi"
  atomically $ do
    chkLoop v `orElse` return ()
    error "you're expected to see this"


module Main where

import T14285a
import Prelude hiding (null)

main :: IO ()
main = do
  let args = "hw"
  print $ null $ pre_images 'a' (Rel (fromList [('a',sfromList args)]) (fromList [('b',sfromList args)]))


module T14285a where

import qualified Data.Foldable as F
import qualified Data.IntMap as IM
import qualified Data.IntSet as IS
import Prelude hiding (null)

data Set k = Set IS.IntSet

empty = Set IS.empty

null (Set a) = IS.null a

sfromList :: (Enum a, Foldable c) => c a -> Set a
sfromList xs = Set $ IS.fromList $ Prelude.map fromEnum $ F.toList xs

{-# inlineable fromList #-}
fromList :: Enum k => [(k,v)] -> Map k v
fromList kvs =
  Map $ IM.fromList $ Prelude.map (\(k,v) -> (fromEnum k, v)) kvs

newtype Map k v = Map { unMap :: (IM.IntMap v) } deriving (Eq, Ord)

{-# inlineable findWithDefault #-}
findWithDefault d k (Map m) = IM.findWithDefault d (fromEnum k) m

data Rel a b = Rel !(Map a (Set b)) !(Map b (Set a))

{-# INLINEABLE images #-}
images x (Rel f b) = findWithDefault empty x f
{-# INLINEABLE pre_images #-}
pre_images x rel = images x $ mirrorRel rel
{-# INLINEABLE mirrorRel #-}
mirrorRel :: Rel a b -> Rel b a
mirrorRel (Rel f g) = Rel g f


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

main :: IO ()
main = r `seq` return ()

r :: Rec
r = Rec{ a = error "xxx", b = 3, c = True }

class C t
instance C Bool

data Rec = forall t. C t => Rec
  { a :: ()
  , b :: !Int
  , c :: t
  }


import System.IO.Unsafe (unsafePerformIO)

data T = T !Bool
data Box a = Box a

f :: Int -> T -> Box Bool
f n t
  | n <= 0 = case t of
      T b -> Box b
  | otherwise = f (n-2) t

f1 :: Int -> Bool -> Box Bool
f1 n t
  | n <= 0 = f (-n) $! T t
  | otherwise = f1 (n-2) t

g :: Int -> Bool
g k = if k <= 0
        then unsafePerformIO (putStrLn "Evaluated True" >> return True)
        else unsafePerformIO (putStrLn "Evaluated False" >> return False)
{-# NOINLINE g #-}

main :: IO ()
main = case f1 4 (g 0) of
    Box _ -> return ()


module Main where

data X = X ()

{-# NOINLINE newX #-}
newX :: () -> IO X
newX n = do
    let {-# NOINLINE value #-}
        value = n
    return (X value)

main = do
    x <- newX (error "Why?")
    case x of
        X _ -> return ()


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

import Control.Exception
main :: IO ()
main = do print (f False)
          print (f True)
          print (g undefined) `catchE` \_ -> putStrLn "g exception"
          print (h undefined) `catchE` \_ -> putStrLn "h exception"
          print (i undefined) `catchE` \_ -> putStrLn "i exception"
          putStrLn "Done"

catchE :: IO a -> (ErrorCall -> IO a) -> IO a
catchE = catch

f :: Bool -> String
f (view -> Nothing) = "Got Nothing"
f (view -> Just x)  = "Got Just " ++ show x

g :: Bool -> String
g (view -> x) = "g Got something"

h :: Bool -> String
h (view -> !x) = "h Got something"

i :: Bool -> String
i !(view -> x) = "i Got something"

view :: Bool -> Maybe Int
view False = Nothing
view True = Just 5


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

f :: (() -> (# Int#, () #)) -> ()
{-# NOINLINE f #-}
-- Strictness signature was (7.8.2)
--    <C(S(LS)), 1*C1(U(A,1*U()))>
-- I.e. calls k, but discards first component of result
f k = case k () of (# _, r #) -> r

g :: Int -> ()
g y = f (\n -> (# case y of I# y2 -> h (h (h (h (h (h (h y2)))))), n #))
   -- RHS is big enough to force worker/wrapper

{-# NOINLINE h #-}
h :: Int# -> Int#
h n = n +# 1#

main = print (g 1)


{-# LANGUAGE NoImplicitPrelude, MagicHash, UnboxedTuples, FlexibleInstances #-}
{-# OPTIONS_GHC -funbox-strict-fields #-}

module Arr (
        Array(..), (!!!), array
    ) where

import GHC.Num
import GHC.ST
import GHC.Base
import Good

data Array e = Array !Int !Int Int (Array# e)

array :: (Int,Int) -> [(Int, e)] -> Array e
array (l,u) ies
    = unsafeArray (l,u) [(index (l,u) i, e) | (i, e) <- ies]

unsafeArray :: (Int,Int) -> [(Int, e)] -> Array e
unsafeArray b ies = unsafeArray' b (rangeSize b) ies

unsafeArray' :: (Int,Int) -> Int -> [(Int, e)] -> Array e
unsafeArray' (l,u) n@(I# n#) ies =
  if n == 0 then error "aa" else runST (ST $ \s1# ->
    case newArray# n# arrEleBottom s1# of
        (# s2#, marr# #) ->
            foldr (fill marr#) (done l u n marr#) ies s2#)

{-# NOINLINE arrEleBottom #-}
arrEleBottom :: a
arrEleBottom = error "(Array.!): undefined array element"

unsafeAt :: Array e -> Int -> e
unsafeAt (Array _ _ _ arr#) (I# i#) =
    case indexArray# arr# i# of (# e #) -> e

fill :: MutableArray# s e -> (Int, e) -> STRep s a -> STRep s a
fill marr# (I# i#, e) next
 = \s1# -> case writeArray# marr# i# e s1# of
             s2# -> next s2#

done :: Int -> Int -> Int -> MutableArray# s e -> STRep s (Array e)
done l u n marr#
  = \s1# -> case unsafeFreezeArray# marr# s1# of
              (# s2#, arr# #) -> (# s2#, Array l u n arr# #)

instance Eq (Array e) where
    (Array l1 _ _ _) == (Array l2 _ _ _) = l1 == l2

instance Ord (Array e) where
    compare (Array l1 _ _ _) (Array l2 _ _ _) = compare l1 l2

{-# INLINE index #-}
index               :: (Int,Int) -> Int -> Int
index (m,n) i | m <= i && i <= n =  i - m
              | otherwise   =  error "index out of range"

rangeSize           :: (Int,Int) -> Int
rangeSize (l,h) = h - l + 1

{-# INLINE (!!!) #-}
(!!!) :: Array e -> Int -> e
arr@(Array l u _ _) !!! i = unsafeAt arr $ index (l,u) i

instance Good (Array Int) where
    isGood (Array _ _ n _) = 0 < n


module Base (
              Map(..)
            , lookup
            , empty
            , insert
            ) where

import Prelude hiding (lookup)
import Good

empty :: Map k a
empty = Tip

data Map k a  = Bin !k a !(Map k a) | Tip

insert :: Ord k => k -> a -> Map k a -> Map k a
insert = go
  where
    go :: Ord k => k -> a -> Map k a -> Map k a
    go kx x Tip = singleton kx x
    go kx x (Bin ky y r) =
        case compare kx ky of
            EQ -> Bin kx x r
            LT -> Bin ky y (go kx x r)
            GT -> Bin ky y (go kx x r)
{-# INLINABLE insert #-}

singleton :: k -> a -> Map k a
singleton k x = Bin k x Tip

lookup :: Eq k => k -> Map k a -> Maybe a
lookup = go
  where
    go x _ | x `seq` False = undefined
    go _ Tip = Nothing
    go k (Bin kx x r) = case k == kx of
      False -> go k r
      True -> Just x
{-# INLINABLE lookup #-}

instance Good k => Good (Map k a) where
  isGood Tip = True
  isGood (Bin k _ r) = isGood k && isGood r


module BuggyOpt
    (
      addSequence, -- induces inliner bug, but not used anywhere
    ) where

import M
import Prelude hiding (lookup)

addSequence :: Map (Array Int) Int -> Map (Array Int) Int
addSequence seqs =
  seq (isJust (lookup seq_ seqs)) (insert seq_ 5 seqs)

seq_ = array (2,2) [ (2,3)]


module Good (Good(..)) where

class Good a where
  isGood :: a -> Bool


module M (Array, (!!!), array, isJust, Map, lookup, insert, empty) where

import Arr (Array, (!!!), array)
import Base (Map, lookup, insert, empty)
import Prelude hiding (lookup)

isJust :: Maybe a -> Bool
isJust Nothing = False
isJust (Just _) = True


module Main where

import BuggyOpt() -- bug inducer!

import Prelude hiding (lookup)
import Good
import M

mkLin :: Array Int -> Map (Array Int) Int
mkLin mseqs =
   (isJust (lookup mseqs empty)) `seq` (insert mseqs 1 empty)

main :: IO ()
main = print $ isGood $ mkLin (array (1,1) [ (1,array (3,3) [(3, 42)]) ]!!!1)


module BottomFromInnerLambda where

expensive :: Int -> Int
expensive 0 = 0
expensive n = expensive n
{-# NOINLINE expensive #-}

-- We could be saying "<S(S),1*(U(U))><L,A>b"
-- but we are saying "<S(S),1*(U(U))>"
-- We should not be saying "<S(S),1*(U(U))>b"
f :: Int -> Int -> Int
f x = expensive x `seq` (\y -> error (show y))


module CaseBinderCPR where

-- This example, taken from nofib's transform (and heavily reduced) ensures that
-- CPR information is added to a case binder

f_list_cmp::(t1 -> t1 -> Int) -> [t1] -> [t1] -> Int;
f_list_cmp a_cmp [] []= 0
f_list_cmp a_cmp [] a_ys= -1
f_list_cmp a_cmp a_xs []= 1
f_list_cmp a_cmp (a_x:a_xs) (a_y:a_ys)=
    if r_order == 0
    then f_list_cmp a_cmp a_xs a_ys
    else r_order
  where
    r_order = a_cmp a_x a_y


{-# LANGUAGE GADTs #-}
module DmdAnalGADTs where

-- This tests the effect of different types in branches of a case

data D a where
    A :: D Int
    B :: D (Int -> Int)

hasCPR :: Int
hasCPR = 1

hasStrSig :: Int -> Int
hasStrSig x = x

diverges :: Int
diverges = diverges

-- The result should not have a CPR property
-- Because we are lubâ€™ing "m" and "<S,U>m" in the case expression.
f :: D x -> x
f x = case x of
    A -> hasCPR
    B -> hasStrSig

-- This should have the CPR property
f' :: D Int -> Int
f' x = case x of
    A -> hasCPR

-- The result should not be diverging, because one branch is terminating.
-- It should also put a strict, but not hyperstrict demand on x
g :: D x -> x
g x = case x of
    A -> diverges
    B -> \_ -> diverges


module FacState where

fac :: Int -> a ->  (a, Int)
fac n s | n < 2     = (s,1)
        | otherwise = case  fac (n-1) s of (s',n') -> let n'' = n*n' in n'' `seq` (s',n'')


module HyperStrUse where

f :: (Int, Int) -> Bool -> Int
f (x,y) True = error (show x)
f (x,y) False = x +1


-- Just an example on how to create tests that test the strictness analyzer

module StrAnalExample where

foo x = x


module T12370 where

foo :: (Int, Int) -> Int
foo (x,y) = x + y
{-# NOINLINE foo #-}

-- If the p is processed by LetUp, then we get nice use-once demands on n and m
bar n m =
    let p = (n,m)
        {-# NOINLINE p #-}
    in foo p


{-# LANGUAGE GADTs #-}

module T8569 where

data Rep t where
  Rint :: Rep Int
  Rdata :: Rep i -> (t -> i) -> Rep t

addUp :: Rep a -> a -> Int
addUp Rint n  = n
addUp (Rdata i f) x = addUp i (f x)


{-# LANGUAGE  MagicHash , UnboxedTuples #-}

module T8598(fun) where

import GHC.Float (Double(..))
import GHC.Integer (decodeDoubleInteger, encodeDoubleInteger)

-- Float.scaleFloat for Doubles, slightly simplified
fun :: Double -> Double
fun x | isFix           = x
      | otherwise       = case x of
          (D# x#) -> case decodeDoubleInteger x# of
            (# i, j #) -> D# (encodeDoubleInteger i j)
  where
  isFix = isDoubleFinite x == 0

foreign import ccall unsafe "isDoubleFinite" isDoubleFinite :: Double -> Int


module UnsatFun where

-- Here we test how a partially applied function (f x)
-- with a bottom result affects the strictness signature
-- when used strictly (g) and lazily (g')
--
-- In both cases, the parameter x should not be absent

f :: Int -> Int -> Int
f x y = error (show x)
{-# NOINLINE f #-}

h :: (Int -> Int) -> Int
h f = f 2
{-# NOINLINE h #-}

h2 :: Bool -> (Int -> Int) -> Int
h2 True  _ = 0
h2 False f = f 2
{-# NOINLINE h2 #-}

-- Should get a bottom result
g :: Int -> Int
g x = let f' = f x
      in h f'

-- Should not get a bottom result
g' :: Int -> Int
g' x = let f' = f x
       in h2 True f'

h3 :: (Int -> Int -> Int) -> Int
h3 f = f 2 `seq` 3
{-# NOINLINE h3 #-}

-- And here we check that the depth of the strictness
-- of h is applied correctly.
g3 :: Int -> Int
g3 x = h3 (\_ _ -> error (show x))


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

module ClosedFam1 where

import Language.Haskell.TH

$(do { decl <- [d| type family Foo a (b :: k) where
                     Foo Int Bool = Int
                     Foo a Maybe = Bool
                     Foo b (x :: Bool) = Char |]
     ; reportWarning (pprint decl)
     ; return [] })


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

module ClosedFam2 where

import Language.Haskell.TH

$( return [ ClosedTypeFamilyD
              (TypeFamilyHead
                (mkName "Equals")
                [ KindedTV (mkName "a") (VarT (mkName "k"))
                , KindedTV (mkName "b") (VarT (mkName "k")) ]
                ( TyVarSig (KindedTV (mkName "r") (VarT (mkName "k"))))
                Nothing)
              [ TySynEqn Nothing
                         (AppT (AppT (ConT (mkName "Equals")) (VarT (mkName "a")))
                               (VarT (mkName "a")))
                         (ConT (mkName "Int"))
              , TySynEqn Nothing
                         (AppT (AppT (ConT (mkName "Equals")) (VarT (mkName "a")))
                               (VarT (mkName "b")))
                         (ConT (mkName "Bool")) ] ])

a :: Equals b b
a = (5 :: Int)

b :: Equals Int Bool
b = False

$( return [ ClosedTypeFamilyD
               (TypeFamilyHead
                (mkName "Foo")
                [ KindedTV (mkName "a") (VarT (mkName "k"))]
                (KindSig StarT ) Nothing )
                [ TySynEqn Nothing
                           (AppT (AppKindT (ConT (mkName "Foo")) StarT)
                                 (VarT (mkName "a")))
                           (ConT (mkName "Int"))
                , TySynEqn Nothing
                           (AppT (AppKindT (ConT (mkName "Foo")) (AppT (AppT ArrowT StarT) (StarT)))
                                 (VarT (mkName "a")))
                           (ConT (mkName "Bool")) ] ])
c :: Foo Int
c = 5

d :: Foo Bool
d = 6

e :: Foo Maybe
e = False


{-# OPTIONS_GHC -fno-warn-missing-fields #-}
module T10047 where

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

n = QuasiQuoter { quoteExp = dyn }


{-# LANGUAGE TemplateHaskell #-}

module T10267 where

import Language.Haskell.TH
import T10267a

[d| i :: a -> a
    i = _foo

    j :: a -> a
    j x = _ |]

$(return [
   SigD (mkName "k")
        (ForallT [PlainTV (mkName "a")]
                 []
                 (AppT (AppT ArrowT (VarT (mkName "a"))) (VarT (mkName "a"))))
 , FunD (mkName "k")
        [Clause [] (NormalB (UnboundVarE (mkName "_foo"))) []]
 ])

$(return [
   SigD (mkName "l")
        (ForallT [PlainTV (mkName "a")]
                 []
                 (AppT (AppT ArrowT (VarT (mkName "a"))) (VarT (mkName "a"))))
 , FunD (mkName "l")
        [Clause [VarP (mkName "x")] (NormalB (UnboundVarE (mkName "_"))) []]
 ])

foo :: a -> a
foo x = $varX


{-# LANGUAGE TemplateHaskell #-}

module T10267a where

import Language.Haskell.TH

varX :: Q Exp
varX = [| x |]


module T10279 where
import Language.Haskell.TH
import Language.Haskell.TH.Syntax

-- NB: rts-1.0 is used here because it doesn't change.
-- You do need to pick the right version number, otherwise the
-- error message doesn't recognize it as a source package ID,
-- (This is OK,  since it will look obviously wrong when they
-- try to find the package in their package database.)
blah = $(conE (Name (mkOccName "Foo") (NameG VarName (mkPkgName "rts-1.0") (mkModName "A"))))


{-# LANGUAGE TemplateHaskell, TypeFamilies #-}

module T10306 where

import Language.Haskell.TH
import GHC.TypeLits

-- Attempting to reify a built-in type family like (+) previously
-- caused a crash, because it has no equations
$(do x <- reify ''(+)
     case x of
       FamilyI (ClosedTypeFamilyD _ []) _ -> return []
       _ -> error $ show x
 )


{-# LANGUAGE TemplateHaskell #-}
module T10596 where
import Language.Haskell.TH
import Language.Haskell.TH.Syntax
import System.IO

do
  putQ (100 :: Int)
  x <- (getQ :: Q (Maybe Int))

  -- It should print "Just 100"
  runIO $ print x
  runIO $ hFlush stdout
  return []


{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
module T10598_TH where

import Language.Haskell.TH

class C a
instance C Int

class C a => D a
instance D Int

{-
newtype Foo = MkFoo Int
  deriving stock    Eq
  deriving anyclass C
  deriving newtype  Read

deriving stock    instance Ord  Foo
deriving anyclass instance D    Foo
deriving newtype  instance Show Foo
-}

$(do fooDataName  <- newName "Foo"
     mkFooConName <- newName "MkFoo"
     let fooType = conT fooDataName
     sequence [ newtypeD (cxt []) fooDataName [] Nothing
                (normalC mkFooConName
                  [ bangType (bang noSourceUnpackedness noSourceStrictness)
                             [t| Int |] ])
                [ derivClause (Just StockStrategy)    [ [t| Eq   |] ]
                , derivClause (Just AnyclassStrategy) [ [t| C    |] ]
                , derivClause (Just NewtypeStrategy)  [ [t| Read |] ] ]
             , standaloneDerivWithStrategyD (Just StockStrategy)
                 (cxt []) [t| Ord $(fooType) |]
             , standaloneDerivWithStrategyD (Just AnyclassStrategy)
                 (cxt []) [t| D $(fooType) |]
             , standaloneDerivWithStrategyD (Just NewtypeStrategy)
                 (cxt []) [t| Show $(fooType) |] ])


{-# LANGUAGE TemplateHaskell #-}

module T10603 where

main = print $ $([| case Just 'a' of Just a -> Just ((\x -> x) a) |])


{-# LANGUAGE MagicHash, TemplateHaskell #-}
module Main where

import Language.Haskell.TH

main :: IO ()
main = do
    putStrLn $([| 'a'#   |] >>= stringE . show)
    putStrLn $([| "abc"# |] >>= stringE . show)


{-# LANGUAGE GHCForeignImportPrim, UnliftedFFITypes, QuasiQuotes, MagicHash #-}

import Language.Haskell.TH
import Language.Haskell.TH.Syntax

import GHC.Exts

{-
   the prim and javascript calling conventions do not support
   headers and the static keyword.
-}

-- check that quasiquoting roundtrips successfully and that the declaration
-- does not include the static keyword
test1 :: String
test1 = $(do (ds@[ForeignD (ImportF _ _ p _ _)]) <-
               [d| foreign import prim "test1" cmm_test1 :: Int# -> Int# |]
             addTopDecls ds
             case p of
              "test1" -> return (LitE . stringL $ p)
              _       -> error $ "unexpected value: " ++ show p
         )

-- check that constructed prim imports with the static keyword are rejected
test2 :: String
test2 = $(do t <- [t| Int# -> Int# |]
             cmm_test2 <- newName "cmm_test2"
             addTopDecls
               [ForeignD (ImportF Prim Safe "static test2" cmm_test2 t)]
             [| test1 |]
         )


{-# LANGUAGE TemplateHaskell #-}
module Main where

import Language.Haskell.TH

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

$(return [])

main :: IO ()
main = putStrLn $(reifyConStrictness 'T >>= stringE . show)


{-# LANGUAGE StrictData, TemplateHaskell #-}
module Main where

import Language.Haskell.TH
import T10697_sourceUtil

$([d|data A1 = A1                   Int {- No unpackedness, no strictness -}|])
$([d|data A2 = A2                  !Int {- No unpackedness, strict        -}|])
$([d|data A3 = A3                  ~Int {- No unpackedness, lazy          -}|])
$([d|data A4 = A4 {-# NOUNPACK #-}  Int {- NOUNPACK, no strictness        -}|])
$([d|data A5 = A5 {-# NOUNPACK #-} !Int {- NOUNPACK, strict               -}|])
$([d|data A6 = A6 {-# NOUNPACK #-} ~Int {- NOUNPACK, lazy                 -}|])
$([d|data A7 = A7 {-#   UNPACK #-}  Int {- UNPACK, no strictness          -}|])
$([d|data A8 = A8 {-#   UNPACK #-} !Int {- UNPACK, strict                 -}|])
$([d|data A9 = A9 {-#   UNPACK #-} ~Int {- UNPACK, lazy                   -}|])

$(do b1 <- newName "B1"
     b2 <- newName "B2"
     b3 <- newName "B3"
     b4 <- newName "B4"
     b5 <- newName "B5"
     b6 <- newName "B6"
     b7 <- newName "B7"
     b8 <- newName "B8"
     b9 <- newName "B9"
     c1 <- newName "C1"
     c2 <- newName "C2"
     c3 <- newName "C3"
     c4 <- newName "C4"
     c5 <- newName "C5"
     c6 <- newName "C6"
     c7 <- newName "C7"
     c8 <- newName "C8"
     c9 <- newName "C9"

     d1 <- makeSimpleDatatype b1 c1 noSourceUnpackedness noSourceStrictness
     d2 <- makeSimpleDatatype b2 c2 noSourceUnpackedness sourceStrict
     d3 <- makeSimpleDatatype b3 c3 noSourceUnpackedness sourceLazy
     d4 <- makeSimpleDatatype b4 c4 sourceNoUnpack       noSourceStrictness
     d5 <- makeSimpleDatatype b5 c5 sourceNoUnpack       sourceStrict
     d6 <- makeSimpleDatatype b6 c6 sourceNoUnpack       sourceLazy
     d7 <- makeSimpleDatatype b7 c7 sourceUnpack         noSourceStrictness
     d8 <- makeSimpleDatatype b8 c8 sourceUnpack         sourceStrict
     d9 <- makeSimpleDatatype b9 c9 sourceUnpack         sourceLazy
     return [d1, d2, d3, d4, d5, d6, d7, d8, d9])

main :: IO ()
main = mapM_ print [ $(checkBang ''E1 noSourceUnpackedness noSourceStrictness)
                   , $(checkBang ''E2 noSourceUnpackedness sourceStrict)
                   , $(checkBang ''E3 noSourceUnpackedness sourceLazy)
                   , $(checkBang ''E4 sourceNoUnpack       noSourceStrictness)
                   , $(checkBang ''E5 sourceNoUnpack       sourceStrict)
                   , $(checkBang ''E6 sourceNoUnpack       sourceLazy)
                   , $(checkBang ''E7 sourceUnpack         noSourceStrictness)
                   , $(checkBang ''E8 sourceUnpack         sourceStrict)
                   , $(checkBang ''E9 sourceUnpack         sourceLazy)
                   ]


{-# LANGUAGE StrictData, TemplateHaskell #-}
module T10697_sourceUtil where

import Language.Haskell.TH

makeSimpleDatatype :: Name
                   -> Name
                   -> SourceUnpackednessQ
                   -> SourceStrictnessQ
                   -> Q Dec
makeSimpleDatatype tyName conName srcUpk srcStr =
  dataD (cxt []) tyName [] Nothing [normalC conName
    [bangType (bang srcUpk srcStr) (conT ''Int)]] []

checkBang :: Name
          -> SourceUnpackednessQ
          -> SourceStrictnessQ
          -> ExpQ
checkBang n srcUpk1 srcStr1 = do
  TyConI (DataD _ _ _ _ [NormalC _ [(Bang srcUpk2 srcStr2, _)]] _) <- reify n
  srcUpk1' <- srcUpk1
  srcStr1' <- srcStr1
  if srcUpk1' == srcUpk2 && srcStr1' == srcStr2
    then [| True |]
    else [| False |]

data E1 = E1                   Int -- No unpackedness, no strictness
data E2 = E2                  !Int -- No unpackedness, strict
data E3 = E3                  ~Int -- No unpackedness, lazy
data E4 = E4 {-# NOUNPACK #-}  Int -- NOUNPACK, no strictness
data E5 = E5 {-# NOUNPACK #-} !Int -- NOUNPACK, strict
data E6 = E6 {-# NOUNPACK #-} ~Int -- NOUNPACK, lazy
data E7 = E7 {-#   UNPACK #-}  Int -- UNPACK, no strictness
data E8 = E8 {-#   UNPACK #-} !Int -- UNPACK, strict
data E9 = E9 {-#   UNPACK #-} ~Int -- UNPACK, lazy


{-# LANGUAGE MagicHash, TemplateHaskell #-}
module Main where

import GHC.Exts
import T10704a

main :: IO ()
main = do
  putStrLn $(fixityExp ''(->))
  putStrLn $(fixityExp ''Show)
  putStrLn $(fixityExp 'show)
  putStrLn $(fixityExp '(+))
  putStrLn $(fixityExp ''Int)
  putStrLn $(fixityExp ''Item)
  putStrLn $(fixityExp ''Char#)
  putStrLn $(fixityExp 'Just)
  putStrLn $(fixityExp 'seq)
  putStrLn $(fixityExp '($))
  putStrLn $(fixityExp ''(:=>))
  putStrLn $(fixityExp ''(:+:))
  putStrLn $(fixityExp ''(:*:))
  putStrLn $(fixityExp ''(:%:))
  putStrLn $(fixityExp ''(:?:))
  putStrLn $(fixityExp ''(:@:))


{-# LANGUAGE MultiParamTypeClasses, TypeFamilies, TypeOperators #-}
module T10704a where

import Language.Haskell.TH

infixl 1 :=>
infixl 2 :+:
infix  3 :*:
infix  4 :%:
infixr 5 :?:
infixr 6 :@:

class a :=> b
type a :+: b = Either a b
data a :*: b = a :*: b
newtype a :%: b = Percent (a, b)
data family a :?: b
type family a :@: b where a :@: b = Int

fixityExp :: Name -> Q Exp
fixityExp n = reifyFixity n >>= stringE . show


{-# LANGUAGE TemplateHaskell #-}
module Main where

import Language.Haskell.TH

main :: IO ()
main = do
  pprint <$> runQ [| do { let { }; return (); } |]             >>= putStrLn
  pprint <$> runQ [| do { let { x = 5 }; return x; } |]        >>= putStrLn
  pprint <$> runQ [| do { let { x = 5; y = 3 }; return x; } |] >>= putStrLn


{-# LANGUAGE TemplateHaskell #-}
module T10796a where

import Data.Ratio
import Data.Set (Set, fromList)
import Language.Haskell.TH.Syntax (liftData)

-- Data instance with toConstr implemented using a variable,
-- not a data constructor
splicedSet :: Set Char
splicedSet = $(liftData (fromList "test"))

-- Infix data constructor
splicedRatio :: Ratio Int
splicedRatio = $(liftData (1 % 2 :: Ratio Int))


{-# LANGUAGE TemplateHaskell #-}
module T10796b where

import Data.Set (Set, fromList)
import Language.Haskell.TH.Quote (dataToPatQ)

badPattern :: Set Char -> Set Char
badPattern s@($(dataToPatQ (const Nothing) (fromList "test"))) = s


{-# LANGUAGE TemplateHaskell #-}
{-# OPTIONS_GHC -ddump-splices -dsuppress-uniques #-}

module T10810 where

$([d| data Foo = (:!) |])


{-# LANGUAGE TemplateHaskell, TypeFamilies #-}

module Bug where

$([d| class C a where
        type F a
        type F a = a |])


{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}

module T10819 where

import T10819_Lib

import Language.Haskell.TH.Syntax

class C a b | b -> a where
  f :: b -> a

data D = X

instance C Int D where
  f X = 2

$(doSomeTH "N" (mkName "D")
    [DerivClause Nothing [ConT (mkName "C") `AppT` ConT (mkName "Int")]])

thing :: N
thing = N X

thing1 :: Int
thing1 = f thing


module T10819_Lib where

import Language.Haskell.TH.Syntax

doSomeTH s tp drv = return [NewtypeD [] n [] Nothing (NormalC n
    [(Bang NoSourceUnpackedness NoSourceStrictness, ConT tp)]) drv]
  where n = mkName s


{-# LANGUAGE LiberalTypeSynonyms #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE MagicHash #-}

module Main where

import Language.Haskell.TH.Syntax
import GHC.LanguageExtensions

main = do
  print $(isExtEnabled Cpp                  >>= lift)
  print $(isExtEnabled LiberalTypeSynonyms  >>= lift)
  print $(isExtEnabled RankNTypes           >>= lift)
  print $(isExtEnabled TypeSynonymInstances >>= lift)
  print $(isExtEnabled MagicHash            >>= lift)


{-# LANGUAGE TemplateHaskell, GADTs, ExplicitForAll, KindSignatures,
             TypeFamilies, DataKinds #-}

module T10828 where

import Language.Haskell.TH hiding (Type)
import System.IO
import Data.Kind (Type)

$( do { decl <- [d| data family D a :: Type -> Type
                    data instance D Int Bool :: Type where
                         DInt :: D Int Bool

                    data E where
                      MkE :: a -> E

                    data Foo a b where
                      MkFoo, MkFoo' :: a -> Foo a b

                    newtype Bar :: Type -> Bool -> Type where
                      MkBar :: a -> Bar a b
                 |]

      ; runIO $ putStrLn (pprint decl) >> hFlush stdout
      ; return decl }
 )

-- data T a :: Type where
--    MkT :: a -> a -> T a
--    MkC :: forall a b. (a ~ Int) => { foo :: a, bar :: b } -> T Int

$( return
   [ DataD [] (mkName "T")
           [ PlainTV (mkName "a") ]
           (Just StarT)
           [ GadtC [(mkName "MkT")]
                   [ ( Bang NoSourceUnpackedness NoSourceStrictness
                     , VarT (mkName "a")
                     )
                   , ( Bang NoSourceUnpackedness NoSourceStrictness
                     , VarT (mkName "a")
                     )
                   ]
                   (AppT (ConT (mkName "T"))
                         (VarT (mkName "a")))
           , ForallC [PlainTV (mkName "a"), PlainTV (mkName "b")]
                     [AppT (AppT EqualityT (VarT $ mkName "a"  ) )
                                           (ConT $ mkName "Int") ] $
             RecGadtC [(mkName "MkC")]
                  [ ( mkName "foo"
                    , Bang NoSourceUnpackedness NoSourceStrictness
                    , VarT (mkName "a")
                    )
                  , ( mkName "bar"
                    , Bang NoSourceUnpackedness NoSourceStrictness
                    , VarT (mkName "b")
                    )
                  ]
                  (AppT (ConT (mkName "T"))
                        (ConT (mkName "Int"))) ]
           [] ])

$( do { -- test reification
        TyConI dec <- runQ $ reify (mkName "T")
      ; runIO $ putStrLn (pprint dec) >> hFlush stdout

        -- test quoting
      ; d <- runQ $ [d|
             data T' a :: Type where
                MkT' :: a -> a -> T' a
                MkC' :: forall a b. (a ~ Int) => { foo :: a, bar :: b }
                                              -> T' Int |]
      ; runIO $ putStrLn (pprint d) >> hFlush stdout
      ; return [] } )


{-# LANGUAGE TemplateHaskell, GADTs, ExplicitForAll, KindSignatures #-}

module T10828a where

import Language.Haskell.TH
import System.IO

-- attempting to place a kind signature on a H98 data type
$( return
   [ DataD [] (mkName "T")
           [ PlainTV (mkName "a") ]
           (Just StarT)
           [ NormalC (mkName "MkT")
                   [ ( Bang NoSourceUnpackedness NoSourceStrictness
                     , VarT (mkName "a")
                     )
                   , ( Bang NoSourceUnpackedness NoSourceStrictness
                     , VarT (mkName "a")
                     )
                   ]
           ]
           [] ])