{-# LANGUAGE FlexibleInstances #-}

-- | Trusted library that unsafe plugins can use
module SafeLang09_A where

class Pos a where
    res :: a -> Bool

-- Any call to res with a list in out TCB
-- should use this method and never a more
-- specific one provided by an untrusted module
instance Pos [a] where
    res _ = True


{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverlappingInstances #-}

-- Untrusted plugin! Don't wan't it changing behaviour of our
-- trusted code
module SafeLang09_B where

import SafeLang09_A

instance Pos a where
    res _ = False

instance Pos [Int] where
    res _ = error "This curry is poisoned!"

function :: Int
function = 3


{-# LANGUAGE Trustworthy #-}
module Main where

import safe SafeLang10_A -- trusted lib
import safe SafeLang10_B -- untrusted plugin

main = do
    let r = res [(1::Int)]
    putStrLn $ "Result: " ++ show r
    putStrLn $ "Result: " ++ show function


{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE Trustworthy #-}

-- | Trusted library that unsafe plugins can use
module SafeLang10_A where

class Pos a where
    res :: a -> Bool

-- Any call to res with a list in out TCB
-- should use this method and never a more
-- specific one provided by an untrusted module
instance Pos [a] where
    res _ = True


{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE Safe #-}

-- Untrusted plugin! Don't wan't it changing behaviour of our
-- trusted code
module SafeLang10_B where

import SafeLang10_A

instance {-# OVERLAPPABLE #-} Pos a where
    res _ = False

instance {-# OVERLAPPING #-} Pos [Int] where
    res _ = error "This curry is poisoned!"

function :: Int
function = 3


{-# LANGUAGE TemplateHaskell #-}
module Main where

import SafeLang11_A
import SafeLang11_B

$(mkSimpleClass ''A)

main = do
    let b = c :: A
    putStrLn $ "I have a value of A :: " ++ show b


{-# LANGUAGE Safe #-}
module SafeLang11_A ( A ) where

data A = A1 | A2

instance Show A where
    show A1 = "A1 is secret!"
    show A2 = "A2 is secret!"


{-# LANGUAGE TemplateHaskell #-}
module SafeLang11_B ( Class(..), mkSimpleClass ) where

import Language.Haskell.TH

class Class a where
        c :: a

mkSimpleClass :: Name -> Q [Dec]
mkSimpleClass name = do
        TyConI (DataD [] dname [] Nothing cs _) <- reify name
        ((NormalC conname []):_) <- return cs
        ClassI (ClassD [] cname [_] [] [SigD mname _]) _ <- reify ''Class
        return [InstanceD Nothing [] (AppT (ConT cname) (ConT dname)) [FunD mname
            [Clause [] (NormalB (ConE conname)) []]]]


{-# LANGUAGE Safe #-}
{-# LANGUAGE TemplateHaskell #-}
module Main where

import SafeLang12_A
import SafeLang12_B

$(mkSimpleClass ''A)

main = do
    let b = c :: A
    putStrLn $ "I have a value of A :: " ++ show b


{-# LANGUAGE Safe #-}
module SafeLang12_A ( A ) where

data A = A1 | A2

instance Show A where
    show A1 = "A1 is secret!"
    show A2 = "A2 is secret!"


{-# LANGUAGE Safe #-}
{-# LANGUAGE TemplateHaskell #-}
module SafeLang12_B ( Class(..), mkSimpleClass ) where

import Language.Haskell.TH

class Class a where
        c :: a

mkSimpleClass :: Name -> Q [Dec]
mkSimpleClass name = do
        TyConI (DataD [] dname [] Nothing cs _) <- reify name
        ((NormalC conname []):_) <- return cs
        ClassI (ClassD [] cname [_] [] [SigD mname _]) _ <- reify ''Class
        return [InstanceD Nothing [] (AppT (ConT cname) (ConT dname)) [FunD mname
            [Clause [] (NormalB (ConE conname)) []]]]


{-# LANGUAGE DeriveDataTypeable, StandaloneDeriving #-}
-- | This shows how to use typeable to perform unsafe
-- casts. Basically its an example of what Safe Haskell
-- should disallow. SafeLang14 will do that.
module Main where

import SafeLang15_A
import Data.Typeable

data H = H String deriving (Typeable, Show)

data G = G Int deriving (Show)

deriving instance Typeable G

deriving instance Typeable P

main = do
    let h = H "Hello World"
        g = G 1
--        Just h' = (cast h) :: Maybe G
        Just p' = (cast p) :: Maybe G
        Just px = (cast $ incrG p') :: Maybe P
    putStrLn $ show h
    putStrLn $ show g
--    putStrLn $ show h'
    putStrLn $ showP p
    putStrLn $ show p'
    putStrLn $ showP px

incrG :: G -> G
incrG (G n) = G $ n + 1


module SafeLang15_A (IsoInt, h, showH, P, p, showP) where

newtype IsoInt = I Int

h :: IsoInt
h = I 2

showH :: String
showH = let I n = h
        in show n

data P = P Int

p :: P
p = P 3

showP :: P -> String
showP (P n) = "Should be 3 := " ++ show n


{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE Safe #-}

-- | Test SafeLanguage disables things
-- Testing ordering doesn't matter this time
-- with Safe appearing after TH.
module SafeLang16 where

f :: Int
f = 1


{-# LANGUAGE Trustworthy #-}
module Main where

import SafeLang17_A -- trusted lib
import SafeLang17_B -- untrusted plugin

main = do
    let r = res [(1::Int)]
    putStrLn $ "Result: " ++ show r
    putStrLn $ "Result: " ++ show function


{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE FlexibleInstances #-}

-- | Trusted library that unsafe plugins can use
module SafeLang17_A where

class Pos a where
    res :: a -> Bool

-- Any call to res with a list in out TCB
-- should use this method and never a more
-- specific one provided by an untrusted module
instance Pos [a] where
    res _ = True


{-# LANGUAGE Safe #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE IncoherentInstances #-}

-- Untrusted plugin! Don't wan't it changing behaviour of our
-- trusted code
module SafeLang17_B where

import SafeLang17_A

instance Pos a where
    res _ = False

instance Pos [Int] where
    res _ = error "This curry is poisoned!"

function :: Int
function = 3


{-# LANGUAGE CPP #-}
#if __GLASGOW_HASKELL__ >= 703
{-# LANGUAGE Safe #-}
#endif
module SafeLang18 where

#define p377 toPair

data StrictPair a b = !a :*: !b

toPair :: StrictPair a b -> (a, b)
toPair (x :*: y) = (x, y)
{-# INLINE p377 #-}


module SafeRecomp01 where

f :: Int
f = 1


module Main where

import SafeRecomp02_A

f :: Int
f = 1

main :: IO ()
main = putStrLn $ show $ f + g


module SafeRecomp02_A where

g :: Int
g = 1


{-# LANGUAGE Safe #-}
-- | Import unsafe module System.IO.Unsafe to make sure it fails
module Main where

import System.IO.Unsafe

f :: Int
f = unsafePerformIO $ putStrLn "What kind of swallow?" >> return 2

main :: IO ()
main = putStrLn $ "X is: " ++ show f


{-# LANGUAGE Safe #-}
-- | Import unsafe module Debug.Trace to make sure it fails
module Main where

import Debug.Trace

f :: Int
f = trace "What kind of swallow?" 2

main :: IO ()
main = putStrLn $ "X is: " ++ show f


{-# LANGUAGE Safe #-}
-- | Import unsafe module Unsafe.Coerce to make sure it fails
module Main where

import Unsafe.Coerce

f :: Int
f = 2

main :: IO ()
main = putStrLn $ "X is: " ++ show f


{-# LANGUAGE Safe #-}
-- | Import unsafe module Control.ST to make sure it fails
module Main where

import Control.Monad.ST.Unsafe

f :: Int
f = 2

main :: IO ()
main = putStrLn $ "X is: " ++ show f


{-# LANGUAGE Safe #-}
-- | Import unsafe module Control.ST to make sure it fails
module Main where

import Control.Monad.ST.Lazy.Unsafe

f :: Int
f = 2

main :: IO ()
main = putStrLn $ "X is: " ++ show f


{-# LANGUAGE Safe #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE UnboxedTuples #-}
module Dep05 where

import GHC.Arr

bad1 = unsafeArray

bad2 = fill

bad3 = done

bad4 = unsafeThawSTArray


{-# LANGUAGE Safe #-}
module Dep06 where

import GHC.Conc

bad1 = unsafeIOToSTM


{-# LANGUAGE Safe #-}
module Dep07 where

import GHC.ForeignPtr

bad1 = unsafeForeignPtrToPtr


{-# LANGUAGE Safe #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
module Dep08 where

import GHC.IOArray

bad1 = unsafeReadIOArray

bad2 = unsafeWriteIOArray


{-# LANGUAGE Safe #-}
module Dep09 where

import GHC.Ptr

bad1 = castFunPtrToPtr


{-# LANGUAGE Safe #-}
module Dep10 where

import GHC.ST

bad1 = liftST

bad2 = unsafeInterleaveST


{-# LANGUAGE Safe #-}
-- | Import SYB stuff that should be safe
module Main where

import Data.Typeable
import Data.Dynamic
import Data.Data

f :: Int
f = 2

main :: IO ()
main = putStrLn $ "X is: " ++ show f


{-# LANGUAGE Safe #-}
-- | Import (now safe by default) modules.
module Main where

import Control.Monad.ST
import Control.Monad.ST.Lazy
import Foreign.ForeignPtr
import Foreign

f :: Int
f = 2

main :: IO ()
main = putStrLn $ "X is: " ++ show f


{-# LANGUAGE Safe #-}
{-# OPTIONS_GHC -fno-warn-deprecations #-}
-- | Import all modules from prelude that should be safe
module Main where

import Numeric
import Prelude

import Control.Applicative
import Control.Arrow
import Control.Category

import Control.Concurrent
import Control.Concurrent.Chan
import Control.Concurrent.MVar
import Control.Concurrent.QSem
import Control.Concurrent.QSemN

import Control.Exception
import Control.Exception.Base

import Control.Monad
import Control.Monad.Fix
import Control.Monad.Instances
import Control.Monad.Zip

import Control.Monad.ST
import Control.Monad.ST.Lazy
import Control.Monad.ST.Strict

import Data.Bifunctor
import Data.Bits
import Data.Bool
import Data.Char
-- import Data.Coerce
import Data.Complex
import Data.Data
import Data.Dynamic
import Data.Either
import Data.Eq
import Data.Fixed
import Data.Foldable
import Data.Function
import Data.Functor.Identity
import Data.Functor
import Data.IORef
import Data.Int
import Data.Ix
import Data.List
import Data.Maybe
import Data.Monoid
import Data.Ord
import Data.Proxy
import Data.Ratio
import Data.String
import Data.Traversable
import Data.Tuple
import Data.Typeable
import Data.Unique
import Data.Version
import Data.Word

import Data.STRef
import Data.STRef.Lazy
import Data.STRef.Strict

import Data.Type.Bool
-- import Data.Type.Coercion
-- import Data.Type.Equality

-- import Debug.Trace

import Foreign

import Foreign.Concurrent
import Foreign.ForeignPtr
import Foreign.Ptr
import Foreign.StablePtr
import Foreign.Storable

import Foreign.C
import Foreign.C.Error
import Foreign.C.String
import Foreign.C.Types

import Foreign.Marshal
import Foreign.Marshal.Alloc
import Foreign.Marshal.Array
import Foreign.Marshal.Error
import Foreign.Marshal.Pool
import Foreign.Marshal.Utils

import System.CPUTime
import System.Console.GetOpt
import System.Environment
import System.Exit
import System.IO
import System.IO.Error
import System.Info
import System.Mem
import System.Mem.StableName
import System.Mem.Weak
import System.Posix.Internals
import System.Posix.Types
import System.Timeout

import Text.ParserCombinators.ReadP
import Text.ParserCombinators.ReadPrec
import Text.Printf
import Text.Read
import Text.Read.Lex
import Text.Show
import Text.Show.Functions

import Type.Reflection

-- import Unsafe.Coerce

f :: Int
f = 2

main :: IO ()
main = putStrLn $ "X is: " ++ show f


{-| `elem`, 'print',
`Unknown',
'<>', ':=:', 'Bool'
-}
module DocsInHiFile
  ( DocsInHiFile.elem
  , D(..)
  , add
  , P(..)
  , Show(..)
  ) where

-- | '()', 'elem'.
elem :: ()
elem = ()

-- | A datatype.
data D
  = D0 -- ^ A constructor for 'D'. '
  | D1 -- ^ Another constructor
  deriving ( Show -- ^ 'Show' instance
           )

add :: Int -- ^ First summand for 'add'
    -> Int -- ^ Second summand
    -> Int -- ^ Sum
add a b = a + b

-- | A class
class P f where
  -- | A class method
  p :: a -- ^ An argument
    -> f a

-- | Another datatype...
data D'
-- ^ ...with two docstrings.


{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -O -Wno-inline-rule-shadowing #-}
-- Rules are ignored without -O

module Orphans where

import GHC.Exts (IsList(..))

-- Some orphan things
instance IsList Bool where
  type Item Bool = Double
  fromList = undefined
  toList = undefined

{-# RULES "myrule1" id id = id #-}

-- And some non-orphan things
data X = X [Int]
instance IsList X where
  type Item X = Int
  fromList = undefined
  toList = undefined

f :: X -> X
f x = x
{-# RULES "myrule2" id f = f #-}


-- !!! This one sent 4.06 into an infinite loop

-- But it worked ok if Simpl006Help.forever is
-- defined in this module.  I have no idea why!

{-# OPTIONS -O #-}

module ShouldCompile where

import Control.Concurrent
import Simpl006Help

after :: Int -> IO a -> IO a
after d c = c

every :: Int -> IO a -> IO ()
every d c = forever (after d c)


module Simpl006Help( forever ) where

forever c  = sequence_ (repeat c)


-- This one killed GHC 5.02 with a funResultTy panic
-- The reason was that the simplifier was doing a
-- case-of-case where the result had a polymorphic type.
-- This in turn showed up because of a newtype (now
-- transparent) with a forall inside it.
--
-- It's quite hard to tickle this one, hence the two-module setup.

module FormParse where

import Control.Monad
import Simpl009Help

identifier :: Parser Char Char
identifier =
  do c <- lookAhead
     guard (c == 'a')
     return c


{-# LANGUAGE ScopedTypeVariables, RankNTypes #-}

-- Helper for simpl009.hs (see comments there)

module Simpl009Help where

import Control.Applicative (Applicative(..), Alternative(empty, (<|>)))
import Control.Monad

newtype Parser s a
  = Parser (forall res . (a -> [String] -> P s res) -> [String] -> P s res)

data P s res
  = Symbol (s -> P s res)
  | Fail [String] [String]
  | Result res (P s res)

instance Functor (Parser s) where
    fmap = liftM

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

instance Monad (Parser s) where
  return a = Parser (\fut -> fut a)

  Parser f >>= k =
    Parser (\fut -> f (\a -> let Parser g = k a in g fut))

  fail s =
    Parser (\fut exp -> Fail exp [s])

instance Alternative (Parser s) where
    empty = mzero
    (<|>) = mplus

instance MonadPlus (Parser s) where
  mplus = error "urk"
  mzero = Parser (\fut exp -> Fail exp [])

lookAhead :: forall s. Parser s s
lookAhead =
  Parser (\fut exp -> Symbol (\c ->
    feed c (fut c [])
  ))
 where
  feed :: forall res. s -> P s res -> P s res
  feed c (Symbol sym)     = sym c
  feed c (Result res fut) = Result res (feed c fut)
  feed c p@(Fail _ _)     = p


module OneShot1 where

import GHC.Base

-- This oneShot is a lie, and together with unsafePerformIO (in the form of
-- trace) in OneShot2, we can observe the difference.

-- Two modules to ensure that oneShot annotations surive interface files, both
-- in explicits unfoldings (foo) and in unannotated functions (baz)

foo :: Int -> Int -> Int
foo y = oneShot (\x -> x+y)
{-# INLINE foo #-}

bar :: Int -> Int -> Int
bar y = (\x -> y+x)
{-# INLINE bar #-}

baz :: Int -> Int -> Int
baz y = oneShot (\x -> x+y)


import OneShot1
import System.Environment
import Debug.Trace

p n = trace "p evaluated" (n > 0)
{-# NOINLINE p #-}

summap :: (Int -> Int) -> (Int -> Int)
summap f n = sum $ map f [1..10]
{-# NOINLINE summap #-}

foo' n = if p n then foo n else foo (n+1)
{-# NOINLINE foo' #-}

bar' n = if p n then bar n else bar (n+1)
{-# NOINLINE bar' #-}

baz' n = if p n then baz n else baz (n+1)
{-# NOINLINE baz' #-}

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


{-# LANGUAGE TypeFamilies, FlexibleContexts #-}

-- This one sent an earlier version of GHC into a
-- loop in the simplfier, because we allowed a RULE
-- to fire on a loop-breaker
--
-- Discovered by Roman L, Nov 09

module Roman where

data T a = T (T a)

type family F a
type instance F (T a) = Wrap (T a)

class B (F a) => C a where
  toF :: a -> F a

go :: C a => a -> Int
{-# INLINE go #-}
go x = gow (toF x)

instance C a => C (T a) where
  {-# INLINE toF #-}
  toF x = Wrap x

newtype Wrap a = Wrap a

class B a where
  dummy :: a

  gow :: a -> Int

instance C a => B (Wrap a) where
  {-# INLINE gow #-}
  gow (Wrap x) = go x
  dummy = error "urk"

foo :: C a => T a -> Int
foo t = let t' = T t in go t'


-- There was a bug in 6.12 that meant that the binding
-- for 'rght' was initially determined (correctly) to be
-- strictly demanded, but the FloatOut pass made it lazy
--
-- The test compiles the program and greps for the
-- binding of 'rght' to check that it is marked strict
-- something like this:
--         rght [Dmd=Just S] :: EvalTest.AList a

module EvalTest where

import GHC.Conc

import Control.Applicative (Applicative(..))
import Control.Monad (liftM, ap)

data Eval a = Done a

instance Functor Eval where
    fmap = liftM

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

instance Monad Eval where
  return x = Done x
  Done x >>= k = k x   -- Note: pattern 'Done x' makes '>>=' strict

rpar :: a -> Eval a
rpar x = x `par` return x

rseq :: a -> Eval a
rseq x = x `pseq` return x

runEval :: Eval a -> a
runEval (Done x) = x

data AList a = ANil | ASing a | Append (AList a) (AList a) | AList [a]

append ANil r = r
append l ANil = l -- **
append l r    = Append l r

parListTreeLike :: Integer -> Integer -> (Integer -> a) -> AList a
parListTreeLike min max fn
 | max - min <= threshold = ASing (fn max)
 | otherwise  =
      runEval $ do
        rpar rght
        rseq left
        return (left `append` rght)
    where
      mid  = min + ((max - min) `quot` 2)
      left = parListTreeLike min mid fn
      rght = parListTreeLike (mid+1) max fn

threshold = 1


module Noinline01 where
import GHC.Magic

{-# INLINE f #-}
f x = True

g = noinline f False


module Par01 where

import GHC.Conc

-- The smoking gun in -ddump-prep is:
--  case Par01.depth d of sat { __DEFAULT -> sat }
-- this should never happen!

depth :: Int -> Int
depth d = d `par` depth d


-- This one triggers the bug reported in Trac #1092
-- The problem is that the rule
--      forall w. f (\v->w) = w
-- erroneously matches the call
--      f id
--
-- Lint catches the error

module Foo where

f :: (Int -> Int) -> Int
{-# NOINLINE f #-}
f g = g 4
{-# RULES
  "f" forall w. f (\v->w) = w
 #-}

h = f id


{-# LANGUAGE RankNTypes #-}
{-# OPTIONS_GHC -ddump-simpl-stats #-}

-- The rule foo/bar should fire

module Roman where

foo :: (forall m. m a -> m b) -> m a -> m b
{-# NOINLINE foo #-}
foo f = f

bar :: (forall m. m a -> m a) -> m a -> m a
bar f = f

{-# RULES "foo/bar" foo = bar #-}

blip = foo id


-- See Trac #1370
-- THis made GHC 6.6 diverge!

module ShouldCompile where

newtype T = V T deriving(Eq,Ord)


-- !!! Desugaring sections with function-type arguments
--  Although this is really a desugaring test, the problem is
-- only tickled by the simplifier

-- type Foo a b = a -> (b -> a) -> b
module ShouldCompile where

(++++) :: (a -> (b -> a) -> b) -> (a -> (b -> a) -> b) -> a -> (b -> a) -> b
x ++++ y = y

g a xs = map (++++ a) xs

h b xs = map (b ++++) xs


{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}

-- !!! class/instance mumble that failed Lint at one time
--
module ShouldCompile where
class Foo a where
   op :: Int -> a -> Bool

data Wibble a b c = MkWibble a b c

instance (Foo a, Foo b, Foo c) => Foo (Wibble a b c) where
    op x y = error "xxx"


-- !! INLINE on recursive functions.
{-
Date: Thu, 8 Dec 94 11:38:24 GMT
From: Julian Seward (DRL PhD) <sewardj@computer-science.manchester.ac.uk>
Message-Id: <9412081138.AA16652@rdf009.cs.man.ac.uk>
To: partain@dcs.gla.ac.uk
-}
module ShouldCompile where

type IMonad a
   = IMonadState -> IMonadReturn a

data IMonadReturn a
   = IMonadOk   IMonadState a
   | IMonadFail IMonadState String

type IMonadState
   = Int

returnI r = \s0 -> IMonadOk   s0 r

failI msg = \s0 -> IMonadFail s0 msg

thenI m k
   = \s0 -> case m s0 of
               IMonadFail s1 msg -> IMonadFail s1 msg
               IMonadOk s1 r1    -> k r1 s1

tickI n = \s0 -> IMonadOk (s0+n) ()

mapI f [] = returnI []
mapI f (x:xs) = f x           `thenI` ( \ fx ->
                mapI f xs     `thenI` ( \ fxs ->
                returnI (fx:fxs)
                ))

{-# INLINE returnI #-}
{-# INLINE failI #-}
{-# INLINE thenI #-}
{-# INLINE tickI #-}
-- {-# INLINE mapI #-}


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

module ShouldCompile where

import Data.Ix
import GHC.Exts

f ixs@(_, ix_end) frozen# =
 let
  !n# =
   case (
         if null (range ixs)
          then 0
          else 1
        ) of { I# x -> x }
 in
 (# frozen#, False #)


-- !!! CPR on newtype with polymorphic argument

{-# OPTIONS -O #-}

module ShouldCompile where

data StateM m s a = STM (s -> m (a,s))

instance Functor m => Functor (StateM m s) where
  fmap f (STM xs) =  STM (\s -> fmap (\ (x,s') -> (f x, s'))
                                     (xs s)
                         )
{-      With GHC 4.04 (first release) this program gave:

  panic! (the `impossible' happened):
          mk_cpr_let: not a product
      forall a{-ruq-} b{-rur-}.
      (a{-ruq-} -> b{-rur-})
      -> MonadLibrary.StateM{-r2o,x-} m{-a30Y-} s{-a30Z-} a{-ruq-}
      -> MonadLibrary.StateM{-r2o,x-} m{-a30Y-} s{-a30Z-} b{-rur-}

 The reason: 'Functor' is a newtype, whose element is a for-all type.

        newtype Functor f = Functor (forall a,b.  (a->b) -> f a -> f b)
-}


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

-- module Formula where
module Main where

import Prelude hiding (logBase)

import Data.Maybe

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

-- Formula
-- The data type for formulas (algegraic expressions).
--
-- It should be an extensible type, so that users of
-- the library can add new kinds of formulas.
-- For example, in this prototype I explore:
--   integer constants (FInt)
--   unknown variables (FVar)
--   sums (FSum)
--   products (FPro)
--   powers (FPow)
--   logarithms (FLog)
-- The user of the library may want to extend it with
-- trigonometric formulas or derivative formulas, for
-- example.
--
-- The idea is to let each kind of formula be a new data
-- type. Similar operations with them are implemented
-- using overloading. So there is a class (FORMULA) to collect
-- them and each kind of formula should be an instance of it.

class (Eq f, Show f) => FORMULA f where
    ty      :: f -> FType
    intVal  :: f -> Integer
    varName :: f -> String
    argList :: f -> [Formula]
    same    :: (FORMULA f1) => f -> f1 -> Bool
    intVal   = error ""
    varName  = error ""
    argList  = error ""
    same _ _ = False

-- By now extensibility is accomplished by existentially
-- quantified type variables.

data Formula = forall f . ( FORMULA f
                          , AddT f
                          ) =>
               Formula f

instance Show Formula where
    show (Formula f) = show f

instance Eq Formula where
    (Formula x) == (Formula y) = same x y

instance FORMULA Formula where
    ty (Formula f) = ty f
    intVal (Formula f) = intVal f
    varName (Formula f) = varName f
    argList (Formula f) = argList f
    same (Formula f) = same f

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

-- How to uniquely identify the type of formula?
-- Each type of formula is associated to a key (FType)
-- that identifies it.
--
-- Here I use an enumated data type. When extending
-- the library, the user will have to modify this
-- data type adding a new constant constructor.

data FType = INT
           | VAR
           | SUM
           | PRO
           | POW
           | LOG
             deriving (Eq,Ord,Enum,Show)

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

-- Integer formula

data FInt = FInt Integer
            deriving (Eq,Show)

mkInt = Formula . FInt

instance FORMULA FInt where
    ty _ = INT
    intVal (FInt x) = x
    same (FInt x) y = isInt y && x == intVal y

-- Variable formula

data FVar = FVar String
            deriving (Eq,Show)

mkVar = Formula . FVar

instance FORMULA FVar where
    ty _ = VAR
    varName (FVar x) = x
    same (FVar x) y = isVar y && x == varName y

-- Sum formula

data FSum = FSum [Formula]
            deriving (Eq,Show)

mkSum = Formula . FSum

instance FORMULA FSum where
    ty _ = SUM
    argList (FSum xs) = xs
    same (FSum xs) y = isSum y && xs == argList y

-- Product formula

data FPro = FPro [Formula]
            deriving (Eq,Show)

mkPro = Formula . FPro

instance FORMULA FPro where
    ty _ = PRO
    argList (FPro xs) = xs
    same (FPro xs) y = isPro y && xs == argList y

-- Exponentiation formula

data FPow = FPow Formula Formula
            deriving (Eq,Show)

mkPow x y = Formula (FPow x y)

instance FORMULA FPow where
    ty _ = POW
    argList (FPow b e) = [b,e]
    same (FPow b e) y = isPow y && [b,e] == argList y

-- Logarithm formula

data FLog = FLog Formula Formula
            deriving (Eq,Show)

mkLog x b = Formula (FLog x b)

instance FORMULA FLog where
    ty _ = LOG
    argList (FLog x b) = [x,b]
    same (FLog x b) y = isLog y && [x,b] == argList y

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

-- Some predicates

isInt x = ty x == INT
isVar x = ty x == VAR
isSum x = ty x == SUM
isPro x = ty x == PRO
isPow x = ty x == POW

isZero x = isInt x && intVal x == 0

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

-- Adding two formulas
-- This is a really very simple algorithm for adding
-- two formulas.

add :: Formula -> Formula -> Formula
add x y
    | isJust u  = fromJust u
    | isJust v  = fromJust v
    | otherwise = mkSum [x,y]
    where
    u = addT x y
    v = addT y x

class AddT a where
    addT :: a -> Formula -> Maybe Formula
    addT _ _ = Nothing

instance {-# OVERLAPPABLE #-} (FORMULA a) => AddT a where {}

instance AddT Formula where
    addT (Formula f) = addT f

instance AddT FInt where
    addT (FInt 0) y  = Just y
    addT (FInt x) y
         | isInt y   = Just (mkInt (x + intVal y))
         | otherwise = Nothing

instance AddT FSum where
    addT (FSum xs) y
         | isSum y   = Just (mkSum (merge xs (argList y)))
         | otherwise = Just (mkSum (merge xs [y]))
         where
         merge = (++)

instance AddT FLog where
    addT (FLog x b) y
         | isLog y && b == logBase y = Just (mkLog (mkPro [x,logExp y]) b)
         | otherwise                 = Nothing
         where
         merge = (++)

isLog x = ty x == LOG

logBase x
    | isLog x = head (tail (argList x))

logExp x
    | isLog x = head (argList x)

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

-- Test addition of formulas

main = print [ add (mkInt 78)  (mkInt 110)
             , add (mkInt 0)   (mkVar "x")
             , add (mkVar "x") (mkInt 0)
             , add (mkVar "x") (mkVar "y")
             , add (mkSum [mkInt 13,mkVar "x"]) (mkVar "y")
             , add (mkLog (mkVar "x") (mkInt 10))
                   (mkLog (mkVar "y") (mkInt 10))
             , add (mkLog (mkVar "x") (mkInt 10))
                   (mkLog (mkVar "y") (mkVar "e"))
             ]


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

-- This one killed GHC 6.0, with a "panic: applyTys"
-- Only with -O, though

module ShouldCompile where

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

foo = case undefined of
        R f -> f ()


{-# LANGUAGE ExistentialQuantification #-}

-- This tests an interaction between GADTs and join points
-- The case-of-case transformation can pretty easily result
-- in a type mis-match, because the join point does not see
-- the refinement from the case branch

module ShouldCompile( h ) where

data T a = forall b. T b [a] | T2

f :: a -> T a -> [a]
f x (T _ a) = a ++ a ++ a ++ [x]
f x T2      = [x]

h :: a -> Bool -> T a -> T a -> [a]
h x b p q = f x (case b of { True -> p; False -> q })


{-# LANGUAGE CPP, RankNTypes, ScopedTypeVariables, KindSignatures,
             MultiParamTypeClasses, FunctionalDependencies #-}

-- This one triggered a bug in the indirection-shorting
-- machinery, which gave a core-lint error

module MHashTable (STHashTable, new, update) where

import Data.Kind            (Type)
import Data.Int             (Int32)
import Control.Monad.ST     (ST)
import Data.STRef           (STRef)
import Data.Array.ST        (STArray)
import Data.Array.MArray    (writeArray)

class Monad m => MutHash arr ref m | arr -> m, ref -> m
                                   , arr -> ref, ref -> arr where
    newMHArray  :: (Int32, Int32) -> a -> m (arr Int32 a)
    readMHArray :: arr Int32 a -> Int32 -> m a
    writeMHArray:: arr Int32 a -> Int32 -> a -> m ()

    newMHRef    :: a -> m (ref a)
    readMHRef   :: ref a -> m a
    writeMHRef  :: ref a -> a -> m ()

instance MutHash (STArray s) (STRef s) (ST s) where
    newMHArray  = undefined
    readMHArray = undefined
    writeMHArray= writeArray

    newMHRef    = undefined
    readMHRef   = undefined
    writeMHRef  = undefined

type STHashTable s key val = HashTable key val (STArray s) (STRef s) (ST s)

newtype HashTable key val arr ref m = HashTable (ref (HT key val arr ref m))

data HT key val arr (ref :: Type -> Type) (m :: Type -> Type) =
  HT { dir :: (arr Int32 (arr Int32 [(key,val)])) }

new :: forall arr ref m key val. (MutHash arr ref m) => m (HashTable key val arr ref m)
new = do
  (dir::arr Int32 (arr Int32 [(key,val)]))  <- newMHArray (0,0) undefined
  (segment::arr Int32 [(key,val)])          <- return undefined
  return (undefined :: HashTable key val arr ref m)

{-# RULES "update/ST" update = updateST #-}
updateST:: STHashTable s k v -> k -> v -> ST s Bool
updateST= update'

update  :: (MutHash arr ref m)
        => HashTable key val arr ref m -> key -> val -> m Bool
{-# NOINLINE [1] update #-}
update  = update'

update' :: (MutHash arr ref m)
        => HashTable key val arr ref m -> key -> val -> m Bool
update' _ _ _ = return False


-- This is a version of tc095.hs, which makes the compiler
-- loop (with -O) because of the recursive data-type bug,
-- unless you have the NOINLINE (which Happy does,
-- as it happens).

-- Keywords: diverge, contravariant, fixpoint

module ShouldSucceed where

happyParse = happyFail 7 7 (error "reading EOF!") (HappyState happyFail) [] [] []

data HappyState b c = HappyState
        (Int ->                         -- token number
         Int ->                         -- token number (yes, again)
         b ->                           -- token semantic value
         HappyState b c ->              -- current state
         [HappyState b c] ->            -- state stack
         c)

{-# NOINLINE happyFail #-}
happyFail _ i tk st@(HappyState action) sts stk = action (-1) (-1) tk st sts ( stk)


{-# LANGUAGE GADTs #-}

-- This one made GHC 6.4.1 panic because of over-zealous
-- complaining in mkCase1 when there was an empty list of
-- alternatives

module Foo2 where

data FooBar  = Foo | Bar

data P a = P0 | P1 FooBar

data PS p where
    C :: P Int -> p b -> PS p

f :: PS P -> Char
f (C (P1 _)   P0)       = 'a'
f (C (P1 Bar) (P1 Bar)) = 'b'
f (C (P1 _)   (P1 Bar)) = 'c'


{-# OPTIONS_GHC -Wno-redundant-constraints -Wno-simplifiable-class-constraints #-}
{-# OPTIONS_GHC -O2 #-}
{-# LANGUAGE RankNTypes, GADTs, FlexibleContexts #-}

-- This one make SpecConstr generate bogus code (hence -O2),
-- with a lint error, in GHC 6.4.1
-- C.f. http://ghc.haskell.org/trac/ghc/ticket/737

module ShouldCompile where

 data IHandler st where
     IHandler :: forall st ev res.
                 Serialize (TxContext ev) => String -> IO ev
                 -> (res -> IO ()) -> Ev st ev res -> IHandler st
     -- Weird test case: (Serialize (TxContext ev)) is simplifiable

 data Ev st ev res  = Ev
 data TxContext evt = TxContext
 data TxConfig      = TxConfig
 data M    a        = M a

 class Serialize a where
 instance Serialize a => Serialize (TxContext a)
 instance Serialize Int
 instance Serialize ()

 data IHR st = forall res ev. Serialize (TxContext ev) => IHR (TxContext ev)

 runHandler :: M (IHR st) ->  IHandler st -> IO ()
 runHandler queue ih@(IHandler tstring inp out run) = runHandler queue ih


{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}

-- Test for trac ticket #1287; ghc 6.6 and 6.6.1 panicked on this

module ShouldCompile where

{-# SPECIALIZE delta' :: Num b => Int -> Int -> b -> b -> b #-}
delta' :: Eq a => a -> a -> b -> b -> b
delta' x y e f = if (x==y) then f else e

{-# SPECIALIZE delta :: Num b => Int -> Int -> b #-}
delta :: (Eq a, Num b) => a -> a -> b
delta x y = delta' x y 0 1


{-# OPTIONS -XImpredicativeTypes -fno-warn-deprecated-flags -XEmptyDataDecls -XGADTs -XLiberalTypeSynonyms -XFlexibleInstances -XScopedTypeVariables #-}

-- See Trac #1627.  The point is that we should get nice
--                  compact code for Foo

-- In GHC 7.0 this fails, and rightly so.

module M(foo) where

import Control.Monad
import Control.Monad.ST
import Data.Array.ST

data E' v m a where
    E :: m a -> E' RValue m a
    V :: m a -> (a -> m ()) -> E' v m a

data LValue
data RValue

type E m a = E' RValue m a
type V m a = E' LValue m a

{-# INLINE runE #-}
runE :: E' v m a -> m a
runE (E t) = t
runE (V t _) = t

instance Monad m => Functor (E' RValue m) where
    {-# INLINE fmap #-}
    fmap f x = liftM f x

instance Monad m => Applicative (E' RValue m) where
    {-# INLINE pure #-}
    pure x = return x
    {-# INLINE (<*>) #-}
    (<*>) = ap

instance (Monad m) => Monad (E' RValue m) where
    {-# INLINE return #-}
    return x = E $ return x
    {-# INLINE (>>=) #-}
    x >>= f = E $ do
        x' <- runE x
        runE (f x')

liftArray :: forall arr m a i . (Ix i, MArray arr a m) =>
             arr i a -> E m (forall v . [E m i] -> E' v m a)
{-# INLINE liftArray #-}
liftArray a = E (do
    let ix :: [E m i] -> m i
        ix [i] = runE i
        {-# INLINE f #-}
        f is = V (ix is >>= readArray a) (\ x -> ix is >>= \ i -> writeArray a i x)
    return f
  )

{-# INLINE liftE2 #-}
liftE2 :: (Monad m) => (a -> b -> c) -> E' va m a -> E' vb m b -> E m c
liftE2 op x y = E $ do
    x' <- runE x
    y' <- runE y
    return (x' `op` y')

{-# INLINE plus #-}
plus :: (Monad m) => E m Int -> E m Int -> E m Int
plus = liftE2 (+)

foo :: forall s . STArray s Int Int -> ST s Int
foo ma = runE $ do
    a <- liftArray ma
    let one :: E (ST t) Int
        one = return 1
    a[one] `plus` a[one]


{-# LANGUAGE UnboxedTuples #-}

-- See Note [Float coercions (unlifted)] in Simplify
-- This one gave a CoreLint error when compiled optimised
--
-- See also Trac #1718, of which this is a simplified version

module ShouldCompile where

bar :: Bool -> Int
bar x = case (case x of { True -> (# 2,3 #); False -> error "urk" }) of
                (# p,q #) -> p+q


{-# LANGUAGE GADTs, FlexibleInstances #-}
{-# OPTIONS_GHC -O2 #-}

-- See Trac #1746

module Foo where

data T a where T :: T a -> T [a]

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

instance C (T [a]) where
  f (T x@(T _)) = f x


-- trac #1709

module FileDialog where

import Simpl020_A

createFolder :: ()
createFolder = geometry 0


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

class GUIValue a

class GUIObject w where
  toGUIObject     :: w -> ()
  cset            :: GUIValue a => a -> w

instance GUIValue Int

class GUIObject w => HasSize w where
  width :: Int -> w

class HasSize w => HasGeometry w where
  geometry :: Int -> w

class GUIObject w => Window w where

instance (GUIObject w, Window w) => HasSize w where
  width w = geometry w

instance Window w => HasGeometry w where
  geometry g = cset g

instance GUIObject ()

instance Window ()


module Main (main) where

import Simpl021A

main :: IO ()
main = do print i
          print j


{- This test checks that specialisations can apply inside
   wrappers.  In particular, the wrapper for 'foo' should
   look like

         Tmpl= \ (n_aal [Occ=Once!] :: GHC.Types.Int) ->
                 case n_aal of _ { GHC.Types.I# ipv_smZ [Occ=Once] ->
                 case Roman.foo_$s$wgo ipv_smZ 6 of ww_spp { __DEFAULT ->
                 GHC.Types.I# ww_spp
                 }
                 }}]
   Note the $s$wgo.  That in turn allows $wgo to be dead code.
-}

module Roman where

foo :: Int -> Int
foo n = n `seq` go (Just n) (Just (6::Int))
  where
    go u (Just x)
      = x `seq`
        case u of
          Nothing -> go (Just 10) (Just m)
          Just n
                 | n <= 0    -> 0
                 | n < 100   -> go (Just (n-2)) (Just x)
                 | n < 500   -> go (Just (n-3)) (Just m)
                 | otherwise -> go (Just (n-1)) (Just (m+m))
      where
        m = x+x+x+x+x+x+x


{-# LANGUAGE CPP, UnboxedTuples, MagicHash, StandaloneDeriving, DeriveDataTypeable #-}
{-# OPTIONS_GHC -O #-}

-- In GHC 6.4, compiling this module gave a Core Lint failure following the
-- specialiser, because a function was floated out that had a RULE that
-- mentioned another function (unpack, in fact).  but the latter wasn't
-- floated because we didn't take the RULES into account properly; result,
-- variable out of scope.

-- It's hard to cut this test down.

module Data.PackedString.Latin1 (
        -- * The @PackedString@ type
        PackedString,      -- abstract, instances: Eq, Ord, Show, Typeable

         -- * Converting to and from @PackedString@s
        pack,
        unpack,

        -- * I\/O with @PackedString@s
        hPut, hGet,

        -- * List-like manipulation functions
        nil,
        cons,
        head,
        tail,
        null,
        append,
        length,
        index,
        map,
        filter,
        reverse,
        concat,
        elem,
        substr,
        take,
        drop,
        splitAt,
        foldl,
        foldr,
        takeWhile,
        dropWhile,
        span,
        break,
        lines,
        unlines,
        words,
        unwords,
        split,
        splitWith,
        join,
--      unpackList, -- eek, otherwise it gets thrown away by the simplifier

    ) where

import qualified Prelude
import Prelude hiding (
        head,
        tail,
        null,
        length,
        (!!),
        map,
        filter,
        reverse,
        concat,
        elem,
        take,
        drop,
        foldl,
        foldr,
        splitAt,
        takeWhile,
        dropWhile,
        span,
        break,
        lines,
        unlines,
        words,
        unwords,
        join
 )

import GHC.Exts
import GHC.IO (IO(..))
import Foreign
import Data.Typeable
import Data.Char
import qualified Data.List
import System.IO

-- -----------------------------------------------------------------------------
-- PackedString type declaration

-- | A space-efficient representation of a 'String', which supports
-- various efficient operations.  A 'PackedString' contains Latin1
-- (8-bit) characters only.
data PackedString = PS {-#UNPACK#-}!Int {-#UNPACK#-}!Int
                       {-#UNPACK#-}!(ForeignPtr Word8)
        -- this is a pretty efficient representation, and can be
        -- converted to/from a StorableArray.
        -- When the ForeignPtr is unpacked, we get the Addr# stored
        -- directly in the PS constructor.

-- Perhaps making a slice should be conditional on the ratio of the
-- slice/string size to limit memory leaks.

instance Eq PackedString where
   a == b =  comparePS a b == EQ

instance Ord PackedString where
   compare = comparePS

comparePS (PS off1 len1 fp1) (PS off2 len2 fp2)
  = inlinePerformIO $
        withForeignPtr fp1 $ \p1 ->
        withForeignPtr fp2 $ \p2 ->
        cmp (p1 `plusPtr` off1) (p2 `plusPtr` off2) len1
  where
    cmp :: Ptr Word8 -> Ptr Word8 -> Int -> IO Ordering
    cmp p1 p2 n
      | n == len1 = if n == len2 then return EQ else return LT
      | n == len2 = return GT
      | otherwise = do
          a <- peekElemOff p1 n
          b <- peekElemOff p2 n
          case a `compare` b of
                EQ -> cmp p1 p2 (n+1)
                LT -> return LT
                GT -> return GT

--instance Read PackedString: ToDo

instance Show PackedString where
    showsPrec p ps r = showsPrec p (unpack ps) r

deriving instance Typeable PackedString

-- -----------------------------------------------------------------------------
-- Constructor functions

-- | The 'nilPS' value is the empty string.
nil :: PackedString
nil = inlinePerformIO $ do
                fp <- newForeignPtr_ nullPtr
                return (PS 0 0 fp)

-- | The 'consPS' function prepends the given character to the
-- given string.
cons :: Char -> PackedString -> PackedString
cons c cs = pack (c : (unpack cs)) -- ToDo:better

-- | Convert a 'String' into a 'PackedString'
packLen :: Int -> String -> PackedString
packLen len str = inlinePerformIO $ do
  fp <- mallocForeignPtrBytes len
  withForeignPtr fp $ \p -> do
        fill_it_in p 0 str
        return (PS 0 len fp)

fill_it_in p i [] = return ()
fill_it_in p i (c:cs) = do pokeElemOff p i (c2w c); fill_it_in p (i+1) cs

pack :: String -> PackedString
pack str = packLen (Prelude.length str) str

{-# INLINE w2c #-}
w2c :: Word8 -> Char
w2c = chr . fromIntegral
{-# INLINE c2w #-}
c2w :: Char -> Word8
c2w = fromIntegral . ord

-- -----------------------------------------------------------------------------
-- List-mimicking functions for PackedStrings

-- | The 'length' function returns the length of the input list.
-- Analogous to 'length'.
length :: PackedString -> Int
length (PS _ len _) = len

-- | The 'index' function returns the character in the string at the
-- given position.
index :: PackedString -> Int -> Char
index ps i
  | i >= 0 && i < len = unsafeIndex ps i
  | otherwise = error "Data.PackedString.Latin1.index: index out of range"
  where len = length ps

unsafeIndex :: PackedString -> Int -> Char
unsafeIndex (PS off len fp) i =
  withPackedString fp $ \p -> do
    w <- peekElemOff (p `plusPtr` off) i
    return $! w2c w

-- | The 'head' function returns the first element of a
-- 'PackedString' or throws an error if the string is empty.
head :: PackedString -> Char
head ps
  | len <= 0 = error "Data.PackedString.Latin1.head: head []"
  | otherwise = index ps 0
  where len = length ps

-- | The 'tail' function returns the tail of a 'PackedString' or throws an error
-- if the string is empty.
tail :: PackedString -> PackedString
tail ps
  | len <= 0 = error "Data.PackedString.Latin1.tail: tail []"
  | len == 1 = nil
  | otherwise  = substr ps 1 (len - 1)
  where len = length ps

-- | The 'null' function returns True iff the argument is null.
null :: PackedString -> Bool
null (PS _ l _) = l == 0

-- | The 'append' function appends the second string onto the first.
append :: PackedString -> PackedString -> PackedString
append xs ys
  | null xs = ys
  | null ys = xs
  | otherwise  = concat [xs,ys]

-- | The 'map' function applies a function to each character in the string.
map :: (Char -> Char) -> PackedString -> PackedString
map f ps = packLen (length ps) (Prelude.map f (unpack ps))

-- | The 'filter' function filters out the appropriate substring.
filter :: (Char -> Bool) -> PackedString -> PackedString {-or String?-}
filter pred ps = pack $ Prelude.filter pred $ unpack ps

-- | The 'foldl' function behaves like 'foldl' on 'PackedString's.
foldl :: (a -> Char -> a) -> a -> PackedString -> a
foldl f b ps = Prelude.foldl f b $ unpack ps

-- | The 'foldr' function behaves like 'foldr' on 'PackedString's.
foldr :: (Char -> a -> a) -> a -> PackedString -> a
foldr f v ps = Prelude.foldr f v $ unpack ps -- no intermediate list, we hope

-- | The 'take' function takes the first @n@ characters of a 'PackedString'.
take :: Int -> PackedString -> PackedString
take n ps = substr ps 0 (n-1)

-- | The 'drop' function drops the first @n@ characters of a 'PackedString'.
drop    :: Int -> PackedString -> PackedString
drop n ps = substr ps n (length ps - 1)

-- | The 'splitWith' function splits a 'PackedString' at a given index.
splitAt :: Int -> PackedString -> (PackedString, PackedString)
splitAt  n ps  = (take n ps, drop n ps)

-- | The 'takeWhile' function is analogous to the 'takeWhile' function.
takeWhile :: (Char -> Bool) -> PackedString -> PackedString
takeWhile pred ps = pack $ Prelude.takeWhile pred $ unpack ps

-- | The 'dropWhile' function is analogous to the 'dropWhile' function.
dropWhile :: (Char -> Bool) -> PackedString -> PackedString
dropWhile pred ps = pack $ Prelude.dropWhile pred $ unpack ps

-- | The 'elem' function returns True iff the given element is in the string.
elem :: Char -> PackedString -> Bool
elem c ps = c `Prelude.elem` unpack ps

-- | The 'span' function returns a pair containing the result of
-- running both 'takeWhile' and 'dropWhile'.
span :: (Char -> Bool) -> PackedString -> (PackedString, PackedString)
span  p ps = (takeWhile p ps, dropWhile p ps)

-- | The 'break' function breaks a string at the first position which
-- satisfies the predicate.
break :: (Char -> Bool) -> PackedString -> (PackedString, PackedString)
break p ps = span (not . p) ps

-- | The 'lines' function splits the input on line-breaks.
lines :: PackedString -> [PackedString]
lines ps = split '\n' ps

-- | The 'unlines' function concatenates the input list after
-- interspersing newlines.
unlines :: [PackedString] -> PackedString
unlines pss = join (pack "\n") pss

-- | The 'words' function is analogous to the 'words' function.
words :: PackedString -> [PackedString]
words ps = Prelude.filter (not.null) (splitWith isSpace ps)

-- | The 'unwords' function is analogous to the 'unwords' function.
unwords :: [PackedString] -> PackedString
unwords pss = join (pack " ") pss

-- | The 'reverse' function reverses the string.
reverse :: PackedString -> PackedString
reverse ps = pack $ Prelude.reverse $ unpack ps

-- | The 'concat' function concatenates a list of 'PackedString's.
concat :: [PackedString] -> PackedString
concat pss = pack $ Prelude.concat $ Prelude.map unpack pss

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

-- | The 'join' function takes a 'PackedString' and a list of 'PackedString's
-- and concatenates the list after interspersing the first argument between
-- each element of the list.
join :: PackedString -> [PackedString] -> PackedString
join filler pss = concat (splice pss)
 where
  splice []  = []
  splice [x] = [x]
  splice (x:y:xs) = x:filler:splice (y:xs)

-- ToDo: the obvious generalisation
{-
  Some properties that hold:

  * split x ls = ls'
      where False = any (map (x `elem`) ls')

  * join (pack [x]) (split x ls) = ls
-}

-- | The 'split' function splits the input string on each occurrence of the given 'Char'.
split :: Char -> PackedString -> [PackedString]
split c = splitWith (== c)

splitWith :: (Char -> Bool) -> PackedString -> [PackedString]
splitWith pred (PS off 0 fp) = []
splitWith pred (PS off len fp) = splitWith' pred off len fp

splitWith' pred off len fp =
  withPackedString fp $ \p -> splitLoop pred p 0 off len fp

splitLoop pred p idx off len fp
        | p `seq` idx `seq` off `seq` fp `seq` False = undefined
splitLoop pred p idx off len fp
        | idx >= len  = return [PS off idx fp]
        | otherwise = do
                w <- peekElemOff p (off+idx)
                if pred (w2c w)
                   then return (PS off idx fp :
                                  splitWith' pred (off+idx+1) (len-idx-1) fp)
                   else splitLoop pred p (idx+1) off len fp

-- -----------------------------------------------------------------------------
-- Local utility functions

-- The definition of @_substr@ is essentially:
-- @take (end - begin + 1) (drop begin str)@.

-- | The 'substr' function takes a 'PackedString' and two indices
-- and returns the substring of the input string between (and including)
-- these indices.
substr :: PackedString -> Int -> Int -> PackedString
substr (PS off len fp) begin end = PS (off+begin) (end-begin+1) fp

-- -----------------------------------------------------------------------------
-- hPut

-- | Outputs a 'PackedString' to the specified 'Handle'.
--
-- NOTE: the string will be output directly in Latin-1.
--
hPut :: Handle -> PackedString -> IO ()
hPut h (PS off l fp) =
  withForeignPtr fp $ \p ->
    hPutBuf h (p `plusPtr` off) l

-- -----------------------------------------------------------------------------
-- hGet

-- | Read a 'PackedString' directly from the specified 'Handle'.
-- This is far more efficient than reading the characters into a 'String'
-- and then using 'pack'.
--
-- NOTE: as with 'hPut', the string representation in the file is
-- assumed to be Latin-1.
hGet :: Handle -> Int -> IO PackedString
hGet h i = do
  fp <- mallocForeignPtrBytes i
  withForeignPtr fp $ \p -> do
    l <- hGetBuf h p i
    return (PS 0 l fp)

-- -----------------------------------------------------------------------------
-- unpacking

{-# INLINE unpack #-}
unpack :: PackedString -> String
unpack ps = build (unpackFoldr ps)

{-# RULES
"unpack-list"  [1]  forall p  . unpackFoldr p (:) [] = unpackList p
 #-}

unpackList :: PackedString -> [Char]
unpackList (PS off len fp) =
   withPackedString fp $ \p -> do
      let loop p (-1) acc = return acc
          loop p n acc = do
             a <- peekElemOff p n
             loop p (n-1) (w2c a : acc)
      loop (p `plusPtr` off) (len-1) []

{-# INLINE [0] unpackFoldr #-}
unpackFoldr :: PackedString -> (Char -> a -> a) -> a -> a
unpackFoldr (PS off len fp) f c =
   withPackedString fp $ \p -> do
      let loop p (-1) acc = return acc
          loop p n acc = do
             a <- peekElemOff p n
             loop p (n-1) (w2c a `f` acc)
      loop (p `plusPtr` off) (len-1) c

-- -----------------------------------------------------------------------------
-- Utils

-- Just like unsafePerformIO, but we inline it.
{-# INLINE inlinePerformIO #-}
inlinePerformIO :: IO a -> a
inlinePerformIO (IO m) = case m realWorld# of (# _, r #)   -> r

withPackedString :: ForeignPtr a -> (Ptr a -> IO b) -> b
withPackedString fp io = inlinePerformIO (withForeignPtr fp io)


{-# OPTIONS_GHC -O2 #-}

-- Ths one fooled the rule-matching in SpecConstr, and gave a CoreLint error

module Foo where

type Token = (Int, Int, Lex, String)

data Lex = Llbrace

laLayout :: Int -> [Int] -> [Token] -> [Token]

laLayout l (s:ss) (t1@(l1, n1, w1, c1) :
                   t2@(l2, n2, w2, c2) : ts)
   | n1 < s    = laLayout l2 (n2:s:ss) ts
   | n1 == s   = []   -- Otherwise laLayout is bottom!
   | otherwise = laLayout l ss (t1:t2:ts)


{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}

-- Trac #1402
-- Broke the specialiser

module ShouldCompile where

newtype Gen a = MkGen{ unGen :: Int -> a }

choose :: Eq a => a -> Gen a
choose n = MkGen (\r -> n)

oneof = choose (1::Int)


{-# LANGUAGE MagicHash #-}
import GHC.CString (unpackFoldrCString#, unpackCString#)
import GHC.Base (eqString)
main :: IO ()
main = do
  let mix c n = fromEnum c + n
  n <- readLn

  print $
    -- We expect the two literals to be concatenated, resulting in "@@@ ab"
    unpackFoldrCString# "@@@ a"# mix
      (unpackFoldrCString# "b"# mix n)

  if eqString (unpackCString# "x"#) (unpackCString# "y"#)
    then putStrLn $ unpackCString# "@@@ c"# -- this should be optimized out
    else putStrLn $ unpackCString# "@@@ d"#

  if eqString (unpackCString# "foo"#) (unpackCString# "foo"#)
    then putStrLn $ unpackCString# "@@@ e"#
    else putStrLn $ unpackCString# "@@@ f"# -- this should be optimized out


-- Test from Kirsten Chevalier
-- Tests the "strict bindings getting floated to top" bug in the floater

module B (bernoulli) where

powers = [2..] : powers

neg_powers = map (zip (iterate id True)) powers

bernoulli = head powers
  where powers = head neg_powers


module T10083 where
  import T10083a
  data RSR = MkRSR SR
  eqRSR (MkRSR s1) (MkRSR s2) = (eqSR s1 s2)
  foo x y = not (eqRSR x y)


module T10083a where
  import {-# SOURCE #-} T10083
  data SR = MkSR RSR
  eqSR (MkSR r1) (MkSR r2) = eqRSR r1 r2


module T10176(buggy) where

{-# NOINLINE error2Args #-}
error2Args :: () -> () -> a
error2Args _ _ = error "here"

newtype ReaderT r a = ReaderT { runReaderT :: r -> IO a }

instance Functor (ReaderT r) where
    fmap = undefined

instance Applicative (ReaderT r) where
    pure    = liftReaderT . pure
    f <*> v = undefined

instance Monad (ReaderT r) where
    return   = liftReaderT . return
    m >>= k  = undefined
    m >> k  = ReaderT $ \r -> do runReaderT m r; runReaderT k r

liftReaderT :: IO a -> ReaderT r a
liftReaderT m = ReaderT (const m)

{-# NOINLINE buggy #-}
buggy fun unit bool =
    runReaderT (do
        if bool then liftReaderT $ print () else pure ()
        case fun unit of
            True -> do
                error2Args unit unit
                pure ()
            _ -> pure ()
        ) () :: IO ()


{-# LANGUAGE TypeOperators, TypeFamilies, GADTs, EmptyCase #-}
module T10180 where

newtype Foo = Foo Int

type family Bar a
type instance Bar Int = Int

type family Baz a where
  Baz Int = Int
  Baz Char = Int

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

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

absurd1 :: Foo :~: Bool -> a
absurd1 x = case x of {}

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

absurd3 :: Baz a :~: Bool -> a
absurd3 x = case x of {}


module T10181 where

-- GHC 8.0 and previous wrongly eta-reduced this to
--   t = t
-- but GHC 8.2 does not; some kind of consequence of
-- better simplification in the early stages.

t a = t a


{-# OPTIONS_GHC -O2 #-}
{-# OPTIONS_GHC -fno-warn-missing-methods #-}
{-# LANGUAGE NoImplicitPrelude #-}
-- {-# OPTIONS_GHC -fno-spec-constr #-} -- Makes the problem go away.
-- {-# OPTIONS_GHC -fspec-constr-count=1 #-} -- Makes the problem go away.

module T10602 where

-- Copy-pasting T10602b.hs into the current module makes the problem go away.
import T10602b

data PairS a = PairS a a

-- Removing the '~' makes the problem go away.
(PairS _ _) >> ~(PairS b g) = PairS b g

class Binary t where
    put :: t -> PairS ()

-- Not using a newtype makes the problem go away.
newtype A a = A [a]

instance Binary a => Binary (A a) where
    put (A xs) = case splitAt 254 xs of
        (_, []) -> foldr (>>) (PairS () ()) (map put xs)
        (_, b)  -> put (A b)


{-# OPTIONS_GHC -O2 #-}
{-# LANGUAGE NoImplicitPrelude #-}
module T10602b (splitAt, map, foldr) where

import GHC.Classes
import GHC.Types
import GHC.Num
import GHC.Base

splitAt                :: Int -> [a] -> ([a],[a])
splitAt n ls
  | n <= 0 = ([], ls)
  | otherwise          = splitAt' n ls
    where
        splitAt' :: Int -> [a] -> ([a], [a])
        splitAt' _  []     = ([], [])
        splitAt' 1  (x:xs) = ([x], xs)
        splitAt' m  (x:xs) = (x:xs', xs'')
          where
            (xs', xs'') = splitAt' (m - 1) xs


-- Made GHC 6.10.2 go into a loop in substRecBndrs
{-# OPTIONS_GHC -w #-}

module T10627 where

import Data.Word

class C a where
    splitFraction    :: a -> (b,a)

roundSimple :: (C a) => a -> b
roundSimple x = error "rik"

{-# RULES
     "rs"  roundSimple = (fromIntegral :: Int -> Word) . roundSimple;
  #-}


module T10694 where

f :: Eq a => a -> Bool
{-# NOINLINE f #-}
f x = x==x

type Foo a b = b

{-# RULES "foo" forall (x :: Foo a Char). f x = True #-}

finkle = f 'c'


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

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

{-
ghc-stage2: panic! (the 'impossible' happened)
  (GHC version 7.11.20150723 for x86_64-unknown-linux):
        Template variable unbound in rewrite rule
-}

module List (sFoldr1) where

data Proxy t

data family Sing (a :: k)

data TyFun (a :: *) (b :: *)

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

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

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

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

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

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

data ErrorSym0 (t1 :: TyFun k1 k2)

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

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

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

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

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


{-# OPTIONS_GHC -O -fno-full-laziness #-}
module T11155 where

foo :: Bool
{-# NOINLINE foo #-}
foo = error "rk"

bar x = let t :: Char
            t = case foo of { True -> 'v'; False -> 'y' }
        in [t]


module T11232 where

import Control.Monad
import Data.Data

mkMp :: ( MonadPlus m
        , Typeable a
        , Typeable b
        )
     => (b -> m b)
     -> a
     -> m a
mkMp ext = unM (maybe (M (const mzero)) id (gcast (M ext)))

newtype M m x = M { unM :: x -> m x }


module T11272 where

import T11272a as A
import Control.Monad.Trans.State

specialised :: Int -> Int -> ()
specialised x y = execState (A.overloaded x y) ()


module T11272a where

import Control.Monad.Trans.State
import Control.Monad

overloaded :: Ord a => a -> a -> State () ()
overloaded x y = do
  () <- get
  when (x <= y) (overloaded y x)
{-# INLINABLE overloaded #-}


{-# LANGUAGE MagicHash, BangPatterns #-}

-- Produces a Lint error in GHC 8.0

module T11444 where
import GHC.Exts (reallyUnsafePtrEquality#, Int (..))

ptrEq :: a -> a -> Bool
ptrEq !x !y = I# (reallyUnsafePtrEquality# x y) == 1


{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE NoImplicitPrelude #-}

-- Trac #11562 reported an ASSERT error
-- It only showed up /without/ -O, and obviously
-- with a compiler built with -DDEBUG

module T11562 where

import Data.Kind

class Category (cat :: k -> k -> Type) where
  id :: cat a a
  (.) :: cat b c -> cat a b -> cat a c

data Dict :: Constraint -> Type where
  Dict :: a => Dict a

newtype C2D a b = Sub (a => Dict b)

instance Category C2D where
  id  = Sub Dict
  f . g = Sub (sub (sub Dict f) g)

sub :: a => (b => r) -> (C2D a b) -> r
sub r (Sub Dict) = r

{-
$ inplace/bin/ghc-stage2 -fforce-recomp -c C.hs -O0

WARNING: file compiler/stgSyn/CoreToStg.hs, line 250
  $fCategoryConstraint:- True False
-}


{-# LANGUAGE TypeFamilies, ScopedTypeVariables#-}

module T11644 where

import Data.Kind (Type)

class Foo m where
    type Bar m :: Type
    action :: m -> Bar m -> m

right x m = action m (Right x)

right' :: (Either a b ~ Bar m, Foo m) => b -> m -> m
right' x m = action m (Right x)

instance Foo Int where
    type Bar Int = Either Int Int
    action m a = either (*) (+) a m

instance Foo Float where
    type Bar Float = Either Float Float
    action m a = either (*) (+) a m

foo = print $ right (1::Int) (3 :: Int)
bar = print $ right (1::Float) (3 :: Float)


{-# LANGUAGE Strict #-}

module Foo where

data Foo = Foo

instance Eq Foo where
  (==) Foo Foo = True


{-# OPTIONS_GHC -O0 #-}
module T12076a(f) where

import GHC.Exts

{-# NOINLINE z #-}
z = ()

f :: () -> ()
f _ = let x = lazy z
      in g x x

{-# NOINLINE g #-}
g :: () -> () -> ()
g _ _ = ()


{-# LANGUAGE ForeignFunctionInterface, MagicHash #-}
module T12076lit where

-- This test-case demonstrates that cpeApp's collect_args can
-- be invoked on a literal

import Foreign.C
import Foreign
import GHC.Exts

main = do let y = Ptr "LOL"#
          x <- strlen y
          x2 <- strlen y -- don't inline y
          case (x,x2) of
            (3,3) -> putStrLn "Yes"
            _ -> putStrLn "No"

foreign import ccall unsafe "strlen"
  strlen :: Ptr a -> IO Int


{-# LANGUAGE MagicHash #-}
module T12076sat where

-- This test demonstrates that we need to saturate
-- primops even when they don't occur in function position.

import GHC.Exts

f = I# (dataToTag# timesWord#)


{-# LANGUAGE TypeFamilies #-}

module T12212 where

type family F a
type instance F Int = Int

foo :: a -> F a
{-# NOINLINE foo #-}
foo = undefined

-- Inferred type
-- forall a b. (Num a, F a ~# F b) => a -> b -> [F a]
f x y = [ foo x, foo y ] ++ f (x-1) y

-- Specialised call to f @ Int @ Int dNumInt <F Int ~ F Int>
g = f (3::Int) (4::Int)


module T12600 where

-- We don't want to see any dictionary-passing in foo. Everything
-- should be inlined or specialized away.

class Eq1 f where
  eq1 :: Eq a => f a -> f a -> Bool

data F a = F !a !a
data G f a = G !(f a) !(f a)

instance Eq1 F where
  eq1 = \(F a b) (F c d) ->
    -- In order to reproduce the problem, the body of this function needs to be
    -- large enough to prevent GHC from voluntarily inlining it.
    larger $ larger $ larger $ larger $ larger $ larger $
      a == c && b == d
  {-# INLINE eq1 #-}

larger :: a -> a
larger = id
{-# NOINLINE larger #-}

instance (Eq1 f) => Eq1 (G f) where
  eq1 = \(G a b) (G c d) -> eq1 a c && eq1 b d
  {-# INLINE eq1 #-}

foo :: G F Int -> G F Int -> Bool
foo a b = eq1 a b


-- ghc --make Main.hs -O1; ./Main +RTS -s -RTS

-- The point here is that we want to see a top-level
-- definition like
--
-- lvl_r5ao :: Int
-- lvl_r5ao = case GHC.Real.$wf1 2# 8# of v_B2
--              { __DEFAULT -> GHC.Types.I# v_B2 }
--
-- with the constant (2^8) being floated to top level

{-# LANGUAGE MagicHash #-}

module Main( main ) where

import GHC.Exts

data Attr = Attr !Int  --- the bang is essential

attrFromInt :: Int -> Attr
{-# NOINLINE attrFromInt #-}
attrFromInt w = Attr (w + (2 ^ (8 :: Int)))

fgFromInt :: Int -> Int
{-# INLINE fgFromInt #-}  -- removing this INLINE makes it many times faster
                          -- just like the manually inlined version
                          -- and NOINLINE lands in between
fgFromInt w = w + (2 ^ (8 :: Int))

attrFromIntINLINE :: Int -> Attr
{-# NOINLINE attrFromIntINLINE #-}
attrFromIntINLINE w = Attr (fgFromInt w)

seqFrame2 :: [Int] -> IO ()
{-# NOINLINE seqFrame2 #-}
seqFrame2 l = do
  -- let crux = attrFromInt
  --   Total   time    2.052s  (  2.072s elapsed)
  -- but the following version is many times slower:
  let crux = attrFromIntINLINE
  --   Total   time    7.896s  (  7.929s elapsed)
  mapM_ (\a -> crux a `seq` return ()) l

main :: IO ()
main = seqFrame2 $ replicate 100000000 0


{-# OPTIONS_GHC -O2 #-}

-- This made the simplifier loop doing infinite inlining
-- in GHC 8.0

module T12776(distinct_degree_factorization_i) where

import Prelude ((==), Eq);

data Slist a = Nil_s | Cons_s a (Slist a) deriving Eq;

map_s :: (a -> b) -> Slist a -> Slist b;
map_s f (Cons_s x21 x22) = Cons_s (f x21) (map_s f x22);

normalize_poly_i :: (Eq a) => (a -> a) -> Slist a -> Slist a;
normalize_poly_i ops xs = if ops (lead_coeff_i xs) == lead_coeff_i xs then Nil_s else map_s ops xs;

mod_poly_one_main_i :: (Eq a) => (a -> a) -> Slist a -> Slist a;
mod_poly_one_main_i ops d =
  if d == d then d else mod_poly_one_main_i ops (normalize_poly_i ops d);

last_s :: (Eq a) => Slist a -> a;
last_s (Cons_s x xs) = (if xs == Nil_s then x else last_s xs);

mod_field_poly_i :: (Eq a) => (a -> a) -> Slist a -> Slist a;
mod_field_poly_i ops cf =
  (if cf == cf then cf else
     mod_poly_one_main_i ops (map_s (\_ -> ops (last_s cf)) cf));

lead_coeff_i :: Eq a => Slist a -> a;
lead_coeff_i pp = (case pp of {
                        Cons_s _ _ -> last_s pp;
                      });

dist_degree_factorize_main_i :: Eq a => (a -> a) -> Slist a -> [Slist a] -> [Slist a];
dist_degree_factorize_main_i ff_ops w res =
  if w == w then res
           else dist_degree_factorize_main_i ff_ops (mod_field_poly_i ff_ops w)
                   [normalize_poly_i ff_ops (mod_field_poly_i ff_ops w)];

distinct_degree_factorization_i :: Eq a => (a -> a) -> [Slist a];
distinct_degree_factorization_i ff_ops = dist_degree_factorize_main_i ff_ops Nil_s []


{-# LANGUAGE DataKinds #-}
module T13025 where
import T13025a

type MyRec = Rec '[ '("A",Int), '("B",Int), '("C",Int) ]

getC :: MyRec -> Int
getC = getField (Proxy::Proxy '("C",Int))

doubleC :: MyRec -> MyRec
doubleC r = setC (2 * (getC r)) r
  where setC = set . (Field :: Int -> Field '("C",Int))

main :: IO ()
main = print (getC (Field 1 :& Field 2 :& Field 3 :& Nil :: MyRec))


{-# LANGUAGE ConstraintKinds, DataKinds, FlexibleContexts,
             FlexibleInstances, GADTs, MultiParamTypeClasses,
             PolyKinds, ScopedTypeVariables, TypeFamilies,
             TypeOperators #-}
module T13025a where

import Data.Kind (Type)

data Nat = Z | S Nat
data Proxy a = Proxy

data Field :: (k,Type) -> Type where
  Field :: a -> Field '(s,a)

type family Index r rs :: Nat where
  Index r (r ': rs) = 'Z
  Index r (s ': rs) = 'S (Index r rs)

data Rec (rs :: [ (k,Type) ]) where
  Nil :: Rec '[]
  (:&) :: Field r -> Rec rs -> Rec (r ': rs)
infixr 5 :&

class Index r rs ~ i => HasField r rs i where
  get :: proxy r -> Rec rs -> Field r
  set :: Field r -> Rec rs -> Rec rs

instance HasField r (r ': rs) 'Z where
  get _ (x :& _) = x
  set x (_ :& xs) = x :& xs

instance (HasField r rs i, Index r (s ': rs) ~ 'S i)
         => HasField r (s ': rs) ('S i) where
  get p (_ :& xs) = get p xs
  set x' (x :& xs) = x :& set x' xs

type Has r rs = HasField r rs (Index r rs)

getField :: Has '(s,a) rs => proxy '(s,a) -> Rec rs -> a
getField p = aux . get p
  where aux :: Field '(s,a) -> a
        aux (Field x) = x


{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE MagicHash #-}
module T13027 (insert) where

import GHC.Exts (isTrue#, reallyUnsafePtrEquality#)

data Set a = Bin {-# UNPACK #-} !Size !a !(Set a) !(Set a)
           | Tip

type Size = Int

insert :: Ord a => a -> Set a -> Set a
insert = go
  where
    go :: Ord a => a -> Set a -> Set a
    go !x Tip = Bin 1 x Tip Tip
    go !x t@(Bin sz y l r) = case compare x y of
        LT | l' `ptrEq` l -> t
           | otherwise -> undefined -- balanceL y l' r
           where !l' = go x l
        GT | r' `ptrEq` r -> t
           | otherwise -> undefined -- balanceR y l r'
           where !r' = go x r
        EQ | x `ptrEq` y -> t
           | otherwise -> Bin sz x l r
{-# INLINABLE insert #-}

ptrEq :: a -> a -> Bool
ptrEq x y = isTrue# (reallyUnsafePtrEquality# x y)
{-# INLINE ptrEq #-}


module T13143 where

{-# NOINLINE f #-}
f :: Int -> a
f x = f x

g :: Bool -> Bool -> Int -> Int
g True  True  p = f p
g False True  p = p + 1
g b     False p = g b True p


{-# LANGUAGE MagicHash, UnboxedTuples #-}
{-# OPTIONS_GHC -funfolding-use-threshold=10 #-}

module T13155 where

import GHC.Ptr
import GHC.Prim
import GHC.Exts

foo :: Ptr Float -> State# RealWorld -> (# State# RealWorld, Float #)
foo p s = case q :: Ptr Float of { Ptr a1 ->
          case readFloatOffAddr# a1 0# s of { (# s1, f1 #) ->
          case q :: Ptr Float of { Ptr a2 ->
          case readFloatOffAddr# a2 1# s of { (# s2, f2 #) ->
          (# s2, F# (plusFloat# f1 f2) #) }}}}
  where
    q :: Ptr a  -- Polymorphic
    q = p `plusPtr` 4


module T13156 where

f g x = let r :: [a] -> [a]
            r = case g x of True -> reverse . reverse
                            False -> reverse
        in
        r `seq` r `seq` r

{- Expected -ddump-prep looks like this.
   (Case-of-type-lambda an oddity of Core Prep.)

-- RHS size: {terms: 9, types: 9, coercions: 0, joins: 0/0}
T13156.f1 :: forall a. [a] -> [a]
[GblId, Arity=1, Caf=NoCafRefs, Str=<S,1*U>, Unf=OtherCon []]
T13156.f1 =
  \ (@ a) (x [Occ=Once] :: [a]) ->
    case GHC.List.reverse @ a x of sat { __DEFAULT ->
    GHC.List.reverse1 @ a sat (GHC.Types.[] @ a)
    }

-- RHS size: {terms: 17, types: 28, coercions: 0, joins: 0/0}
T13156.f
  :: forall p.
     (p -> GHC.Types.Bool) -> p -> [GHC.Types.Int] -> [GHC.Types.Int]
[GblId,
 Arity=2,
 Caf=NoCafRefs,
 Str=<C(S),1*C1(U)><L,U>,
 Unf=OtherCon []]
T13156.f =
  \ (@ p)
    (g [Occ=Once!] :: p -> GHC.Types.Bool)
    (x [Occ=Once] :: p) ->
    case \ (@ a) ->
           case g x of {
             GHC.Types.False -> GHC.List.reverse @ a;
             GHC.Types.True -> T13156.f1 @ a
           }
    of r [Dmd=<S,U>]
    { __DEFAULT ->
    case r @ GHC.Types.Any of { __DEFAULT -> r @ GHC.Types.Int }
    }

-}


module T13170 where
f :: Int -> Bool
f x = y == 2 || y == 3
  where y = -x


{-# LANGUAGE MagicHash #-}

module T13317 where

import GHC.Base

f x = let x = "foo"#
          y1 = unpackCString# x
          y2 = unpackCString# x
      in
      (y1, case y2 of
              'f' : _ -> True
              _       -> False
      )
-- This case-expression should simplify
-- yielding a KnownBranch simplifier tick


{-# LANGUAGE MagicHash #-}

module T13338 where

import GHC.Exts

magic# :: Int# -> Bool
magic# x# = True
{-# NOINLINE magic# #-}

f :: Int# -> Int -> Int
f x# n = length [ i | i@(I# i#) <- [0..n], magic# (remInt# x# 100000# -# i#) ]


module Hi where

-- These two should be de-duplicated by CSE
f, g :: Int -> Int
f x = 2 + x
g x = 2 + x


{-# LANGUAGE MagicHash #-}

module T13367( z ) where
import GHC.Exts
data T = MkT Addr#

x = MkT "foo"#
y = MkT "foo"#

z = (x,y)


{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}

module Data.Vector.Hybrid.Internal (Vector) where

import Control.Monad (liftM2)
import Data.Functor.Identity (Identity(..))
import GHC.ST (ST, runST)
import Text.Read (ReadPrec, readPrec)
import Data.Kind (Type)

-----

class Monad m => PrimMonad m where
  type PrimState m

instance PrimMonad (ST s) where
  type PrimState (ST s) = s

class GMVector v a where
  gmbasicLength      :: v s a -> Int
  gmbasicUnsafeSlice :: Int -> Int -> v s a -> v s a
  gmbasicUnsafeNew   :: PrimMonad m => Int -> m (v (PrimState m) a)
  gmbasicUnsafeWrite :: PrimMonad m => v (PrimState m) a -> Int -> a -> m ()

type family GMutable (v :: Type -> Type) :: Type -> Type -> Type

class GMVector (GMutable v) a => GVector v a where
  gbasicUnsafeFreeze :: PrimMonad m => GMutable v (PrimState m) a -> m (v a)

data Step s a where
  Yield :: a -> s -> Step s a

instance Functor (Step s) where
  {-# INLINE fmap #-}
  fmap f (Yield x s) = Yield (f x) s

data Stream m a = forall s. Stream (s -> m (Step s a)) s
data Chunk v a = Chunk Int (forall m. (PrimMonad m, GVector v a) => GMutable v (PrimState m) a -> m ())
data New v a = New { newrun :: forall s. ST s (GMutable v s a) }
type MBundle m v a = Stream m (Chunk v a)
type Bundle v a = MBundle Identity v a

mbfromStream :: Monad m => Stream m a -> MBundle m v a
{-# INLINE mbfromStream #-}
mbfromStream (Stream step t) = Stream step' t
  where
    step' s = do r <- step s
                 return $ fmap (\x -> Chunk 1 (\v -> gmbasicUnsafeWrite v 0 x)) r

mbunsafeFromList :: Monad m => [a] -> MBundle m v a
{-# INLINE [1] mbunsafeFromList #-}
mbunsafeFromList xs = mbfromStream (sfromList xs)

blift :: Monad m => Bundle v a -> MBundle m v a
{-# INLINE [1] blift #-}
blift (Stream vstep t) = Stream (return . runIdentity . vstep) t

sfromList :: Monad m => [a] -> Stream m a
{-# INLINE sfromList #-}
sfromList zs = Stream step zs
  where
    step (x:xs) = return (Yield x xs)
    step _ = undefined

sfoldlM :: Monad m => (a -> b -> m a) -> a -> Stream m b -> m a
{-# INLINE [1] sfoldlM #-}
sfoldlM m w (Stream step t) = foldlM_loop w t
  where
    foldlM_loop z s
      = do
          r <- step s
          case r of
            Yield x s' -> do { z' <- m z x; foldlM_loop z' s' }

gmvunstream :: (PrimMonad m, GVector v a)
            => Bundle v a -> m (GMutable v (PrimState m) a)
{-# INLINE [1] gmvunstream #-}
gmvunstream s = gmvmunstreamUnknown (blift s)

gmvmunstreamUnknown :: (PrimMonad m, GVector v a)
                    => MBundle m v a -> m (GMutable v (PrimState m) a)
{-# INLINE gmvmunstreamUnknown #-}
gmvmunstreamUnknown s
  = do
      v <- gmbasicUnsafeNew 0
      (_, _) <- sfoldlM copyChunk (v,0) s
      return undefined
  where
    {-# INLINE [0] copyChunk #-}
    copyChunk (v,i) (Chunk n f)
      = do
          let j = i+n
          v' <- if gmbasicLength v < j
                  then gmbasicUnsafeNew undefined
                  else return v
          f (gmbasicUnsafeSlice i n v')
          return (v',j)

newunstream :: GVector v a => Bundle v a -> New v a
{-# INLINE [1] newunstream #-}
newunstream s = s `seq` New (gmvunstream s)

gnew :: GVector v a => New v a -> v a
{-# INLINE [1] gnew #-}
gnew m = m `seq` runST (gbasicUnsafeFreeze =<< newrun m)

gunstream :: GVector v a => Bundle v a -> v a
{-# INLINE gunstream #-}
gunstream s = gnew (newunstream s)

gfromList :: GVector v a => [a] -> v a
{-# INLINE gfromList #-}
gfromList = gunstream . mbunsafeFromList

greadPrec :: (GVector v a, Read a) => ReadPrec (v a)
{-# INLINE greadPrec #-}
greadPrec = do
  xs <- readPrec
  return (gfromList xs)

-----

data MVector :: (Type -> Type -> Type) ->
                (Type -> Type -> Type) ->
                (Type -> Type -> Type) where
  MV :: !(u s a) -> !(v s b) -> MVector u v s (a, b)

instance (GMVector u a, GMVector v b) => GMVector (MVector u v) (a, b) where
  gmbasicLength (MV ks _) = gmbasicLength ks
  gmbasicUnsafeSlice s e (MV ks vs) = MV (gmbasicUnsafeSlice s e ks) (gmbasicUnsafeSlice s e vs)

  gmbasicUnsafeNew n = liftM2 MV (gmbasicUnsafeNew n) (gmbasicUnsafeNew n)
  -- Removing this INLINE pragma makes it compile
  {-# INLINE gmbasicUnsafeNew #-}

  gmbasicUnsafeWrite (MV ks vs) n (k,v) = do
    gmbasicUnsafeWrite ks n k
    gmbasicUnsafeWrite vs n v

data Vector :: (Type -> Type) -> (Type -> Type) -> Type -> Type

type instance GMutable (Vector u v) = MVector (GMutable u) (GMutable v)

instance (GVector u a, GVector v b) => GVector (Vector u v) (a, b) where
  gbasicUnsafeFreeze = undefined

instance (GVector u a, GVector v b, Read a, Read b, c ~ (a, b)) => Read (Vector u v c) where
  readPrec = greadPrec


{-# LANGUAGE MagicHash #-}
module T13413 where

import GHC.Exts

fillBlock2 :: (Int# -> Int# -> IO ())
           -> Int# -> Int# -> IO ()

fillBlock2 write x0 y0
 = fillBlock y0 x0
 where
   {-# INLINE fillBlock #-}
   fillBlock y ix
         | 1# <- y >=# y0
         = return ()
         | otherwise
         = do   write ix x0
                fillBlock (y +# 1#) ix


module T13417 where

-- Amazingly this crashed GHC 8.0.2

data T a = E7

cons7 :: T a -> T b
cons7 E7 = E7


{-# LANGUAGE EmptyCase, EmptyDataDecls, TypeFamilies #-}

module T13468 where

import GHC.Generics

data Void

instance Generic Void where
   type Rep Void = V1
   from x = case x of
   to x = case x of


{-# LANGUAGE RankNTypes, GADTs #-}

module Foo where

g :: (Int, Int) -> Int
{-# NOINLINE g #-}
g (p,q) = p+q

f :: Int -> Int -> Int -> Int
f x p q
  = g (let j y = (p,q)
           {-# NOINLINE j #-}
          in
          case x of
            2 -> j 3
            _ -> j 4)


{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE BangPatterns #-}

{- # OPTIONS_GHC -Werror #-}
{-# OPTIONS_GHC -g -O2 #-}

module Bug (bug) where

-- import GHC.Base (seq)
import Unsafe.Coerce (unsafeCoerce)

undefined :: a
undefined = undefined

data TypeRep (a :: k) where
    TrTyCon :: TypeRep (a :: k)
    TrApp   :: forall k1 k2 (a :: k1 -> k2) (b :: k1).
               TypeRep (a b)

data SomeTypeRep where
    SomeTypeRep :: forall k (a :: k).
                   TypeRep a
                -> SomeTypeRep

mkTrApp :: forall k1 k2 (a :: k1 -> k2) (b :: k1).
           TypeRep (a :: k1 -> k2)
        -> TypeRep (a b)
mkTrApp TrTyCon = undefined
mkTrApp TrApp   = undefined

bug :: SomeTypeRep
-- bug = f x -- this works
bug = f (f x)
  where x = SomeTypeRep TrTyCon
        f :: SomeTypeRep -> SomeTypeRep
        f (SomeTypeRep acc) = SomeTypeRep (mkTrApp (unsafeCoerce acc))


{-# OPTIONS_GHC -O -fmax-simplifier-iterations=0 #-}

-- Not running the simplifier leads to type-lets persisting longer

module T13708 where

indexOr :: a -> Int -> [a] -> a
indexOr fallback idx xs =
  if (idx < length xs)
  then xs !! idx
  else fallback


{-# LANGUAGE EmptyCase, GADTs #-}

module T13990 where

data T a where
  TInt :: T Int

absurd :: T Bool -> a
absurd v = case v of {}

data Foo = Foo !(T Bool)

absurdFoo :: Foo -> a
absurdFoo (Foo x) = absurd x


module T14137 where

-- The point of this test is that we should inline 'thunk'
-- into j's RHS, and we can do so quite aggressively, even
-- when we aren't optimising. See the ticket.
--
-- It's not a big deal, because in the end FloatIn
-- does the same job, only later

f xs = let thunk = length xs
           j = Just thunk
           g 0 = j
           g n = g (n-1)
       in
       g 7


-- We don't want to see a case match on the result
-- of dataToTag#. We check that by looking for case
-- matches on any literal other than 0# or 1#. We
-- only really expect to see 1# here (and not the tag
-- for OtherOS), but just in case GHC decides to get
-- clever with its knowledge of the possible results
-- of (==#), we also permit 0#.
{-# LANGUAGE MagicHash, BangPatterns #-}
module T14140 where
import GHC.Exts

data OS = Linux | Windows | OSX        -- tier 1 desktop OSs
        | FreeBSD | OpenBSD | NetBSD   -- other free Unix OSs
        | DragonFly
        | Solaris | AIX | HPUX | IRIX  -- ageing Unix OSs
        | HaLVM                        -- bare metal / VMs / hypervisors
        | Hurd                         -- GNU's microkernel
        | IOS  | Android               -- mobile OSs
        | Ghcjs
        | OtherOS String

-- This is similar to the derived Eq instance. We write it
-- out manually to prevent future deriving changes from
-- changing the test.
instance Eq OS where
  OtherOS x == OtherOS y = x == y
  (!x) == (!y) = case dataToTag# x ==# dataToTag# y of
               1# -> True
               _ -> False


module T14152 where

{-
This test case tests exitification. With exitification, the "case thunk" should
be lifted out of "innerGo", then "thunk" gets inlined, we have case-of-case and
case-of-known-constructor and the string "dead code" should disappear

The test case T14152b uses the same file, but with -fno-exitification, and checks
that the strings "dead code" is still present. If not, then some other optimization
does the job now (great!), but then we need to come up with a better test case
for exitification (or get rid of it).
-}

go 0 y = y
go n y = innerGo n y
  where
    innerGo 10 y = 0 -- we want to be lazy in thunk
    innerGo 0 y = case thunk of
        Nothing -> error "dead code"
        Just y' -> go (n-1) (y + y')
    innerGo n y = innerGo (n-1) (y*y)

    thunk = if y==0 then Just (y + y) else Just y


module T14186 where

foo f g (x, xs) = (f (g x), map (f . g) xs)
bar f g (x, xs) = (f (g x), map (f . g) xs)


{-# LANGUAGE TypeApplications, ScopedTypeVariables, GADTs, RankNTypes,
             PolyKinds, KindSignatures #-}
{-# OPTIONS_GHC -O2 #-} -- We are provoking a bug in SpecConstr

module T14270a where

import Data.Kind
import Data.Proxy

data T a = T1 (T a) | T2

data K (a :: k) where
  K1 :: K (a :: Type)
  K2 :: K a

f :: T (a :: Type) -> Bool
f (T1 x) = f x
f T2     = True

g :: forall k (a :: k). K a -> T a -> Bool
g kv x = case kv of
            K1 -> f @a T2   -- f @a (T1 x) gives a different crash
            k2 -> True

-- The point here is that the call to f looks like
--    f @(a |> co) (T2 @(a |> co))
-- where 'co' is bound by the pattern match on K1
-- See Note [SpecConstr and casts] in SpecConstr


import Data.Bits (bit)

main :: IO ()
main = putStrLn (show (f undefined))

f :: [Int] -> Int
f = sum . zipWith ((+) . bit) [0..] . map undefined . scanl undefined undefined


module MergeSort (
  msortBy
 ) where

infixl 7 :%
infixr 6 :&

data LenList a = LL {-# UNPACK #-} !Int Bool [a]

data LenListAnd a b = {-# UNPACK #-} !(LenList a) :% b

data Stack a
  = End
  | {-# UNPACK #-} !(LenList a) :& (Stack a)

msortBy :: (a -> a -> Ordering) -> [a] -> [a]
msortBy cmp = mergeSplit End where
  splitAsc n _ _ _ | n `seq` False = undefined
  splitAsc n as _ [] = LL n True as :% []
  splitAsc n as a bs@(b:bs') = case cmp a b of
    GT -> LL n False as :% bs
    _  -> splitAsc (n + 1) as b bs'

  splitDesc n _ _ _ | n `seq` False = undefined
  splitDesc n rs a [] = LL n True (a:rs) :% []
  splitDesc n rs a bs@(b:bs') = case cmp a b of
    GT -> splitDesc (n + 1) (a:rs) b bs'
    _  -> LL n True (a:rs) :% bs

  mergeLL (LL na fa as) (LL nb fb bs) = LL (na + nb) True $ mergeLs na as nb bs where
    mergeLs nx  _ ny  _ | nx `seq` ny `seq` False = undefined
    mergeLs  0  _ ny ys = if fb then ys else take ny ys
    mergeLs  _ [] ny ys = if fb then ys else take ny ys
    mergeLs nx xs  0  _ = if fa then xs else take nx xs
    mergeLs nx xs  _ [] = if fa then xs else take nx xs
    mergeLs nx xs@(x:xs') ny ys@(y:ys') = case cmp x y of
      GT -> y:mergeLs nx xs (ny - 1) ys'
      _  -> x:mergeLs (nx - 1) xs' ny ys

  push ssx px@(LL nx _ _) = case ssx of
    End -> px :% ssx
    py@(LL ny _ _) :& ssy -> case ssy of
      End
        | nx >= ny -> mergeLL py px :% ssy
      pz@(LL nz _ _) :& ssz
        | nx >= ny || nx + ny >= nz -> case nx > nz of
            False -> push ssy $ mergeLL py px
            _     -> case push ssz $ mergeLL pz py of
              pz' :% ssz' -> push (pz' :& ssz') px
      _ -> px :% ssx

  mergeAll _ px | px `seq` False = undefined
  mergeAll ssx px@(LL nx _ xs) = case ssx of
    End -> xs
    py@(LL _ _ _) :& ssy -> case ssy of
      End -> case mergeLL py px of
        LL _ _ xys -> xys
      pz@(LL nz _ _) :& ssz -> case nx > nz of
        False -> mergeAll ssy $ mergeLL py px
        _     -> case push ssz $ mergeLL pz py of
          pz' :% ssz' -> mergeAll (pz' :& ssz') px

  mergeSplit ss _ | ss `seq` False = undefined
  mergeSplit ss [] = case ss of
    End -> []
    px :& ss' -> mergeAll ss' px
  mergeSplit ss as@(a:as') = case as' of
    [] -> mergeAll ss $ LL 1 True as
    b:bs -> case cmp a b of
      GT -> case splitDesc 2 [a] b bs of
        px :% rs -> case push ss px of
          px' :% ss' -> mergeSplit (px' :& ss') rs
      _  -> case splitAsc 2 as b bs of
        px :% rs -> case push ss px of
          px' :% ss' -> mergeSplit (px' :& ss') rs
  {-# INLINABLE mergeSplit #-}


{-# OPTIONS_GHC -g -O #-}
{-# OPTIONS
  -fno-strictness
  -fno-case-merge
  -fno-call-arity
  -fno-case-folding
  -fno-cse
  -fno-do-eta-reduction
  -fno-do-lambda-eta-expansion
  -fno-float-in
  -ffull-laziness
  -fno-enable-rewrite-rules
#-}
-- This used to fail with:
--
-- *** Core Lint errors : in result of Simplifier ***
-- <no location info>: warning:
--     [RHS of str_sZr :: Addr#]
--     Recursive or top-level binder has strict demand info: str_sZr
--     Binder's demand info: <L,U>
module T14779a where

mkConstr :: String -> String
mkConstr str = r
  where
    r = idx `seq` str
    idx = eqS r str `seq` [r]

conMkFixed :: String
conMkFixed = mkConstr "MkFixed"

eqS :: String -> String -> Bool
eqS [] [] = True
eqS _ _ = False


{-# OPTIONS_GHC -g -O #-}
-- This used to fail with:
--
-- *** Core Lint errors : in result of Simplifier ***
-- <no location info>: warning:
--     [RHS of str_s2UI :: Addr#]
--     The type of this binder is unlifted: str_s2UI
--     Binder's type: Addr#

module T14779b where

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

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

data DataRep = AlgRep [Constr]
             | IntRep
             | FloatRep
             | CharRep
             | NoRep

data ConstrRep = AlgConstr    ConIndex
               | IntConstr    Integer
               | FloatConstr  Rational
               | CharConstr   Char

type ConIndex = Int

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

mkDataType :: String -> [Constr] -> DataType
mkDataType str cs = DataType
                        { tycon   = str
                        , datarep = AlgRep cs
                        }

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

dataTypeConstrs :: DataType -> [Constr]
dataTypeConstrs dt = case datarep dt of
                        (AlgRep cons) -> cons
                        _ -> errorWithoutStackTrace $
                               "Data.Data.dataTypeConstrs is not supported for "
                                    ++ dataTypeName dt ++
                                    ", as it is not an algebraic data type."
dataTypeName :: DataType -> String
dataTypeName = tycon

showConstr :: Constr -> String
showConstr = constring

-- | The type parameter should be an instance of 'HasResolution'.
newtype Fixed a = MkFixed Integer -- ^ @since 4.7.0.0
        deriving (Eq,Ord)

tyFixed :: DataType
tyFixed = mkDataType "Data.Fixed.Fixed" [conMkFixed]
conMkFixed :: Constr
conMkFixed = mkConstr tyFixed "MkFixed" [] Prefix


module T14959 where

import Data.Bits (setBit)

f = foldl setBit 0 [x | (x,_) <- zip [0..] [1]] :: Integer


{-# LANGUAGE GADTs  #-}
module T14978 where

data Equal a b where
  Refl :: Equal a a

data Goof a where
  Goof :: {-# UNPACK #-} !(Equal a Int) -> Goof a

foo :: Goof Int
foo = Goof Refl


module T15002 where

import Control.Concurrent.MVar (MVar, modifyMVar_, putMVar)
import Data.Foldable (for_)

broadcastThen :: Either [MVar a] a -> MVar (Either [MVar a] a) -> a -> IO ()
broadcastThen finalState mv x =
    modifyMVar_ mv $ \mx -> do
      case mx of
        Left ls -> do for_ ls (`putMVar` x)
                      return finalState
        Right _ -> return finalState


module T15005 (
    OrderCell,
    ElementCell,
    rawAlgorithm,
    rawAlgorithmWithSize
    ) where

-- Control

import Control.Applicative
import Control.Monad
import Control.Monad.ST

-- Data

import Data.Word
import Data.Bits
import Data.STRef

type RawOrder s o = STRef s (o s)

type RawElement s e = STRef s (e s)

data RawAlgorithm s o e = RawAlgorithm {
    newOrder        :: ST s (RawOrder s o),
    compareElements :: RawElement s e -> RawElement s e -> RawOrder s o -> ST s Ordering,
    newMinimum      :: RawOrder s o -> ST s (RawElement s e),
    newMaximum      :: RawOrder s o -> ST s (RawElement s e),
    newAfter        :: RawElement s e -> RawOrder s o -> ST s (RawElement s e),
    newBefore       :: RawElement s e -> RawOrder s o -> ST s (RawElement s e),
    delete          :: RawElement s e -> RawOrder s o -> ST s ()
}
{-FIXME:
    If we ever allow users to plug in their own algorithms, we have to flag the
    respective function as unsafe and point out that referential transparency is
    in danger if the algorithm does not fulfill the specification. This is
    because element comparison is presented to the user as a pure function. The
    important condition is that for any two elements, compareElements must
    always return the same result as long as delete is not called on either
    element.
-}

type OrderCell = Cell

type ElementCell = Cell

data Cell s = Cell {
                  label :: Label,
                  next  :: CellRef s,
                  prev  :: CellRef s
              }

type CellRef s = STRef s (Cell s)

newtype Label = Label LabelWord deriving (Eq, Ord)

type LabelWord = Word64

labelWordSize :: Int
labelWordSize = 64

initialBaseLabel :: Label
initialBaseLabel = Label 0

rawAlgorithm :: RawAlgorithm s OrderCell ElementCell
rawAlgorithm = rawAlgorithmWithSize defaultSize

defaultSize :: Int
defaultSize = 63

rawAlgorithmWithSize :: Int -> RawAlgorithm s OrderCell ElementCell
rawAlgorithmWithSize size
    | size < 0 || size >= labelWordSize
        = error "Data.Order.Algorithm.dietzSleatorAmortizedLogWithSize: \
                \Size out of bounds"
    | otherwise
        = RawAlgorithm {
              newOrder        = fixST $
                                \ ref -> newSTRef $ Cell {
                                   label = initialBaseLabel,
                                   next  = ref,
                                   prev  = ref
                                },
              compareElements = \ ref1 ref2 baseRef -> do
                                    baseCell <- readSTRef baseRef
                                    cell1 <- readSTRef ref1
                                    cell2 <- readSTRef ref2
                                    let offset1 = labelDiff (label cell1)
                                                            (label baseCell)
                                    let offset2 = labelDiff (label cell2)
                                                            (label baseCell)
                                    return $ compare offset1 offset2,
              newMinimum      = newAfterCell,
              newMaximum      = newBeforeCell,
              newAfter        = const . newAfterCell,
              newBefore       = const . newBeforeCell,
              delete          = \ ref _ -> do
                                    cell <- readSTRef ref
                                    modifySTRef
                                        (prev cell)
                                        (\ prevCell -> prevCell {
                                                           next = next cell
                                                       })
                                    modifySTRef
                                        (next cell)
                                        (\ nextCell -> nextCell {
                                                           prev = prev cell
                                                       })
          } where

    noOfLabels :: LabelWord
    noOfLabels = shiftL 1 size

    labelMask :: LabelWord
    labelMask = pred noOfLabels

    toLabel :: LabelWord -> Label
    toLabel = Label . (.&. labelMask)

    labelSum :: Label -> Label -> Label
    labelSum (Label word1) (Label word2) = toLabel (word1 + word2)

    labelDiff :: Label -> Label -> Label
    labelDiff (Label word1) (Label word2) = toLabel (word1 - word2)

    labelDistance :: Label -> Label -> LabelWord
    labelDistance lbl1 lbl2 = case labelDiff lbl1 lbl2 of
                                  Label word | word == 0 -> noOfLabels
                                             | otherwise -> word

    newAfterCell :: CellRef s -> ST s (CellRef s)
    newAfterCell ref = do
        relabel ref
        lbl <- label <$> readSTRef ref
        nextRef <- next <$> readSTRef ref
        nextLbl <- label <$> readSTRef nextRef
        newRef <- newSTRef $ Cell {
            label = labelSum lbl (Label (labelDistance nextLbl lbl `div` 2)),
            next  = nextRef,
            prev  = ref
        }
        modifySTRef ref     (\ cell     -> cell     { next = newRef })
        modifySTRef nextRef (\ nextCell -> nextCell { prev = newRef })
        return newRef

    relabel :: CellRef s -> ST s ()
    relabel startRef = do
        startCell <- readSTRef startRef
        let delimSearch ref gapCount = do
                cell <- readSTRef ref
                let gapSum = labelDistance (label cell) (label startCell)
                if gapSum <= gapCount ^ 2
                    then if ref == startRef
                             then error "Data.Order.Algorithm.\
                                        \dietzSleatorAmortizedLogWithSize: \
                                        \Order full"
                             else delimSearch (next cell) (succ gapCount)
                    else return (ref, gapSum, gapCount)
        (delimRef, gapSum, gapCount) <- delimSearch (next startCell) 1
        let smallGap = gapSum `div` gapCount
        let largeGapCount = gapSum `mod` gapCount
        let changeLabels ref ix = when (ref /= delimRef) $ do
                cell <- readSTRef ref
                let lbl = labelSum
                              (label startCell)
                              (Label (ix * smallGap + min largeGapCount ix))
                writeSTRef ref (cell { label = lbl })
                changeLabels (next cell) (succ ix)
        changeLabels (next startCell) 1
    {-FIXME:
        We allow the number of cells to be larger than the square root of the
        number of possible labels as long as we find a sparse part in our circle
        of cells (since our order full condition is only true if the complete
        circle is congested). This should not influence correctness and probably
        also not time complexity, but we should check this more thoroughly.
    -}
    {-FIXME:
        We arrange the large and small gaps differently from Dietz and Sleator
        by putting all the large gaps at the beginning instead of distributing
        them over the relabeled area. However, this should not influence time
        complexity, as the complexity proof seems to only rely on the fact that
        gap sizes differ by at most 1. We should check this more thoroughly
        though.
    -}

    newBeforeCell :: CellRef s -> ST s (CellRef s)
    newBeforeCell ref = do
        cell <- readSTRef ref
        newAfterCell (prev cell)


module T15056 where

import T15056a

blam x = foo 3 [1..x]
-- We expect fold/build to fire


module T15056a where

test :: Int -> Bool
test 0 = True
test n = test (n-1)

foo :: Foldable t => Int -> t Int -> Int
foo n xs | test n
         = foldr (+) n xs
         | otherwise
         = n+7


{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE PatternSynonyms #-}
module Bar (pattern PointerExpr) where

import Data.Kind (Type)
import T15186A

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

pattern PointerExpr :: Expr tp
pattern PointerExpr <-
   App (RollRecursive (EmptyAssn :> BVRepr) (App _))

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

data CrucibleType where
  RecursiveType :: Ctx CrucibleType -> CrucibleType

data TypeRepr (tp :: CrucibleType) where
  BVRepr :: TypeRepr tp
  TypeReprDummy :: TypeRepr tp

data App (f :: CrucibleType -> Type) (tp :: CrucibleType) where
  RollRecursive :: !(Assignment TypeRepr ctx)
                -> !(Expr tp)
                -> App f ('RecursiveType ctx)

data Expr (tp :: CrucibleType)
  = App !(App Expr tp)
  | ExprDummy


{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE ViewPatterns #-}
module T15186A (Ctx, Assignment, pattern EmptyAssn, pattern (:>)) where

import Data.Kind (Type)

data Ctx k
  = EmptyCtx
  | Ctx k ::> k

type SingleCtx x = 'EmptyCtx '::> x

type family (<+>) (x :: Ctx k) (y :: Ctx k) :: Ctx k where
  x <+> 'EmptyCtx = x
  x <+> (y '::> e) = (x <+> y) '::> e

data Height = Zero | Succ Height

data BinomialTree (h::Height) (f :: k -> Type) :: Ctx k -> Type where
  Empty :: BinomialTree h f 'EmptyCtx
  PlusOne  :: !Int
           -> !(BinomialTree ('Succ h) f x)
           -> !(BalancedTree h f y)
           -> BinomialTree h f (x <+> y)
  PlusZero  :: !Int
            -> !(BinomialTree ('Succ h) f x)
            -> BinomialTree h f x

newtype Assignment (f :: k -> Type) (ctx :: Ctx k)
  = Assignment (BinomialTree 'Zero f ctx)

data AssignView f ctx where
  AssignEmpty :: AssignView f 'EmptyCtx
  AssignExtend :: Assignment f ctx
               -> f tp
               -> AssignView f (ctx '::> tp)

data DropResult f (ctx :: Ctx k) where
  DropEmpty :: DropResult f 'EmptyCtx
  DropExt   :: BinomialTree 'Zero f x
            -> f y
            -> DropResult f (x '::> y)

data BalancedTree h (f :: k -> Type) (p :: Ctx k) where
  BalLeaf :: !(f x) -> BalancedTree 'Zero f (SingleCtx x)
  BalPair :: !(BalancedTree h f x)
          -> !(BalancedTree h f y)
          -> BalancedTree ('Succ h) f (x <+> y)

bal_drop :: forall h f x y
          . BinomialTree h f x
         -> BalancedTree h f y
         -> DropResult f (x <+> y)
bal_drop t (BalLeaf e) = DropExt t e
bal_drop _ (BalPair {}) = undefined

bin_drop :: forall h f ctx
          . BinomialTree h f ctx
         -> DropResult f ctx
bin_drop Empty = DropEmpty
bin_drop (PlusZero _ u) = bin_drop u
bin_drop (PlusOne s t u) =
  let m = case t of
            Empty -> Empty
            _ -> PlusZero s t
   in bal_drop m u

viewAssign :: forall f ctx . Assignment f ctx -> AssignView f ctx
viewAssign (Assignment x) =
  case bin_drop x of
    DropEmpty -> AssignEmpty
    DropExt t v -> AssignExtend (Assignment t) v

pattern EmptyAssn :: () => ctx ~ 'EmptyCtx => Assignment f ctx
pattern EmptyAssn <- (viewAssign -> AssignEmpty)

pattern (:>) :: () => ctx' ~ (ctx '::> tp) => Assignment f ctx -> f tp -> Assignment f ctx'
pattern (:>) a v <- (viewAssign -> AssignExtend a v)