module Roman where

-- This is a simplified version of simplCore/should_compile/spec-inline.hs
--
-- It reproduces a problem where workers get specialized in different ways
-- depending on the values of uniques.
--
-- Compare:
--
--   $s$wgo_s1CN :: Int# -> Int -> Int#
--   [LclId, Arity=2, Str=<L,U><L,U>]
--   $s$wgo_s1CN =
--     \ (sc_s1CI :: Int#) (sc_s1CJ :: Int) ->
--       case tagToEnum# @ Bool (<=# sc_s1CI 0#) of _ [Occ=Dead] {
--         False ->
--           $wgo_s1BU (Just @ Int (I# (-# sc_s1CI 1#))) (Just @ Int sc_s1CJ);
--         True -> 0#
--       }
--
-- vs
--
--   $s$wgo_s18mTj :: Int -> Int# -> Int#
--   [LclId, Arity=2, Str=<L,U><L,U>]
--   $s$wgo_s18mTj =
--     \ (sc_s18mTn :: Int) (sc_s18mTo :: Int#) ->
--       case tagToEnum# @ Bool (<=# sc_s18mTo 0#) of _ [Occ=Dead] {
--         False ->
--           $wgo_s18mUc
--             (Just @ Int (I# (-# sc_s18mTo 1#))) (Just @ Int sc_s18mTn);
--         True -> 0#
--       }

foo :: Int -> Int
foo n =
  go (Just n) (Just (6::Int))
  where
  go Nothing (Just x) = go (Just 10) (Just x)
  go (Just n) (Just x)
    | n <= 0    = 0
    | otherwise = go (Just (n-1)) (Just x)


module A where

data ADT a b = Z a b deriving Eq


module A where

data F a b = F { x :: !Int, y :: !(Float,Float), z :: !(a,b) }


module A where

newtype Pair1 f g a = Pair1 {unPair1 :: (f a, g a)}
  deriving Eq


{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
module ShouldCompile where

-- tests deterministic order of fixities in the interface file

infixl 1 `f`
infixr 2 \\\
infix  3 :==>
infix  4 `MkFoo`

data Foo = MkFoo Int | Float :==> Double

f :: a -> b -> a
x `f` y = x

(\\\) :: (Eq a) => [a] -> [a] -> [a]
(\\\) xs ys =  xs


module A where

-- Reproduces an issue where rules would abstract over typeclass dictionaries
-- non-deterministically.
--
-- Compare:
--
-- RULES: "SPECLOL $csize" [ALWAYS]
--            forall ($dOrd_a1sc :: Ord Int) ($dNum_a1sd :: Num Int).
--              $csize_a1sg @ Int $dOrd_a1sc $dNum_a1sd
--              = $s$csize_d1zr]
-- with:
--
-- RULES: "SPEC $csize" [ALWAYS]
--            forall ($dNum_a18n42 :: Num Int) ($dOrd_a18n43 :: Ord Int).
--              $csize_a18n3Z @ Int $dOrd_a18n43 $dNum_a18n42
--              = $s$csize_d18mWO]

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

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


{-# LANGUAGE PolyKinds, MultiParamTypeClasses, FunctionalDependencies,
             UndecidableInstances, FlexibleInstances #-}

module T10109 where

data Succ a

class Add (a :: k1) (b :: k2) (ab :: k3) | a b -> ab
instance (Add a b ab) => Add (Succ a) b (Succ ab)


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

module T9063 where

import Data.Type.Equality
import Data.Proxy

-- reproduces an issue where type variables in the axiom are in
-- non-deterministic order

class kproxy ~ 'KProxy => PEq (kproxy :: KProxy a) where
  type FunnyEq (x :: a) (y :: a) :: Bool
  type FunnyEq x y = x == y

instance PEq ('KProxy :: KProxy Bool)

foo :: Proxy (FunnyEq True True) -> Proxy (True == True)
foo = id


{-# LANGUAGE
    ScopedTypeVariables
  , DataKinds
  , GADTs
  , RankNTypes
  , TypeOperators
  , PolyKinds -- Comment out PolyKinds and the bug goes away.
  #-}
{-# OPTIONS_GHC -O #-}
  -- The bug is in SimplUtils.abstractFloats, so we need -O to trigger it

module KeyValue where

import Data.Kind

data AccValidation err a = AccFailure err | AccSuccess a

data KeyValueError = MissingValue

type WithKeyValueError = AccValidation [KeyValueError]

missing :: forall f rs. RecApplicative rs => Rec (WithKeyValueError :. f) rs
missing = rpure missingField
  where
    missingField :: forall x. (WithKeyValueError :. f) x
    missingField = Compose $ AccFailure [MissingValue]

data Rec :: (u -> Type) -> [u] -> Type where
  RNil :: Rec f '[]
  (:&) :: !(f r) -> !(Rec f rs) -> Rec f (r ': rs)

newtype Compose (f :: l -> Type) (g :: k -> l) (x :: k)
  = Compose { getCompose :: f (g x) }

type (:.) f g = Compose f g

class RecApplicative rs where
  rpure
    :: (forall x. f x)
    -> Rec f rs


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

module A where

infixr 7 :*
infix  8 :*:

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

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

data First
data Next p

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

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

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

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

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

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

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


{-# LANGUAGE UnicodeSyntax, MultiParamTypeClasses, FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# OPTIONS -w #-}

module A where

data PSum a b = Empty | Tree a b [(PSum a b)]

extractMinX âˆ· (Ord a, Eq b, Num b) â‡’ PSum a b â†’ ((a,b), PSum a b)
extractMinX Empty = undefined
extractMinX (Tree v r xs) = ((v,r), Empty)

toListX âˆ· (Ord a, Eq b, Num b) â‡’ PSum a b â†’ [(a,b)]
toListX Empty = []
toListX x = let (y, z) = extractMinX x in y : toListX z

main âˆ· IO ()
main = print $ take 20 $ toListX $ (Empty :: PSum Int Int)


{-
    Copyright 2009 Mario Blazevic

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

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

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

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

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

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

{-   Somewhere we get:

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

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

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

{-# OPTIONS -w #-}

module A where

import Control.Monad (liftM, liftM2, when, ap)
-- import Control.Monad.Identity

import Debug.Trace (trace)

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

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

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

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

instance Functor Identity where
    fmap = liftM

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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


{-# LANGUAGE
    Arrows
  , TypeOperators
  #-}
-- This is extracted from arrow-list package
-- The problem was that some internal tuples that Arrows desugaring
-- generates the components in different orders depending on the order
-- of Uniques.
module A
(
 ifA
)
where

import Control.Arrow
import Prelude hiding (id, (.))

class Arrow arr => ArrowList arr where
  arrL :: (a -> [b]) -> a `arr` b
  mapL :: ([b] -> [c]) -> (a `arr` b) -> (a `arr` c)

empty :: ArrowList arr => (a `arr` b) -> a `arr` Bool
empty = mapL (\xs -> [if null xs then True else False])

ifA :: (ArrowList arr, ArrowChoice arr)
    => (a `arr` c)  -- ^ Arrow used as condition.
    -> (a `arr` b)  -- ^ Arrow to use when condition has results.
    -> (a `arr` b)  -- ^ Arrow to use when condition has no results.
    -> a `arr` b
ifA c t e = proc i -> do x <- empty c -< i; if x then e -< i else t -< i


{-# OPTIONS_GHC -Wall #-}
{-# LANGUAGE RecursiveDo #-}
{-# LANGUAGE TupleSections #-}
module A where

import Control.Arrow (first)
import Control.Monad.Fix
import Control.Monad

-- Reduced example from rev-state package.
-- Reproduces an issue where the tuples generated when desugaring
-- mdo have nondeterministic order of components.
--
-- Consider:
--
--    do rec
--      a <- f b
--      b <- f a
--      return a
--
-- Compare:
--
--  do
--    (a, b) <- mfix $ \ ~(a, b) -> do
--      a <- f b
--      b <- f a
--      return (a, b)
--    return a
--
-- vs
--
--  do
--    (b, a) <- mfix $ \ ~(b, a) -> do
--      a <- f b
--      b <- f a
--      return (b, a)
--    return a

newtype StateT s m a = StateT
  { runStateT :: s -> m (a, s) }

instance MonadFix m => Monad (StateT s m) where
  return x = StateT $ \s -> pure (x, s)
  m >>= f = StateT $ \s -> do
    rec
      (x, s'') <- runStateT m s'
      (x', s') <- runStateT (f x) s
    return (x', s'')

instance MonadFix m => Applicative (StateT s m) where
  (<*>) = ap
  pure = return

instance Functor m => Functor (StateT s m) where
  -- this instance is hand-written
  -- so we don't have to rely on m being MonadFix
  fmap f m = StateT $ \s -> first f `fmap` runStateT m s


{-# LANGUAGE ApplicativeDo #-}
{-# OPTIONS_GHC -ddump-types #-}
module A where

test2 f = do
  x <- f 3
  y <- f 4
  return (x + y)


-- | Test that SPEC rules are named deterministically.
module A where

test1 :: Num a => a -> a -> a
test1 x y = x + 42 * y
{-# SPECIALISE test1 :: Int -> Int -> Int #-}


{-# LANGUAGE ForeignFunctionInterface #-}

module A ( mkStringWriter, (<>>) ) where

import Foreign.Ptr
import Prelude

-- generated C wrappers used to use Unique values for the label
foreign import ccall "wrapper" mkStringWriter :: Int -> IO (Ptr Int)
-- make sure we properly z-encode the generated stubs
foreign import ccall "wrapper" (<>>) :: Int -> IO (Ptr Int)


module Main (main) where

main :: IO ()
main = putStrLn "Hello World"


{-# LANGUAGE ForeignFunctionInterface #-}
module TestStub016 where
foreign export ccall f :: Int -> Int
f :: Int -> Int
f n = n + 1


{-# LANGUAGE ForeignFunctionInterface #-}
module TestStub017 where
foreign export ccall f :: Int -> Int
f :: Int -> Int
f n = n + 1


{-# LANGUAGE ForeignFunctionInterface #-}
module TestStub018 where
foreign export ccall f :: Int -> Int
f :: Int -> Int
f n = n + 1


{-# LANGUAGE ForeignFunctionInterface #-}
module TestStub019 where
foreign export ccall f :: Int -> Int
f :: Int -> Int
f n = n + 1


{-# LANGUAGE ForeignFunctionInterface #-}
module TestStub034 where
foreign export ccall f :: Int -> Int
f :: Int -> Int
f n = n + 1


{-# LANGUAGE ForeignFunctionInterface #-}
module TestStub035 where
foreign export ccall f :: Int -> Int
f :: Int -> Int
f n = n + 1


module InlineCheck where

foo = (+1)

foo1 = (+1)
{-# NOINLINE foo1 #-}

qux = foo 3

qux1 = foo1 3

too = qux


module Foo where

import Data.List

id1 :: a -> a
id1 = 5


module JSON where

foo :: a -> a
foo = id


-- an options pragma that needs more than 1k of buffer to read
{-# OPTIONS_GHC
                                                                                -w #-}

module Pragma002 () where

-- This will make a warning if the pragma isn't picked up
foo _ = ()
foo _ = ()


{-# LANGUAGE ForeignFunctionInterface #-}
module Shared001 where

-- Test for building DLLs with ghc -shared, see #2745

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

foreign export ccall f :: Int -> Int


import System.Environment

main :: IO ()
main = do args <- getArgs
          mapM_ (putStrLn . f) args

f :: String -> String
f str = "Arg: " ++ show str


{-# LANGUAGE ForeignFunctionInterface #-}
module Static001 where
foreign export ccall f :: Int -> Int
f :: Int -> Int
f n = n + 1


module T10182 where
import T10182a
instance Show (a -> b) where
    show _  = ""


module T10182a where
import {-# SOURCE #-} T10182


-- | Test file for issue #10320.

module Main (main) where

main :: IO ()
main = print $ map (+1) (map (+1) [1, 2, 3])

{-# RULES "map/map"    forall f g xs.  map f (map g xs) = map (f.g) xs #-}


{-# LANGUAGE MagicHash #-}
module T10600 where

import GHC.Prim

-- This shouldn't compile as unlifted bindings aren't allowed at top-level.
-- However, #10600 described the situation where an error isn't throw when we
-- compile with -fno-code.
foo :: Int#
foo = 10600#


{-# LANGUAGE CPP #-}

module T10869 where
import T10869A

main :: IO()
#if defined(__GLASGOW_HASKELL__)
main = writeMsg
#endif


{-# LANGUAGE CPP #-}
module T10869A (writeMsg) where

writeMsg :: IO ()
#if defined(__GLASGOW_HASKELL__)
writeMsg = putStrLn "Hello HSPP File"
#endif


{-# LANGUAGE CPP #-}
main = do
    putStrLn VERSION_containers
#if MIN_VERSION_base(3,0,0)
    putStrLn "OK"
#endif


{-# LANGUAGE Strict #-}
-- | Strict should imply StrictData
module Main where

data Lazy a = Lazy ~a

main :: IO ()
main =
  case Lazy undefined of
    Lazy _ -> putStrLn "Lazy"


{-# LANGUAGE TypeFamilies #-}

module T11381 where

-- ensure that this code does not compile without TypeFamilyDependencies and that
-- injectivity error is not reported.
type family F a = r | r -> a
type instance F Int = Bool
type instance F Int = Char


main :: IO ()
main = putStrLn "hello world"


{-# LANGUAGE CPP #-}
main = do
#ifndef VERSION_containers
    putStrLn "OK"
#endif


{-# LANGUAGE CPP #-}
#include "T12135.h"
main = print message


{-# LANGUAGE CPP #-}

#if SHOULD_PASS
message :: String
message = "Hello!"
#endif

main :: IO ()
main = putStrLn message


-- Test that setting the TMP environment variable to a path with non-ASCII
-- characters works.
main :: IO ()
main = putStrLn "hello world"


{-# LANGUAGE CApiFFI #-}
{-# OPTIONS_GHC -optc-O3 #-}

module T14452 where
foreign import capi unsafe "stdlib.h exit" c_exit :: Int -> IO ()


{-# LANGUAGE OverloadedStrings #-}
import Ar

-- obtained from echo -n \0 > x.o && ar -q b.a x.o && cat b.a
archive = "!<arch>\nx.o/            0           0     0     644     1         \
\`\n0\nx.o/            0           0     0     644     1         `\n0\n"

main = print (parseAr archive)


module T2182 where
instance Read (IO a) where
 readsPrec = undefined
x = read "" :: IO Bool
y = show (\x -> x)
z = (\x -> x) == (\y -> y)


module T2182_A where
import Text.Show.Functions
instance Eq (a -> b) where
    _ == _ = True


{-# LANGUAGE CPP #-}
{-# OPTIONS_GHC -DTEST #-}
{-# OPTIONS_GHC -fffi #-} -- deprecation warning
#ifdef TEST
{-# LANGUAGE EmptyDataDecls #-}
#endif

module Test2464 where
data T


{-# OPTIONS -package blargh #-}
module Test where


{-# LANGUAGE CPP #-}
{-# OPTIONS_GHC -optP -C -optP -ffreestanding #-}

#define A 'a'

main :: IO ()
main = putStrLn [A,
-- CPP treats this as the beginning of a multiline C-style comment: /usr/local/*
                 'b',
-- And */ close it. By passing `-optP -C` we tell CPP not to delete it.
                 'c']


{-# OPTIONS_GHC -F -pgmF ./test_preprocessor.txt #-}
module Main where

main = print "Hello World"


{-# OPTIONS -F -pgmF ./T3674_pre #-}

module Test3674 where

data Foo a where MkFoo :: Foo a


import System.Environment
main = do
 [_,inf,outf] <- getArgs
 s <- readFile inf
 writeFile outf ("{-# LANGUAGE GADTs #-}\n" ++ s)


-- Test the flage `force-no-intermediates` (issue #4114)
module Main (main) where

import T4114aSub

keep, nokeep :: [FilePath]
keep   = ["T4114aSub.hi", "T4114aSub.o", "T4114a.hi", "T4114a.o"]
nokeep = [ ]

main :: IO ()
main = do
  mapM_ assertNoKeep nokeep
  mapM_ assertKeep keep


module T4114aSub (assertKeep, assertNoKeep) where

import Control.Monad    (unless, when)
import System.Directory (doesFileExist)

assertNoKeep :: FilePath -> IO ()
assertNoKeep a =
   whenM (doesFileExist a) $
       error ("error: intermediate '" ++ a ++ "' exists")

assertKeep :: FilePath -> IO ()
assertKeep a =
   unlessM (doesFileExist a) $
       error ("error: intermediate '" ++ a ++ "' is missing")

whenM :: Monad m => m Bool -> m () -> m ()
whenM mp f = mp >>= \p -> when p f

unlessM :: Monad m => m Bool -> m () -> m ()
unlessM mp f = mp >>= \p -> unless p f


-- Test the flage `force-no-intermediates` (issue #4114)
module Main (main) where

import T4114bSub

keep, nokeep :: [FilePath]
keep   = ["T4114bSub.o", "T4114b.o"]
nokeep = ["T4114bSub.hi", "T4114b.hi"]

main :: IO ()
main = do
  mapM_ assertNoKeep nokeep
  mapM_ assertKeep keep


module T4114bSub (assertKeep, assertNoKeep) where

import Control.Monad    (unless, when)
import System.Directory (doesFileExist)

assertNoKeep :: FilePath -> IO ()
assertNoKeep a =
   whenM (doesFileExist a) $
       error ("error: intermediate '" ++ a ++ "' exists")

assertKeep :: FilePath -> IO ()
assertKeep a =
   unlessM (doesFileExist a) $
       error ("error: intermediate '" ++ a ++ "' is missing")

whenM :: Monad m => m Bool -> m () -> m ()
whenM mp f = mp >>= \p -> when p f

unlessM :: Monad m => m Bool -> m () -> m ()
unlessM mp f = mp >>= \p -> unless p f


-- Test the flage `force-no-intermediates` (issue #4114)
module Main (main) where

import T4114cSub

keep, nokeep :: [FilePath]
keep   = ["T4114cSub.hi", "T4114c.hi"]
nokeep = ["T4114cSub.o", "T4114c.o"]

main :: IO ()
main = do
  mapM_ assertNoKeep nokeep
  mapM_ assertKeep keep


module T4114cSub (assertKeep, assertNoKeep) where

import Control.Monad    (unless, when)
import System.Directory (doesFileExist)

assertNoKeep :: FilePath -> IO ()
assertNoKeep a =
   whenM (doesFileExist a) $
       error ("error: intermediate '" ++ a ++ "' exists")

assertKeep :: FilePath -> IO ()
assertKeep a =
   unlessM (doesFileExist a) $
       error ("error: intermediate '" ++ a ++ "' is missing")

whenM :: Monad m => m Bool -> m () -> m ()
whenM mp f = mp >>= \p -> when p f

unlessM :: Monad m => m Bool -> m () -> m ()
unlessM mp f = mp >>= \p -> unless p f


-- Test the flage `force-no-intermediates` (issue #4114)
module Main (main) where

import T4114dSub

keep, nokeep :: [FilePath]
keep   = ["T4114dSub.myhi", "T4114d.myhi"]
nokeep = ["T4114dSub.myo", "T4114d.myo"]

main :: IO ()
main = do
  mapM_ assertNoKeep nokeep
  mapM_ assertKeep keep


module T4114dSub (assertKeep, assertNoKeep) where

import Control.Monad    (unless, when)
import System.Directory (doesFileExist)

assertNoKeep :: FilePath -> IO ()
assertNoKeep a =
   whenM (doesFileExist a) $
       error ("error: intermediate '" ++ a ++ "' exists")

assertKeep :: FilePath -> IO ()
assertKeep a =
   unlessM (doesFileExist a) $
       error ("error: intermediate '" ++ a ++ "' is missing")

whenM :: Monad m => m Bool -> m () -> m ()
whenM mp f = mp >>= \p -> when p f

unlessM :: Monad m => m Bool -> m () -> m ()
unlessM mp f = mp >>= \p -> unless p f


-- | A test for ensuring that GHC's supporting language extensions remains in
-- sync with Cabal's own extension list.
--
-- If you have ended up here due to a test failure, please see
-- Note [Adding a language extension] in compiler/main/DynFlags.hs.

module Main (main) where

import Control.Monad
import Data.List
import DynFlags
import Language.Haskell.Extension

main :: IO ()
main = do
    let ghcExtensions = map flagSpecName xFlags
        cabalExtensions = map show [ toEnum 0 :: KnownExtension .. ]
        ghcOnlyExtensions = ghcExtensions \\ cabalExtensions
        cabalOnlyExtensions = cabalExtensions \\ ghcExtensions
    check "GHC-only flags" expectedGhcOnlyExtensions ghcOnlyExtensions
    check "Cabal-only flags" expectedCabalOnlyExtensions cabalOnlyExtensions

check :: String -> [String] -> [String] -> IO ()
check title expected got
    = do let unexpected = got \\ expected
             missing = expected \\ got
             showProblems problemType problems
                 = unless (null problems) $
                       do putStrLn (title ++ ": " ++ problemType)
                          putStrLn "-----"
                          mapM_ putStrLn problems
                          putStrLn "-----"
                          putStrLn ""
         showProblems "Unexpected flags" unexpected
         showProblems "Missing flags" missing

-- See Note [Adding a language extension] in compiler/main/DynFlags.hs.
expectedGhcOnlyExtensions :: [String]
expectedGhcOnlyExtensions = ["RelaxedLayout",
                             "AlternativeLayoutRule",
                             "AlternativeLayoutRuleTransitional",
                             "EmptyDataDeriving",
                             "GeneralisedNewtypeDeriving"]

expectedCabalOnlyExtensions :: [String]
expectedCabalOnlyExtensions = ["Generics",
                               "ExtensibleRecords",
                               "RestrictedTypeSynonyms",
                               "HereDocuments",
                               "NewQualifiedOperators",
                               "XmlSyntax",
                               "RegularPatterns",
                               "SafeImports",
                               "Safe",
                               "Unsafe",
                               "Trustworthy"]


{-# LANGUAGE CPP #-}
{-# OPTIONS_GHC -DFOO="bar baz" #-}
main = print FOO

-- Test that GHC can compile option pragmas containing spaces.
-- When a .hsc contains `#define FOO "bar baz"`, hsc2hs emits:
--
--     {-# OPTIONS_GHC -optc-DFOO="bar baz" #-}


import qualified GHC
import System.Environment

main = do
  (libdir:_) <- getArgs
  GHC.runGhcT (Just libdir) $ do
      -- begin initialize
      df0 <- GHC.getSessionDynFlags
      let df1 = df0{GHC.ghcMode    = GHC.CompManager,
                    GHC.hscTarget  = GHC.HscInterpreted,
                    GHC.ghcLink    = GHC.LinkInMemory,
                    GHC.verbosity  = 0}
      _ <- GHC.setSessionDynFlags df1
      -- begin reset
      GHC.setContext []
      GHC.setTargets []
      _ <- GHC.load GHC.LoadAllTargets
      return ()


module T6037 where

fÃ³o :: Int
fÃ³o = ()


main :: IO ()
main = print (f (3 + 4 :: Int))

f :: Int -> Int
f x = x
{-# NOINLINE [1] f #-}

{-# RULES "rule" forall x. f x = 8 #-}


{-# LANGUAGE Haskell2010 #-}
module T706 where

foreign export ccall f :: Int -> Int

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


module A where

data ABC = A | B | C

abc :: ABC -> Int
abc x = case x of
    A -> 1


{-# LANGUAGE UnicodeSyntax #-}
module T8959a where

foo :: Int -> Int
foo = ()


module Main where

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

solve :: Int -> StateT () [] ()
solve carry | carry > 0 =
  do guard (0 == carry)
     solve (carry -1)
solve 0 = mzero

main :: IO ()
main = return ()


module Main where

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

solve :: Int -> StateT () [] ()
solve 0 = mzero
solve carry | carry > 0 =
  do guard (0 == carry)
     solve (carry -1)

main :: IO ()
main = return ()


{-# OPTIONS_GHC -Wall -fwarn-tabs -Werror #-}

-- check that all warnings are emitted before failing due to -Werror (#1666)

-- missing type sig warning (type checker)
main = do
        let main = main -- shadowing warning (renamer)
	putStrLn "hello" -- tab warning (lexer)

f [] = []
f [] = [] -- overlapping pattern
-- incomplete pattern


{-# LANGUAGE ForeignFunctionInterface #-}
module B027.F where
foreign export ccall f :: Int -> Int
f :: Int -> Int
f n = n + 1


{-# LANGUAGE ForeignFunctionInterface #-}
module B028.F where
foreign export ccall f :: Int -> Int
f :: Int -> Int
f n = n + 1


{-# LANGUAGE ForeignFunctionInterface #-}
module B042stub.C where

foreign export ccall foo :: IO ()
foo :: IO ()
foo = return ()


{-# LANGUAGE ForeignFunctionInterface #-}
module B044.F where
foreign export ccall f :: Int -> Int
f :: Int -> Int
f n = n + 1


{-# LANGUAGE ForeignFunctionInterface #-}
module B045.F where
foreign export ccall f :: Int -> Int
f :: Int -> Int
f n = n + 1


module Main where

import A
import B

main = do print a
          print b


module C where

import A
import B

ab :: String
ab = [a, b]


module Main (main) where

import C

main :: IO ()
main = putStrLn c


import Distribution.Simple
main = defaultMain


module C where

import A
import B

c :: String
c = [a, b]


{-# OPTIONS_GHC -fwarn-unused-binds #-}

module A (a, a_type_default, a_missing_sig) where

a :: Int
a = 4

a_type_default :: Int
a_type_default = 2 ^ 2

a_missing_sig = ()


{-# OPTIONS_GHC -fwarn-type-defaults #-}

module B (b, b_unused_bind, b_missing_sig) where

b :: Int
b = 5

b_unused_bind :: Int -> Int
b_unused_bind x = 2

b_missing_sig = ()


{-# OPTIONS_GHC -fwarn-missing-signatures #-}

module Main (main, c_type_default, c_unused_bind) where

import A (a)
import B (b)

main :: IO ()
main = print (a + b)

c_type_default :: Int
c_type_default = 2 ^ 2

c_unused_bind :: Int -> Int
c_unused_bind x = 2


{-# OPTIONS_GHC -Wall -Werror #-}

module A_First where


module A_Main where

import A_First  () -- Turns on -Wall -Werror
import A_Second () -- Is not -Wall clean


module A_Second where

-- Not -Wall clean: Missing signature:
a = 'c'


module B_First where

-- Not -Wall clean: Missing signature:
a = 'c'


module B_Main where

import B_First  () -- Is not -Wall clean
import B_Second () -- Turns on -Wall -Werror


{-# OPTIONS_GHC -Wall -Werror #-}

module B_Second where


{-# OPTIONS_GHC -Wall -Werror #-}

module C_Child where


module C_Main where

import C_Child () -- Turns on -Wall -Werror

-- Not -Wall clean: Missing signature:
a = 'c'


module D_Child where

-- Not -Wall clean: Missing signature:
a = 'c'


{-# OPTIONS_GHC -Wall -Werror #-}

module D_Main where

import D_Child () -- Is not -Wall clean


module ManyFirst where

-- Not -Wall clean: Missing signature:
a = 'c'


{-# OPTIONS_GHC -Wall -Werror #-}

module ManySecond where


module ManyThird where

-- Not -Wall clean: Missing signature:
a = 'c'


module Handles
  ( hsNewSOHandle
  ) where

import Foreign

import Types

import MyCode

foreign export ccall "hs_soHandles"
  hsNewSOHandle :: SOHandleExport

hsNewSOHandle :: SOHandleExport
hsNewSOHandle = newStablePtr SOHandles
  { someData = "I'm a shared object"
  , someFn = myFunction
  }


{-# LANGUAGE RecordWildCards #-}

module Main (main) where

import Control.Exception
import Control.Monad

import Foreign

import Types

import System.Environment
import System.Posix.DynamicLinker
import GHCi.ObjLink

rotateSO
  :: (FunPtr (IO (StablePtr a)) -> (IO (StablePtr a)))
  -> String
  -> (Maybe FilePath, FilePath)
  -> IO a
rotateSO dynamicCall symName (old, newDLL) = do
  -- initObjLinker is idempotent
  initObjLinker DontRetainCAFs

  loadObj newDLL
  resolved <- resolveObjs
  unless resolved $
    throwIO (ErrorCall $ "Unable to resolve objects for " ++ newDLL)
  c_sym <- lookupSymbol symName
  h <- case c_sym of
    Nothing -> throwIO (ErrorCall "Could not find symbol")
    Just p_sym ->
      bracket (dynamicCall $ castPtrToFunPtr p_sym) freeStablePtr deRefStablePtr
  purgeObj newDLL
  forM_ old unloadObj
  return h

foreign import ccall "dynamic"
  mkCallable :: FunPtr SOHandleExport -> SOHandleExport

main :: IO ()
main = do
  [file] <- getArgs
  SOHandles{..} <- rotateSO mkCallable "hs_soHandles" (Nothing, file)
  someFn 7
  putStrLn $ "someData = " ++ show someData


module MyCode
  ( myFunction
  ) where

myFunction :: Int -> IO ()
myFunction i = putStrLn $ "Adding to 20: " ++ show (i + 20)


module Types
  ( SOHandles(..)
  , SOHandleExport
  ) where

import Foreign

data SOHandles = SOHandles
  { someData :: String
  , someFn :: Int -> IO ()
  }

type SOHandleExport = IO (StablePtr SOHandles)


module Main (main) where

import B (foo)

main :: IO ()
main = print foo


{-# LANGUAGE ForeignFunctionInterface #-}

module Main where

main :: IO ()
main = foo

foreign import ccall unsafe "c.h foo" foo :: IO ()


module A where

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


module B where

g :: Int -> Int
g x = x * 2


module C (f, g) where

import A
import B


{-# LANGUAGE RankNTypes #-}
module C (f, g) where

import A
import B

{-# RULES "f/g"  forall x . f (g x) = x #-}


module D () where

import C () -- so we don't get a dependency on C's export list


module E where

import D  -- get the RULE from C via D
import A
import B

z = f (g 3)


{-# LANGUAGE TypeOperators #-}
module A where

import B ((:-))

-- assumes :- is right-associative
f :: Int :- Int :- Int
f = (1,(2,3))


{-# LANGUAGE TypeOperators #-}

module B where

infixr 9 :-

type a :- b = (a,b)


{-# LANGUAGE TypeOperators #-}

module B where

infixl 9 :-

type a :- b = (a,b)


import Distribution.Simple
main = defaultMain


module Main (main) where

import B

main = print b


module A (T,t) where

data T = T
t = T

instance Eq T where
  t1 == t2 = True


module A (T,t) where

data T = T
t = T

instance Eq T where
  t1 == t2 = False


module Main where

import B

main = print (t == t)


{-# LANGUAGE TemplateHaskell #-}
module Main where
import Sub
main = print $x


{-# LANGUAGE TemplateHaskell #-}
module Sub where
x = [| 1 |]


{-# LANGUAGE TemplateHaskell #-}
module Sub where
x = [| 2 |]


module Main where
import X

main :: IO ()
main = print $ case f x of A -> True; B -> False


module X (x, D1(..), D2(..))
where

data D1 = D { f :: D2 } -- deriving Show
data D2 = A | B -- deriving Show

x :: D1
x = D { f = A }


module X (x, D1(..), D2(..))
where

data D1 = D { f :: D2 } -- deriving Show
data D2 = A | B -- deriving Show

x :: D1
x = D { f = B }


{-# LANGUAGE CPP #-}
module Main where

#include "A.hsinc"
#include "B.hsinc"


import Control.Monad (forM_)

main :: IO ()
main = forM_ [0..0xffff] $ \i -> do
   putStrLn $ ".section s" ++ show i ++ ",\"\",@progbits"
   putStrLn $ ".asciz \"Section " ++ show i ++ "\""
   putStrLn ""


{-# LANGUAGE TypeFamilies #-}
module A where
type family F a
type instance F Int = Bool


{-# LANGUAGE TypeFamilies #-}
module A2 where
type family F a
type instance F Int = Bool


{-# LANGUAGE TypeFamilies #-}
module A where
type family F a


{-# LANGUAGE TypeFamilies #-}
module B where
import A
data B
type instance F (B,b) = ()
b :: () -> F (B,b)
b = id


{-# LANGUAGE TypeFamilies #-}
module C where
import A
data C
type instance F (a,C) = ()


{-# LANGUAGE TypeFamilies #-}
module C where
import A
data C
type instance F (a,C) = Bool


{-# LANGUAGE TypeApplications #-}
module E where
import A
import B
import C
import D
c :: F (a, C) -> Bool
c = id
e :: () -> Bool
e = c . b @ C


module A where

import B
import C

foo :: Int
foo = 4


module B where

data B a = B a

b :: a -> B a
b = B


module C where

data C a = C a

c :: a -> C a
c = C


module Main (main) where

import B (foo)

main :: IO ()
main = print foo


{-# LANGUAGE CPP #-}

-- This should fail to compile with "ghc -Wcpp-undef -Werror ...".
#if this_cpp_identifier_does_not_exist
message :: String
message = "This is wrong!"
#endif

main :: IO ()
main = putStrLn "Hello"


module C where

import Language.Haskell.TH

import {-# SOURCE #-} A

nothing = return [] :: Q [Dec]


{-# LANGUAGE TemplateHaskell #-}
module T12062 where

import C

$(nothing)


{-# LANGUAGE ForeignFunctionInterface, CPP #-}
import Foreign.C
foreign import ccall unsafe "test" test :: CInt -> IO ()

main :: IO ()
-- Use conditional language to test passing a file with a filename
-- starting with a hyphen to the preprocessor.
#if defined(__GLASGOW_HASKELL__)
main = test 3
#endif


{-# LANGUAGE RecordWildCards #-}
module A where
import B
data E = MkE
p (H{..}) = ()


module B where
import {-# SOURCE #-} A
data H = H { h :: E }


module Main (main) where

import Distribution.Simple

main :: IO ()
main = defaultMain


module Main where

import A

x = T

main = print "ok"


{-# LANGUAGE TypeFamilies #-}
module D (D) where

type family D a
type instance D Int = Int


{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE TypeFamilies #-}
module E where

import                Data.Kind (Type, Constraint)
import {-# SOURCE #-} Y

data E

type family CF a :: Type -> Constraint
type instance CF E = Y


module Y where

import                D ()
import {-# SOURCE #-} E

class Y o


import Control.Exception (assert)

main = assert False (putStrLn "OK")


module V () where

import {-# SOURCE #-} F ()


-- {-# OPTIONS_GHC -fno-full-laziness #-}
module A (toTypedData, toTypedDataNoDef) where

toTypedData :: String -> IO Int
toTypedData s = wrapPrint "yoyo" $ toTypedDataNoDef s

wrapPrint :: String -> IO Int -> IO Int
wrapPrint s act = do
    putStrLn s
    act

toTypedDataNoDef  :: String -> IO Int
toTypedDataNoDef s = return $ length s


{-# OPTIONS_GHC -fno-full-laziness #-}
module A (toTypedData, toTypedDataNoDef) where

toTypedData :: String -> IO Int
toTypedData s = wrapPrint "yoyo" $ toTypedDataNoDef s

wrapPrint :: String -> IO Int -> IO Int
wrapPrint s act = do
    putStrLn s
    act

toTypedDataNoDef  :: String -> IO Int
toTypedDataNoDef s = return $ length s


module B ( TypeClass(..) ) where

import A

class Show a => TypeClass a where
    getSize :: a -> IO Int
    getSize a = toTypedData (show a)

    printA :: a -> IO ()


module Main where

import B

data MyDataType = MyDataType String Int deriving Show

instance TypeClass MyDataType where
    printA = putStrLn . show

main :: IO ()
main = do
    let myValue = MyDataType "haha" 99
    sz <- getSize myValue
    putStrLn $ show sz
    printA myValue


module Main where

import C (x)
import GHC.Exts (inline)

main = print (inline x)


module D (f) where

import E

{-# INLINE f #-}
f :: Int -> Int
f x = h x


module E (h) where

h :: Int -> Int
h x = x + x + x + x + x + x + x + x


module E (h) where

h :: Int -> Int
h x = x + x + x + x + x + x + x


module A (

    A (A)

) where

    import Internal


module Internal (

    A (A)

) where

    data A = A


import Distribution.Simple
main = defaultMain


module B where

    import A
    import {-# SOURCE #-} Internal

    a :: A
    a = A


module Test where

import Test2 hiding (main)

main = doit


module Test2 where

doit = print "Test2.doit"
main = print "Test2.main"


module A where

import B

showField :: Fields v -> String
showField a = show a


{-# LANGUAGE TypeFamilies #-}
module B where

class Entity v where
   data Fields v

instance Show (Fields v) where show = undefined


{-# LANGUAGE TypeFamilies #-}
module B where

class Entity v where
   data Fields v

-- Remove instance
-- instance Show (Fields v) where show = undefined


{-# LANGUAGE NoImplicitPrelude #-}
module D where

import A
import C

typeRepX :: Fingerprint
typeRepX = mkTyConApp Fingerprint


{-# LANGUAGE NoImplicitPrelude #-}
module A where

data Fingerprint = Fingerprint


{-# LANGUAGE NoImplicitPrelude #-}
module B (fingerprintFingerprints) where

import A
import C

fingerprintFingerprints :: [Fingerprint] -> Fingerprint
fingerprintFingerprints = undefined mkTyConApp

undefined :: a
undefined = undefined


{-# LANGUAGE NoImplicitPrelude #-}

module C where

import A
import {-# SOURCE #-} B

mkTyConApp :: Fingerprint -> Fingerprint
mkTyConApp f = fingerprintFingerprints [f]


import qualified TestPrim

main = print $ TestPrim.tpo 8 9


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

module TestPrim
  (
    tpo#
  , tpo
  ) where

import GHC.Base -- Int and I#

foreign import prim "test_prim_op" tpo# :: Int# -> Int# -> Int#

tpo :: Int -> Int -> Int
tpo (I# a) (I# b) = I# (tpo# a b)


module A where

import {-# SOURCE #-} B

data X = X Y


module B where

import A

data Y = Y Int Int

thing :: X -> a
thing (X (Y a b)) = thing (X (Y a b))


module C where

import A
import B

panic :: Int -> a
panic x = thing (X (Y x x))


{-# LANGUAGE CPP #-}
module A where

#include "A.inc"


{-# OPTIONS_GHC -F -pgmF ./t8602.sh -optF A -optF B -optF C #-}


{-# LANGUAGE TypeFamilies #-}

module A where

type family F a b


{-# LANGUAGE TypeFamilies #-}

module B where

import A
import C

type instance F a b = b

oops :: F a b -> a -> b
oops = const


module C (oops) where

import {-# SOURCE #-} B


{-# LANGUAGE TypeFamilies #-}

module D where

import A
import C

type instance F a b = a

unsafeCoerce :: a -> b
unsafeCoerce x = oops x x


module Main where

import D ( unsafeCoerce )

main = print $ (unsafeCoerce True :: Int)


{-# LANGUAGE ForeignFunctionInterface #-}

main :: IO ()
main = putStrLn "hello world"

foreign export ccall "hello" hello :: IO ()

hello :: IO ()
hello = putStrLn "hello world again"


{-# LANGUAGE ForeignFunctionInterface #-}

import Foreign
import System.Posix.DynamicLinker

main :: IO ()
main = do
    dl <- dlopen "./T13702" [RTLD_NOW]
    funptr <- dlsym dl "hello" :: IO (FunPtr (IO ()))
    mkAction funptr

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


{-# LANGUAGE ForeignFunctionInterface #-}
module T3807Export where

import Foreign.C

foo :: IO CInt
foo = return (3 + read "123")

foreign export ccall foo :: IO CInt


{-# LANGUAGE ForeignFunctionInterface #-}
module T4464H where

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

foreign export ccall f :: Int -> Int


{-# OPTIONS -fglasgow-exts -O -ddump-stranal #-}

module Foo(foo) where

foo :: Int -> Int
foo n = baz (n+1) (bar1 n)

{-# NOINLINE bar1 #-}
bar1 n = 1 + bar n

bar :: Int -> Int
{-# NOINLINE bar #-}
{-# RULES
"bar/foo" forall n. bar (foo n) = n
   #-}
bar n = n-1

baz :: Int -> Int -> Int
{-# INLINE [0] baz #-}
baz m n = m

{- Ronam writes (Feb08)

    Note that bar becomes dead as soon as baz gets inlined. But strangely,
    the simplifier only deletes it after full laziness and CSE. That is, it
    is not deleted in the phase in which baz gets inlined. In fact, it is
    still there after w/w and the subsequent simplifier run. It gets deleted
    immediately if I comment out the rule.

    I stumbled over this when I removed one simplifier run after SpecConstr
    (at the moment, it runs twice at the end but I don't think that should
    be necessary). With this change, the original version of a specialised
    loop (the one with the rules) is not longer deleted even if it isn't
    used any more. I'll reenable the second simplifier run for now but
    should this really be necessary?

No, it should not be necessary.  A refactoring in OccurAnal makes
this work right. Look at the simplifier output just before strictness
analysis; there should be a binding for 'foo', but for nothing else.

-}


{-# OPTIONS_GHC -fglasgow-exts -O -ddump-prep #-}
module Max(result) where

foo ys = foldr (\x xs -> x : reverse xs) [] ys

result xs =
    let stuff = [1, 1, 1, 1, 1, 1]
    in foo (reverse stuff)

-- What used to happen is that foldr got expanded by main simplification
-- and the resulting "go" function got floated out but because we manufactured
-- a new binder for it in newPolyBndrs we would lose its demand signature!
-- This means that the later application of it in result did not use call by value :-(

-- Eyeball test:
--  Ensure that Max.poly_go has a demand signature
--  Ensure that we use call by value to call Max.poly_go in result
--      i.e. the call to Max.poly_go inside Max.result looks like this:
--
-- case GHC.List.poly_rev @ t1_a6x sat_seb (GHC.Base.[] @ t1_a6x)
--        of sat_sed { __DEFAULT ->
--        Max.poly_go @ t1_a6x sat_sed
--        } } in


{-# OPTIONS_GHC -fglasgow-exts -O -ddump-simpl -fno-method-sharing #-}
module Roman where

import Control.Monad.ST

newtype T s a = T { unT :: Int -> ST s a }

instance Monad (T s) where
   return = T . const . return
   T p >>= f = T $ \i -> do { x <- p i
                            ; unT (f x) i }

myIndex :: T s Int
{-# INLINE myIndex #-}
myIndex = T return

foo :: T s Int
foo = do { x <- myIndex
         ; return (x + 1) }

{-   At one stage we got code looking like this:

    U.a3 =
       \ (@ s_a8E) (i_shA :: GHC.Base.Int) (eta_shB :: GHC.Prim.State# s_a8E) ->
         case ((((U.myIndex @ s_a8E)
                 `cast` ...)
                  i_shA)
               `cast` ...)
                eta_shB
         of wild_si5 { (# new_s_shF, r_shG #) -> ...

    U.foo :: forall s_a5S. U.T s_a5S GHC.Base.Int
    U.foo = U.a3 `cast` ...

The point is that myIndex should be inlined, else code is bad -}


{-# OPTIONS -fglasgow-exts -O -dshow-passes #-}

module Foo where
import GHC.Base

foo :: Int -> Int
foo (I# n#) = bar i i
   where i# = n# +# 1#
         i  = I# i#

bar :: Int -> Int -> Int
{-# INLINE [0] bar #-}
bar _ n = n

{-   The trouble here was

    *** Simplify:
         Result size = 25
         Result size = 25
         Result size = 25
         Result size = 25
         Result size = 25
    *** Simplify:
         Result size = 25
         Result size = 25
         Result size = 25
         Result size = 25
         Result size = 25

    etc.

The reason was this:
        x = n# +# 1#
        i = I# x

Being an unboxed value, we were treating the argument context of x
as interesting, and hence inlining x in the arg of I#. But then we just
float it out again, giving an infinite loop.
-}


{-# OPTIONS_GHC -fglasgow-exts -O -ddump-simpl #-}
module Roman where

foo :: Int -> Maybe Int -> Int
foo 0 (Just n) = n
foo 0 Nothing  = 1
foo n p = let f = foo (n-1+n-1+n-1+n-1+n-1+n-1+n-1+n-1)
           in
           case p of { Just m -> f (Just m); Nothing -> f Nothing }

{-  At one time this oddly produced;

     foo = \n p ->
          case n of ds {
            __DEFAULT ->
              let
                x = ds -# 1 +# ds -# 1 +# ds -# 1 +# ds -# 1 +# ds -# 1
              in
              case p of {
                Nothing ->
                  foo (x +# ds -# 1 +# ds -# 1 +# ds -# 1) Nothing
                ;
                Just m ->
                  foo (x +# ds -# 1 +# ds -# 1 +# ds -# 1) (Just m)
              };
            0 ->
              case p of {
                Nothing -> lvl_sbC; Just n -> n
              }
          }

But it shouldn't; and doesn't now.

-}


module CmmTx where

data TxRes a = TxRes Bool a

instance Monad TxRes where
    return = TxRes False

{-  Here you can get a simplifier loop thus:
NOTE: Simplifier still going after 4 iterations; bailing out.  Size = 52
NOTE: Simplifier still going after 4 iterations; bailing out.  Size = 52
NOTE: Simplifier still going after 4 iterations; bailing out.  Size = 52
NOTE: Simplifier still going after 4 iterations; bailing out.  Size = 52

Reason: 'a' is inline (not pre/post unconditionally; just ordinary inlining)
Then, since ($dm>>) has arity 3, the rhs of (>>) is a PAP, so the arg is
floated out, past the big lambdas.

See Note [Unsaturated functions] in SimplUtils

------------------------------------------------------------
a_s9f{v} [lid] =
  base:GHC.Base.:DMonad{v r5} [gid]
    @ main:CmmTx.TxRes{tc rd}
    >>={v a6E} [lid]
    >>{v a6H} [lid]
    return{v a6J} [lid]
    fail{v a6M} [lid]
>>{v a6H} [lid] [ALWAYS LoopBreaker Nothing] :: forall a{tv a6F} [tv]
                                                       b{tv a6G} [tv].
                                                main:CmmTx.TxRes{tc rd} a{tv a6F} [tv]
                                                -> main:CmmTx.TxRes{tc rd} b{tv a6G} [tv]
                                                -> main:CmmTx.TxRes{tc rd} b{tv a6G} [tv]
[Arity 2
 Str: DmdType LL]
>>{v a6H} [lid] =
  \ (@ a{tv a78} [sk] :: ghc-prim:GHC.Prim.*{(w) tc 34d})
    (@ b{tv a79} [sk] :: ghc-prim:GHC.Prim.*{(w) tc 34d}) ->
    base:GHC.Base.$dm>>{v r5f} [gid]
      @ main:CmmTx.TxRes{tc rd} a_s9f{v} [lid] @ a{tv a78} [sk] @ b{tv a79} [sk]
 -}


> {-# LANGUAGE BangPatterns,CPP #-}
> module IOList (delete) where

Goal: we want all the IORef boxes to go away in the "delete" operation
below.  There are two versions of the code: one using the record
selector "next", the other using a hand-written record selector
"myNext" (see the use in delete).  Currently (6.10), neither version
gives good code, but for different reasons.  The record selector
version is not inlined, and the myNext version gives rise to a join
point that takes the reboxed IORef as an argument.

#define USE_UNPACK
-- #define USE_STRICT

#if defined(USE_UNPACK)
#define UNPACK(p) {-# UNPACK #-} !(p)
#elif defined(USE_STRICT)
#define UNPACK(p) !(p)
#else
#define UNPACK(p) p
#endif

> import Data.IORef

> data List a = Node { val :: a, next :: UNPACK(IORef (List a))}
>           | Null
>           | Head {next :: UNPACK(IORef (List a)) }

> {-# INLINE [0] myNext #-}
> myNext :: List a -> IORef (List a)
> myNext Node{next=n} = n
> myNext Head{next=n} = n
> myNext Null = error "null"

> data ListHandle a = ListHandle { headList :: UNPACK(IORef (IORef (List a))),
>                            tailList :: UNPACK(IORef (IORef (List a))) }

> delete :: Eq a => ListHandle a -> a -> IO Bool
> delete (ListHandle {headList = ptrPtr})  i =
>          do startptr <- readIORef ptrPtr
>             delete2 startptr i
>   where
>    delete2 :: Eq a => IORef (List a) -> a -> IO Bool
>    delete2 prevPtr i =
>     do
>    { prevNode <- readIORef prevPtr
>    ; let curNodePtr = next {- or: myNext -} prevNode --  head/node have both next
>    ; curNode <- readIORef curNodePtr
>    ; case curNode of
>        Null -> return False  -- we've reached the end of the list
>                              -- element not found
>        Node {val = curval, next = nextNode} ->
>          if (curval /= i)
>           then delete2 curNodePtr i         -- keep searching
>           else
>               -- delete element (ie delink node)
>               do { case prevNode of
>                      Head {} -> do writeIORef prevPtr (Head {next = nextNode})
>                                    return True
>                      Node {} -> do writeIORef prevPtr
>                                       (Node {val = val prevNode, next = nextNode})
>                                    return True
>                  }
>     }


-- Check that the record selector for maskMB unfolds in the body of f
-- At one stage it didn't because the implicit unfolding looked too big

-- Trac #2581

module ShouldCompile where
import Data.Array.Base

data MBloom s a = MB {
     shiftMB :: {-# UNPACK #-} !Int
    , maskMB :: {-# UNPACK #-} !Int
    , bitArrayMB :: {-# UNPACK #-} !(STUArray s Int Int)
    }

f a b c = case maskMB (MB a b c) of
            3 -> True
            _ -> False


{-# OPTIONS_GHC -O2 -ddump-simpl  #-}
module Roman where

{- From: Roman Leshchinskiy [mailto:rl@cse.unsw.edu.au]
   Sent: 07 February 2008 03:34
   Subject: Quadratic SpecConstr

Here is a program which makes SpecConstr generate a quadratic number of
iterations:
-}

bar :: Int -> Int -> Int
bar m n = foo n (n,n) (n,n) (n,n) (n,n)
   where
     foo :: Int -> (Int,Int) -> (Int,Int) -> (Int,Int) -> (Int,Int) -> Int
     foo n p q r s
       | n == 0    = m
       | n > 3000  = case p of { (p1,p2) -> foo (n-1) (p2,p1) q r s }
       | n > 2000  = case q of { (q1,q2) -> foo (n-1) p (q2,q1) r s }
       | n > 1000  = case r of { (r1,r2) -> foo (n-1) p q (r2,r1) s }
       | otherwise = case s of { (s1,s2) -> foo (n-1) p q r (s2,s1) }

{- For this particular function, I get 14 specialisations, one for each
   possible combination of arguments.

   However, since we can see all the call sites outside the loop, we could
   use that to 'seed' the specialisation, and get just one specialisation.
-}

-- Eyeball guidance:
--      There should be just one specialisation for foo
--      Indeed, the original function should disappear,
--              since it isn't used


-- The question here is whether f gets eta-expanded
-- (assuming the state hack).  It should, but
-- didn't in GHC 6.10

module Foo where

import GHC.Base

{-# NOINLINE z #-}
z :: State# a -> Bool
z s = True

{-# NOINLINE k #-}
k :: Int -> State# a -> Bool
k y s = False

f []     = z
f (x:xs) = k (length xs)


{-# OPTIONS -O2 -XBangPatterns #-}

-- The thing to look for here is that the implementation
-- of 'length' does not allocate in the inner loop
--
-- See Trac #3116

module T3116 where

import Foreign

data SByteString
   = BS  {-# UNPACK #-} !(ForeignPtr Word8)  -- payload
         {-# UNPACK #-} !Int                 -- offset
         {-# UNPACK #-} !Int                 -- length

data ByteString
    =  Empty
    |  Chunk {-# UNPACK #-} !SByteString ByteString

bnull :: ByteString -> Bool
bnull Empty = True
bnull _     = False

btail :: ByteString -> ByteString
btail Empty = error "empty tail"
btail (Chunk (BS fp s 1) cs) = cs
btail (Chunk (BS fp s l) cs) = Chunk (BS fp (s+1) (l-1)) cs

length :: ByteString -> Int
length = go 0
  where
    go !n bs  | bnull bs   = n
              | otherwise  = go (n+1) (btail bs)


-- !!! cc001 -- ccall with standard boxed arguments and results

module ShouldCompile where

-- simple functions

foreign import ccall unsafe "a" a :: IO Int

foreign import ccall unsafe "b" b :: Int -> IO Int

foreign import ccall unsafe "c"
  c :: Int -> Char -> Float -> Double -> IO Float

-- simple monadic code

d =     a               >>= \ x ->
        b x             >>= \ y ->
        c y 'f' 1.0 2.0


{-# LANGUAGE MagicHash, UnliftedFFITypes #-}
-- !!! cc004 -- foreign declarations
module ShouldCompile where

import Foreign
import GHC.Exts
import Data.Int
import Data.Word

-- importing functions

-- We can't import the same function using both stdcall and ccall
-- calling conventions in the same file when compiling via C (this is a
-- restriction in the C backend caused by the need to emit a prototype
-- for stdcall functions).
foreign import stdcall        "p" m_stdcall :: StablePtr a -> IO (StablePtr b)
foreign import ccall   unsafe "q" m_ccall   :: ByteArray# -> IO Int

-- We can't redefine the calling conventions of certain functions (those from
-- math.h).
foreign import stdcall "my_sin" my_sin :: Double -> IO Double
foreign import stdcall "my_cos" my_cos :: Double -> IO Double

foreign import stdcall "m1" m8  :: IO Int8
foreign import stdcall "m2" m16 :: IO Int16
foreign import stdcall "m3" m32 :: IO Int32
foreign import stdcall "m4" m64 :: IO Int64

foreign import stdcall "dynamic" d8  :: FunPtr (IO Int8) -> IO Int8
foreign import stdcall "dynamic" d16 :: FunPtr (IO Int16) -> IO Int16
foreign import stdcall "dynamic" d32 :: FunPtr (IO Int32) -> IO Int32
foreign import stdcall "dynamic" d64 :: FunPtr (IO Int64) -> IO Int64

foreign import ccall unsafe "kitchen"
   sink :: Ptr a
        -> ByteArray#
        -> MutableByteArray# RealWorld
        -> Int
        -> Int8
        -> Int16
        -> Int32
        -> Int64
        -> Word8
        -> Word16
        -> Word32
        -> Word64
        -> Float
        -> Double
        -> IO ()

type Sink2 b = Ptr b
            -> ByteArray#
            -> MutableByteArray# RealWorld
            -> Int
            -> Int8
            -> Int16
            -> Int32
            -> Word8
            -> Word16
            -> Word32
            -> Float
            -> Double
            -> IO ()

foreign import ccall unsafe "dynamic"
  sink2 :: Ptr (Sink2 b) -> Sink2 b


-- !!! cc005 -- foreign export declarations
module ShouldCompile (d8) where

import Foreign.Ptr   --import Foreign
                 --import GlaExts
                 --import Int
                 --import Word
type Addr = FunPtr (Int -> IO ())
foreign import ccall "wrapper" d8  :: (Int -> IO ())  -> IO Addr

-- exporting functions
{-
m_stdcall :: Int -> IO Int
m_stdcall x = return x

x = putChar

foreign export ccall "m1" doo :: Int -> IO Int

doo :: Eq a => a -> IO Int
doo _ = return 2

foreign export ccall "listAppend" plusplus :: StablePtr [a] -> StablePtr [a] -> IO (StablePtr [a])

plusplus :: StablePtr [a] -> StablePtr [a] -> IO (StablePtr [a])
plusplus x y = do
  l1 <- deRefStablePtr x
  l2 <- deRefStablePtr y
  makeStablePtr (l1 ++ l2)

foreign export ccall "m11" m_stdcall :: Int -> IO Int

m_ccall :: Int -> Int -> IO Int
m_ccall x y = return (x-y)

foreign export ccall   "m2" m_ccall   :: Int -> Int -> IO Int

foreign export ccall   "putcha" putChar :: Char -> IO ()

foreign export stdcall "Math" "sin" my_sin :: Double -> IO Double
foreign export stdcall "Math" "cos" my_cos :: Double -> IO Double

my_sin = undefined
my_cos = undefined

foreign export stdcall "m111" m8  :: IO Int8
foreign export stdcall "m22" m16 :: IO Int16
foreign export stdcall "m3" m32 :: IO Int32
foreign export stdcall "m4" m64 :: IO Int64

m8 = undefined
m16 = undefined
m32 = undefined
m64 = undefined

foreign export stdcall dynamic d8  :: (Addr -> IO Int8)  -> IO Addr
foreign export stdcall dynamic d16 :: (Addr -> IO Int16) -> IO Addr
foreign export stdcall dynamic d32 :: (Addr -> IO Int32) -> IO Addr
foreign export stdcall dynamic d64 :: (Addr -> IO Int64) -> IO Addr

d8 = undefined
d16 = undefined
d32 = undefined
d64 = undefined

foreign export ccall "kitchen"
   sink :: --ForeignObj
--        -> ByteArray Int
--      -> MutableByteArray Int RealWorld
           Int
        -> Int8
        -> Int16
        -> Int32
        -> Int64
        -> Word8
        -> Word16
        -> Word32
        -> Word64
        -> Float
        -> Double
        -> IO Int

sink  = undefined
sink2 = undefined

foreign export ccall dynamic
  sink2 :: (--ForeignObj
--        -> ByteArray Int
--      -> MutableByteArray Int RealWorld
           StablePtr a
        -> Int
        -> Int8
        -> Int16
        -> Int32
        -> Int64
        -> Word8
        -> Word16
        -> Word32
        -> Word64
        -> Float
        -> Double
        -> IO ())
        -> IO Addr

-}


-- !!! cc007 -- foreign import with external name equal to Haskell name.
module ShouldCompile where

foreign import ccall sine :: Double -> Double


-- !!! cc008 -- foreign export dynamic returning newtype of Addr
module ShouldCompile where

import Foreign
type Addr = FunPtr (IO ())
newtype NPtr a = NPtr Addr

foreign import ccall "wrapper" mkFoo :: IO () -> IO (NPtr Int)


-- !!! cc009 -- foreign label returning newtype of Addr
module ShouldCompile where

import Foreign
type Addr = Ptr ()
newtype NPtr a = NPtr Addr

foreign import ccall "&" foo :: NPtr Int


module ShouldCompile where
import Foreign
foreign import ccall "dynamic" imp :: FunPtr Int -> Int
f1 a = imp a + 1
f2 a = imp a + 2


module ShouldCompile where

import Foreign

-- !!! test that a recursive newtype can be used as an argument or result
-- type of a foreign import.

newtype T = T (Ptr T)
foreign import ccall foo :: T -> IO T


{-# LANGUAGE ForeignFunctionInterface #-}
-- !!! test that infix operators can be exported with foreign export,
-- and that we can export something which isn't defined in this module.
module ShouldCompile where
foreign export ccall "plusInt" (+) :: Int -> Int -> Int


{-# LANGUAGE ForeignFunctionInterface #-}
-- !!! test that exporting the same thing multiple times works.
module ShouldCompile where

import Data.Int

foreign export ccall "addByte" (+) :: Int8  -> Int8  -> Int8
foreign export ccall "addInt"  (+) :: Int16 -> Int16 -> Int16
foreign export ccall "addLong" (+) :: Int32 -> Int32 -> Int32

foreign export ccall "divByte" div :: Int8  -> Int8  -> Int8
foreign export ccall "divInt"  div :: Int16 -> Int16 -> Int16
foreign export ccall "divLong" div :: Int32 -> Int32 -> Int32


module Blah ( foo ) where
import Foreign.Ptr ( FunPtr )
type Bar = Int -> Double -> Double -> Double -> IO ()
foreign import ccall unsafe "dynamic" foo :: FunPtr Bar -> Bar


{-# LANGUAGE TypeFamilies #-}

module Cc015 where

import Foreign
import Foreign.C.Types

type S a = a
type IOS a = IO a
type SFunPtr a = FunPtr a

type family F a
type instance F Int = Int
type instance F Bool = G2
type instance F Char = FunPtr (Int -> IO Int)

newtype G1  = G1  Int
newtype G1F = G1F (F (S Int))
newtype G2  = G2  Char
newtype G3  = G3  (IO Int)
newtype G4  = G4  G3
newtype NIO a = NIO (IO a)

-- Type synonyms should be transparent to the typechecker
foreign import ccall f1       ::          S Int -> IOS Int
foreign export ccall "g1"  f1 ::          S Int -> IOS Int
foreign import ccall "&h1" h1 :: SFunPtr (S Int -> IOS Int)
-- As should type functions
foreign import ccall f2         ::         F Int -> IO (F Int)
foreign export ccall "g2"   f2  ::         F Int -> IO (F Int)
foreign import ccall "&h2"  h2  :: F Char
foreign import ccall "&h2b" h2b :: FunPtr (F Int -> IO (F Int))
-- And newtype
foreign import ccall f3       ::         G1 -> G2 -> G4
foreign export ccall "g3" f3  ::         G1 -> G2 -> G4
foreign import ccall "&h3" h3 :: FunPtr (G1 -> G2 -> G4)
-- And a combination
foreign import ccall f4       ::         G1F -> F Bool -> S G4
foreign export ccall "g4" f4  ::         G1F -> F Bool -> S G4
foreign import ccall "&h4" h4 :: FunPtr (G1F -> F Bool -> S G4)
-- And a newtyped IO
foreign import ccall f5       ::         NIO Int
foreign export ccall "g5" f5  ::         NIO Int
foreign import ccall "&h5" h5 :: FunPtr (NIO Int)


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

module Cc015 where

import Foreign
import Foreign.C.Types
import GHC.Prim

type family F a
type instance F Int = Int# -> Int#

foreign import prim "f" f :: F Int


{-# LANGUAGE GeneralizedNewtypeDeriving #-}

-- Tests newtype unwrapping for the IO monad itself
-- Notice the RenderM monad, which is used in the
-- type of the callback function

module ShouldCompile where

import Control.Applicative (Applicative)

import Foreign.Ptr
newtype RenderM a = RenderM (IO a) deriving (Functor, Applicative, Monad)

type RenderCallback = Int -> Int -> RenderM ()

foreign import ccall duma_onRender :: FunPtr RenderCallback -> RenderM ()

foreign import ccall "wrapper" mkRenderCallback
     :: RenderCallback -> RenderM (FunPtr RenderCallback)

onRender :: RenderCallback -> RenderM ()
onRender f = mkRenderCallback f >>= duma_onRender


{-# LANGUAGE GHCForeignImportPrim #-}
module T10460 where
import GHC.Exts
-- don't link me!
foreign import prim "f" f :: Any -> Any


{-# LANGUAGE ForeignFunctionInterface #-}
module T11983 where

{-# INCLUDE T11983.h #-}

import Foreign.Ptr

foreign import ccall "intptr_example"
    intPtrExample :: IntPtr -> IO ()
foreign import ccall "uintptr_example"
    wordPtrExample :: WordPtr -> IO ()


{-# LANGUAGE ForeignFunctionInterface #-}
module T where

import Foreign
foreign import ccall "f" f :: FunPtr (Int -> IO ())


{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE TypeFamilies #-}
module T14125 where

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

data UnixReturn

data family IOErrno a
newtype instance IOErrno UnixReturn = UnixErrno CInt

foreign import ccall unsafe "string.h"
  strerror :: IOErrno UnixReturn -> IO CString

foreign import ccall unsafe "HsBase.h __hscore_get_errno"
  get_errno :: IO (IOErrno UnixReturn)


{-# LANGUAGE ForeignFunctionInterface #-}
module Test where

foreign import ccall "path/to/foo.h foo" foo :: Int -> IO Float


module ShouldCompile where

import Foreign
import Foreign.C

-- extra space before the function name:
foreign import ccall unsafe " g_get_application_name"
  g_get_application_name :: (IO (Ptr CChar))

-- and after:
foreign import ccall unsafe "g_get_application_name "
  g_get_application_name' :: (IO (Ptr CChar))


{-# LANGUAGE CApiFFI #-}

module M where

import Foreign.C

foreign import capi "math.h value sqrt" f :: CInt -> CInt


{-# LANGUAGE CApiFFI #-}

module Main (main) where

import Foreign.C

main :: IO ()
main = print i

foreign import ccall "ccall_value_c.h value i" i :: CInt


{-# LANGUAGE ForeignFunctionInterface, MagicHash #-}

-- Trac #1037

module Foo where

import GHC.Prim

foreign import ccall foo :: Int -> State# RealWorld


{-# LANGUAGE ForeignFunctionInterface, UnboxedTuples, MagicHash, UnliftedFFITypes #-}

-- Test for Trac #1680

module ShouldFail where

import GHC.Exts

foreign import ccall unsafe "foo"
        foo :: Int# -> Int# -> Int# -> (# Int# , Int#, Int# #)


{-# LANGUAGE UnliftedFFITypes, MagicHash #-}
-- !!! illegal types in foreign export delarations
module ShouldFail where

import GHC.Exts

foreign export ccall foo :: Int# -> IO ()
foo i | isTrue# (i ==# 0#) = return ()

foreign export ccall bar :: Int -> Int#
bar _ = 42#


module Ccfail004 where

import Ccfail004A

newtype NT = NT [NT]

-- All these should be rejected as the newtype constructors aren't in scope
foreign import ccall f1 :: NInt -> IO Int
foreign import ccall f2 :: Int -> IO NInt
foreign import ccall f3 :: Int -> NIO Int

-- Both these should be rejected as NT is recursive
foreign import ccall f4 :: NT -> IO ()
foreign import ccall f5 :: IO NT


module Ccfail004A (NInt, NIO) where

newtype NInt = NInt Int

newtype NIO a = NIO (IO a)


{-# LANGUAGE TypeFamilies #-}

module Ccfail005 where

type family F a
type instance F Bool = D -> IO Int
type instance F Char = Int -> IO D
data D = D

-- These should be rejected as D isn't a type we can use with the FFI.
-- Note that, in the signature the user writes, there aren't an
-- "argument type" and "result type" to complain about, though.
foreign import ccall f1 :: F Bool
foreign import ccall f2 :: F Char


{-# LANGUAGE MagicHash, GHCForeignImportPrim #-}

module T10461 where
import GHC.Exts

foreign import prim cheneycopy :: Any -> Word#


{-# LANGUAGE ForeignFunctionInterface, RankNTypes #-}
module Foo where

import Foreign
type X u = Ptr ()
foreign import ccall bla :: (forall u. X u) -> IO ()


module T5664 where

import Foreign
import Foreign.C

data D = D
newtype I = I CInt

foreign import ccall "dynamic"
  mkFun1 :: FunPtr (CInt -> IO ()) -> CInt -> IO ()

foreign import ccall "dynamic"
  mkFun2 :: FunPtr (I -> IO ()) -> CInt -> IO ()

foreign import ccall "dynamic"
  mkFun3 :: FunPtr (D -> IO ()) -> CInt -> IO ()

foreign import ccall "wrapper"
  mkCallBack1 :: IO CInt -> IO (FunPtr (IO CInt))

foreign import ccall "wrapper"
  mkCallBack2 :: IO CInt -> IO (FunPtr (IO I))

foreign import ccall "wrapper"
  mkCallBack3 :: IO CInt -> IO (FunPtr (IO D))


module T7243 where

import Foreign.Ptr
foreign import ccall "wrapper" foo :: IO (FunPtr ())


module Foo where

import Foreign.Ptr

-- foreign import ccall "stdio.h &putchar" c_putchar :: () -> FunPtr (Char -> IO ())
foreign import ccall "stdio.h &putchar" c_putchar :: Int -> IO ()


{-# LANGUAGE ForeignFunctionInterface #-}

-- | Test that unsafe FFI calls crash the RTS if they attempt to re-enter
-- Haskell-land
module Main where

import Foreign

foreign import ccall "wrapper" wrap_f :: IO () -> IO (FunPtr (IO ()))
foreign import ccall unsafe hello :: FunPtr (IO ()) -> IO ()

f :: IO ()
f = putStrLn "Back in Haskell"

main :: IO ()
main = do
    putStrLn "In Haskell"
    wrap_f f >>= hello
    putStrLn "Finished"


{-# LANGUAGE CApiFFI #-}

module Main (main) where

import Capi_Ctype_A_002

import Foreign
import Foreign.C

main :: IO ()
main = alloca $ \p ->
           do poke p (Foo 5 6 7)
              r1 <- f p
              print r1

foreign import capi unsafe "capi_ctype_002_B.h f"
    f :: Ptr Foo -> IO CInt


{-# LANGUAGE CApiFFI #-}

module Main (main) where

import Foreign.C

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

foreign import capi "capi_value_c.h value i" i :: CInt
foreign import capi "capi_value_c.h value j" j :: CInt


import Control.Monad
import Foreign
import Foreign.Ptr

type CInt  = Int32
type CSize = Word32

foreign import ccall "wrapper"
   mkComparator :: (Ptr Int -> Ptr Int -> IO CInt)
                -> IO (Ptr (Ptr Int -> Ptr Int -> IO CInt))

foreign import ccall
   qsort :: Ptr Int -> CSize -> CSize -> Ptr (Ptr Int -> Ptr Int -> IO CInt)
         -> IO ()

compareInts :: Ptr Int -> Ptr Int -> IO CInt
compareInts a1 a2 = do
   i1 <- peek a1
   i2 <- peek a2
   return (fromIntegral (i1 - i2 :: Int))

main :: IO ()
main = do
   let values = [ 12, 56, 90, 34, 78 ] :: [Int]
       n      = length values
   buf <- mallocArray n
   zipWithM_ (pokeElemOff buf) [ 0 .. ] values
   c <- mkComparator compareInts
   qsort buf (fromIntegral n) (fromIntegral (sizeOf (head values))) c
   mapM (peekElemOff buf) [ 0 .. n-1 ] >>= (print :: [Int] -> IO ())


-- !!! A simple FFI test

-- This one provoked a bogus renamer error in 4.08.1:
--      panic: tcLookupGlobalValue: <THIS>.PrelIOBase.returnIO{-0B,s-}
-- (the error was actually in DsMonad.dsLookupGlobalValue!)

module Main where

import Foreign

foreign export ccall "gccd" mygcd :: Int -> Int -> Int

main = putStrLn "No bug"

mygcd a b = if (a==b) then a
            else if (a<b) then mygcd a (b-a)
            else mygcd (a-b) a


{-# LANGUAGE ForeignFunctionInterface #-}
module Foo where

foreign export ccall foo :: Int -> IO Int

foo :: Int -> IO Int
foo n = return (length (f n))

f :: Int -> [Int]
f 0 = []
f n = n:(f (n-1))


-- !!! Test passing doubles to a ccall

import Foreign.C

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

main = c_sin 1.0 >>= print


-- !!! Test ccalls with large numbers of arguments

-- In 0.19, we lost the ability to do ccalls with more than 6 arguments
-- on the Sparc.  Just to make sure it never happens again...

import Foreign.C

main =
  withCString "Testing %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d\n" $ \cstr ->
  printf cstr
         0  1  2  3  4  5  6  7  8  9
        10 11 12 13 14 15 16 17 18 19
        20 21 22 23 24 25 26 27 28 29
        30 31 32 33 34 35 36 37 38 39

foreign import ccall unsafe
  printf :: CString
         -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int
         -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int
         -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int
         -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int
         -> IO ()


-- !!! test for foreign import dynamic/wrapper, originally by Alastair Reid,
-- with a few changes to get it to run on GHC by Simon Marlow.

import Foreign hiding ( unsafePerformIO )
import Foreign.C
import Control.Exception
import System.IO.Unsafe
import Prelude hiding (read)
import System.IO (hFlush, stdout)

main = do

  putStrLn "\nTesting sin==mysin (should return lots of Trues)"
  print (testSin sin mysin)

-- disabled because errno is not necessarily a label these days

--   putStrLn "\nTesting errno"
--   err <- peek errno
--  putStrLn $ "errno == " ++ show err

  putStrLn "\nTesting puts (and withString)"
  withCString "Test successful" puts

  putStrLn "\nTesting peekArray0"
  s <- withCString "Test successful" (peekArray0 (castCharToCChar '\0'))
  putStr (map castCCharToChar s)

-- disabled due to use of non-portable constants in arguments to open:

--  putStrLn "\nTesting open, read and close"
--  s <- testRead "ffi005.hs" 200
--  putStrLn (map castCCharToChar s)

--  putStrLn "\nTesting open, write and close"
--  testWrite "/tmp/test_write" "Test successful"

  putStrLn "\nTesting sin==dynamic_sin (should return lots of Trues)"
  print (testSin sin (dyn_sin sin_addr))

  putStrLn "\nTesting sin==IO wrapped_sin (should return lots of Trues)"
  sin_addr2 <- wrapIO (return . sin)
  print (testSin sin (unsafePerformIO . (dyn_sinIO sin_addr2)))
  freeHaskellFunPtr sin_addr2

  putStrLn "\nTesting sin==Id wrapped_sin (should return lots of Trues)"
  sin_addr3 <- wrapId sin
  print (testSin sin (dyn_sin sin_addr3))
  freeHaskellFunPtr sin_addr3

  putStrLn "\nTesting exit"
  hFlush stdout
  exit 3

testSin f g = [ (f x == g x) | x <- [0,0.01 .. 1] ]

foreign import ccall "sin" mysin :: CDouble -> CDouble
foreign import ccall "dynamic" dyn_sin :: FunPtr (CDouble -> CDouble) -> (CDouble -> CDouble)
foreign import ccall "dynamic" dyn_sinIO :: FunPtr (CDouble -> IO CDouble) -> (CDouble -> IO CDouble)
foreign import ccall "&sin" sin_addr :: FunPtr (CDouble -> CDouble)
foreign import ccall "wrapper" wrapId :: (CDouble -> CDouble) -> IO (FunPtr (CDouble -> CDouble))
foreign import ccall "wrapper" wrapIO :: (CDouble -> IO CDouble) -> IO (FunPtr (CDouble -> IO CDouble))

-- foreign import ccall safe "static stdlib.h &errno" errno :: Ptr CInt

withBuffer sz m = do
  b <- mallocArray sz
  sz' <- m b
  s <- peekArray sz' b
  free b
  return s

foreign import ccall puts :: CString -> IO CInt

-- foreign import ccall "open" open'  :: CString -> CInt -> IO CInt
-- foreign import ccall "open" open2' :: CString -> CInt -> CInt -> IO CInt
-- foreign import ccall "creat" creat' :: CString -> CInt -> IO CInt
-- foreign import ccall        close :: CInt -> IO CInt
-- foreign import ccall "read" read' :: CInt -> CString -> CInt -> IO CInt
-- foreign import ccall "write" write' :: CInt -> CString -> CInt -> IO CInt

-- creat s m   = withCString s $ \s' -> unix "creat" $ creat' s' m
-- open s m    = withCString s $ \s' -> unix "open"  $ open' s' m
-- open2 s m n = withCString s $ \s' -> unix "open2" $ open2' s' m n
-- write fd s  = withCString s $ \s' -> unix "write" $ write' fd s' (fromIntegral (length s))
-- read  fd sz = withBuffer sz $ \s' -> unix "read"  $ read' fd s' (fromIntegral sz)

-- unix s m = do
--   x <- m
--   if x < 0
--    then do
--      err <- peek errno
--      ioError $ userError $ s ++ ": " ++ show (x,err)
--    else return (fromIntegral x)

-- testRead fn sz = bracket (open fn 0) close (flip read sz)
-- testWrite fn s = bracket (open2 fn (512+64+1) 511) close (flip write s)

foreign import ccall exit :: Int -> IO ()

-- Various bits of rubbish.
-- foreign import ccall "static stdlib.h exit" (***) :: CString -> CString -> IO Int
--
-- foreign import ccall safe "static stdlib.h printf" (+++) :: CString -> CString -> IO Int
-- foreign import ccall safe "static stdlib.h &errno" illegal_foo :: Ptr Int
--
-- foreign import ccall safe "wrapper" illegal_bar :: Char -> IO (FunCString)
-- foreign import ccall safe "dynamic" illegal_baz :: FunCString -> Char

-- foreign export ccall "id_charstar" id :: CString -> CString


-- !!! Test that we can call a foreign import "wrapper" using foreign
-- import "dynamic", in both IO and non-IO flavours.

import Foreign
import Foreign.C

type IOF = Int -> IO Int
type F   = Int ->    Int

foreign import ccall "wrapper" wrap_f    :: F -> IO (FunPtr F)
foreign import ccall "wrapper" wrap_f_io :: IOF -> IO (FunPtr IOF)

foreign import ccall "dynamic" f    :: FunPtr F   -> F
foreign import ccall "dynamic" f_io :: FunPtr IOF -> IOF

double :: Int -> Int
double x = x * 2

double_io :: Int -> IO Int
double_io x = return (x * 2)

main = do
  double1 <- wrap_f double
  print (f double1 42)
  double2 <- wrap_f_io double_io
  x <- f_io double2 42
  print x


-- !!! Test System.Exit.exitWith called from a foreign import "wrapper"

import Foreign
import Foreign.C

import System.Exit

type IOF = IO ()
foreign import ccall "wrapper" wrap_f_io :: IOF -> IO (FunPtr IOF)
foreign import ccall "dynamic" call_io :: FunPtr IOF -> IOF

exit = do putStrLn "exiting..."; exitWith ExitSuccess

main = do f <- wrap_f_io exit; call_io f


-- !!! Test exceptions in a foreign import "wrapper"

import Foreign
import Foreign.C

import System.Exit

type IOF = IO ()
foreign import ccall "wrapper" wrap_f_io :: IOF -> IO (FunPtr IOF)
foreign import ccall "dynamic" call_io :: FunPtr IOF -> IOF

mk_error = error "this is an error"

main = do f <- wrap_f_io mk_error; call_io f


import Foreign
import System.Random

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

type FunType5I = Int -> Int -> Int -> Int -> Int -> Int

foreign import ccall "dynamic" callFun5I :: FunPtr FunType5I -> FunType5I
foreign import ccall "wrapper" mkFun5I   :: FunType5I -> IO (FunPtr FunType5I)

manyArgs5I :: FunType5I
manyArgs5I a1 a2 a3 a4 a5 = (((a1 * 31 + a2) * 31 + a3) * 31 + a4) * 31 + a5

test5I :: IO ()
test5I = do
  a1 <- randomIO
  a2 <- randomIO
  a3 <- randomIO
  a4 <- randomIO
  a5 <- randomIO
  funAddr <- mkFun5I manyArgs5I
  print (callFun5I funAddr a1 a2 a3 a4 a5 ==
         manyArgs5I        a1 a2 a3 a4 a5)
  freeHaskellFunPtr funAddr

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

type FunType11D = Double -> Double -> Double -> Double -> Double -> Double
               -> Double -> Double -> Double -> Double -> Double -> Double

foreign import ccall "dynamic" callFun11D :: FunPtr FunType11D -> FunType11D
foreign import ccall "wrapper" mkFun11D   :: FunType11D -> IO (FunPtr FunType11D)

manyArgs11D :: FunType11D
manyArgs11D a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 =
  ((((a1 * 31 + a2) * 31 + a3) * 31 + a4) * 31 + a5) * 31 + a6
  + a7 + a8 + a9 + a10 + a11

test11D :: IO ()
test11D = do
  a1 <- randomIO
  a2 <- randomIO
  a3 <- randomIO
  a4 <- randomIO
  a5 <- randomIO
  a6 <- randomIO
  a7 <- randomIO
  a8 <- randomIO
  a9 <- randomIO
  a10 <- randomIO
  a11 <- randomIO
  funAddr <- mkFun11D manyArgs11D
  let x = callFun11D funAddr a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11
      y = manyArgs11D        a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11
  if x /= y then
        print x >> print y
     else
       print True
  freeHaskellFunPtr funAddr

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

type FunType11M = Int -> Double -> Float -> Char -> Bool -> Int -> Float -> Int
               -> Char -> Double -> Bool -> Double

foreign import ccall "dynamic" callFun11M :: FunPtr FunType11M -> FunType11M
foreign import ccall "wrapper" mkFun11M   :: FunType11M -> IO (FunPtr FunType11M)

manyArgs11M :: FunType11M
manyArgs11M a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 =
   (((((((((fromIntegral           a1   * 31 +                         a2)  * 31 +
            realToFrac             a3)  * 31 + fromIntegral (fromEnum  a4)) * 31 +
            fromIntegral (fromEnum a5)) * 31 + fromIntegral            a6)  * 31 +
            realToFrac             a7)  * 31 + fromIntegral            a8)  * 31 +
            fromIntegral (fromEnum a9)) * 31 +                         a10) * 31 +
            fromIntegral (fromEnum a11)

test11M :: IO ()
test11M = do
  a1  <- randomIO
  a2  <- randomIO
  a3  <- randomIO
  a4  <- randomIO
  a5  <- randomIO
  a6  <- randomIO
  a7  <- randomIO
  a8  <- randomIO
  a9  <- randomIO
  a10 <- randomIO
  a11 <- randomIO
  funAddr <- mkFun11M manyArgs11M
  print (callFun11M funAddr a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 ==
         manyArgs11M        a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11)
  freeHaskellFunPtr funAddr

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

type FunTypeM1 = Double -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int
              -> Int -> Int -> Int -> Double

foreign import ccall "dynamic" callFunM1 :: FunPtr FunTypeM1 -> FunTypeM1
foreign import ccall "wrapper" mkFunM1   :: FunTypeM1 -> IO (FunPtr FunTypeM1)

manyArgsM1 :: FunTypeM1
manyArgsM1 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 =
   ((((((((((              a1  * 31 + fromIntegral  a2) * 31 +
             fromIntegral  a3) * 31 + fromIntegral  a4) * 31 +
             fromIntegral  a5) * 31 + fromIntegral  a6) * 31 +
             fromIntegral  a7) * 31 + fromIntegral  a8) * 31 +
             fromIntegral  a9) * 31 + fromIntegral a10) * 31 +
             fromIntegral a11) * 31 + fromIntegral a12

testM1 :: IO ()
testM1 = do
  a1  <- randomIO
  a2  <- randomIO
  a3  <- randomIO
  a4  <- randomIO
  a5  <- randomIO
  a6  <- randomIO
  a7  <- randomIO
  a8  <- randomIO
  a9  <- randomIO
  a10 <- randomIO
  a11 <- randomIO
  a12 <- randomIO
  funAddr <- mkFunM1 manyArgsM1
  print (callFunM1 funAddr a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 ==
         manyArgsM1        a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12)
  freeHaskellFunPtr funAddr

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

type FunTypeM2 = Int -> Double -> Int -> Int -> Int -> Int -> Int -> Int -> Int
              -> Int -> Int -> Int -> Double

foreign import ccall "dynamic" callFunM2 :: FunPtr FunTypeM2 -> FunTypeM2
foreign import ccall "wrapper" mkFunM2   :: FunTypeM2 -> IO (FunPtr FunTypeM2)

manyArgsM2 :: FunTypeM2
manyArgsM2 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 =
   ((((((((((fromIntegral  a1  * 31 +               a2) * 31 +
             fromIntegral  a3) * 31 + fromIntegral  a4) * 31 +
             fromIntegral  a5) * 31 + fromIntegral  a6) * 31 +
             fromIntegral  a7) * 31 + fromIntegral  a8) * 31 +
             fromIntegral  a9) * 31 + fromIntegral a10) * 31 +
             fromIntegral a11) * 31 + fromIntegral a12

testM2 :: IO ()
testM2 = do
  a1  <- randomIO
  a2  <- randomIO
  a3  <- randomIO
  a4  <- randomIO
  a5  <- randomIO
  a6  <- randomIO
  a7  <- randomIO
  a8  <- randomIO
  a9  <- randomIO
  a10 <- randomIO
  a11 <- randomIO
  a12 <- randomIO
  funAddr <- mkFunM2 manyArgsM2
  print (callFunM2 funAddr a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 ==
         manyArgsM2        a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12)
  freeHaskellFunPtr funAddr

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

type FunTypeM3 = Int -> Int -> Double -> Int -> Int -> Int -> Int -> Int -> Int
              -> Int -> Int -> Int -> Double

foreign import ccall "dynamic" callFunM3 :: FunPtr FunTypeM3 -> FunTypeM3
foreign import ccall "wrapper" mkFunM3   :: FunTypeM3 -> IO (FunPtr FunTypeM3)

manyArgsM3 :: FunTypeM3
manyArgsM3 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 =
   ((((((((((fromIntegral  a1  * 31 + fromIntegral  a2) * 31 +
                           a3) * 31 + fromIntegral  a4) * 31 +
             fromIntegral  a5) * 31 + fromIntegral  a6) * 31 +
             fromIntegral  a7) * 31 + fromIntegral  a8) * 31 +
             fromIntegral  a9) * 31 + fromIntegral a10) * 31 +
             fromIntegral a11) * 31 + fromIntegral a12

testM3 :: IO ()
testM3 = do
  a1  <- randomIO
  a2  <- randomIO
  a3  <- randomIO
  a4  <- randomIO
  a5  <- randomIO
  a6  <- randomIO
  a7  <- randomIO
  a8  <- randomIO
  a9  <- randomIO
  a10 <- randomIO
  a11 <- randomIO
  a12 <- randomIO
  funAddr <- mkFunM3 manyArgsM3
  print (callFunM3 funAddr a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 ==
         manyArgsM3        a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12)
  freeHaskellFunPtr funAddr

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

type FunTypeM4 = Int -> Int -> Int -> Double -> Int -> Int -> Int -> Int -> Int
              -> Int -> Int -> Int -> Double

foreign import ccall "dynamic" callFunM4 :: FunPtr FunTypeM4 -> FunTypeM4
foreign import ccall "wrapper" mkFunM4   :: FunTypeM4 -> IO (FunPtr FunTypeM4)

manyArgsM4 :: FunTypeM4
manyArgsM4 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 =
   ((((((((((fromIntegral  a1  * 31 + fromIntegral  a2) * 31 +
             fromIntegral  a3) * 31 +               a4) * 31 +
             fromIntegral  a5) * 31 + fromIntegral  a6) * 31 +
             fromIntegral  a7) * 31 + fromIntegral  a8) * 31 +
             fromIntegral  a9) * 31 + fromIntegral a10) * 31 +
             fromIntegral a11) * 31 + fromIntegral a12

testM4 :: IO ()
testM4 = do
  a1  <- randomIO
  a2  <- randomIO
  a3  <- randomIO
  a4  <- randomIO
  a5  <- randomIO
  a6  <- randomIO
  a7  <- randomIO
  a8  <- randomIO
  a9  <- randomIO
  a10 <- randomIO
  a11 <- randomIO
  a12 <- randomIO
  funAddr <- mkFunM4 manyArgsM4
  print (callFunM4 funAddr a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 ==
         manyArgsM4        a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12)
  freeHaskellFunPtr funAddr

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

type FunTypeM5 = Int -> Int -> Int -> Int -> Double -> Int -> Int -> Int -> Int
              -> Int -> Int -> Int -> Double

foreign import ccall "dynamic" callFunM5 :: FunPtr FunTypeM5 -> FunTypeM5
foreign import ccall "wrapper" mkFunM5   :: FunTypeM5 -> IO (FunPtr FunTypeM5)

manyArgsM5 :: FunTypeM5
manyArgsM5 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 =
   ((((((((((fromIntegral  a1  * 31 + fromIntegral  a2) * 31 +
             fromIntegral  a3) * 31 + fromIntegral  a4) * 31 +
                           a5) * 31 + fromIntegral  a6) * 31 +
             fromIntegral  a7) * 31 + fromIntegral  a8) * 31 +
             fromIntegral  a9) * 31 + fromIntegral a10) * 31 +
             fromIntegral a11) * 31 + fromIntegral a12

testM5 :: IO ()
testM5 = do
  a1  <- randomIO
  a2  <- randomIO
  a3  <- randomIO
  a4  <- randomIO
  a5  <- randomIO
  a6  <- randomIO
  a7  <- randomIO
  a8  <- randomIO
  a9  <- randomIO
  a10 <- randomIO
  a11 <- randomIO
  a12 <- randomIO
  funAddr <- mkFunM5 manyArgsM5
  print (callFunM5 funAddr a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 ==
         manyArgsM5        a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12)
  freeHaskellFunPtr funAddr

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

type FunTypeM6 = Int -> Int -> Int -> Int -> Int -> Double -> Int -> Int -> Int
              -> Int -> Int -> Int -> Double

foreign import ccall "dynamic" callFunM6 :: FunPtr FunTypeM6 -> FunTypeM6
foreign import ccall "wrapper" mkFunM6   :: FunTypeM6 -> IO (FunPtr FunTypeM6)

manyArgsM6 :: FunTypeM6
manyArgsM6 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 =
   ((((((((((fromIntegral  a1  * 31 + fromIntegral  a2) * 31 +
             fromIntegral  a3) * 31 + fromIntegral  a4) * 31 +
             fromIntegral  a5) * 31 +               a6) * 31 +
             fromIntegral  a7) * 31 + fromIntegral  a8) * 31 +
             fromIntegral  a9) * 31 + fromIntegral a10) * 31 +
             fromIntegral a11) * 31 + fromIntegral a12

testM6 :: IO ()
testM6 = do
  a1  <- randomIO
  a2  <- randomIO
  a3  <- randomIO
  a4  <- randomIO
  a5  <- randomIO
  a6  <- randomIO
  a7  <- randomIO
  a8  <- randomIO
  a9  <- randomIO
  a10 <- randomIO
  a11 <- randomIO
  a12 <- randomIO
  funAddr <- mkFunM6 manyArgsM6
  print (callFunM6 funAddr a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 ==
         manyArgsM6        a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12)
  freeHaskellFunPtr funAddr

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

type FunTypeM7 = Int -> Int -> Int -> Int -> Int -> Int -> Double -> Int -> Int
              -> Int -> Int -> Int -> Double

foreign import ccall "dynamic" callFunM7 :: FunPtr FunTypeM7 -> FunTypeM7
foreign import ccall "wrapper" mkFunM7   :: FunTypeM7 -> IO (FunPtr FunTypeM7)

manyArgsM7 :: FunTypeM7
manyArgsM7 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 =
   ((((((((((fromIntegral  a1  * 31 + fromIntegral  a2) * 31 +
             fromIntegral  a3) * 31 + fromIntegral  a4) * 31 +
             fromIntegral  a5) * 31 + fromIntegral  a6) * 31 +
                           a7) * 31 + fromIntegral  a8) * 31 +
             fromIntegral  a9) * 31 + fromIntegral a10) * 31 +
             fromIntegral a11) * 31 + fromIntegral a12

testM7 :: IO ()
testM7 = do
  a1  <- randomIO
  a2  <- randomIO
  a3  <- randomIO
  a4  <- randomIO
  a5  <- randomIO
  a6  <- randomIO
  a7  <- randomIO
  a8  <- randomIO
  a9  <- randomIO
  a10 <- randomIO
  a11 <- randomIO
  a12 <- randomIO
  funAddr <- mkFunM7 manyArgsM7
  print (callFunM7 funAddr a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 ==
         manyArgsM7        a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12)
  freeHaskellFunPtr funAddr

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

type FunTypeM8 = Int -> Int -> Int -> Int -> Int -> Int -> Int -> Double -> Int
              -> Int -> Int -> Int -> Double

foreign import ccall "dynamic" callFunM8 :: FunPtr FunTypeM8 -> FunTypeM8
foreign import ccall "wrapper" mkFunM8   :: FunTypeM8 -> IO (FunPtr FunTypeM8)

manyArgsM8 :: FunTypeM8
manyArgsM8 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 =
   ((((((((((fromIntegral  a1  * 31 + fromIntegral  a2) * 31 +
             fromIntegral  a3) * 31 + fromIntegral  a4) * 31 +
             fromIntegral  a5) * 31 + fromIntegral  a6) * 31 +
             fromIntegral  a7) * 31 +               a8) * 31 +
             fromIntegral  a9) * 31 + fromIntegral a10) * 31 +
             fromIntegral a11) * 31 + fromIntegral a12

testM8 :: IO ()
testM8 = do
  a1  <- randomIO
  a2  <- randomIO
  a3  <- randomIO
  a4  <- randomIO
  a5  <- randomIO
  a6  <- randomIO
  a7  <- randomIO
  a8  <- randomIO
  a9  <- randomIO
  a10 <- randomIO
  a11 <- randomIO
  a12 <- randomIO
  funAddr <- mkFunM8 manyArgsM8
  print (callFunM8 funAddr a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 ==
         manyArgsM8        a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12)
  freeHaskellFunPtr funAddr

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

type FunTypeM9 = Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Double
              -> Int -> Int -> Int -> Double

foreign import ccall "dynamic" callFunM9 :: FunPtr FunTypeM9 -> FunTypeM9
foreign import ccall "wrapper" mkFunM9   :: FunTypeM9 -> IO (FunPtr FunTypeM9)

manyArgsM9 :: FunTypeM9
manyArgsM9 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 =
   ((((((((((fromIntegral  a1  * 31 + fromIntegral  a2) * 31 +
             fromIntegral  a3) * 31 + fromIntegral  a4) * 31 +
             fromIntegral  a5) * 31 + fromIntegral  a6) * 31 +
             fromIntegral  a7) * 31 + fromIntegral  a8) * 31 +
                           a9) * 31 + fromIntegral a10) * 31 +
             fromIntegral a11) * 31 + fromIntegral a12

testM9 :: IO ()
testM9 = do
  a1  <- randomIO
  a2  <- randomIO
  a3  <- randomIO
  a4  <- randomIO
  a5  <- randomIO
  a6  <- randomIO
  a7  <- randomIO
  a8  <- randomIO
  a9  <- randomIO
  a10 <- randomIO
  a11 <- randomIO
  a12 <- randomIO
  funAddr <- mkFunM9 manyArgsM9
  print (callFunM9 funAddr a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 ==
         manyArgsM9        a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12)
  freeHaskellFunPtr funAddr

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

type FunTypeM10 = Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int
               -> Double -> Int -> Int -> Double

foreign import ccall "dynamic" callFunM10 :: FunPtr FunTypeM10 -> FunTypeM10
foreign import ccall "wrapper" mkFunM10   :: FunTypeM10 -> IO (FunPtr FunTypeM10)

manyArgsM10 :: FunTypeM10
manyArgsM10 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 =
   ((((((((((fromIntegral  a1  * 31 + fromIntegral  a2) * 31 +
             fromIntegral  a3) * 31 + fromIntegral  a4) * 31 +
             fromIntegral  a5) * 31 + fromIntegral  a6) * 31 +
             fromIntegral  a7) * 31 + fromIntegral  a8) * 31 +
             fromIntegral  a9) * 31 +              a10) * 31 +
             fromIntegral a11) * 31 + fromIntegral a12

testM10 :: IO ()
testM10 = do
  a1  <- randomIO
  a2  <- randomIO
  a3  <- randomIO
  a4  <- randomIO
  a5  <- randomIO
  a6  <- randomIO
  a7  <- randomIO
  a8  <- randomIO
  a9  <- randomIO
  a10 <- randomIO
  a11 <- randomIO
  a12 <- randomIO
  funAddr <- mkFunM10 manyArgsM10
  print (callFunM10 funAddr a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 ==
         manyArgsM10        a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12)
  freeHaskellFunPtr funAddr

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

type FunTypeM11 = Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int
               -> Int -> Double -> Int -> Double

foreign import ccall "dynamic" callFunM11 :: FunPtr FunTypeM11 -> FunTypeM11
foreign import ccall "wrapper" mkFunM11   :: FunTypeM11 -> IO (FunPtr FunTypeM11)

manyArgsM11 :: FunTypeM11
manyArgsM11 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 =
   ((((((((((fromIntegral  a1  * 31 + fromIntegral  a2) * 31 +
             fromIntegral  a3) * 31 + fromIntegral  a4) * 31 +
             fromIntegral  a5) * 31 + fromIntegral  a6) * 31 +
             fromIntegral  a7) * 31 + fromIntegral  a8) * 31 +
             fromIntegral  a9) * 31 + fromIntegral a10) * 31 +
                          a11) * 31 + fromIntegral a12

testM11 :: IO ()
testM11 = do
  a1  <- randomIO
  a2  <- randomIO
  a3  <- randomIO
  a4  <- randomIO
  a5  <- randomIO
  a6  <- randomIO
  a7  <- randomIO
  a8  <- randomIO
  a9  <- randomIO
  a10 <- randomIO
  a11 <- randomIO
  a12 <- randomIO
  funAddr <- mkFunM11 manyArgsM11
  print (callFunM11 funAddr a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 ==
         manyArgsM11        a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12)
  freeHaskellFunPtr funAddr

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

type FunTypeM12 = Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int
               -> Int -> Int -> Double -> Double

foreign import ccall "dynamic" callFunM12 :: FunPtr FunTypeM12 -> FunTypeM12
foreign import ccall "wrapper" mkFunM12   :: FunTypeM12 -> IO (FunPtr FunTypeM12)

manyArgsM12 :: FunTypeM12
manyArgsM12 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 =
   ((((((((((fromIntegral  a1  * 31 + fromIntegral  a2) * 31 +
             fromIntegral  a3) * 31 + fromIntegral  a4) * 31 +
             fromIntegral  a5) * 31 + fromIntegral  a6) * 31 +
             fromIntegral  a7) * 31 + fromIntegral  a8) * 31 +
             fromIntegral  a9) * 31 + fromIntegral a10) * 31 +
             fromIntegral a11) * 31 +              a12

testM12 :: IO ()
testM12 = do
  a1  <- randomIO
  a2  <- randomIO
  a3  <- randomIO
  a4  <- randomIO
  a5  <- randomIO
  a6  <- randomIO
  a7  <- randomIO
  a8  <- randomIO
  a9  <- randomIO
  a10 <- randomIO
  a11 <- randomIO
  a12 <- randomIO
  funAddr <- mkFunM12 manyArgsM12
  print (callFunM12 funAddr a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 ==
         manyArgsM12        a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12)
  freeHaskellFunPtr funAddr

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

rep :: String -> IO () -> IO ()
rep msg tst = do
   putStrLn ("Testing " ++ msg ++ "...")
   sequence_ (replicate 10 tst)

main :: IO ()
main = do
  setStdGen (mkStdGen 4711)
  rep "5 Int arguments" test5I
  rep "11 Double arguments" test11D
  rep "11 mixed arguments" test11M
  rep "Double as 1st argument, rest Int" testM1
  rep "Double as 2nd argument, rest Int" testM2
  rep "Double as 3rd argument, rest Int" testM3
  rep "Double as 4th argument, rest Int" testM4
  rep "Double as 5th argument, rest Int" testM5
  rep "Double as 6th argument, rest Int" testM6
  rep "Double as 7th argument, rest Int" testM7
  rep "Double as 8th argument, rest Int" testM8
  rep "Double as 9th argument, rest Int" testM9
  rep "Double as 10th argument, rest Int" testM10
  rep "Double as 11th argument, rest Int" testM11
  rep "Double as 12th argument, rest Int" testM12


import Foreign

-- !!! GHC 5.04.2 was missing rts_mkFunPtr, which meant that this example
-- !!! didn't link.

foreign import ccall "wrapper"
  makeHaskellFun :: (FunPtr a -> IO ()) -> IO (FunPtr (FunPtr a -> IO ()))

main = makeHaskellFun (const (return ()))


{-# LANGUAGE ForeignFunctionInterface #-}

-- !!! returning a Bool from a foreign export confused GHCi 6.0.1.

import Foreign

foreign import ccall "wrapper"
  mkFoo :: (Int -> IO Bool) -> IO (FunPtr (Int -> IO Bool))

foo :: Int -> IO Bool
foo x = return (x == 42)

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

main = do
   foo_fun <- mkFoo foo
   call_foo foo_fun 3 >>= print
   call_foo foo_fun 42 >>= print