{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE NamedFieldPuns #-}
module T15957_Fail where

data P = P { x :: Int, y :: Int }

f1 P{..} = 1 + 3 -- nothing bound is used
f2 P{x, ..} = x + 3 -- y bound but not used
f3 P{x, y, ..} = x + y -- no bindings left, i.e. no new useful bindings introduced

g2 P{x=a, ..} = a + 3
g3 P{x=a, y=b, ..} = a + b
g4 P{x=0, y=0,..} = 0
g4 _ = 0

-- Record wildcards in lets have different scoping rules.. they bring
-- all the identifiers into scope
do_example :: IO Int
do_example = do
  let P{..} = P 1 2
  return $ 0

let_in_example :: Int
let_in_example =
  let P{..} = P 1 2
  in 0

data Q = Q { a, b :: P }

nested :: Q -> Int
nested Q { a = P{..}, .. } = (case b of (P x1 _) -> x1)


module T1595a where

a, b :: Integer -> Tpyo
a = undefined
b = undefined


{-# LANGUAGE TypeFamilies #-}
module T16002 where

data A
type family B (x :: *) :: * where
  A x = x


module T16114 where

data T a
instance Eq a => Eq a => Eq (T a) where (==) = undefined


{-# LANGUAGE TypeFamilies #-}
module T16116b where

class C a where
  type F a
instance C [a] where
  type F [a] = b


{-# LANGUAGE ScopedTypeVariables #-}
module T16385 where

instance c
instance forall c. c


-- Trac #2490
module ShouldFail where

-- All these sections are illegal

f x = [ (`head` x, ())
      , (+ x, ())
      , ((), + x)
      , ((), + x, ())
      , ((), x +) ]


{-# OPTIONS_GHC -fwarn-name-shadowing -XNamedFieldPuns -XRecordWildCards #-}
module WildCard where

data Record = Record {field1 :: Int, field2 :: Double}

field3 :: Int
field3 = 3

test1 (Record {field1, field2}) = let test = 1 in field1

test2 :: (Record, Int)
test2 = let
    field1 = 10
    field2 = 10.0
    field3 = 8
    in (Record {..}, field3)


{-# LANGUAGE DisambiguateRecordFields #-}
-- Trac #2901

module T2901 where

f = F.Foo { F.field = "" }


{-# LANGUAGE TypeOperators #-}

-- Trac #2993

module T2993 where

foo b a = a <**> b . b


{-# LANGUAGE MultiParamTypeClasses #-}

-- Test Trac #3265

module T3265 where

data a :+: b = Left a | Right b

class a :*: b where {}


module T3792 where

import Prelude( Prelude.map )   -- Illegal


-- Test Trac #4042

module T4042 where

f :: A -> A
f
-- The above line is a naked Template Haskell splice
-- When compiling without -XTemplateHaskell we don't
-- want a confusing error message saying "A is not in scope"

data A = A


{-# LANGUAGE DefaultSignatures #-}
module T5001b where

class GEnum a where
     genum :: [a]
     default genum :: [a]
     genum = undefined

instance GEnum Int where
     {-# INLINE genum #-}


{-# OPTIONS_GHC -fwarn-unused-imports  #-}
module RedundantImport where

-- this import is redundant, but GHC does not spot it
import qualified Foreign.Storable

import Foreign.Storable (Storable, sizeOf, alignment, peek, poke, )
import Foreign.Ptr (castPtr, )

newtype T a = Cons a

instance Storable a => Storable (T a) where
   sizeOf (Cons a) = sizeOf a
   alignment (Cons a) = alignment a
   peek = fmap Cons . peek . castPtr
   poke p (Cons a) = poke (castPtr p) a


-- The issue here is getting an error message with a decent source location
module T5281 where

import T5281A

x = deprec


module T5281A where

{-# DEPRECATED deprec "This is deprecated" #-}
deprec :: Int
deprec = 5


{-# LANGUAGE DisambiguateRecordFields #-}
module T5372 where
import qualified T5372a
notScope (MkS { x = n }) = n


module T5372a where
data S = MkS { x :: Int, y :: Bool }


module T5385 where

import T5385a( (:::) )


module T5385a where

data T = Int ::: Int


{-# LANGUAGE StandaloneDeriving #-}
module T5513 where

deriving instance lowercase_name a


module T5533 where

data T a = CT {f1 :: Int -> a, f2 :: Double}
f2 :: Int -> Double
g x = CT {f1 = \t -> f2 t + x, f2 = x}


module T5589 where

bbb, aaa :: Int
aaa :: Int
aaa = undefined
bbb = undefined


module T5745 where

import T5745a

f :: T
f = f


module T5745a( module T5745b ) where

import T5745b hiding( T )


module T5745b where

data T = MkT
data S = MkS


{-# LANGUAGE RecordWildCards #-}
{-# OPTIONS_GHC -Werror #-}

module T5892a where

import Data.Tree ( Tree( Node, rootLabel ))
-- Not importing field 'subForest'

foo :: Tree [Int] -> Tree [Int]
foo (Node {..}) -- Pattern match does not bind 'subForest'
  = let rootLabel = []
    in Node {..}   -- Hence warning here


{-# LANGUAGE RecordWildCards #-}
module T5892b where

import Data.Tree ( Tree( Node, rootLabel ))
-- Not importing field 'subForest'

Node{..} = Node [] []
-- Binds 'rootLabel' only

foo = T5892b.rootLabel
bar = T5892b.subForest


module T5951 where

class A a
class B b
class C c

instance
       A =>
       B =>
       C where
         foo = undefined


{-# LANGUAGE TypeFamilies, PolyKinds #-}

module T6018rnfail where

-- IA = injectivity annotation `| foo -> bar`

-- use incorrect tyvar in LHS of IA
type family F a = r | a -> a
type family Fc a = r | a -> a where
  Fc a = a
class Fcl a where
  type Ft a = r | a -> a

-- declare result tyvar to be duplicate (without IA)
type family G a = a
type family Gc a = a where
  Gc a = a

-- declare result tyvar to be duplicate (with IA)
type family Gb a = a | a -> a
type family Gcb a = a | a -> a where
  Gcb a = a
class Gclb a where -- here we want two errors
  type Gtb a = a | a -> a

-- not in-scope tyvar in RHS of IA
type family I a b = r | r -> c
type family Ic a b = r | r -> c where
  Ic a b = a
class Icl a b where
  type It a b = r | r -> c

-- not in-scope tyvar in LHS of IA
type family L a b = r | c -> a
type family Lc a b = r | c -> a where
  Lc a b = a
class Lcl a b where
  type Lt a b = r | c -> a

-- result variable shadows variable in class head
class M a b where
  type Mt b = a | a -> b

-- here b is out-of-scope
class N a b where
  type Nt a = r | r -> a b

-- result is out of scope. Not possible for associated types
type family O1  a | r -> a
type family Oc1 a | r -> a where
    Oc1 a = a
type family O2  a :: * | r -> a
type family Oc2 a :: * | r -> a where
    Oc2 a = a


{-# LANGUAGE ParallelListComp #-}

module T6060 where

foo = do let bad = [True | x <- [] | y <- []]


module T7164 where

class Foo m where
    herp :: (a -> a) -> m b -> m b
    derp :: m a

derp :: Int
derp = 123


module T7338 where

a, a :: Int
a :: Int
a = 0


module T7338a where

a, b :: Int
a = undefined
b = undefined

c, a :: Int
c = undefined

c, d :: Int
d = undefined


{-# OPTIONS_GHC -fwarn-unused-imports #-}

module T7454 where

import Control.Arrow( Arrow, arr )

foo () = arr


module T7906 where

class Foo f where
    foo :: f
{-# INLINABLE foo #-}


module T7937 where

-- Without this operator definition, a precedence parsing error is reported.
-- Perhaps the default precedence is being assumed for the unknown operator?
-- That seems wrong, since there's no way to know what the precedence will be when
-- the operator is defined as the programmer intended.

foo = 3 > 4 *** 5 == 6


module T7943 where

data Foo = A { bar :: String }
          | B String { bar :: String }


{-# OPTIONS_GHC -Wall #-}

module T8149 where

import Control.Monad.Trans.Writer (WriterT, runWriterT)

foo :: Bool
foo = runWriterT `seq` True


{-# LANGUAGE RecordWildCards #-}
module T8448 where

data R = R {r :: Int}
f x = undefined [] {r = x}


module T9006 where

import T9006a (T(T))


{-# LANGUAGE CPP #-}

module T9032 where

#ifdef ERR
import T9032
#endif

f x = x


module T9077 where

main :: IO {}
main = print "hello"


module T9156 where

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


module T9177 where

-- the main use case
type Foo = (int)

-- other interesting cases
type Foo2 = (integerr)

-- These two out-of-scope errors aren't caught until
-- the type checker, so they aren't reported at all
-- because the renamer aborts compilation
foo3 = bar
foo4 = Fun

-- this warning is suboptimal (fun would be illegal here)
foo5 Fun = ()

-- No errors here:
data Bar = Bar
fun x = x


module T9177a where

foo3 = bar
foo4 = Fun


{-# LANGUAGE RecordWildCards #-}

module T9436 where

data T = T { x :: Int }

f :: T -> Int
f (T' { .. }) = x + 1


{-# LANGUAGE RecordWildCards #-}

module T9437 where

data Foo = Foo { x :: Int }

test :: Foo -> Foo
test foo = foo { .. }


{-# LANGUAGE RecordWildCards #-}
module T9815 where

newtype N = N Int deriving (Show)

foo = print N{..}


{-# LANGUAGE RoleAnnotations, PolyKinds #-}

module Roles1 where

import Data.Kind (Type)

data T1 a = K1 a
data T2 a = K2 a
data T3 (a :: k) = K3
data T4 (a :: Type -> Type) b = K4 (a b)

data T5 a = K5 a
data T6 a = K6
data T7 a b = K7 b

type role T1 nominal
type role T2 representational
type role T3 phantom
type role T4 nominal _
type role T5 _


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

-- tests axiom roles

module Roles13 where

newtype Age = MkAge Int
newtype Wrap a = MkWrap a

convert :: Wrap Age -> Int
convert (MkWrap (MkAge i)) = i


{-# LANGUAGE RoleAnnotations, IncoherentInstances #-}

module Roles12 where

type role C2 representational
class C2 a where
  meth2 :: a -> a


module Roles2 where

import GHC.Ptr

-- these *must* have certain roles, or things break strangely
-- see TcForeign

data T1 a = K1 (IO a)
data T2 a = K2 (FunPtr a)


{-# LANGUAGE TypeFamilies, MultiParamTypeClasses #-}
{-# LANGUAGE AllowAmbiguousTypes #-}  -- meth3, meth4 are ambiguous

module Roles3 where

class C1 a where
  meth1 :: a -> a

class C2 a b where
  meth2 :: a ~ b => a -> b

class C3 a b where
  type F3 b
  meth3 :: a -> F3 b -> F3 b

type family F4 a

class C4 a b where
  meth4 :: a -> F4 b -> F4 b

type Syn1 a = F4 a
type Syn2 a = [a]


{-# LANGUAGE RoleAnnotations #-}

module Roles4 where

type role C1 nominal
class C1 a where
  meth1 :: a -> a

type Syn1 a = [a]

class C3 a where
  meth3 :: a -> Syn1 a


{-# LANGUAGE RoleAnnotations #-}
module T10263 where

data Maybe a = AF
type role Maybe representational


{-# LANGUAGE RoleAnnotations #-}
module T14101 where

type role Array representational
data Array a

type Arr = Array

data Foo a = Foo (Arr a)
type role Foo representational


{-# LANGUAGE RoleAnnotations, DatatypeContexts, IncoherentInstances,
             FlexibleInstances #-}

module T8958 where

class Nominal a
instance Nominal a

class Representational a
instance Representational a
type role Representational representational

newtype (Nominal k, Representational v) => Map k v = MkMap [(k,v)]


module T9204b where

import T9204b2

data P a = P


module T9204b2 where

import {-# SOURCE #-} T9204b


{-# LANGUAGE GeneralizedNewtypeDeriving, TypeFamilies #-}

module Roles10 where

type family F a
type instance F Int = Bool
type instance F Age = Char

class C a where
  meth :: a -> F a

instance C Int where
  meth = (> 0)

newtype Age = MkAge Int
  deriving C


{-# LANGUAGE GADTs, RoleAnnotations #-}

module Roles11 where

type role T2 representational
data T2 a where
  K2 :: T2 Int


module Roles12 where

import Roles12a

data T a


module Roles12a where
import {-# SOURCE #-} Roles12


module Roles5 where

data T a
class C a
type S a = Int

type role T nominal
type role C representational
type role S phantom


{-# LANGUAGE RoleAnnotations #-}

module Roles6 where

data Foo a b = MkFoo (a b)

type role Foo nominal representational phantom


{-# LANGUAGE RoleAnnotations #-}

module Roles7 where

class Bar a
type role Bar repesentational
 -- spelling error intentional!


{-# LANGUAGE RoleAnnotations, GADTs #-}

module Roles8 where

data T1 a = K1 a

type role T1 nominal
type role T1 nominal

data T2 b = MkT2

type role T2 representational
type role T2 phantom


{-# LANGUAGE GeneralizedNewtypeDeriving #-}

module RolesIArray where

import Data.Word
import Data.Array.IArray
import Data.Array.Unboxed

newtype N = MkN Word64
  deriving (IArray UArray)


{-# LANGUAGE RoleAnnotations #-}

module T8773 where

type role C2 representational
class C2 a where
  meth2 :: a -> a


module T9204 where

import T9204a

data D a


module T9204a where
import {-# SOURCE #-} T9204


module Main where

import Control.Exception
import Control.Monad
import Data.List
import System.Mem

main = do
  let
    testAlloc n = do
      let start = 999999
      setAllocationCounter start
      evaluate (last [1..n])
      c <- getAllocationCounter
      -- print (start - c)
      return (start - c)
  results <- forM [1..1000] testAlloc
  print (sort results == results)
    -- results better be in ascending order


module Main where

break2 p (x:xs) = if p x then
                    ([],x:xs)
                  else
                    let (b1,b2) = break2 p xs
                    in  (x : b1, b2)
break2 p []     = ([],[])

surprise xs = b1 ++ "\n surprise " ++ b2
               where
               (b1,b2) = break2 (=='\n') xs

test n = length $ surprise $ [head (show i) | i <-[1..n] ] ++ "\n the end"

main = print $ test 10000


{-
By default, on Windows a segfault will pop up an annoying dialog box.
We want the RTS to catch it instead.
-}

module Main where

import Foreign

main :: IO ()
main = do x <- peek nullPtr
          print (x :: Int)


{-
By default, on Windows a division-by-zero will pop up an annoying dialog box.
We want the RTS to catch it instead.
-}

module Main where

import GHC.Base

main :: IO ()
main = print (5 `divInt` 0)


import System.Process
import System.Posix.Signals
import Control.Monad(when)

data SigState = Ignored | Default | Handled
    deriving (Eq, Read, Show)

data ChildInfo = ChildInfo {
        masked :: [(Int,Bool)],
        handlers :: [(Int, SigState)] }
    deriving (Read, Show)

main = do out <- readProcess "./exec_signals_child" [] ""
          let ci = read out :: ChildInfo
              blockedSigs = [x | (x, True) <- masked ci]
              ignoredSigs = [x | (x, Ignored) <- handlers ci]
          when (not $ null blockedSigs) $
            putStrLn ("signals " ++ show blockedSigs ++ " are blocked")
          when (not $ null ignoredSigs) $
            putStrLn ("signals " ++ show ignoredSigs ++ " are ignored")


import Control.Concurrent
import Control.Monad
import Foreign.Ptr

main = do
  fptr <- wrap $ return . (*4)
  forkIO $ forever $ do
    _ <- dyn fptr 4
    return ()
  threadDelay $ 100 * 1000

foreign import ccall "wrapper" wrap :: (Double -> IO Double) -> IO (FunPtr (Double -> IO Double))
foreign import ccall "dynamic" dyn :: FunPtr (Double -> IO Double) -> Double -> IO Double


-- A test to show that -XStaticPointers keeps generated CAFs alive.
{-# LANGUAGE StaticPointers #-}
module Main where

import GHC.StaticPtr

import Control.Concurrent
import Data.Maybe (fromJust)
import GHC.Fingerprint
import System.Mem
import System.Mem.Weak
import Unsafe.Coerce (unsafeCoerce)

nats :: [Integer]
nats = [0 .. ]

-- The key of a 'StaticPtr' to some CAF.
nats_key :: StaticKey
nats_key = staticKey (static nats :: StaticPtr [Integer])

main = do
  let z = nats !! 400
  print z
  performGC
  addFinalizer z (putStrLn "finalizer z")
  print z
  performGC
  threadDelay 1000000
  Just p <- unsafeLookupStaticPtr nats_key
  print (deRefStaticPtr (unsafeCoerce p) !! 800 :: Integer)
  -- Uncommenting the next line keeps 'nats' alive and would prevent a segfault
  -- if 'nats' were garbage collected.
  -- print (nats !! 900)


module KeepCafs1 where

import KeepCafsBase

foreign export ccall "getX"
  getX :: IO Int

getX :: IO Int
getX = return x


module KeepCafs2 where

import KeepCafsBase

foreign export ccall "getX"
  getX :: IO Int

getX :: IO Int
getX = return (x + 1)


module KeepCafsBase (x) where

x :: Int
x = last [1..1000]


module Main (main) where

import Foreign
import GHCi.ObjLink
import System.Mem
import System.Exit

foreign import ccall "dynamic"
  callGetX :: FunPtr (IO Int) -> IO Int

main :: IO ()
main = do
  initObjLinker DontRetainCAFs
  let
    loadAndCall obj = do
      loadObj obj
      resolveObjs
      r <- lookupSymbol "getX"
      case r of
        Nothing -> die "cannot find getX"
        Just ptr -> callGetX (castPtrToFunPtr ptr) >>= print
      unloadObj obj
      performGC
  loadAndCall "KeepCafs1.o"
  loadAndCall "KeepCafs2.o"


module LinkerUnload (init) where

import GHC
import DynFlags
import Linker
import System.Environment
import MonadUtils ( MonadIO(..) )

foreign export ccall loadPackages :: IO ()

loadPackages :: IO ()
loadPackages = do
  [libdir] <- getArgs
  runGhc (Just libdir) $ do
    dflags <- getSessionDynFlags
    let dflags' = dflags { hscTarget = HscNothing
                         , ghcLink  = LinkInMemory }
    pkgs <- setSessionDynFlags dflags'
    hsc_env <- getSession
    liftIO $ Linker.linkPackages hsc_env pkgs


-- A test to show that Static Pointers can be listed.
{-# LANGUAGE StaticPointers #-}
module Main where

import Control.Monad (when)
import Data.List ((\\))
import GHC.StaticPtr
import System.Exit

main = do
    found <- staticPtrKeys
    when (not $ eqBags found expected) $ do
      print ("expected", expected)
      print ("found", found)
      exitFailure
  where

    expected =
      [ staticKey $  static (\x -> x :: Int)
      , staticKey   (static return :: StaticPtr (Int -> IO Int))
      , staticKey $  static g
      ]

    eqBags :: Eq a => [a] -> [a] -> Bool
    eqBags xs ys = null (xs \\ ys) && null (ys \\ xs)

g :: Int -> Int
g = (+1)


import System.Environment
import Control.Monad
import Control.Concurrent

main = do
  [n] <- map read <$> getArgs
  mvars <- replicateM n newEmptyMVar
  sequence_ [ forkIO $ putMVar m $! nsoln n
            | (m,n) <- zip mvars (repeat 9) ]
  mapM_ takeMVar mvars

nsoln nq = length (gen nq)
 where
    safe :: Int -> Int -> [Int] -> Bool
    safe x d []    = True
    safe x d (q:l) = x /= q && x /= q+d && x /= q-d && safe x (d+1) l

    gen :: Int -> [[Int]]
    gen 0 = [[]]
    gen n = [ (q:b) | b <- gen (n-1), q <- [1..nq], safe q 1 b]


-- Test for a bug that provoked the following assertion failure:
-- nursery-chunks1: internal error: ASSERTION FAILED: file rts/sm/Sanity.c, line 903
module Main (main) where

import Control.Monad
import System.Environment
import GHC.Conc

main = do
  [n,m] <- fmap read <$> getArgs
  forM_ [1..n] $ \n' ->
    when (sum [1.. m::Integer] > 0) $ setNumCapabilities (fromIntegral n')


module Main where
import Data.Array.IO
import Control.Monad
main = do
  arrs <- sequence $ repeat $ (newArray_ (0,2^28) :: IO (IOUArray Int Int))
        -- larger than 2^28 causes other problems...
  print (length arrs)


-- Test for bug #1791
import Control.Monad.ST
import Data.Array.ST
import Data.Array.MArray
import Data.Array.Base(unsafeNewArray_)
main = print (runST (do make_empty_table >> return ()))

make_empty_table::  ST s (STArray s (Int, Int) (Maybe ep))
make_empty_table =
       unsafeNewArray_ ((1, 1), (16384, 16384))


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

module Main where

import GHC.Exts
import GHC.Base

-- Try to overflow BLOCK_ROUND_UP in the computation of req_blocks in allocate()
-- Here we invoke allocate() via newByteArray#.
-- Request a number of bytes close to HS_WORD_MAX,
-- subtracting a few words for overhead in newByteArray#.
main :: IO ()
main =
    IO $ \s1# ->
           case newByteArray# (maxInt# -# 10#) s1# of
             (# s2#, _ #) -> (# s2#, () #)
  where
    maxInt# :: Int#
    !(I# maxInt#) = maxBound


{-# LANGUAGE ForeignFunctionInterface #-}
module Main where

import Foreign

-- Test allocate(), the easy way.
data Cap = Cap
foreign import ccall "rts_unsafeGetMyCapability" myCapability :: IO (Ptr Cap)
foreign import ccall "allocate" allocate :: Ptr Cap -> Word -> IO (Ptr ())

-- Number of words n such that n * sizeof(W_) exactly overflows a word
-- (2^30 on a 32-bit system, 2^61 on a 64-bit system)
overflowWordCount :: Word
overflowWordCount = fromInteger $
                    (fromIntegral (maxBound :: Word) + 1) `div`
                    fromIntegral (sizeOf (undefined :: Word))

main = do
  cap <- myCapability
  allocate cap (overflowWordCount - 1)


{-# LANGUAGE ForeignFunctionInterface #-}
module Main where

import Foreign

-- Test allocate(), the easy way.
data Cap = Cap
foreign import ccall "rts_unsafeGetMyCapability" myCapability :: IO (Ptr Cap)
foreign import ccall "allocate" allocate :: Ptr Cap -> Word -> IO (Ptr ())

-- Number of words n such that n * sizeof(W_) exactly overflows a word
-- (2^30 on a 32-bit system, 2^61 on a 64-bit system)
overflowWordCount :: Word
overflowWordCount = fromInteger $
                    (fromIntegral (maxBound :: Word) + 1) `div`
                    fromIntegral (sizeOf (undefined :: Word))

main = do
  cap <- myCapability
  allocate cap (overflowWordCount + 1)


-- | A test to load symbols exposed with @-rdynamic@.
--
-- Exporting 'f' from Main is important, otherwise, the corresponding symbol
-- wouldn't appear in symbol tables.
--
{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE MagicHash                #-}
{-# LANGUAGE UnboxedTuples            #-}
module Main(main, f) where

import Foreign.C.String ( withCString, CString )
import GHC.Exts         ( addrToAny# )
import GHC.Ptr          ( Ptr(..), nullPtr )
import System.Info      ( os, arch )
import Encoding

main = (loadFunction Nothing "Main" "f" :: IO (Maybe String)) >>= print

f :: String
f = "works"

-- loadFunction__ taken from
-- @plugins-1.5.4.0:System.Plugins.Load.loadFunction__@
loadFunction :: Maybe String
             -> String
             -> String
           -> IO (Maybe a)
loadFunction mpkg m valsym = do
    c_initLinker
    let symbol = prefixUnderscore
                   ++ maybe "" (\p -> zEncodeString p ++ "_") mpkg
                   ++ zEncodeString m ++ "_" ++ zEncodeString valsym
                   ++ "_closure"
    ptr@(Ptr addr) <- withCString symbol c_lookupSymbol
    if (ptr == nullPtr)
    then return Nothing
    else case addrToAny# addr of
           (# hval #) -> return ( Just hval )
  where
    prefixUnderscore = case (os, arch) of
                         ("mingw32", "x86_64") -> ""
                         ("cygwin" , "x86_64") -> ""
                         ("mingw32", _       ) -> "_"
                         ("darwin" , _       ) -> "_"
                         ("cygwin" , _       ) -> "_"
                         _                     -> ""

foreign import ccall safe "lookupSymbol" c_lookupSymbol :: CString -> IO (Ptr a)
foreign import ccall safe "initLinker" c_initLinker :: IO ()


import Control.Concurrent
import System.IO
import System.Mem

main :: IO ()
main = do hSetBuffering stdout LineBuffering
          mapM_ doIter [1..3]

doIter :: Int -> IO ()
doIter n = do putStrLn ("Iteration " ++ show n)
              let xs = [n .. 1000000 + n]
              putStrLn ("Last: " ++ show (last xs))
              putStrLn "GC 1 start"
              performGC
              putStrLn "GC 1 done"
              putStrLn ("Head: " ++ show (head xs))
              putStrLn "GC 2 start"
              performGC
              putStrLn "GC 2 done"


import System.Mem.StableName
import System.Mem

-- Test that we get the same StableName even after a GC.  This is easy
-- to get wrong, by not following indirections properly.

main = do
  let x = [1..10]
  seq x (return ())
  n1 <- makeStableName x
  performGC
  n2 <- makeStableName x
  print (n1 == n2)


module Main where

import Control.Concurrent
import Control.Exception

main = do
  -- stack will grow as we evaluate the expression, and then shrink again
  evaluate $ foldr (+) 0 [1..200000]
  threadDelay 10 -- allow stack to shrink back to its smallest size


{-# LANGUAGE CPP #-}
#include "stack001.hs"


{-# LANGUAGE MagicHash, UnboxedTuples #-}

import GHC.Exts
import System.Environment

main = do
  [n] <- fmap (fmap read) getArgs
  case g n of
    (# a, b, c, d, e, f, g, h, i #) -> print a

-- a deep stack in which each frame is an unboxed tuple-return, to exercise
-- the stack underflow machinery.
g :: Int -> (# Int,Float,Double,Int#,Float#,Double#,Int,Float,Double #)
g 0 = (# 1, 2.0, 3.0, 1#, 2.0#, 3.0##, 1, 2.0, 3.0 #)
g x = case g (x-1) of
        (# a, b, c, d, e, f, g, h, i #) ->
          (# a+1, b, c, d, e, f, g, h, i #)


module Main where

import Control.Monad
import GHC.RTS.Flags

-- Ensure that +RTS -K0 is parsed
main :: IO ()
main = do
    flags <- getGCFlags
    unless (maxStkSize flags == 0) $ putStrLn "uh oh"


import Control.Concurrent
import System.Posix.Signals

main :: IO ()
main = do
    _ <- flip (installHandler sig) Nothing $ Catch $
        putStrLn $ "Received my signal"
    raiseSignal sig
    threadDelay 100000
  where
    sig = sigUSR2


-- A reduced version of the original test case

{-# LANGUAGE ForeignFunctionInterface #-}

import Control.Concurrent
import Control.Monad
import Foreign.C.Types
import Foreign.Ptr

main :: IO ()
main = do
    mv <- newEmptyMVar
    -- Fork a thread to continually dereference a stable pointer...
    void $ forkIO $ f 1 1000000 >> putMVar mv ()
    -- ...while we keep enlarging the stable pointer table
    f 65536 1
    void $ takeMVar mv
  where
    f nWraps nApplies = replicateM_ nWraps $ do
                            -- Each call to wrap creates a stable pointer
                            wrappedPlus <- wrap (+)
                            c_applyFun nApplies wrappedPlus 1 2

type CIntFun = CInt -> CInt -> CInt

foreign import ccall "wrapper"
    wrap :: CIntFun -> IO (FunPtr CIntFun)

foreign import ccall "apply_fun"
    c_applyFun :: CInt -> FunPtr CIntFun -> CInt -> CInt -> IO CInt


-- A variant of the T10296a.hs test case in which
--   - the FFI machinery has been eliminated
--   - a primop (deRefStablePtr#) is used to dereference the stable pointer
--   - the stable pointers are explicitly freed at the end

import Control.Concurrent
import Control.Monad
import Foreign.StablePtr

main :: IO ()
main = do
    sp <- newStablePtr ()
    _ <- forkIO $ forever $ deRefStablePtr sp >> threadDelay 0
    sps <- replicateM 1048576 $ newStablePtr ()
    ----------------------------------------------------------
    mapM_ freeStablePtr sps
    freeStablePtr sp


import Foreign.C
import Foreign.Marshal.Array
import Foreign.Storable
import Control.Concurrent

-- The test works only on UNIX like.
-- unportable bits:
import qualified System.Posix.Internals as SPI
import qualified System.Posix.Types as SPT

pipe :: IO (CInt, CInt)
pipe = allocaArray 2 $ \fds -> do
    throwErrnoIfMinus1_ "pipe" $ SPI.c_pipe fds
    rd <- peekElemOff fds 0
    wr <- peekElemOff fds 1
    return (rd, wr)

main :: IO ()
main = do
    (r1, w1)  <- pipe
    (r2, _w2) <- pipe
    _ <- forkIO $ do -- thread A
                     threadWaitRead (SPT.Fd r1)
    _ <- forkIO $ do -- thread B
                     threadWaitRead (SPT.Fd r2)
    yield -- switch to A, then B
          -- now both are blocked
    _ <- SPI.c_close w1 -- unblocking thread A fd
    _ <- SPI.c_close r2 -- breaking   thread B fd
    yield -- kick RTS IO manager

{-
 Trac #10590 exposed a bug as:
   T10590: internal error: removeThreadFromDeQueue: not found
    (GHC version 7.11.20150702 for x86_64_unknown_linux)
    Please report this as a GHC bug:  http://www.haskell.org/ghc/reportabug
 -}


-- T10728 test case for ``-maxN<n>``

module Main where

import GHC.Conc (getNumProcessors, getNumCapabilities)
import GHC.Environment
import Data.List

main :: IO ()
main = do
  -- We're parsing args passed in to make sure things are proper between the
  -- cli and the program.
  n <- getN <$> getFullArgs

  c <- getNumCapabilities
  p <- getNumProcessors

  putStr $ check n c p

-----

check :: Int -> Int -> Int -> String
check n c p
  |  n /= 0 && c /= 0 && p /= 0 -- These should never be 0
  -- Capabilities are equal to n, are they also within processor count?
  && (n == c && c <= p)
  -- Capabilities are equal to processor count, are they also within n?
  || (c == p && c <= n)
  = "maxN Successful"
check _n _c _p = "maxN Error"

-- Parsing ``-maxN<n>`` from Args to be sure of it.
getN :: [String] -> Int
getN args = case filter (isPrefixOf "-maxN") (reverse args) of
    (maxN:_) -> read (drop 5 maxN)
    _        -> error "Please pass `-maxN<n>` on command-line"


import Control.Concurrent
import Control.Monad
import Foreign
import Foreign.C.Types
import System.Environment

foreign import ccall safe "finalizerlib.h init_value"
    init_value :: Ptr CInt -> IO ()

foreign import ccall safe "finalizerlib.h &finalize_value"
    finalize_value :: FinalizerPtr CInt

allocateValue :: IO ()
allocateValue = do
    fp <- mallocForeignPtrBytes 10000
    withForeignPtr fp init_value
    addForeignPtrFinalizer finalize_value fp

main :: IO ()
main = do
    [n] <- fmap (fmap read) getArgs
    _ <- forkIO (loop n)
    loop n
  where
    loop n = replicateM_ n allocateValue


{-# LANGUAGE RecursiveDo, LambdaCase, BangPatterns #-}

import Control.Monad.Fix
import Data.IORef
import System.Mem.Weak
import System.Mem

import Control.Monad
import Data.Foldable

data Pull = Pull
  { weakSelf  :: Weak Pull
  , compute :: Weak Pull -> IO Int
  , invalidators :: IORef [Weak Pull]
  , cached  :: IORef (Maybe Int)
  }

makePull :: (Weak Pull -> IO Int) -> IO Pull
makePull f = do
  rec
    -- This seems to be the culprit, changing the order makes the weakRef get gc'ed
    -- In this configuration it crashes

    !foo <- Pull weak f <$> newIORef [] <*> newIORef Nothing
    weak <- mkWeakPtr foo Nothing

  return foo

invalidate :: Pull -> IO ()
invalidate p = do
  writeIORef (cached p) Nothing
  invs <- readIORef (invalidators p)
  writeIORef (invalidators p) []
  traverse_ (deRefWeak >=> traverse_ invalidate) invs

pull :: Weak Pull -> Pull -> IO Int
pull weak p = do
  modifyIORef (invalidators p) (weak :)
  pull' p

pull' :: Pull -> IO Int
pull' p = do
  readIORef (cached p) >>= \case
    Nothing -> do
      r <- compute p (weakSelf p)
      writeIORef (cached p) (Just r)
      return r

    Just r -> return r

add :: Pull -> Int -> IO (Pull)
add p n = makePull (\w -> (+n) <$> pull w p)

main = do
  h <- newIORef 0

  source <- makePull (const $ readIORef h)
  p <- foldM add source (take 1000 (repeat 1))   -- 100 is not enough for crash

  forM_ [1..10] $ \i -> do

    writeIORef h i
    invalidate source -- Crashes here on second iteration

    --performGC
    -- This avoids the crash

    print =<< pull' p


module Main where

foreign import ccall "c" c_exp :: Int

main = print c_exp


{-# LANGUAGE CPP #-}

#if defined(i386_HOST_ARCH)
# define WINDOWS_CCONV stdcall
#elif defined(x86_64_HOST_ARCH)
# define WINDOWS_CCONV ccall
#else
# error Unknown mingw32 arch
#endif

import Foreign.C.String

foreign import WINDOWS_CCONV "_strdup" strdup :: CString -> IO CString
foreign import WINDOWS_CCONV "strdup" strdup2 :: CString -> IO CString

dupString :: String -> IO String
dupString str = newCString str >>= strdup >>= peekCString

dupString2 :: String -> IO String
dupString2 str = newCString str >>= strdup2 >>= peekCString

main =
 do print =<< dupString  "Hello World!"
    print =<< dupString2 "Hello Again World!"


import Control.Concurrent
import Control.Exception
import System.IO
import System.Posix
import System.Posix.IO

main = do
  (pout1, pin1) <- createPipe
  (pout2, _) <- createPipe
  pid <- forkProcess $ do
           hdl <- fdToHandle pin1
           hSetBuffering hdl LineBuffering
           handle (\UserInterrupt{} -> hPutStrLn hdl "caught")
                  $ do hPutStrLn hdl "registered"
                       hdl2 <- fdToHandle pout2
                       putStrLn =<< hGetLine hdl2
  hdl <- fdToHandle pout1
  hSetBuffering hdl LineBuffering
  "registered" <- hGetLine hdl
  signalProcess sigINT pid
  putStrLn =<< hGetLine hdl


module Main where

import Foreign
import Foreign.Ptr
import Foreign.C

import Foreign.Marshal.Array

foreign import ccall unsafe "mult" mult :: Ptr CInt -> Ptr CInt
                                        -> CInt -> IO CInt

main = do res <- withArray [1..10] $ \a ->
                 withArray [5..15] $ \b ->
                   mult a b 10
          print res


import GHC.Conc

main :: IO ()
main = setNumCapabilities 0


-- Test that isByteArray# returns True for large but not explicitly pinned byte
-- arrays

{-# LANGUAGE MagicHash #-}
{-# LANGUAGE UnboxedTuples  #-}

import Control.Monad
import GHC.Exts
import GHC.IO

main :: IO ()
main = do
    pinned <- IO $ \s0 ->
      case newByteArray# 1000000# s0 of
        (# s1, arr# #) ->
            case isMutableByteArrayPinned# arr# of
              n# -> (# s1, isTrue# n# #)
    unless pinned $ putStrLn "BAD"


module Main (main) where

import System.Timeout

fuc :: Integer -> Integer
fuc 0 = 1
fuc n = n * fuc (n - 1)

main :: IO ()
main = do
  let x = fuc 30000
  timeout 1000 (print x)
  print (x > 0)


module Main where

import Control.Monad
import Data.Array.IO.Safe
import Data.Word
import GHC.Stats
import System.Exit
import System.Mem

printAlloc :: String -> IO (Word64, Word64)
printAlloc name = do
    performGC
    details <- gc <$> getRTSStats
    let dat = (gcdetails_live_bytes details, gcdetails_mem_in_use_bytes details)
    putStrLn $ name ++ ": " ++ show dat
    pure dat

allocateAndPrint :: IO ()
allocateAndPrint = do
    -- allocate and touch a lot of memory (4MB * 260 ~ 1GB)
    memoryHog <- forM [1 .. 300] $ \_ ->
        (newArray (0, 1000000) 0 :: IO (IOUArray Word Word32))
    _ <- printAlloc "with large allocation"
    -- do something with memory to prevent it from being GC'ed until now
    forM_ memoryHog $ \a -> void $ readArray a 0

main :: IO ()
main = do
    (firstLive, firstTotal) <- printAlloc "initial"
    allocateAndPrint
    (lastLive, lastTotal) <- printAlloc "final"

    -- Now there is no reason to have more memory allocated than at start
    let ratio = fromIntegral lastTotal / fromIntegral firstTotal
    putStrLn $ "alloc ratio " ++ show ratio
    when (ratio > 1.5) $ exitFailure


{-# LANGUAGE MagicHash, UnboxedTuples #-}

import GHC.Compact
import GHC.Int
import GHC.Prim
import GHC.IO
import GHC.Exts

data BA = ByteArray ByteArray#

newByteArray :: Int -> IO BA
newByteArray (I# sz) = IO $ \s -> case newByteArray# sz s of {
  (# s', arr# #) -> case unsafeFreezeByteArray# arr# s of {
  (# s'', barr# #) -> (# s', ByteArray barr# #) }}

main :: IO ()
main = do
  ByteArray arr1# <- fmap getCompact $ newByteArray 65000 >>= compact
  ByteArray arr2# <- newByteArray 65000
  print (I# (isByteArrayPinned# arr1#))
  print (I# (isByteArrayPinned# arr2#))
  putStrLn "Finished"


module Main where

import qualified Data.Set as Set
import Control.Monad
import Data.List

---
---
---

data Direction = DirUp | DirLeft | DirRight | DirDown
    deriving (Eq,Ord,Show,Read)

directions = [DirUp,DirLeft,DirRight,DirDown]

coordOffset DirUp = (-1,0)
coordOffset DirLeft = (0,-1)
coordOffset DirRight = (0,1)
coordOffset DirDown = (1,0)

move (r,c) d = (r+dr,c+dc) where (dr,dc) = coordOffset d

sortPair (x,y) =
    case compare x y of
        EQ -> (x,y)
        LT -> (x,y)
        GT -> (y,x)
mapPair12 f (x,y) = (f x,f y)

cachedUsingList f = f'
    where
        list = map f [0..]
        f' i = list !! i

nubSorted [] = []
nubSorted (x:xs) = nubSorted' x xs
    where
        nubSorted' x [] = [x]
        nubSorted' x (y:ys)
            | x == y  = nubSorted' x ys
            | otherwise  = x : nubSorted' y ys

---
---
---

size = 21
largestExplicitlyEnumeratedArea = 7

type Cell = (Int,Int)
type Edge = (Cell,Cell)

mkEdge cell1 cell2 = sortPair (cell1,cell2)

cellsAround area = nubSorted $ sort $
    do
        cell <- area
        dir <- directions
        let cell2 = move cell dir
        guard $ cell2 `notElem` area
        return $ cell2

increaseAreas areas = nubSorted $ sort $
    do
        area <- areas
        cell2 <- cellsAround area
        return $ sort $ cell2 : area
getAreas :: Int -> [[Cell]]
getAreasRaw 1 = [[(0,0)]]
getAreasRaw n = areas
    where
        areas = increaseAreas $ getAreas $ n - 1
getAreas = cachedUsingList getAreasRaw

getEdges area = mapPair12 (map snd) $ partition fst $ nubSorted $ sort $
    do
        cell <- area
        dir <- directions
        let cell2 = move cell dir
        let isInternal = cell2 `elem` area
        return (isInternal,mkEdge cell cell2)

type SizedArea = (Int,((Set.Set Cell,Set.Set Cell),(Set.Set Edge,Set.Set Edge)))
getExtendedAreas n =
    do
        area <- getAreas n
        let areaAround = cellsAround area
        let edgeInfo = getEdges area
        return ((Set.fromList area,Set.fromList areaAround),mapPair12 Set.fromList edgeInfo)

getSizedAreasThrough :: Int -> [SizedArea]
getSizedAreasThrough n =
    do
        n' <- [1 .. n]
        extendedArea <- getExtendedAreas n'
        return $ (n',extendedArea)

sizeForSizedArea (asize,_) = asize
allSizedAreas = getSizedAreasThrough largestExplicitlyEnumeratedArea

main = print $ allSizedAreas


import GHCi.ObjLink

library_name = "libfoo_script_T2615.so" -- this is really a linker script

main = do
  initObjLinker RetainCAFs
  result <- loadDLL library_name
  case result of
    Nothing -> putStrLn (library_name ++ " loaded successfully")
    Just x  -> putStrLn ("error: " ++ x)


main = print $ do x <- [ 0 .. 5 ] ; let { y = 5 - y } ; return y


{-# LANGUAGE ForeignFunctionInterface #-}

import Foreign hiding ( unsafePerformIO )
import Foreign.C
import System.IO.Unsafe

d f x = unsafePerformIO $ do
    g <- mkfun f
    r <- deriv g x 1
    return r

main = do
    print $ d (\x -> x * 2) 3
    print $ d (\x -> x * d (\y -> x + y) 5) 7

foreign import ccall safe "deriv"
    deriv :: FunPtr (CDouble -> CDouble) -> CDouble -> CDouble -> IO CDouble

foreign import ccall safe "wrapper"
    mkfun :: (CDouble -> CDouble) -> IO (FunPtr (CDouble -> CDouble))


{-# LANGUAGE ForeignFunctionInterface #-}
module Main where

import Foreign
import Control.Concurrent

type Fun = Int -> IO Int

foreign import ccall "wrapper" mkF :: Fun -> IO (FunPtr Fun)

foreign import ccall "dynamic" callF :: FunPtr Fun -> Fun

-- This test should create 5 OS threads only:
--   one for main
--   worker 1 for the IO manager
--   worker 1 for the timeout manager
--   worker 3 to run the first forkIO
--   worker 4 created when worker 2 makes its foreign call

-- Due to #4850, an extra worker was being created because worker 2 was
-- lost after returning from its foreign call.

main = do
  m <- newEmptyMVar
  callback m >> takeMVar m >>= print
  callback m >> takeMVar m >>= print

callback m =
  forkIO $ do
    f <- mkF $ \x -> return (x+1)
    r <- callF f 3
    putMVar m r


module Main where

import Foreign
import Foreign.C
import Text.Printf
import System.Exit
import Control.Monad

foreign import ccall "getesp" getesp :: IO CInt

main = do
  checkSpAlignment
  wrap checkSpAlignment >>= run
  wrap1 args1 >>= \f -> run1 f 3
  wrap2 args2 >>= \f -> run2 f 3 4
  wrap3 args3 >>= \f -> run3 f 3 4 5
  wrap4 args4 >>= \f -> run4 f 3 4 5 6

foreign import ccall "wrapper" wrap :: IO () -> IO (FunPtr (IO ()))
foreign import ccall "dynamic" run  :: FunPtr (IO ()) -> IO ()

type Args1 = Int -> IO ()

foreign import ccall "wrapper" wrap1 :: Args1 -> IO (FunPtr Args1)
foreign import ccall "dynamic" run1  :: FunPtr Args1 -> Args1

args1 :: Args1
args1 _ = checkSpAlignment

type Args2 = Int -> Int -> IO ()

foreign import ccall "wrapper" wrap2 :: Args2 -> IO (FunPtr Args2)
foreign import ccall "dynamic" run2  :: FunPtr Args2 -> Args2

args2 :: Args2
args2 _ _ = checkSpAlignment

type Args3 = Int -> Int -> Int -> IO ()

foreign import ccall "wrapper" wrap3 :: Args3 -> IO (FunPtr Args3)
foreign import ccall "dynamic" run3  :: FunPtr Args3 -> Args3

args3 :: Args3
args3 _ _ _ = checkSpAlignment

type Args4 = Int -> Int -> Int -> Int -> IO ()

foreign import ccall "wrapper" wrap4 :: Args4 -> IO (FunPtr Args4)
foreign import ccall "dynamic" run4  :: FunPtr Args4 -> Args4

args4 :: Args4
args4 _ _ _ _ = checkSpAlignment

checkSpAlignment :: IO ()
checkSpAlignment = do
  esp <- getesp
  when (((esp + fromIntegral (sizeOf (undefined :: Ptr ()))) .&. 15) /= 0) $ do
     printf "esp not aligned correctly: %x\n" (fromIntegral esp :: Word32)
     exitWith (ExitFailure 1)


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

import GHC.Exts

foreign import prim "test" test :: Int# -> Int# -> Int# -> Int# -> Int#
                                -> Int# -> Int# -> Int# -> Int# -> Int#
                                -> Int#

v :: Int
v = I# (test 111# 112# 113# 114# 115# 116# 117# 118# 119# 120#)

main :: IO ()
main = print v


{-# LANGUAGE ForeignFunctionInterface, CPP #-}
import Foreign.C.String
import Control.Monad
import System.Environment
import System.FilePath
import Foreign.Ptr

-- Type of paths is different on Windows
#if defined(mingw32_HOST_OS)
type PathString = CWString
withPathString = withCWString
#else
type PathString = CString
withPathString = withCString
#endif

mungeDLL :: FilePath -> FilePath
#if defined(mingw32_HOST_OS)
-- Strip extension because addDLL on Windows doesn't want it
mungeDLL f =
    let (base, ext) = splitExtension f
    in if ext == ".dll" then base else error ("unexpected DLL file name: " ++ f)
#else
mungeDLL = id
#endif

main = do
    [ty, object] <- getArgs
    initLinker
    if ty == "dyn"
      then do
        r <- withPathString (mungeDLL object) $ \s -> addDLL s
        when (r /= nullPtr) $ error =<< peekCString r
      else do
        r <- withPathString object $ \s -> loadObj s
        when (r /= 1) $ error "loadObj failed"
    r <- resolveObjs
    when (r /= 1) $ error "resolveObj failed"
    putStrLn "success"

{-
    f <- withCString (mungeSymbol "do_checks") lookupSymbol
    when (f == nullFunPtr) $ error "lookupSymbol failed"
    mkIO f

foreign import ccall "lookupSymbol" lookupSymbol :: CString -> IO (FunPtr (IO ()))
foreign import ccall "dynamic" mkIO :: FunPtr (IO ()) -> IO ()

mungeSymbol :: String -> String
#if LEADING_UNDERSCORE
mungeSymbol s = "_" ++ s -- Mac OS X
#else
mungeSymbol = id
#endif
-}

foreign import ccall "initLinker" initLinker :: IO ()
foreign import ccall "addDLL" addDLL :: PathString -> IO CString
foreign import ccall "loadObj" loadObj :: PathString -> IO Int
foreign import ccall "resolveObjs" resolveObjs :: IO Int


import Control.Concurrent
main = do
  m <- newEmptyMVar
  forkIO $ putStrLn "Hello World!" >> putMVar m ()
  takeMVar m


module F where
import System.Environment

foreign export ccall f :: IO ()
f = do
  getProgName >>= print
  getArgs >>= print


{-# LANGUAGE ForeignFunctionInterface #-}

module Main where

foreign import ccall "global.h printx"
  c_printx :: IO ()

main = do
  c_printx


import Control.Concurrent

main = do
  t <- myThreadId
  forkIO (threadDelay 100000 >> killThread t)
  threadDelay . fromInteger $
    min 9223372036840001 (fromIntegral (maxBound :: Int))
    -- caused an overflow in 7.4.2, non-threaded RTS


{-# LANGUAGE ForeignFunctionInterface, MagicHash #-}
import GHC.ForeignPtr
import GHC.Ptr
import System.Mem

-- Don't use debugBelch() directly, because we cannot call varargs functions
-- using the FFI (doing so produces a segfault on 64-bit Linux, for example).
-- See Debug.Trace.traceIO, which also uses debugBelch2.
foreign import ccall "&debugBelch2" fun :: FunPtr (Ptr () -> Ptr () -> IO ())

new name = do
    p <- newForeignPtr_ (Ptr name)
    addForeignPtrFinalizerEnv fun (Ptr "finalizer 1 (%s)\n"#) p
    addForeignPtrFinalizerEnv fun (Ptr "finalizer 2 (%s)\n"#) p
    return p

main = do
    p <- new "p"#
    q <- new "q"#
    r <- new "r"#
    performGC -- collect p. finalizer order: 2, then 1.
--    print q
    touchForeignPtr q
    performGC -- collect q. finalizer order: 1, then 2.
              -- expected order: 2, then 1.
--    print r
    touchForeignPtr r
    performGC -- collect r. finalizer order: 2, then 1.


import GHC.Conc.Sync
import System.Environment

test n = atomically $ f [1..n]
 where
  f [] = retry
  f (x:xs) = do
    ys <- f xs
    return (x:ys)

main = do
  [n] <- getArgs
  test (read n)


import GHC.Conc.Sync
import Control.Monad
import System.Environment

test n = do
  dog <- newTVarIO False
  cat <- newTVarIO False
  let unset = do
        d <- readTVar dog
        c <- readTVar cat
        if (d || c) then retry else return ()
      setDog = unset >> writeTVar dog True
      setCat = unset >> writeTVar cat True
      reset = do
        d <- readTVar dog
        c <- readTVar cat
        guard (d || c)
        writeTVar dog False
        writeTVar cat False

  replicateM_ n (do
    forkIO (atomically setDog)
    forkIO (atomically setCat)
    atomically reset
    atomically reset)

main = do
  [n] <- getArgs
  test (read n :: Int)


{-# LANGUAGE TemplateHaskell #-}
module Main where

import T7919A

allDecs

main = print test


{-# LANGUAGE TemplateHaskell #-}

module T7919A where

import Control.Applicative
import Control.DeepSeq
import Control.Monad
import Language.Haskell.TH

-- on x86-64 with 7.6.3 it works with size 510 and fails with size 511
size = 512

dataName = mkName "Large"
stepName = mkName "step"

-- data Large = Large Int ... Int  -- generate 'size' fields, not strict
largeData =
  dataD
    (cxt [])
    (dataName)
    []
    Nothing
    [normalC dataName
             (replicate size (((,) <$> bang noSourceUnpackedness
                                       noSourceStrictness) `ap` [t| Int |]))]
    []

conE' :: Name -> [ExpQ] -> ExpQ
conE' n es = foldl appE (conE n) es

varName s i = mkName (s ++ show (((i - 1) `mod` size) + 1))

-- step (Large i1 ... in) =
--   let
--     j1 = i1 + j4
--     ...
--     jn = in + j(3n + 1 `mod` n)
--   in
--     Large j1 ... jn
largeStep =
  funD
    stepName
    [clause
      [conP dataName (map (\ i -> varP (varName "i" i)) [1..size])]
      (normalB
        (letE
          (map (\ i -> valD (varP (varName "j" i)) (normalB [| $(varE (varName "i" i)) + $(varE $ varName "i" (i * 3 + 1)) |]) []) [1..size])
          (tupE [conE' dataName (map (\ i -> varE (varName "j" i)) [1..size]), varE $ varName "j" 1])
        )
      )
      []
    ]

-- test = let step ... in runSteps step 100000 (Large 1 ... 1)
largeLet =
  valD
    (varP (mkName "test"))
    (normalB (letE [largeStep] [| runSteps $(varE stepName) 100000 $(conE' dataName (map (const $ litE $ integerL 1) [1..size]))|]))
    []

allDecs =
  sequence [largeData, largeLet]

runSteps :: (state -> (state, Int)) -> Int -> state -> [Int]
runSteps f n i | n <= 0    = []
               | otherwise = case f i of
                               (i', r) -> {-i' `deepseq`-} (r : runSteps f (n - 1) i')
-- could use deepseq here to avoid the space leak, but it's not necessary


{-# LANGUAGE ScopedTypeVariables #-}

import Control.Exception
import Control.Monad
import GHC.Conc

main = join $ atomically $ do
  catchSTM
    (throwSTM ThreadKilled `orElse` return (putStrLn "wtf"))
    (\(e::SomeException) -> return (putStrLn "ok"))


module T8124 where

f :: Int -> Int
f x = x + 1

foreign export ccall "f" f :: Int -> Int


import Control.Concurrent
import Control.Monad
import GHC.Conc

main = do
  mainTid <- myThreadId
  labelThread mainTid "main"
  forM_ [0..0] $ \i -> forkIO $ do
    subTid <- myThreadId
    labelThread subTid $ "sub " ++ show i
    forM_ [0..100000000] $ \j -> putStrLn $ "sub " ++ show i ++ ": " ++ show j
  yield
  setNumCapabilities 2


{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE UnboxedTuples #-}
import Control.Monad
import GHC.Conc
import Foreign.Marshal.Alloc
import Foreign.Ptr
import Foreign.Storable
import Foreign.C.Types
import GHC.IO
import GHC.Exts

foreign import ccall unsafe "&puts" puts :: FunPtr (Ptr CChar -> IO ())

main :: IO ()
main = do
  ptr@(Ptr p) <- malloc
  poke (ptr :: Ptr CChar) 0
  setNumCapabilities 2
  let !(FunPtr puts#) = puts
  replicateM_ 10000 $ IO $ \s -> let
    !(# s1, w #) = mkWeakNoFinalizer# () () s
    !(# s2, _ #) = addCFinalizerToWeak# puts# p 0# nullAddr# w s1
    !(# s3, _ #) = addCFinalizerToWeak# puts# p 0# nullAddr# w s2
    !(# s4, _ #) = addCFinalizerToWeak# puts# p 0# nullAddr# w s3
    !(# s5, _ #) = addCFinalizerToWeak# puts# p 0# nullAddr# w s4
    !(# s6, _ #) = addCFinalizerToWeak# puts# p 0# nullAddr# w s5
    !(# s7, _ #) = addCFinalizerToWeak# puts# p 0# nullAddr# w s6
    !(# s8, _ #) = addCFinalizerToWeak# puts# p 0# nullAddr# w s7
    !(# s9, _ #) = addCFinalizerToWeak# puts# p 0# nullAddr# w s8
    !(# s10, _ #) = addCFinalizerToWeak# puts# p 0# nullAddr# w s9
    !(# s11, _ #) = addCFinalizerToWeak# puts# p 0# nullAddr# w s10
    !(# s12, _ #) = addCFinalizerToWeak# puts# p 0# nullAddr# w s11
    !(# s13, _ #) = addCFinalizerToWeak# puts# p 0# nullAddr# w s12
    !(# s14, _ #) = addCFinalizerToWeak# puts# p 0# nullAddr# w s13
    !(# s15, _ #) = addCFinalizerToWeak# puts# p 0# nullAddr# w s14
    !(# s16, _ #) = addCFinalizerToWeak# puts# p 0# nullAddr# w s15
    !(# s17, _ #) = addCFinalizerToWeak# puts# p 0# nullAddr# w s16
    !(# s18, _ #) = addCFinalizerToWeak# puts# p 0# nullAddr# w s17
    !(# s19, _ #) = addCFinalizerToWeak# puts# p 0# nullAddr# w s18
    !(# s20, _ #) = addCFinalizerToWeak# puts# p 0# nullAddr# w s19
    in (# s20, () #)


{-# LANGUAGE ImpredicativeTypes #-}
-- This is nofib/smp/threads006.  It fails in GHC 7.8.2 with a GC crash.

{-# OPTIONS_GHC -O2 #-}
import System.IO
import System.Environment
import System.CPUTime
import Text.Printf
import Control.Monad
import Control.Concurrent
import Control.Concurrent.MVar
import Control.Exception

main :: IO ()
main = do
    hSetBuffering stdout NoBuffering
    [nthreads] <- fmap (map read) getArgs
    tids <- replicateM nthreads (mask $ \_ -> forkIO $ return ())
    m <- newEmptyMVar
    -- do it in a subthread to avoid bound-thread overhead
    forkIO $ do mapM_ killThread tids; putMVar m ()
    takeMVar m
    return ()


module Main where

import Control.Monad
import System.Mem.StableName

main :: IO ()
main = replicateM_ 500000 (makeStableName foo)

foo :: Int
foo = 1


import Control.Concurrent

main = threadDelay 2000000


module Main where

main :: IO ()
main = return ()


module Test where

f :: Int -> Int
f x = x + head caf

-- make sure that even when we have a CAF, we can unload the code
caf :: [Int]
caf = [1..10]

foreign export ccall f :: Int -> Int


{-# LANGUAGE MagicHash #-}
{-# LANGUAGE UnboxedTuples #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedStrings #-}
import Data.Word
import GHC.Base
import GHC.Ptr

import qualified Data.ByteString as B
import qualified Data.ByteString.Unsafe as BU

main :: IO ()
main = do
  traceBinaryEventIO "0123456789"
  traceBinaryEventIO $ B.replicate 10 0
  traceBinaryEventIO $ B.replicate (maxSize + 1) 0

maxSize :: Int
maxSize = fromIntegral (maxBound :: Word16)

traceBinaryEventIO :: B.ByteString -> IO ()
traceBinaryEventIO bytes =
  BU.unsafeUseAsCStringLen bytes $ \(Ptr p, I# n) -> IO $ \s -> do
    case traceBinaryEvent# p n s of
      s' -> (# s', () #)


import Data.Word
import Debug.Trace

main = do
  traceEventIO "testing"
  traceEventIO "%s" -- see #3874
  traceEventIO $ replicate (maxSize + 1) 'A'

maxSize :: Int
maxSize = fromIntegral (maxBound :: Word16)


--We check if RTS arguments are properly filtered/passed along
--by outputting them to stdout.

import System.Environment

main :: IO ()
main = getArgs >>= putStr . show


--We check the generation count as a way to verify an RTS argument
--was actually parsed and accepted by the RTS.

import GHC.RTS.Flags (getGCFlags, generations)

main :: IO ()
main = do
    gcFlags <- getGCFlags
    putStr . show $ generations gcFlags


-- Copyright (C) 2015, Luke Iannini

{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE ForeignFunctionInterface #-}

module Main where
import Printf ( pr )

foreign import ccall "talkToCxx" talkToCxx :: IO ()

main :: IO ()
main = do
  putStrLn ( $(pr "Hello From Template Haskell!") )
  talkToCxx


-- Copyright (C) 2015, Luke Iannini

{-# LANGUAGE TemplateHaskell #-}
module Printf where

-- Skeletal printf from the paper:
-- http://research.microsoft.com/pubs/67015/meta-haskell.pdf
-- It needs to be in a separate module to the one where
-- you intend to use it.

-- Import some Template Haskell syntax
import Language.Haskell.TH

-- Describe a format string
data Format = D | S | L String

-- Parse a format string.  This is left largely to you
-- as we are here interested in building our first ever
-- Template Haskell program and not in building printf.
parse :: String -> [Format]
parse s   = [ L s ]

-- Generate Haskell source code from a parsed representation
-- of the format string.  This code will be spliced into
-- the module which calls "pr", at compile time.
gen :: [Format] -> Q Exp
gen [D]   = [| \n -> show n |]
gen [S]   = [| \s -> s |]
gen [L s] = stringE s

-- Here we generate the Haskell code for the splice
-- from an input format string.
pr :: String -> Q Exp
pr s = gen (parse s)


module Main where

foreign import ccall "c" c_exp :: Int

main = print c_exp


module Main where

foreign import ccall "a" a_exp :: Int

main = print a_exp


module Main where

foreign import ccall "a" a_exp :: Int
foreign import ccall "c" c_exp :: Int

main = print $ c_exp * a_exp


module Main where

foreign import ccall "power2" power2 :: Int -> Int

main = print $ power2 4


module Main where

foreign import ccall "power3" power3 :: Int -> Int

main = print $ power3 4


-- Copyright (c) 2016, Ryan Scott
-- ExternBug.hs
{-# LANGUAGE ForeignFunctionInterface #-}
module ExternBug (bar) where

{-# INCLUDE foo.h #-}

foreign import ccall "bar"
  bar :: IO ()


module Main where

foreign import ccall "foo" c_foo :: Int

main = print c_foo


import System.Environment (getArgs)

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


module Main where

foreign import ccall "with_copysign" c_with_copysign :: Double -> Double

main = print $ c_with_copysign 8.5


import Control.Exception
force :: [a] -> [a]
force [] = []
force x@(a:b) = x `seq` a : force b

{-# NOINLINE infiniteList #-}
infiniteList :: [Int]
infiniteList = [1..]

heapOverflow :: IO ()
heapOverflow = do
  evaluate $ length infiniteList -- Force the list
  evaluate infiniteList -- So that the list cannot be garbage collected.
  return ()

main :: IO ()
main = heapOverflow `catch` \x -> case x of
  HeapOverflow -> putStrLn "Heap overflow caught!"
  _ -> throwIO x


module Conf where

iTERATIONS :: Int
iTERATIONS = 1000 * 1000 * 100

bufferSize :: (Num a) => a
bufferSize = 1024


module Main where

import Util
import ManyQueue

main = do
  runTest testManyQueue'1P3C
  runTest testManyQueue'1P1C


{-# LANGUAGE BangPatterns #-}

module ManyQueue where

import Control.Concurrent
import Control.Monad

import Conf

newtype MQueue a = MQueue [MVar a]

newMQueue size = do
  lst <- replicateM size newEmptyMVar
  return (MQueue (cycle lst))

writeMQueue :: (MQueue a) -> a -> IO (MQueue a)
writeMQueue (MQueue (x:xs)) el = do
  putMVar x el
  return (MQueue xs)

readMQueue :: (MQueue a) -> IO (MQueue a, a)
readMQueue (MQueue (x:xs)) = do
  el <- takeMVar x
  return ((MQueue xs), el)

testManyQueue'1P1C = do
  print "Test.ManyQueue.testManyQueue'1P1C"
  finished <- newEmptyMVar

  mq <- newMQueue bufferSize

  let
--      elements = [0] ++ [1 .. iTERATIONS] -- workaround
      elements = [0 .. iTERATIONS] -- heap overflow

      writer _ 0 = putMVar finished ()
      writer q x = do
                  q' <- writeMQueue q x
                  writer q' (x-1)

      writer' _ [] = putMVar finished ()
      writer' q (x:xs) = do
                  q' <- writeMQueue q x
                  writer' q' xs

      reader _ !acc 0 = print acc >> putMVar finished ()
      reader q !acc n = do
                  (q', x) <- readMQueue q
                  reader q' (acc+x) (n-1)

  --forkIO $ writer mq iTERATIONS
  forkIO $ writer' mq elements
  forkIO $ reader mq 0 iTERATIONS

  takeMVar finished
  takeMVar finished

testManyQueue'1P3C = do
  print "Test.ManyQueue.testManyQueue'1P3C"
  let tCount = 3
  finished <- newEmptyMVar

  mqs <- replicateM tCount (newMQueue bufferSize)

  let elements = [0 .. iTERATIONS]

      writer _ [] = putMVar finished ()
      writer qs (x:xs) = do
                  qs' <- mapM (\q -> writeMQueue q x) qs
                  writer qs' xs

      reader _ !acc 0 = print acc >> putMVar finished ()
      reader q !acc n = do
                  (q', x) <- readMQueue q
                  reader q' (acc+x) (n-1)

  forkIO $ writer mqs elements
  mapM_ (\ mq -> forkIO $ reader mq 0 iTERATIONS) mqs

  replicateM (tCount+1) (takeMVar finished)

  return ()


{-# LANGUAGE BangPatterns #-}

module Util where

import Data.Time
-- import Data.List.Split (splitEvery)

import Conf

timed act = do
  putStrLn ""
  t0 <- getCurrentTime
  !v <- act
  t1 <- getCurrentTime
  let td = diffUTCTime t1 t0
  putStrLn $ "Action time: " ++ show td
  return (v,td)

splitEvery _ [] = []
splitEvery n xs = let (lxs,rxs) = splitAt n xs in lxs : splitEvery n rxs

runTest :: (IO ()) -> IO ()
runTest test = do
  (_, t) <- timed test
  let format x = unwords . reverse . map reverse . splitEvery 3 . reverse . show $ x
      val = format (round (fromIntegral iTERATIONS / realToFrac t :: Double) :: Integer)

  putStr "OpsPerSecond: "
  putStrLn val


module Main where

import Control.Concurrent

foreign import ccall "showControlBits" checkfpu :: IO ()

main
 = do checkfpu
      forkOS checkfpu


{-# LANGUAGE BangPatterns #-}
data Test = Test !Int

{-# NOINLINE f #-}
f a = Test (a + 1)

main = let (Test x) = f 1 in print x


import qualified Data.Array.Unboxed as UA
import Data.Word

main :: IO ()
main = print (UA.listArray (1, 2^(20::Int)) (repeat 0)
              :: UA.UArray Int Word64)
       -- this unboxed array should at least take:
       --   2^20 * 64 bits
       -- = 8 * (2^20 bytes)
       -- = 8 MiB (in heap)


main :: IO ()
main = main' ()
  where
    main' _ = main >> main' ()


import Control.Concurrent.MVar  (readMVar)
import System.Environment       (getArgs)
import System.Exit              (ExitCode (ExitFailure), exitFailure)
import System.IO                (hClose, hGetLine, hPutStrLn)
import System.Posix.Process     (exitImmediately, getProcessID)
import System.Posix.Signals     (Handler (Catch), installHandler, sigHUP,
                                 signalProcess)
import System.Process           (StdStream (CreatePipe), createProcess, proc,
                                 std_in, std_out, waitForProcess)
import System.Process.Internals (ProcessHandle (..),
                                 ProcessHandle__ (OpenHandle))
import System.Timeout           (timeout)

main :: IO ()
main = do
    args <- getArgs
    case args of
        ["--runghc", runghc] -> runParent runghc
        ["child"] -> runChild
        _ -> error $ "Unknown args: " ++ show args

runParent :: FilePath -> IO ()
runParent runghc = do
    (Just inH, Just outH, Nothing, ph@(ProcessHandle mvar _)) <-
        createProcess (proc runghc ["T-signals-child.hs", "child"])
            { std_in = CreatePipe
            , std_out = CreatePipe
            }

    -- Get the PID of the actual child process. This will initially be
    -- runghc. If executeFile is used by runghc, that same process
    -- will become the ghc process running our code from
    -- runChild. Otherwise, runChild will run in a child of this
    -- process.
    OpenHandle childPid <- readMVar mvar

    -- Get the PID of the process actually running the runChild code,
    -- by reading it from its stdout (see runChild below).
    pidS <- hGetLine outH
    let pid = fromIntegral (read pidS :: Int)

    -- Send the child process the HUP signal. We know this is after
    -- the signal handler has been installed, since we already got the
    -- PID from the process.
    signalProcess sigHUP childPid

    -- Send the child some input so that it will exit if it didn't
    -- have a sigHUP handler installed.
    hPutStrLn inH ""
    hClose inH

    -- Read out the rest of stdout from the child, which will be
    -- either "NOSIGNAL\n" or "HUP\n"
    rest <- hGetLine outH

    -- Get the exit code of the child
    ec <- waitForProcess ph

    -- Check that everything matches
    if childPid /= pid || rest /= hupMessage || ec /= hupExitCode
        then do
            -- Debugging display
            putStrLn $ concat
                [ "Child process: "
                , show childPid
                , ", real process: "
                , show pid
                ]
            putStrLn $ concat
                [ "Expected "
                , show hupMessage
                , ", received: "
                , show rest
                ]
            putStrLn $ concat
                [ "Expected "
                , show hupExitCode
                , ", received "
                , show ec
                ]
            exitFailure
        else return ()

runChild :: IO ()
runChild = do
    -- Install our sigHUP handler: print the HUP message and exit with
    -- the HUP exit code.
    let handler = Catch $ do
            putStrLn hupMessage
            exitImmediately hupExitCode
    _ <- installHandler sigHUP handler Nothing

    -- Get our actual process ID and print it to stdout.
    pid <- getProcessID
    print (fromIntegral pid :: Int)

    -- Block until we receive input, giving a chance for the signal
    -- handler to be triggered, and if the signal handler isn't
    -- triggered, gives us an escape route from this function.
    --
    -- Include a reasonable timeout to prevent this from running for
    -- too long
    _ <- timeout 10000000 getLine

    -- Reaching this point indicates a failure of the test. Print some
    -- non HUP message and exit with a non HUP exit
    -- code. Interestingly, in a failure, this exit code will _not_
    -- be received by the parent process, since the runghc process
    -- itself will exit with ExitFailure -1, indicating that it was
    -- killed by signal 1 (SIGHUP).
    putStrLn "No signal received"
    exitImmediately $ ExitFailure 41

hupExitCode :: ExitCode
hupExitCode = ExitFailure 42

hupMessage :: String
hupMessage = "HUP"


#!/usr/bin/env whatever

{-# LANGUAGE CPP #-}

module Main where

-- Compiling a program with CPP that also has a hash bang should work (#6132).
-- Before ghc-7.8, it failed with:
--
-- error: invalid preprocessing directive #!
-- #!/usr/bin/env runghc

#if 1
main = return ()
#endif


{-# OPTIONS_GHC -fpackage-trust #-}
{-# LANGUAGE Unsafe #-}
module Check01 ( main' ) where

import safe Check01_B

main' = do
    let n = mainM 1
    print $ n


{-# LANGUAGE Trustworthy #-}
module Check01_A (
        trace
    ) where

import qualified Debug.Trace as D
import qualified Data.ByteString.Lazy.Char8 as BS

-- | Allowed declasification
trace :: String -> a -> a
trace s = D.trace $ s ++ show a3

a3 :: BS.ByteString
a3 = BS.take 3 $ BS.repeat 'a'


{-# LANGUAGE Safe #-}

-- Since Safe we require base package be trusted to compile
module Check01_B where

import Check01_A

mainM :: Int -> Int
mainM n = trace "Allowed Leak" $ n * 2


{-# LANGUAGE Unsafe #-}
module Check02 ( main' ) where

import safe Check02_B

main' = do
    let n = mainM 1
    print $ n


{-# LANGUAGE Trustworthy #-}
module Check02_A (
        trace
    ) where

import qualified Debug.Trace as D
import qualified Data.ByteString.Lazy.Char8 as BS

-- | Allowed declasification
trace :: String -> a -> a
trace s = D.trace $ s ++ show a3

a3 :: BS.ByteString
a3 = BS.take 3 $ BS.repeat 'a'


{-# LANGUAGE Safe #-}

-- Since Safe we require base package be trusted to compile
module Check02_B where

import Check02_A

mainM :: Int -> Int
mainM n = trace "Allowed Leak" $ n * 2


{-# LANGUAGE Unsafe #-}
module Check03 where

import Check03_B

mainN = do
    let n = mainM 1
    print $ n


{-# LANGUAGE Trustworthy #-}
module Check03_A (
        trace
    ) where

import qualified Debug.Trace as D
import qualified Data.ByteString.Lazy.Char8 as BS

-- | Allowed declasification
trace :: String -> a -> a
trace s = D.trace $ s ++ show a3

a3 :: BS.ByteString
a3 = BS.take 3 $ BS.repeat 'a'


{-# LANGUAGE Safe #-}

-- Since Safe we require base package be trusted to compile
module Check03_B where

import Check03_A

mainM :: Int -> Int
mainM n = trace "Allowed Leak" $ n * 2


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

import Check04_1

main = main'


{-# LANGUAGE Unsafe #-}
module Check04_1 ( main' ) where

import safe Check04_B

main' = do
    let n = mainM 1
    print $ n


{-# LANGUAGE Trustworthy #-}
module Check04_A (
        trace
    ) where

import qualified Debug.Trace as D
import qualified Data.ByteString.Lazy.Char8 as BS

-- | Allowed declasification
trace :: String -> a -> a
trace s = D.trace $ s ++ show a3

a3 :: BS.ByteString
a3 = BS.take 3 $ BS.repeat 'a'


{-# LANGUAGE Safe #-}

-- Since Safe we require base package be trusted to compile
module Check04_B where

import Check04_A

mainM :: Int -> Int
mainM n = trace "Allowed Leak" $ n * 2


{-# OPTIONS_GHC -fpackage-trust #-}
module Check05 ( main' ) where

main' = do
    let n = 1
    print $ n


{-# LANGUAGE Trustworthy, NoImplicitPrelude #-}
{-# OPTIONS_GHC -fpackage-trust #-}

-- make sure importing a safe-infered module brings in the
-- pkg trust requirements correctly.
module Check06 ( main' ) where

import safe Check06_A

main' =
    let n = mainM 1
    in n


-- safe infered, with requirement base is trusted
module Check06_A where

mainM :: Int -> Int
mainM n = n + 1


{-# LANGUAGE Trustworthy, NoImplicitPrelude #-}
{-# OPTIONS_GHC -fpackage-trust #-}

-- make sure selective safe imports brings in pkg trust requirements correctly.
-- (e.g only for the imports that are safe ones)
module Check07 ( main' ) where

import safe Check07_A -- no pkg trust reqs
import Check07_B -- base pkg trust req

main' =
    let n = a (b 1)
    in n


{-# LANGUAGE NoImplicitPrelude #-}

-- safe infered, with no pkg trust reqs
module Check07_A where

a :: a -> a
a n = n


-- safe infered, with requirement base is trusted
module Check07_B where

import Prelude

b :: Int -> Int
b n = n + 1


{-# LANGUAGE Trustworthy, NoImplicitPrelude #-}
{-# OPTIONS_GHC -fpackage-trust #-}

-- make sure selective safe imports brings in pkg trust requirements correctly.
-- (e.g only for the imports that are safe ones)
module Check08 ( main' ) where

import safe Check08_A -- no pkg trust reqs
import safe Check08_B -- base pkg trust req

main' =
    let n = a (b 1)
    in n


{-# LANGUAGE NoImplicitPrelude #-}

-- safe infered, with no pkg trust reqs
module Check08_A where

a :: a -> a
a n = n


-- safe infered, with requirement base is trusted
module Check08_B where

import Prelude

b :: Int -> Int
b n = n + 1


{-# LANGUAGE Safe #-}
module Check09 where

import Prelude
import Data.ByteString.Char8

b :: ByteString
b = pack "Hello World"


{-# LANGUAGE Safe #-}
module Check10 where

import Prelude
import Data.ByteString.Char8

b :: ByteString
b = pack "Hello World"


{-# LANGUAGE Trustworthy #-}
module CheckA (
        trace
    ) where

import qualified Debug.Trace as D
import qualified Data.ByteString.Lazy.Char8 as BS

-- | Allowed declasification
trace :: String -> a -> a
trace s = D.trace $ s ++ show a3

a3 :: BS.ByteString
a3 = BS.take 3 $ BS.repeat 'a'


{-# LANGUAGE Safe #-}

-- Since Safe we require base package be trusted to compile
module CheckB where

import CheckB_Aux

mainM :: Int -> Int
mainM n = trace "Allowed Leak" $ n * 2


{-# LANGUAGE Trustworthy #-}
module CheckB_Aux (
        trace
    ) where

import qualified Debug.Trace as D
import qualified Data.ByteString.Lazy.Char8 as BS

-- | Allowed declasification
trace :: String -> a -> a
trace s = D.trace $ s ++ show a3

a3 :: BS.ByteString
a3 = BS.take 3 $ BS.repeat 'a'


{-# LANGUAGE Safe #-}
{-# LANGUAGE NoImplicitPrelude #-}
module ImpSafe01 ( MyWord ) where

-- While Data.Word is safe it imports trustworthy
-- modules in base, hence base needs to be trusted.
-- Note: Worthwhile giving out better error messages for cases
-- like this if I can.
import Data.Word

type MyWord = Word


{-# LANGUAGE Safe #-}
{-# LANGUAGE NoImplicitPrelude #-}
module ImpSafe02 ( MyWord ) where

-- While Data.Word is safe it imports trustworthy
-- modules in base, hence base needs to be trusted.
-- Note: Worthwhile giving out better error messages for cases
-- like this if I can.
import Data.Word

type MyWord = Word


{-# LANGUAGE Trustworthy #-}
module Main where

import safe Prelude
import safe ImpSafe03_A

main = putStrLn "test"


{-# LANGUAGE Trustworthy #-}
module ImpSafe03_A where

import safe Prelude
import safe qualified Data.ByteString.Char8 as BS

s = BS.pack "Hello World"


{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE NoImplicitPrelude #-}
module ImpSafe04 ( MyWord ) where

-- While Data.Word is safe it imports trustworthy
-- modules in base, hence base needs to be trusted.
-- Note: Worthwhile giving out better error messages for cases
-- like this if I can.
import safe Data.Word
import System.IO.Unsafe

type MyWord = Word


{-# LANGUAGE Safe #-}
module Main where

import M_SafePkg

main = do
    putStrLn $ show bigInt


{-# LANGUAGE Safe #-}
module Main where

import M_SafePkg2

main = do
    putStrLn $ show bigInt


{-# LANGUAGE Safe #-}
module Main where

import M_SafePkg3

main = do
    putStrLn $ show bigInt


{-# LANGUAGE Safe #-}
module Main where

import M_SafePkg5

main = do
    putStrLn $ show bigInt


{-# LANGUAGE Trustworthy #-}
module Main where

import Prelude
import safe M_SafePkg6

main = putStrLn "test"


{-# LANGUAGE Trustworthy #-}
module Main where

import Prelude
import safe M_SafePkg7

main = putStrLn "test"


{-# LANGUAGE Trustworthy #-}
module Main where

import Prelude
import safe M_SafePkg8

main = putStrLn "test"


{-# LANGUAGE Safe #-}
module M_SafePkg where

bigInt :: Int
bigInt = 9


{-# LANGUAGE Trustworthy #-}
module M_SafePkg2 where

bigInt :: Int
bigInt = 9


{-# LANGUAGE Safe #-}
module M_SafePkg3 where

import qualified M_SafePkg2 as M2

bigInt :: Int
bigInt = M2.bigInt


{-# LANGUAGE Safe #-}
module M_SafePkg4 where

import qualified M_SafePkg3 as M3
import Data.Word

bigInt :: Int
bigInt = M3.bigInt

type MyWord = Word


-- safe inference
-- same module as M_SafePkg4 which compiles with -XSafe.
-- Want to make sure compiles fine and is infered safe and
-- also picks up corrected pkg trust requirements.
module M_SafePkg5 where

import qualified M_SafePkg3 as M3
import Data.Word

bigInt :: Int
bigInt = M3.bigInt

type MyWord = Word


{-# LANGUAGE Trustworthy #-}
module M_SafePkg6 where

import safe Prelude
import safe qualified Data.ByteString.Char8 as BS

s = BS.pack "Hello World"


{-# LANGUAGE Safe #-}
module M_SafePkg7 where

import Prelude
import qualified Data.ByteString.Char8 as BS

s = BS.pack "Hello World"


{-# LANGUAGE Trustworthy #-}
module M_SafePkg8 where

import Prelude
import safe qualified Data.ByteString.Char8 as BS

s = BS.pack "Hello World"


import Distribution.Simple

main = defaultMain


{-# LANGUAGE CPP #-}

-- | CPP should still be allowed
module Main where

#include "Flags01_A.cpp"

#define mainn main=putStrLn str

mainn


{-# OPTIONS_GHC -pgmdll pgmdll, -I., -L., -Uggg, -Dggg, -with-rtsopts full #-}

-- | These are all flags that should be allowed
module Flags02 where

f :: Int
f = 1


{-# LANGUAGE Safe #-}

-- | Basic test to see if Safe flags compiles
module SafeFlags01 where

f :: Int
f = 1


{-# LANGUAGE Trustworthy #-}

-- | Basic test to see if Safe flags compiles
module SafeFlags02 where

f :: Int
f = 1


{-# LANGUAGE SafeImport #-}

-- | Basic test to see if Safe flags compiles
module SafeFlags03 where

f :: Int
f = 1


{-# LANGUAGE SafeLanguage #-}

-- | Basic test to see if Safe flags compiles
module SafeFlags04 where

f :: Int
f = 1


{-# LANGUAGE Safe, Unsafe #-}

-- | Basic test to see if Safe flags compiles
module SafeFlags05 where

f :: Int
f = 1


{-# LANGUAGE Trustworthy, Unsafe #-}

-- | Basic test to see if Safe flags compiles
module SafeFlags06 where

f :: Int
f = 1


{-# LANGUAGE SafeLanguage, Unsafe #-}

-- | Basic test to see if Safe flags compiles
module SafeFlags07 where

f :: Int
f = 1


{-# LANGUAGE SafeLanguage, Trustworthy #-}

-- | Basic test to see if Safe flags compiles
module SafeFlags08 where

f :: Int
f = 1


{-# LANGUAGE SafeLanguage, Safe #-}

-- | Basic test to see if Safe flags compiles
module SafeFlags09 where

f :: Int
f = 1


{-# LANGUAGE Safe, Trustworthy #-}

-- | Basic test to see if Safe flags compiles
module SafeFlags10 where

f :: Int
f = 1


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

-- | Basic test to see if Safe flags compiles
module SafeFlags11 where

f :: Int
f = 1


{-# LANGUAGE Unsafe #-}
-- | Basic test to see if Safe flags compiles
module SafeFlags12 where

f :: Int
f = 1


{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE Unsafe #-}
-- | Basic test to see if Safe flags compiles
module SafeFlags13 where

f :: Int
f = 1


{-# LANGUAGE Safe #-}
{-# LANGUAGE Unsafe #-}
-- | Basic test to see if Safe flags compiles
module SafeFlags14 where

f :: Int
f = 1


{-# LANGUAGE Unsafe #-}
{-# OPTIONS_GHC -fpackage-trust #-}
-- | Basic test to see if Safe flags compiles
module SafeFlags15 where

f :: Int
f = 1


{-# LANGUAGE Trustworthy #-}
{-# OPTIONS_GHC -fpackage-trust #-}
-- | Basic test to see if Safe flags compiles
module SafeFlags16 where

f :: Int
f = 1


{-# LANGUAGE Safe #-}
{-# OPTIONS_GHC -fpackage-trust #-}
-- | Basic test to see if Safe flags compiles
module SafeFlags17 where

f :: Int
f = 1


{-# OPTIONS_GHC -fpackage-trust #-}
-- | Basic test to see if Safe flags compiles
module SafeFlags18 where

f :: Int
f = 1


{-# OPTIONS_GHC -fno-package-trust #-}
-- | Basic test to see if Safe flags compiles
-- test should fail as there shouldn't be a no-package-trust flag, only a
-- package-trust flag!
module SafeFlags19 where

f :: Int
f = 1


{-# LANGUAGE Safe #-}
{-# OPTIONS_GHC -fpackage-trust #-}
-- | Basic test to see if Safe flags compiles
module SafeFlags20 where

f :: Int
f = 1


{-# OPTIONS_GHC -fwarn-unsafe #-}
-- | Basic test to see if Safe warning flags compile
-- Warn if module is infered unsafe
-- In this test the warning _shouldn't_ fire
module SafeFlags21 where

f :: Int
f = 1


{-# OPTIONS_GHC -fwarn-unsafe #-}
-- | Basic test to see if Safe warning flags compile
-- Warn if module is infered unsafe
-- In this test the warning _should_ fire
module SafeFlags22 where

import System.IO.Unsafe

f :: Int
f = 1


{-# OPTIONS_GHC -fwarn-unsafe -Werror #-}
-- | Basic test to see if Safe warning flags compile
-- Warn if module is infered unsafe
-- In this test the warning _should_ fire and cause a compile fail
module SafeFlags22 where

import System.IO.Unsafe

f :: Int
f = 1


{-# OPTIONS_GHC -fwarn-safe #-}
-- | Basic test to see if Safe warning flags compile
-- Warn if module is infered safe
-- In this test the warning _shouldn't_ fire
module SafeFlags23 where

import System.IO.Unsafe

f :: Int
f = 1


{-# OPTIONS_GHC -fwarn-safe #-}
-- | Basic test to see if Safe warning flags compile
-- Warn if module is infered safe
-- In this test the warning _should_ fire
module SafeFlags25 where

f :: Int
f = 1


{-# OPTIONS_GHC -fwarn-safe -Werror #-}
-- | Basic test to see if Safe warning flags compile
-- Warn if module is infered safe
-- In this test the warning _should_ fire and cause a compile fail
module SafeFlags26 where

f :: Int
f = 1


{-# OPTIONS_GHC -fno-safe-infer #-}
-- | Basic test to see if no safe infer flag compiles
-- This module would usually infer safely, so it shouldn't be safe now.
-- We don't actually check that here though, see test '' for that.
module SafeFlags27 where

f :: Int
f = 1


{-# OPTIONS_GHC -trust base, -trust bytestring #-}
-- | Basic test to see if no safe infer flag compiles
-- This module would usually infer safely, so it shouldn't be safe now.
-- We don't actually check that here though, see test '' for that.
module SafeFlags28 where

f :: Int
f = 1


{-# LANGUAGE Safe #-}
{-# OPTIONS_GHC -trust base -trust bytestring #-}
-- | Basic test to see if no safe infer flag compiles
-- This module would usually infer safely, so it shouldn't be safe now.
-- We don't actually check that here though, see test '' for that.
module SafeFlags29 where

f :: Int
f = 1


{-# LANGUAGE Safe, Unsafe, Trustworthy #-}
-- | Basic test to see that incompatible flags give a nice error
-- message and ghc do not panic (see issue #11580).
module SafeFlags30 where

f :: Int
f = 1


{-# LANGUAGE Safe #-}
module SafeIgnore where

import SafeIgnoreA

foo = ()


{-# LANGUAGE Unsafe #-}
module SafeIgnoreA where

qux = ()


{-# LANGUAGE Trustworthy #-}
module A (a) where

import System.IO.Unsafe

a :: Int
a = 1

unsafe = unsafePerformIO


{-# LANGUAGE Unsafe #-}
module B where

import System.IO.Unsafe

a :: Int
a = 1


{-# LANGUAGE Safe #-}
module C (a, C(), D(..)) where

a :: Int
a = 1

b :: Int
b = 2

data C a = C a Int

data D a = D a Int


module D (a) where

a :: Int
a = 1

b :: Int
b = 2


module E where

import System.IO.Unsafe

a :: Int
a = 1


{-# LANGUAGE FlexibleInstances #-}
module P13_A where

class Pos a where { res :: a -> Bool }

instance Pos [a] where { res _ = True }

instance Pos Char where { res _ = True }


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

-- | Compilation should fail as we have overlapping instances that don't obey
-- our heuristics.
module SH_Overlap1 where

import safe SH_Overlap1_A

instance
  C [a] where
    f _ = "[a]"

test :: String
test = f ([1,2,3,4] :: [Int])


{-# OPTIONS_GHC -fwarn-unsafe #-}
{-# LANGUAGE FlexibleInstances #-}

-- | Same as `SH_Overlap6`, but now we are inferring safety. Safe since
-- overlapped instance declares itself overlappable.
module SH_Overlap10 where

import SH_Overlap10_A

instance
  {-# OVERLAPS #-}
  C [a] where
    f _ = "[a]"

test :: String
test = f ([1,2,3,4] :: [Int])


{-# OPTIONS_GHC -fwarn-unsafe #-}
{-# LANGUAGE FlexibleInstances #-}
module SH_Overlap10_A (
    C(..)
  ) where

import SH_Overlap10_B

instance
  {-# OVERLAPS #-}
  C [Int] where
    f _ = "[Int]"


{-# OPTIONS_GHC -fwarn-unsafe #-}
module SH_Overlap10_B (
    C(..)
  ) where

class C a where
  f :: a -> String


{-# OPTIONS_GHC -fwarn-unsafe #-}
{-# LANGUAGE FlexibleInstances #-}

-- | Same as `SH_Overlap6`, but now we are inferring safety. Should be inferred
-- unsafe due to overlapping instances at call site `f`.
--
-- Testing that we are given correct reason.
module SH_Overlap11 where

import SH_Overlap11_A

instance
  C [a] where
    f _ = "[a]"

test :: String
test = f ([1,2,3,4] :: [Int])


{-# OPTIONS_GHC -fwarn-unsafe #-}
{-# LANGUAGE FlexibleInstances #-}
module SH_Overlap11_A (
    C(..)
  ) where

import SH_Overlap11_B

instance
  {-# OVERLAPS #-}
  C [Int] where
    f _ = "[Int]"


{-# OPTIONS_GHC -fwarn-unsafe #-}
module SH_Overlap11_B (
    C(..)
  ) where

class C a where
  f :: a -> String


{-# LANGUAGE Safe #-}
{-# LANGUAGE FlexibleInstances #-}
module SH_Overlap1_A (
    C(..)
  ) where

import SH_Overlap1_B

instance
  {-# OVERLAPS #-}
  C [Int] where
    f _ = "[Int]"


{-# LANGUAGE Safe #-}
module SH_Overlap1_B (
    C(..)
  ) where

class C a where
  f :: a -> String


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

-- | Same as SH_Overlap1, but SH_Overlap2_A is not imported as 'safe'.
--
-- Question: Should the OI-check be enforced? Y, see reasoning in
-- `SH_Overlap4.hs` for why the Safe Haskell overlapping instance check should
-- be tied to Safe Haskell mode only, and not to safe imports.
module SH_Overlap2 where

import SH_Overlap2_A

instance
  C [a] where
    f _ = "[a]"

test :: String
test = f ([1,2,3,4] :: [Int])


{-# LANGUAGE Safe #-}
{-# LANGUAGE FlexibleInstances #-}
module SH_Overlap2_A (
    C(..)
  ) where

import SH_Overlap2_B

instance
  {-# OVERLAPS #-}
  C [Int] where
    f _ = "[Int]"


{-# LANGUAGE Safe #-}
module SH_Overlap2_B (
    C(..)
  ) where

class C a where
  f :: a -> String


{-# LANGUAGE Unsafe #-}
{-# LANGUAGE FlexibleInstances #-}

-- | Same as SH_Overlap1, but module where overlap occurs (SH_Overlap3) is
-- marked `Unsafe`. Compilation should succeed (symmetry with inferring safety).
module SH_Overlap3 where

import SH_Overlap3_A

instance
  C [a] where
    f _ = "[a]"

test :: String
test = f ([1,2,3,4] :: [Int])


{-# LANGUAGE Safe #-}
{-# LANGUAGE FlexibleInstances #-}
module SH_Overlap3_A (
    C(..)
  ) where

import SH_Overlap3_B

instance
  {-# OVERLAPS #-}
  C [Int] where
    f _ = "[Int]"


{-# LANGUAGE Safe #-}
module SH_Overlap3_B (
    C(..)
  ) where

class C a where
  f :: a -> String


{-# LANGUAGE Unsafe #-}
{-# LANGUAGE FlexibleInstances #-}

-- | Same as SH_Overlap3, however, SH_Overlap4_A is imported as `safe`.
--
-- Question: Should compilation now fail? N. At first it seems a nice idea to
-- tie the overlap check to safe imports. However, instances are a global
-- entity and can be imported by multiple import paths. How should safe imports
-- interact with this? Especially when considering transitive situations...
--
-- Simplest is to just enforce the overlap check in Safe and Trustworthy
-- modules, but not in Unsafe ones.
module SH_Overlap4 where

import safe SH_Overlap4_A

instance
  C [a] where
    f _ = "[a]"

test :: String
test = f ([1,2,3,4] :: [Int])


{-# LANGUAGE Safe #-}
{-# LANGUAGE FlexibleInstances #-}
module SH_Overlap4_A (
    C(..)
  ) where

import SH_Overlap4_B

instance
  {-# OVERLAPS #-}
  C [Int] where
    f _ = "[Int]"


{-# LANGUAGE Safe #-}
module SH_Overlap4_B (
    C(..)
  ) where

class C a where
  f :: a -> String


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

-- | Compilation should fail as we have overlapping instances that don't obey
-- our heuristics.
module SH_Overlap5 where

import safe SH_Overlap5_A

instance
  C [a] where
    f _ = "[a]"

test :: String
test = f ([1,2,3,4] :: [Int])


{-# LANGUAGE Safe #-}
{-# LANGUAGE FlexibleInstances #-}
module SH_Overlap5_A (
    C(..)
  ) where

import SH_Overlap5_B

instance
  {-# OVERLAPS #-}
  C [Int] where
    f _ = "[Int]"


{-# LANGUAGE Safe #-}
module SH_Overlap5_B (
    C(..)
  ) where

class C a where
  f :: a -> String


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

-- | Same as `SH_Overlap5` but dependencies are now inferred-safe, not
-- explicitly marked. Compilation should still fail.
module SH_Overlap6 where

import safe SH_Overlap6_A

instance C [a] where
  f _ = "[a]"

test :: String
test = f ([1,2,3,4] :: [Int])


{-# OPTIONS_GHC -fwarn-unsafe #-}
{-# LANGUAGE FlexibleInstances #-}
module SH_Overlap6_A (
    C(..)
  ) where

import SH_Overlap6_B

instance
  {-# OVERLAPS #-}
  C [Int] where
    f _ = "[Int]"


{-# OPTIONS_GHC -fwarn-unsafe #-}
module SH_Overlap6_B (
    C(..)
  ) where

class C a where
  f :: a -> String


{-# OPTIONS_GHC -fwarn-unsafe #-}
{-# LANGUAGE FlexibleInstances #-}

-- | Same as `SH_Overlap6`, but now we are inferring safety. Should be inferred
-- unsafe due to overlapping instances at call site `f`.
module SH_Overlap7 where

import SH_Overlap7_A

instance C [a] where
  f _ = "[a]"

test :: String
test = f ([1,2,3,4] :: [Int])


{-# OPTIONS_GHC -fwarn-unsafe #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE Safe #-}
module SH_Overlap7_A (
    C(..)
  ) where

import SH_Overlap7_B

instance
  {-# OVERLAPS #-}
  C [Int] where
    f _ = "[Int]"


{-# OPTIONS_GHC -fwarn-unsafe #-}
{-# LANGUAGE Safe #-}
module SH_Overlap7_B (
    C(..)
  ) where

class C a where
  f :: a -> String


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

-- | Overlapping instances, but with a single parameter type-class and no
-- orphans. So `SH_Overlap8` decided to explicitly depend on `SH_Overlap8_A`
-- since that's where the type-class `C` with function `f` is defined.
--
-- Question: Safe or Unsafe? Safe
module SH_Overlap8 where

import safe SH_Overlap8_A

instance C [a] where
  f _ = "[a]"

test :: String
test = f ([1,2,3,4] :: [Int])


{-# LANGUAGE Safe #-}
{-# LANGUAGE FlexibleInstances #-}
module SH_Overlap8_A (
    C(..)
  ) where

class C a where
  f :: a -> String

instance
  {-# OVERLAPS #-}
  C [Int] where
    f _ = "[Int]"


{-# OPTIONS_GHC -fwarn-safe #-}
{-# LANGUAGE FlexibleInstances #-}

-- | Same as `SH_Overlap6`, but now we are inferring safety. Should be inferred
-- unsafe due to overlapping instances at call site `f`.
module SH_Overlap9 where

import SH_Overlap9_A

instance
  C [a] where
    f _ = "[a]"

test :: String
test = f ([1,2,3,4] :: [Int])


{-# OPTIONS_GHC -fwarn-unsafe #-}
{-# LANGUAGE FlexibleInstances #-}
module SH_Overlap9_A (
    C(..)
  ) where

import SH_Overlap9_B

instance
  {-# OVERLAPS #-}
  C [Int] where
    f _ = "[Int]"


{-# OPTIONS_GHC -fwarn-unsafe #-}
module SH_Overlap9_B (
    C(..)
  ) where

class C a where
  f :: a -> String


-- | Should fail compilation because safe imports aren't enabled
-- not because of trying to import an unsafe module
module Mixed01 where

import safe System.IO.Unsafe

f :: Int
f = 1


{-# LANGUAGE Unsafe #-}
-- | Should fail compilation because we import Data.Word as safe and unsafe
module Mixed02 where

import safe qualified Data.Word as DW
import Data.Word

f :: Int
f = 1


{-# LANGUAGE Unsafe #-}
-- | Should fail compilation because we import Data.Word as safe and unsafe
module Mixed03 where

import safe qualified Data.Word as DW
import System.IO
import Data.Word

f :: Int
f = 1


{-# LANGUAGE Safe #-}
module SafeInfered01 where

import safe SafeInfered01_A

g :: Int
g = f


-- | Trivial Safe Module
module SafeInfered01_A where

f :: Int
f = 1


{-# LANGUAGE Safe #-}
module SafeInfered02 where

import safe SafeInfered02_A

g :: Int
g = f


{-# LANGUAGE DeriveDataTypeable #-}
-- | Only uses deriving of Typeable so should be considered safe
module SafeInfered02_A where

import Data.Typeable

data G = G Int deriving (Typeable)

f :: Int
f = 1


{-# LANGUAGE Safe #-}
module SafeInfered03 where

import safe SafeInfered03_A

g :: Int
g = 1


{-# LANGUAGE ForeignFunctionInterface #-}
-- | FFI but in IO monad so safe
module SafeInfered03_A where

import Foreign.C

foreign import ccall "math.h" sin :: CDouble -> IO CDouble


{-# LANGUAGE Safe #-}
module SafeInfered04 where

import safe SafeInfered04_A

g :: Int
g = f


{-# OPTIONS_GHC -fenable-rewrite-rules #-}
-- | Safe as while it enables rules it doesn't define any. UnsafeInfered05 is a
-- test case for when rules are defined and it should be unsafe
module SafeInfered04_A where

f :: Int
f = 1


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

-- | We allow this overlap to succeed since the module is regarded as
-- `-XUnsafe`.
module SafeInfered05 where

import safe SafeInfered05_A

instance C [a] where
  f _ = "[a]"

test2 :: String
test2 = f ([1,2,3,4] :: [Int])


{-# LANGUAGE FlexibleInstances #-}
{-# OPTIONS_GHC -fwarn-safe #-}
module SafeInfered05_A where

class C a where
  f :: a -> String

instance C [Int] where
  f _ = "[Int]"


{-# LANGUAGE Unsafe #-}
{-# OPTIONS_GHC -fwarn-safe #-}
{-# OPTIONS_GHC -fwarn-unsafe #-}
{-# OPTIONS_GHC -fenable-rewrite-rules #-}

-- | Trivial Safe Module
module SafeWarn01 where

g :: Int
g = 1


{-# LANGUAGE Trustworthy #-}

-- | This module is marked trustworthy but should be inferable as -XSafe.
-- But no warning enabled.
module TrustworthySafe01 where

g :: Int
g = 1


{-# LANGUAGE Trustworthy #-}
{-# OPTIONS_GHC -fwarn-trustworthy-safe #-}

-- | This module is marked trustworthy but should be inferable as -XSafe.
-- Warning enabled.
module TrustworthySafe02 where

g :: Int
g = 1


{-# LANGUAGE Trustworthy #-}
{-# OPTIONS_GHC -Wall #-}
{-# OPTIONS_GHC -fwarn-trustworthy-safe #-} -- temp broken by 452d6aa95

-- | This module is marked trustworthy but should be inferable as -XSafe.
-- Warning enabled through `-W`.
module TrustworthySafe03 where

g :: Int
g = 1


{-# LANGUAGE Trustworthy #-}
{-# OPTIONS_GHC -W -fno-warn-trustworthy-safe #-}

-- | This module is marked trustworthy but should be inferable as -XSafe.
-- Warning enabled through `-W` but then disabled with `-fno-warn...`.
module TrustworthySafe04 where

g :: Int
g = 1


{-# LANGUAGE Safe #-}
module UnsafeInfered01 where

import safe UnsafeInfered01_A

g :: IO a -> a
g = f


-- | Trivial Unsafe Module
module UnsafeInfered01_A where

import System.IO.Unsafe

f :: IO a -> a
f = unsafePerformIO


{-# LANGUAGE Safe #-}
module UnsafeInfered02 where

import safe UnsafeInfered02_A

g :: Int
g = f


{-# LANGUAGE TemplateHaskell #-}
-- | Unsafe as uses TH
module UnsafeInfered02_A where

f :: Int
f = 1


{-# LANGUAGE Safe #-}
module UnsafeInfered03 where

import safe UnsafeInfered03_A

g :: Int
g = f


{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-- | Unsafe as uses GND
module UnsafeInfered03_A where

f :: Int
f = 1


{-# LANGUAGE Safe #-}
module UnsafeInfered05 where

import safe UnsafeInfered05_A

g :: Int
g = f


{-# OPTIONS_GHC -fenable-rewrite-rules #-}
-- | Unsafe as uses RULES
-- Although only turns on the flag doesn't define? So mark safe
-- maybe?
module UnsafeInfered05_A where

{-# RULES "f" f = undefined #-}
{-# NOINLINE [1] f #-}
f :: Int
f = 1


{-# LANGUAGE Safe #-}
module UnsafeInfered06 where

import safe UnsafeInfered06_A


{-# LANGUAGE ForeignFunctionInterface #-}
-- | Unsafe as uses FFI with a pure function
module UnsafeInfered06_A where

import Foreign.C

foreign import ccall "math.h" sin :: CDouble -> CDouble


{-# LANGUAGE Safe #-}
module UnsafeInfered08 where

import safe UnsafeInfered08_A

f :: Int
f = g


{-# LANGUAGE OverlappingInstances #-}
{-# OPTIONS_GHC -w #-}  -- Turn off deprecation for OverlappingInstances
-- | Safe, as we now check at overlap occurrence, not definition.
module UnsafeInfered08_A where

g :: Int
g = 1


{-# LANGUAGE Safe #-}
module UnsafeInfered09 where

import safe UnsafeInfered09_A

h :: Int
h = g


-- | Unsafe as we explicitly marked UnsafeInfered09_B as unsafe
module UnsafeInfered09_A where

import UnsafeInfered09_B

g :: Int
g = f


{-# LANGUAGE Unsafe #-}
module UnsafeInfered09_B where

f :: Int
f = 1


{-# LANGUAGE Safe #-}
-- | Basic test to see if no safe infer flag works
module UnsafeInfered10 where

import UnsafeInfered10_A

g :: Int
g = f


{-# OPTIONS_GHC -fno-safe-infer #-}
-- | Basic test to see if no safe infer flag works
-- This module would usually infer safely, so it shouldn't be safe now.
module UnsafeInfered10_A where

f :: Int
f = 1


{-# LANGUAGE Safe #-}
-- | Basic test to see if no safe infer flag works
module UnsafeInfered11 where

import UnsafeInfered11_A

g :: Int
g = f


{-# OPTIONS_GHC -fwarn-unsafe #-}
{-# OPTIONS_GHC -fenable-rewrite-rules #-}
-- | Basic test to see if no safe infer flag works
-- This module would usually infer safely, so it shouldn't be safe now.
module UnsafeInfered11_A where

f :: Int
f = 1

data T = T1 | T2 | T3 deriving ( Eq, Ord, Show )

lookupx :: Ord key => Show val => [(key,val)] -> key -> Maybe val
lookupx [] _                      = Nothing
lookupx ((t,a):xs) t' | t == t'   = Just a
                      | otherwise = lookupx xs t'

{-# RULES "lookupx/T" lookupx = tLookup #-}
{-# NOINLINE [1] lookupx #-}

tLookup :: [(T,a)] -> T -> Maybe a
tLookup [] _                      = Nothing
tLookup ((t,a):xs) t' | t /= t'   = Just a
                      | otherwise = tLookup xs t'

space = [(T1,"a"),(T2,"b"),(T3,"c")]
key = T3

main = do
    putStrLn $ "looking for " ++ show key
    putStrLn $ "in space " ++ show space
    putStrLn $ "Found: " ++ show (fromMaybe "Not Found!" $ lookupx space key)
    let b | Just "c" <- lookupx space key = "YES"
          | otherwise                     = "NO"
    putStrLn $ "Rules Disabled: " ++ b

fromMaybe :: a -> Maybe a -> a
fromMaybe a Nothing  = a
fromMaybe _ (Just a) = a


{-# LANGUAGE TemplateHaskell #-}
{-# OPTIONS_GHC -fwarn-unsafe -Werror #-}
module UnsafeInfered12 where

a :: Int
a = 1


{-# OPTIONS_GHC -fwarn-unsafe -Werror #-}
{-# LANGUAGE FlexibleInstances #-}
module UnsafeInfered13 where

class C a where
  f :: a -> String

instance {-# OVERLAPS #-} C a where
  f _ = "a"


{-# OPTIONS_GHC -fwarn-unsafe -Werror #-}
{-# LANGUAGE FlexibleInstances #-}
module UnsafeInfered14 where

class C a where
  f :: a -> String

instance {-# OVERLAPPABLE #-} C a where
  f _ = "a"


{-# OPTIONS_GHC -fwarn-unsafe -Werror #-}
{-# LANGUAGE FlexibleInstances #-}
module UnsafeInfered15 where

class C a where
  f :: a -> String

instance {-# OVERLAPPING #-} C a where
  f _ = "a"


{-# OPTIONS_GHC -fwarn-unsafe -Werror #-}
{-# LANGUAGE FlexibleInstances #-}
module UnsafeInfered16 where

class C a where
  f :: a -> String

instance {-# OVERLAPPING #-} C a where
  f _ = "a"

instance {-# OVERLAPS #-} C Int where
  f _ = "Int"

instance {-# OVERLAPPABLE #-} C Bool where
  f _ = "Bool"


{-# OPTIONS_GHC -fwarn-unsafe -Werror #-}
{-# LANGUAGE FlexibleInstances #-}
module UnsafeInfered17 where

class C a where
  f :: a -> String

instance {-# INCOHERENT #-} C a where
  f _ = "a"


{-# OPTIONS_GHC -fwarn-unsafe #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverlappingInstances #-}
module UnsafeInfered18 where

class C a where
  f :: a -> String

instance C a where
  f _ = "a"


{-# OPTIONS_GHC -fwarn-unsafe -Werror #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE IncoherentInstances #-}
module UnsafeInfered19 where

class C a where
  f :: a -> String

instance C a where
  f _ = "a"


{-# OPTIONS_GHC -fwarn-safe #-}
{-# OPTIONS_GHC -fwarn-unsafe #-}

-- | Trivial Unsafe Module
module UnsafeWarn01 where

import System.IO.Unsafe

f :: IO a -> a
f = unsafePerformIO


{-# OPTIONS_GHC -fwarn-safe #-}
{-# OPTIONS_GHC -fwarn-unsafe #-}

{-# LANGUAGE TemplateHaskell #-}
-- | Unsafe as uses TH
module UnsafeWarn02 where

f :: Int
f = 1


{-# LANGUAGE Trustworthy #-}
{-# OPTIONS_GHC -fwarn-safe #-}
{-# OPTIONS_GHC -fwarn-unsafe #-}

-- | Trivial Unsafe Module
module UnsafeWarn03 where

import System.IO.Unsafe

f :: IO a -> a
f = unsafePerformIO


{-# LANGUAGE Trustworthy #-}
{-# OPTIONS_GHC -fwarn-trustworthy-safe #-}
{-# OPTIONS_GHC -fwarn-unsafe #-}

-- | Trivial Unsafe Module
module UnsafeWarn04 where

import System.IO.Unsafe

f :: IO a -> a
f = unsafePerformIO


{-# LANGUAGE Unsafe #-}
{-# OPTIONS_GHC -fwarn-trustworthy-safe #-}
{-# OPTIONS_GHC -fwarn-safe #-}
{-# OPTIONS_GHC -fwarn-unsafe #-}
{-# OPTIONS_GHC -fenable-rewrite-rules #-}

-- | Trivial Unsafe Module
module UnsafeWarn05 where

import System.IO.Unsafe

f :: IO a -> a
f = unsafePerformIO

{-# RULES "g" g = undefined #-}
{-# NOINLINE [1] g #-}
g :: Int
g = 1


{-# OPTIONS_GHC -fenable-rewrite-rules #-}
{-# OPTIONS_GHC -fwarn-safe #-}
{-# OPTIONS_GHC -fwarn-unsafe #-}

-- | Unsafe as uses RULES
module UnsafeWarn06 where

{-# RULES "f" f = undefined #-}
{-# NOINLINE [1] f #-}
f :: Int
f = 1


{-# LANGUAGE Trustworthy #-}
{-# OPTIONS_GHC -fenable-rewrite-rules #-}
{-# OPTIONS_GHC -fwarn-safe #-}
{-# OPTIONS_GHC -fwarn-unsafe #-}

-- | Unsafe as uses RULES
module UnsafeWarn07 where

{-# RULES "f" f = undefined #-}
{-# NOINLINE [1] f #-}
f :: Int
f = 1


{-# LANGUAGE Safe, TemplateHaskell #-}

-- | Test SafeLanguage disables things
module SafeLang01 where

f :: Int
f = 1


{-# LANGUAGE Safe, GeneralizedNewtypeDeriving #-}

-- | Test SafeLanguage disables things
module SafeLang02 where

f :: Int
f = 1


{-# LANGUAGE Safe #-}
{-# OPTIONS_GHC -fenable-rewrite-rules #-}

-- | Test SafeLanguage disables things
module SafeLang03 where

{-# RULES "f" f = undefined #-}
f :: Int
f = 1


{-# OPTIONS_GHC -fenable-rewrite-rules #-}
-- | Check rules work as normal without Safe
module Main where

data T = T1 | T2 | T3 deriving ( Eq, Ord, Show )

lookupx :: Ord key => Show val => [(key,val)] -> key -> Maybe val
lookupx [] _                      = Nothing
lookupx ((t,a):xs) t' | t == t'   = Just a
                      | otherwise = lookupx xs t'

{-# RULES "lookupx/T" lookupx = tLookup #-}
tLookup :: [(T,a)] -> T -> Maybe a
tLookup [] _                      = Nothing
tLookup ((t,a):xs) t' | t /= t'   = Just a
                      | otherwise = tLookup xs t'

space = [(T1,"a"),(T2,"b"),(T3,"c")]
key = T3

main = do
    putStrLn $ "looking for " ++ show key
    putStrLn $ "in space " ++ show space
    putStrLn $ "Found: " ++ show (fromMaybe "Not Found!" $ lookupx space key)
    let b | Just "c" <- lookupx space key = "YES"
          | otherwise                     = "NO"
    putStrLn $ "Rules Disabled: " ++ b

fromMaybe :: a -> Maybe a -> a
fromMaybe a Nothing  = a
fromMaybe _ (Just a) = a


{-# LANGUAGE Safe #-}
{-# OPTIONS_GHC -fenable-rewrite-rules #-}

-- | Check rules are disabled under Safe
module Main where

data T = T1 | T2 | T3 deriving ( Eq, Ord, Show )

lookupx :: Ord key => Show val => [(key,val)] -> key -> Maybe val
lookupx [] _                      = Nothing
lookupx ((t,a):xs) t' | t == t'   = Just a
                      | otherwise = lookupx xs t'

{-# RULES "lookupx/T" lookupx = tLookup #-}
tLookup :: [(T,a)] -> T -> Maybe a
tLookup [] _                      = Nothing
tLookup ((t,a):xs) t' | t /= t'   = Just a
                      | otherwise = tLookup xs t'

space = [(T1,"a"),(T2,"b"),(T3,"c")]
key = T3

main = do
    putStrLn $ "looking for " ++ show key
    putStrLn $ "in space " ++ show space
    putStrLn $ "Found: " ++ show (fromMaybe "Not Found!" $ lookupx space key)
    let b | Just "c" <- lookupx space key = "YES"
          | otherwise                     = "NO"
    putStrLn $ "Rules Disabled: " ++ b

fromMaybe :: a -> Maybe a -> a
fromMaybe a Nothing  = a
fromMaybe _ (Just a) = a


{-# LANGUAGE Safe #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}

-- Here we stop it succeeding (SAFE)

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

import SafeLang07_A

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

instance IntIso Int where
    intIso = id

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

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

forceInt :: MinList Int -> MinList Int
forceInt = id

a1, a2 :: MinList Int
a1 = foldl insertMinList (newMinList $ head nums) (tail nums)
a2 = forceInt $ intIso $ foldl (\x y -> insertMinList x $ Down y) (newMinList $ Down $ head nums) (tail nums)

nums :: [Int]
nums = [1,4,0,1,-5,2,3,5,-1,2,0,0,-4,-3,9]

main = do
    printIntMinList a1
    printIntMinList a2


{-# LANGUAGE Trustworthy #-}

-- | Here we expose a MinList API that only allows elements
-- to be inserted into a list if they are at least greater
-- than an initial element the list is created with.
module SafeLang07_A (
        MinList,
        newMinList,
        insertMinList,
        printIntMinList
    ) where

data MinList a = MinList a [a]

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

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

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


{-# LANGUAGE Safe #-}
{-# LANGUAGE ForeignFunctionInterface #-}

-- | Make sure FFI must be IO type
module Main where

import Foreign.C

foreign import ccall "SafeLang08_A" c_sin :: CDouble -> CDouble

sinx :: Double -> Double
sinx d = realToFrac $ c_sin $ realToFrac d

x :: Double
x = 0.8932

main :: IO ()
main = do
    putStrLn "Hello World"
    putStrLn $ "Sin of " ++ (show x) ++ " is "  ++ (show $ sinx x)


module Main where

import SafeLang09_A -- trusted lib
import SafeLang09_B -- untrusted plugin

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