{-# LANGUAGE MagicHash, UnboxedTuples #-}
import GHC.Exts
newtype Eval a = Eval {runEval :: State# RealWorld -> (# State# RealWorld, a #)}

-- inline sequence ::  [Eval a] -> Eval [a]
well_sequenced ::  [Eval a] -> Eval [a]
well_sequenced = foldr cons nil where
  cons e es = Eval $ \s -> case runEval e s of
                       (# s', a #) -> case runEval es s' of
                         (# s'', as #) -> (# s'', a : as #)
  nil = Eval $ \s -> (# s, [] #)

-- seemingly demonic use of spark#
ill_sequenced ::  [Eval a] -> Eval [a]
ill_sequenced  as = Eval $ spark# (case well_sequenced as of
             Eval f -> case f realWorld# of  (# _, a' #) -> a')

-- 'parallelized' version of (show >=> show >=> show >=> show >=> show)
main :: IO ()
main = putStrLn ((layer . layer . layer . layer . layer) (:[]) 'y')
  where
  layer :: (Char -> String) -> (Char -> String)
  layer f = (\(Eval x) -> case x realWorld# of (# _, as #) -> concat as)
        . well_sequenced    -- [Eval String] -> Eval [String]
        . map ill_sequenced -- [[Eval Char]] -> [Eval String];
                            -- 'map well_sequenced' is fine
        . map (map (\x -> Eval $ \s -> (# s, x #))) -- wrap each Char in Eval
        . chunk'            -- String -> [String]
        . concatMap f
        . show              -- add single quotes

  chunk' ::  String -> [String]
  chunk' [] = []
  chunk' xs =  as : chunk' bs where (as,bs) = splitAt 3 xs

  -- this doesn't work:
  -- chunk (a:b:c:xs) = [a,b,c]:chunk xs
  -- chunk xs = [xs]


import Data.Word( Word8 )

toV :: Float -> Word8
toV d = let coeff = significand d *  255.9999 / d
            a = truncate $ d * coeff
            b = exponent d
        in a `seq` (b `seq` a)

main :: IO ()
main =
  print $ map toV [ 3.56158e-2, 0.7415215, 0.5383201, 0.1289829, 0.45520145 ]


{-# LANGUAGE MagicHash #-}

import GHC.Exts

f :: Float# -> Float#
f x = x
{-# NOINLINE f #-}

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

h :: Float -> Float
h (F# x) = let a = F# (f x)
               b = D# (g (2.0##))
           in a `seq` (b `seq` a)

main = print (h 1.0)


import Data.Bits
import Data.Int
import Data.Word

unsafeShift32R :: (Bits a, Num a) => a -> a
unsafeShift32R x = unsafeShiftR x 32

main :: IO ()
main = do
    print $ map unsafeShift32R [ 123456, 0x7fffffff :: Int ]
    print $ map unsafeShift32R [ -123456, -0x80000000 :: Int ]
    print $ map unsafeShift32R [ 123456, 0xffffffff :: Word ]


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

-- Test the function of the isPinnedByteArray# primop

import GHC.Exts
import GHC.IO

main :: IO ()
main = do
    -- Unpinned MutableByteArray
    r <- IO $ \s0 ->
      case newByteArray# 1024# s0 of
        (# s1, mba #) ->
           (# s1, isTrue# (isMutableByteArrayPinned# mba) #)
    print r

    -- Pinned MutableByteArray
    r <- IO $ \s0 ->
      case newPinnedByteArray# 1024# s0 of
        (# s1, mba #) ->
           (# s1, isTrue# (isMutableByteArrayPinned# mba) #)
    print r

    -- Pinned, Aligned MutableByteArray
    r <- IO $ \s0 ->
      case newAlignedPinnedByteArray# 1024# 16# s0 of
        (# s1, mba #) ->
           (# s1, isTrue# (isMutableByteArrayPinned# mba) #)
    print r

    -- Unpinned ByteArray
    r <- IO $ \s0 ->
      case newByteArray# 1024# s0 of
        (# s1, mba #) ->
          case unsafeFreezeByteArray# mba s1 of
             (# s2, ba #) ->
                (# s2, isTrue# (isByteArrayPinned# ba) #)
    print r

    -- Pinned ByteArray
    r <- IO $ \s0 ->
      case newPinnedByteArray# 1024# s0 of
        (# s1, mba #) ->
          case unsafeFreezeByteArray# mba s1 of
             (# s2, ba #) ->
                (# s2, isTrue# (isByteArrayPinned# ba) #)
    print r


f :: Int -> IO ()
f p = case p of
  0 -> return ()
  1 -> return ()
  2 -> return ()
  3 -> return ()
  4 -> return ()
  10 -> return ()
  11 -> return ()
  _ -> print p
{-# NOINLINE f #-}

main = f 8


-- Test that static pointers still work when the users try
-- to unpack StaticPtr fields.
{-# LANGUAGE StaticPointers #-}
{-# LANGUAGE LambdaCase #-}

import GHC.StaticPtr
import T12622_A

g = True

main :: IO ()
main = do
  let T s = sg :: T (Bool -> Bool)
  lookupKey s >>= \f -> print (f True)

lookupKey :: StaticPtr a -> IO a
lookupKey p = unsafeLookupStaticPtr (staticKey p) >>= \case
  Just p -> return $ deRefStaticPtr p
  Nothing -> error $ "couldn't find " ++ show (staticPtrInfo p)


-- A.hs
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE StaticPointers #-}
module T12622_A where

import Data.Typeable
import GHC.StaticPtr

g :: a -> Bool
g _ = True

data T a = T {-# UNPACK #-} !(StaticPtr a)

sg :: Typeable a => T (a -> Bool)
sg = T (static g)


{-# LANGUAGE OverloadedStrings #-}

module Main (main) where

import           Data.ByteString        (ByteString)
import qualified Data.ByteString        as B

answers :: [ByteString]
answers = map (B.filter (/= 0x20))
    [ "e3b0c442 98fc1c14 9afbf4c8 996fb924 27ae41e4 649b934c a495991b 7852b855"
    , "d7a8fbb3 07d78094 69ca9abc b0082e4f 8d5651e4 6d3cdb76 2d02d0bf 37c9e592"
    , "e4c4d8f3 bf76b692 de791a17 3e053211 50f7a345 b46484fe 427f6acc 7ecc81be"
    , "ba7816bf 8f01cfea 414140de 5dae2223 b00361a3 96177a9c b410ff61 f20015ad"
    , "248d6a61 d20638b8 e5c02693 0c3e6039 a33ce459 64ff2167 f6ecedd4 19db06c1"
    , "cf5b16a7 78af8380 036ce59e 7b049237 0b249b11 e8f07a51 afac4503 7afee9d1"
    , "cdc76e5c 9914fb92 81a1c7e2 84d73e67 f1809a48 a497200e 046d39cc c7112cd0"
    ]

x, y :: ByteString
x = "e3b0c442 98fc1c14 9afbf4c8 996fb924 27ae41e4 649b934c a495991b 7852b855"
y = B.filter (/= 0x20) x

main :: IO ()
main = do
    print (seq x ())
    print (seq y ())
    print (length answers)
    print (seq (head answers) ()) -- segfault!


{- # OPTIONS_GHC -Wall -Werror #-}
module Main (main) where

import qualified Data.ByteString as S
import qualified Data.ByteString.Char8 as S8

main :: IO ()
main = (S8.concat (map S.singleton (S.unpack (S8.pack "<foo>"))) == S8.empty) `seq` return ()


import Data.Bits ((.&.))

flags :: Int -> Int
flags x
  | x .&. 128 > 0 = 12
  | otherwise = 13
{-# NOINLINE flags #-}

main :: IO ()
main = print (flags 255)


module Main where

import DynFlags
import RepType
import SMRep
import StgCmmLayout
import StgCmmClosure
import GHC
import GhcMonad
import System.Environment
import Platform

main :: IO ()
main = do
    [libdir] <- getArgs
    runGhc (Just libdir) tests

-- How to read tests:
--   F(a,8) = field a at offset 8
--   P(4,8) = 4 bytes of padding at offset 8
tests :: Ghc ()
tests = do
      (_, _, off) <- runTest [("a", FloatRep), ("b", DoubleRep)]
      assert_32_64 (map fmt off)
          ["F(a,4)", "F(b,8)"]
          ["F(a,8)", "P(4,12)", "F(b,16)"]

      (_, _, off) <- runTest [("a", FloatRep), ("b", FloatRep)]
      assert_32_64 (map fmt off)
          ["F(a,4)", "F(b,8)"]
          ["F(a,8)", "F(b,12)"]

      (_, _, off) <- runTest [("a", FloatRep), ("b", FloatRep), ("c", FloatRep)]
      assert_32_64 (map fmt off)
          ["F(a,4)", "F(b,8)", "F(c,12)"]
          ["F(a,8)", "F(b,12)", "F(c,16)", "P(4,20)"]

      (_, _, off) <- runTest [("a", FloatRep), ("b", FloatRep), ("c", Int64Rep)]
      assert_32_64 (map fmt off)
          ["F(a,4)", "F(b,8)", "F(c,12)"]
          ["F(a,8)", "F(b,12)", "F(c,16)"]

      (_, _, off) <- runTest [("a", Int64Rep), ("b", FloatRep), ("c", FloatRep)]
      assert_32_64 (map fmt off)
          ["F(a,4)", "F(b,12)", "F(c,16)"]
          ["F(a,8)", "F(b,16)", "F(c,20)"]

      (_, _, off) <- runTest [("a", Int64Rep), ("b", FloatRep), ("c", Int64Rep)]
      assert_32_64 (map fmt off)
          ["F(a,4)", "F(b,12)", "F(c,16)"]
          ["F(a,8)", "F(b,16)", "P(4,20)", "F(c,24)"]

assert_32_64 :: (Eq a, Show a) => a -> a -> a -> Ghc ()
assert_32_64 actual expected32 expected64 = do
    dflags <- getDynFlags
    let
      expected
          | word_size == 4 = expected32
          | word_size == 8 = expected64
      word_size = wORD_SIZE dflags
    case actual == expected of
        True -> return ()
        False ->
            error $ "Expected:\n" ++ show expected
                 ++ "\nBut got:\n" ++ show actual

runTest :: [(a, PrimRep)] -> Ghc (WordOff , WordOff, [FieldOffOrPadding a])
runTest prim_reps = do
    dflags <- getDynFlags
    return $ mkVirtHeapOffsetsWithPadding dflags StdHeader (mkNonVoids prim_reps)
  where
    mkNonVoids = map (\(a, prim_rep) -> NonVoid (prim_rep, a))

fmt :: FieldOffOrPadding String -> String
fmt (FieldOff (NonVoid id) off) = "F(" ++ id ++ "," ++ show off ++ ")"
fmt (Padding len off) = "P(" ++ show len ++ "," ++ show off ++ ")"


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

import GHC.Exts

{-# NOINLINE f #-}
f :: (Int# -> Float# -> Double# -> Float# -> Double# -> String) -> String
f g = g 3# 4.0# 5.0## 6.0# 6.9## ++ " World!"

{-# NOINLINE p #-}
p :: Int# -> Float# -> Double# -> Float# -> Double# -> String
p i j k l m = "Hello"

{-# NOINLINE q #-}
q :: Int# -> Int# -> Float# -> Double# -> Float# -> Double# -> String
q _ i j k l m = "Hello " ++ show (F# l) ++ " " ++ show (D# m)

{-# NOINLINE r #-}
r :: Int# -> Float# -> Double# -> Float# -> Double# -> String
r i = let !(I# z) = length [I# 1# .. I# i] in \j k l m -> p z j k l m
  -- ghc won't eta-expand around the length, because it has unknown cost

main = do
  putStrLn (f p)    -- fast call
  putStrLn (f r)    -- slow call: function but wrong arity
  let g = last [q 1#]
  putStrLn (f g)    -- slow call: thunk


module Main where

import Control.Concurrent
import Control.Monad
import Data.Word
import Foreign.Marshal.Alloc
import Foreign.Storable
import Numeric
import GHC.Ptr

main :: IO ()
main = do
    replicateM_ 49 $ threadDelay 1
    _ <- forkIO $ do
       allocaBytes 4 $ \p -> do
         forever $ do
           poke p (0xDEADBEEF :: Word32)
           threadDelay 10
           x <- peek p
           unless (x == 0xDEADBEEF) $ putStrLn (showHex x "")
    threadDelay 1000000


{-# OPTIONS_GHC -O1 #-}

{-
  On windows some xmm registers are callee saved. This means
  they can't be used as scratch registers before a call to C.

  In #14619 this wasn't respected which lead to a wrong value
  ending up in xmm6 and being returned in the final result.

  This code compiles to a non trivial fp computation followed
  by a call to sqrt at O1+. If xmm6 isn't properly handled it
  will be used as a scratch register failing the test.

  The original code used regular sqrt which on 8.2 generated
  a C call in the backend. To imitate this behaviour on 8.4+
  we force a call to a C function instead.
-}

module Main (main) where

import Prelude hiding((*>), (<*))
import Foreign.C
import Unsafe.Coerce

foreign import ccall unsafe "sqrt" call_sqrt :: CDouble -> CDouble

type V3 = (Double, Double, Double)

absf :: V3 -> V3 -> Double
absf (x, y, z) (x', y', z') = x*x' +y*y'+z*z'

{-# NOINLINE sphereIntersection #-}
sphereIntersection :: V3 -> V3 -> (V3)
sphereIntersection orig dir@(_, _, dirz)
  | b < 0  = undefined
  | t1   > 0  = dir
  | t1   < 0  = orig
  | otherwise = undefined
    where b  = orig `absf` dir
          sqrtDisc = realToFrac . call_sqrt $ CDouble b
          t1 = b - sqrtDisc

main = print $ sphereIntersection (11, 22, 33) (44, 55, 66)


module Main where

import Debug.Trace

main :: IO ()
main = print (alg 3 1)

alg :: Word -> Word -> Word
alg a b
  | traceShow (a, b) False = undefined
  | c < b = alg b c
  | c > b = alg c b
  | otherwise = c
  where
    c = a - b


{-# LANGUAGE MagicHash #-}

import GHC.Exts
import GHC.Prim

main :: IO ()
main = print (cmpT a T2)
  where
    {-# NOINLINE f #-}
    f = T2
    {-# NOINLINE a #-}
    a = f

data T = T1 | T2 | T3 | T4 | T5 | T6 | T7 | T8 | T9

cmpT a b
    = case dataToTag# a of
        a' -> case dataToTag# b of
                b' ->
                      if tagToEnum# (a' <# b') :: Bool then
                          LT -- used to return this
                      else
                          if tagToEnum# (a' ==# b') :: Bool then
                              EQ -- should return this
                          else
                              GT


{-# LANGUAGE MagicHash #-}

import GHC.Exts
import GHC.Prim

main :: IO ()
main = do
    print (I# (dataToTag# a))  -- used to print 0, should print 1
    print (I# (dataToTag# f))  -- used to print 1 correctly

  where
    {-# NOINLINE f #-}
    f = T2
    {-# NOINLINE a #-}
    a = f

data T = T1 | T2


import qualified Data.Set as S

main = print $
  let {-# noinline f #-}
      f () = T2
  in  S.fromList [f (), f ()]

data T = T1 | T2 | T3 | T4 | T5 | T6 | T7 | T8 | T9
  deriving (Show, Read, Eq, Ord, Bounded, Enum)


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

module Main (enumFromCallbackCatch, consume, next, main) where

import Control.Monad
import Foreign
import GHC.ForeignPtr
import GHC.Base (realWorld#)
import Data.Word (Word8)
import Foreign.Storable (peek)
import GHC.IO

data ByteString = PS {-# UNPACK #-} !(ForeignPtr Word8) {-# UNPACK #-} !Int

instance Show ByteString where
  showsPrec p ps r = showsPrec p (unpackAppendCharsStrict ps []) r

unpackAppendCharsStrict :: ByteString -> [Char] -> [Char]
unpackAppendCharsStrict (PS fp len) xs =
    unsafeDupablePerformIO $ withForeignPtr fp $ \base ->
      loop (base `plusPtr` (-1)) (base `plusPtr` 960) xs
  where
    loop !sentinal !p acc
      | p == sentinal = return acc
      | otherwise     = do x <- peek p
                           loop sentinal (p `plusPtr` (-1)) (w2c x:acc)

w2c :: Word8 -> Char
w2c = toEnum . fromEnum

packCStringLen :: Int -> IO ByteString
packCStringLen l = do
  p <- callocBytes bufsize
  fp <- newForeignPtr finalizerFree p
  return $! PS fp l
{-# NOINLINE packCStringLen #-}

bufsize :: Int
bufsize = 8192

{-# NOINLINE readFromPtr #-}
readFromPtr :: IO ByteString
readFromPtr = do
    bs <- packCStringLen bufsize
    length (show bs) `seq` return bs

newtype Iteratee s = Iteratee { runIter :: forall r.
          ((s -> Iteratee s) -> IO r) ->
          IO r}

enumFromCallbackCatch :: IO ()
enumFromCallbackCatch = produce 500 consume
  where
    produce 0 (Iteratee f) = return ()
    produce n (Iteratee f) = f onCont
      where onCont k = do bs <- readFromPtr; produce (n-1) (k bs)

consume = Iteratee $ \onCont -> onCont next
next x = Iteratee $ \onCont -> print x >> onCont (\_ -> consume)

main :: IO ()
main = do
  _ <- enumFromCallbackCatch
  pure ()


{-# OPTIONS_GHC -funbox-strict-fields #-}
import Data.List

data Vec4 = Vec4 !Float !Float !Float !Float

main :: IO ()
main = print traceList

traceList = concatMap (\(x,y) -> let (r,g,b,a) = getPixel (x,y) in [r,g,b,a])
    [(0,0)]
    where
    getPixel (x,y) = (red,green,blue,alpha)
        where
        Vec4 fr fg fb fa = seq x (Vec4 1 2 3 4)
        red = round fr
        green = round fg
        blue = round fb
        alpha = round fa


import System.Environment
main = do [x] <- getArgs
          print (read x < (1e400 :: Double))
          print (read x < (-1e400 :: Double))
          print (read x == (0/0 :: Double))
          -- the last doesn't get constant-folded to NaN, so we're not really
          -- testing properly here.  Still, we might manage to constant fold
          -- this in the future, so I'll leave it in place.


{-# OPTIONS_GHC -XMagicHash #-}
module Main where
import GHC.Base

import Foreign
import Foreign.C
import GHC.Ptr (Ptr(..))

utf8DecodeChar# :: Addr# -> Bool -> Bool
{-# NOINLINE utf8DecodeChar# #-}
utf8DecodeChar# a# fred =
  case () of
    _ | isTrue# (word2Int# (indexWord8OffAddr# a# 0#) <=# 0x7F#) -> True

-- Omitting the next line gives an ASSERT error:
-- ghc-6.9: panic! (the 'impossible' happened)
--   (GHC version 6.9 for x86_64-unknown-linux):
--      ASSERT failed! file nativeGen/MachCodeGen.hs line 1049
-- %MO_S_Le_I8(I8[R2], 127 :: I8)
      | fred -> True

      | otherwise -> False

main = print (utf8DecodeChar# "\128"# False) -- should be False


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

import GHC.Base
import GHC.Num

complement (I# x#) = I# (word2Int# (int2Word# (4294967295#) `xor#` int2Word# (-1#)))

main = print (complement (-1))


module Main where

import Control.Monad.ST.Lazy
import Data.STRef.Lazy
import Data.Array.ST
import Data.Int
import Debug.Trace

data Refs s = Refs
    { memory    :: STArray s Int8 Int8
    , pc        :: STRef s Int8
    }

main :: IO ()
main = do
    print $ runST m
  where
    m = do
      m <- newArray_ (0,30)
      p <- newSTRef 0
      let r = Refs m p
      writeArray m 0 0x4
      v <- readSTRef p
      modifySTRef p (+1)
--      trace ("v: " ++ show v) $ return ()
      op <- readArray m v
      case {- trace ("v: " ++ show v) $ -} op of
          0x4 -> modifySTRef p (+100) -- should run this
          n   -> error ("should never match this: " ++ show n)


main = print $ pqr' 0 1

pqr' :: Int -> Int -> Integer
pqr' a b | a == b - 1 = rab
         | otherwise = ram * rmb
    where m = (a + b) `div` 2
          ram = pqr' a m
          rmb = pqr' m b
          rab = toInteger (6 * b - 5) * toInteger (2 * b - 1) *
                toInteger (6 * b - 1)


module Main(main) where

main = print (take 2 (edi2 0))

-- In 6.12, edi2 lead to a stack overflow (see #3677)

edi :: Integer -> [Integer]
edi x | x `mod` 1000000 == 0 = x : edi (x+1)
      | otherwise             = edi (x+1)

edi2 :: Integer -> [Integer]
edi2 x | x `mod` 1000000 == 0 = x : y
       | otherwise             = y
       where
         y = edi2 (x+1)


module Main where

import Numeric
import System.IO

main = do
 let d = read "2.0e-2" :: Double
 print $ "Float Version : " ++ (fToStr $ realToFrac d)
 print $ "Double Version: " ++ (dToStr d)

double :: IO Double
double = do
   x <- getLine
   return $ read x

dToStr :: Double -> String
dToStr d = show d

fToStr :: Float -> String
fToStr = (dToStr . realToFrac)


{-# LANGUAGE DeriveDataTypeable #-}
import Control.Exception as E
import Data.Typeable

throwIfNegative :: Int -> String
throwIfNegative n | n < 0     = error "negative"
                  | otherwise = "no worries"
{-# NOINLINE throwIfNegative #-}

data HUnitFailure = HUnitFailure String deriving (Show,Typeable)
instance Exception HUnitFailure

assertFailure :: String -> a -- Not an IO function!
assertFailure msg = E.throw (HUnitFailure msg)

main :: IO ()
main =
    handleJust errorCalls (const (return ())) (do
        evaluate (throwIfNegative (-1)) -- Pure expression evaluated in IO
        assertFailure "must throw when given a negative number")
  where errorCalls (ErrorCall _) = Just ()


{-# LANGUAGE MagicHash,GHCForeignImportPrim,UnliftedFFITypes #-}
module Main where

import GHC.Exts

foreign import prim "f5149" f :: Int# -> Int# -> Double# -> Int#

main = print (I# (f 1# 2# 1.0##))


module Main where

wrap x = [x]!!0

f :: [Int] -> a
f a = foldr (\b -> \c -> c) (undefined ()) (a ++ a) 0

main = do
  print $ (f [] :: String)
  print $ wrap $ (f [] :: Int)
  print $ wrap $ (f [] :: (Int, Int, Int, Int))


module Main where

import Data.Int
import Data.Word

-- Test case for bug #5785. The cause of this was that the LLVM backend
-- converted all Int constants using (fromInteger :: Int) and so on 32bit a
-- Int64 or Word32 would be truncated to 32bit! value before printing out.
main :: IO ()
main = do
    -- first two should print as big numbers (as unsigned)
    print (-1 :: Word8)
    print (-1 :: Word16)
    print (-1 :: Word32)
    print (-1 :: Word64)
    print (-1 :: Int8)
    print (-1 :: Int16)
    print (-1 :: Int32)
    print (-1 :: Int64)

    -- only requires 32 bits (unsigned)
    print (2316287658 :: Word8)
    print (2316287658 :: Word16)
    print (2316287658 :: Word32)
    print (2316287658 :: Word64)
    print (2316287658 :: Int8)
    print (2316287658 :: Int16)
    print (2316287658 :: Int32)
    print (2316287658 :: Int64)

    -- this requries a 64 (unsigned) bit word to store correctly
    print (32342316287658 :: Word8)
    print (32342316287658 :: Word16)
    print (32342316287658 :: Word32)
    print (32342316287658 :: Word64)
    print (32342316287658 :: Int8)
    print (32342316287658 :: Int16)
    print (32342316287658 :: Int32)
    print (32342316287658 :: Int64)


import Data.Bits
import Data.Word
import Debug.Trace

fl :: Word64 -> Word64 -> Word64
fl fin sk =
        let (x1, x2) = w64tow32 fin in
        let (k1, k2) = w64tow32 sk in
        let y2 = x2 `xor` ((x1 .&. k1) `rotateL` 1) in
        let y1 = x1 `xor` (y2 .|. k2) in
        trace (show fin ++ " " ++ show sk ++ " -> " ++ show (w32tow64 (y1, y2))) $ w32tow64 (y1, y2)

w64tow32 :: Word64 -> (Word32, Word32)
w64tow32 w = (fromIntegral (w `shiftR` 32), fromIntegral (w .&. 0xffffffff))

w32tow64 :: (Word32, Word32) -> Word64
w32tow64 (x1, x2) = ((fromIntegral x1) `shiftL` 32) .|. (fromIntegral x2)

a, b :: Word64
a = 1238988323332265734
b = 11185553392205053542

main :: IO ()
main =
    putStrLn $ "fl " ++ show a ++ " " ++ show b ++ " -> " ++ show (fl a b)


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

import GHC.Exts

{-# NOINLINE f #-}
f :: (Int# -> Float# -> Double# -> String) -> String
f g = g 3# 4.0# 6.9## ++ " World!"

{-# NOINLINE p #-}
p :: Int# -> Float# -> Double# -> String
p i j k = "Hello"

{-# NOINLINE q #-}
q :: Int# -> Int# -> Float# -> Double# -> String
q _ i j k = "Hello"

{-# NOINLINE r #-}
r :: Int# -> Float# -> Double# -> String
r i = let !(I# z) = length [I# 1# .. I# i] in \j k -> p z j k
  -- ghc won't eta-expand around the length, because it has unknown cost

main = do
  putStrLn (f p)    -- fast call
  putStrLn (f r)    -- slow call: function but wrong arity
  let g = last [q 1#]
  putStrLn (f g)    -- slow call: thunk


-- Test #6146 (a bug in -feager-blackholing) I couldn't reliably
-- reproduce it, but this program occasionally triggers it so it's
-- better than nothing.

module Main (main) where

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

main :: IO ()
main = do
    putStrLn "First number?  "
    num1 <- readLn :: IO Int
    performGC -- provokes bug (sometimes)
    putStrLn "Second number? "
    num2 <- readLn :: IO Int
    let total = num1 + num2
    putStrLn $ "The sum is " ++ (show total) ++ "."


module Main where

main :: IO ()
main = putStrLn $ printFloat 100

printFloat :: Float -> String
printFloat x = f (show (round (x * 10)))
    where f "0" = "0"
          f _   = show (round x)


{-# LANGUAGE BangPatterns, MagicHash #-}
import Control.Exception
import System.Environment
import GHC.Exts

main = do
  args <- getArgs
  foo args

foo _ = let !e = toException (ErrorCall "test") in
        raise# e


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

main = print $ map f [1,256,65536,minBound,maxBound]

f (I# x#) =
      [ I# (narrow8Int#  (narrow16Int# x#))
      , I# (narrow8Int#  (narrow32Int# x#))
      , I# (narrow16Int# (narrow8Int#  x#))
      , I# (narrow16Int# (narrow32Int# x#))
      , I# (narrow32Int# (narrow8Int#  x#))
      , I# (narrow32Int# (narrow16Int# x#))]


-- !!! Bug # 7600.
-- The LLVM backend can be tricky to get right with floating point constants
-- and GHC. See Note [LLVM Float Types] in compiler/llvmGen/Llvm/Types.hs for
-- why this is.
--
-- Two issues to watch for (that this bug tries to track):
--
-- 1) We need to narrow a double to a float but then expand back out (so that
-- we end up with the precision of a float but in double precision byte form).
-- GHC seems to optimize this away for some ways of doing this.
--
-- 2) The 'realToFrac' method returns different results at the byte level
-- depending on if optimisations are on or off. We use the double2float and
-- float2Double methods instead as they don't suffer from this.
--
-- Also worth looking at ticket # 3676 about issues with 'realToFrac'.
module Main (main) where

import T7600_A

-- a fp constant that requires double precision, but we only use a single
-- precision type.
-- expected output: float 0x7FF0000000000000
float_number :: Float
float_number = 1.82173691287639817263897126389712638972163e+300

-- as above but use double precision so we can represent it.
-- expected output: double 0x7E45C3163C1ACF96
double_number :: Double
double_number = 1.82173691287639817263897126389712638972163e+300

-- Test run
main :: IO ()
main = test_run float_number double_number

-- XXX: We don't run below, but it can be useful to test how the optimizer is
-- running... the NOINLINE pragmas are needed below generally, but often not
-- for Bug31_A as the constant is in a different module...

-- -- Test run
-- test_run' :: Float -> Double -> IO ()
-- test_run' float_number double_number = do
--     print $ dToStr double_number
--     print $ dToStr (widen $ narrow double_number)
--     print $ dToStr (widen' $ narrow' double_number)
--     let dd = case double_number of { (D# x) -> x }
--     print $ dToStr (D# (float2Double# (double2Float# dd)))
--
-- -- use standard Haskell functions for type conversion... which are kind of
-- -- insane (see ticket # 3676) [these fail when -O0 is used...]
-- {-# NOINLINE narrow #-}
-- narrow :: Double -> Float
-- narrow = realToFrac
--
-- {-# NOINLINE widen #-}
-- widen :: Float -> Double
-- widen = realToFrac
--
-- -- use GHC specific functions which work as expected [work for both -O0 and -O]
-- {-# NOINLINE narrow' #-}
-- narrow' :: Double -> Float
-- narrow' = double2Float
--
-- {-# NOINLINE widen' #-}
-- widen' :: Float -> Double
-- widen' = float2Double
--
-- doubleToBytes :: Double -> [Int]
-- doubleToBytes d
--    = runST (do
--         arr <- newArray_ ((0::Int),7)
--         writeArray arr 0 d
--         arr <- castDoubleToWord8Array arr
--         i0 <- readArray arr 0
--         i1 <- readArray arr 1
--         i2 <- readArray arr 2
--         i3 <- readArray arr 3
--         i4 <- readArray arr 4
--         i5 <- readArray arr 5
--         i6 <- readArray arr 6
--         i7 <- readArray arr 7
--         return (map fromIntegral [i0,i1,i2,i3,i4,i5,i6,i7])
--      )
--
-- castFloatToWord8Array :: STUArray s Int Float -> ST s (STUArray s Int Word8)
-- castFloatToWord8Array = castSTUArray
--
-- castDoubleToWord8Array :: STUArray s Int Double -> ST s (STUArray s Int Word8)
-- castDoubleToWord8Array = castSTUArray
--
-- dToStr :: Double -> String
-- dToStr d
--   = let bs     = doubleToBytes d
--         hex d' = case showHex d' "" of
--                      []    -> error "dToStr: too few hex digits for float"
--                      [x]   -> ['0',x]
--                      [x,y] -> [x,y]
--                      _     -> error "dToStr: too many hex digits for float"
--
--         str  = map toUpper $ concat . fixEndian . (map hex) $ bs
--     in  "0x" ++ str
--
-- fixEndian :: [a] -> [a]
-- -- #ifdef WORDS_BIGENDIAN
-- -- fixEndian = id
-- -- #else
-- fixEndian = reverse
-- -- #endif


-- !!! Bug # 7600.
-- See file T7600 for main description.
module T7600_A (test_run) where

import Control.Monad.ST
import Data.Array.Unsafe( castSTUArray )
import Data.Array.ST hiding( castSTUArray )
import Data.Char
import Data.Word
import Numeric

import GHC.Float

-- Test run
test_run :: Float -> Double -> IO ()
test_run float_number double_number = do
    print $ dToStr double_number
    -- XXX: Below is the bad code due to changing with optimisation.
    -- print $ dToStr (widen $ narrow double_number)
    print $ dToStr (widen' $ narrow' double_number)

-- use standard Haskell functions for type conversion... which are kind of
-- insane (see ticket # 3676) [these fail when -O0 is used...]
narrow :: Double -> Float
{-# NOINLINE narrow #-}
narrow = realToFrac

widen :: Float -> Double
{-# NOINLINE widen #-}
widen = realToFrac

-- use GHC specific functions which work as expected [work for both -O0 and -O]
narrow' :: Double -> Float
{-# NOINLINE narrow' #-}
narrow' = double2Float

widen' :: Float -> Double
{-# NOINLINE widen' #-}
widen' = float2Double

doubleToWord64 :: Double -> Word64
doubleToWord64 d
   = runST (do
        arr <- newArray_ ((0::Int),0)
        writeArray arr 0 d
        arr <- castDoubleToWord64Array arr
        readArray arr 0
     )

castFloatToWord64Array :: STUArray s Int Float -> ST s (STUArray s Int Word64)
castFloatToWord64Array = castSTUArray

castDoubleToWord64Array :: STUArray s Int Double -> ST s (STUArray s Int Word64)
castDoubleToWord64Array = castSTUArray

dToStr :: Double -> String
dToStr d
  = let bs     = doubleToWord64 d
        hex d' = showHex d' ""

        str  = map toUpper $ hex bs
    in  "0x" ++ str


module Main (main) where

import Control.Monad
import System.IO
import System.Random

main :: IO ()
main = do
    hSetBuffering stdout NoBuffering
    let q = fold $ zip [1..] (take 200 [500.0,400.0..])
    print q
    putStrLn "Before atMost"
    let (xs,q') = atMost 0.5 q -- this causes seqfault with -O2
    print xs
    print q'
    putStrLn "After atMost"

fold :: [(Key, Prio)] -> PSQ
fold []         = Void
fold ((u,r):xs) = insert u r $ fold xs

data Elem = E
    { _key   :: Key
    , prio   :: Prio
    } deriving (Eq, Show)

type Prio = Double
type Key = Int

data PSQ = Void
           | Winner Elem Tree
           deriving (Eq, Show)

singleton :: Key -> Prio -> PSQ
singleton k p = Winner (E k p) Start

insert :: Key -> Prio -> PSQ -> PSQ
insert k p q = case q of
    Void -> singleton k p
    Winner e t -> Winner (E k p) (Fork e Start t)

atMost :: Prio -> PSQ -> ([Elem], PSQ)
atMost pt q = case q of
    (Winner e _)
        | prio e > pt -> ([], q)
    Void              -> ([], Void)
    Winner e Start    -> ([e], Void)
    Winner e (Fork e' tl tr) ->
        let (sequ, q')   = atMost pt (Winner e' tl)
            (sequ', q'') = atMost pt (Winner e tr)
        in (sequ ++ sequ', q' `play` q'')

data Tree = Start
          | Fork Elem Tree Tree
    deriving (Eq, Show)

lloser :: Key -> Prio -> Tree -> Tree -> Tree
lloser k p tl tr = Fork (E k p) tl tr

play :: PSQ -> PSQ -> PSQ
Void `play` t' = t'
t `play` Void  = t
Winner e@(E k p) t `play` Winner e'@(E k' p') t'
    | p <= p'   = Winner e  (lloser k' p' t t')
    | otherwise = Winner e' (lloser k  p  t t')


{-# LANGUAGE MagicHash #-}
module Main where
import T8103_A

float_text = case (0.0## `foo` 1.2##) of
               0.0## -> "1"
               _     -> "0"
main = putStrLn (float_text)


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

{-# NOINLINE foo #-}
foo  :: Double# -> Double# -> Double#
foo a b = (a +## b)


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

module Main where

import GHC.Prim
import GHC.Types
import Foreign
import Foreign.Ptr
import GHC.Ptr

wrapFetch :: (a -> State# RealWorld -> State# RealWorld) -> (a -> IO ())
wrapFetch prefetch  a = IO (\ s -> (# prefetch a s, ()#))

main :: IO ()
main = do
    (ptr :: Ptr Int) <- malloc
    wrapFetch (\ (Ptr adr)-> prefetchAddr3# adr 0# ) ptr
    wrapFetch prefetchValue1# (1 ::Int)
    wrapFetch prefetchValue2# "hiiii"
    wrapFetch prefetchValue3# (Just "testing")
    wrapFetch prefetchValue0# (error "this shouldn't get evaluated")
    --  -- ^^ this is to make sure it doesn't force thunks!
    --incontrast,
    --wrapFetch prefetchValue0#  $! (error "this shouldn't get evaluated")
    -- would trigger an exception
    putStrLn "success"


{-# LANGUAGE RankNTypes #-}

newtype FMList = FM {unFM :: forall m. m -> m}

main = print (delete 2000 (FM id) :: Int)

delete 0 _ = 0
delete n (FM a) = a $ delete (n-1) $ FM $ \g -> a (const g) undefined


{-# LANGUAGE MagicHash, UnboxedTuples #-}

import GHC.Prim
import GHC.Word

big :: Word
big = maxBound

carry :: Word
carry = case big of
  W# w -> case plusWord2# w w of
    (# hi, lo #) -> W# hi

main = print carry


{-# LANGUAGE MagicHash #-}

import Control.Monad
import Data.Bits
import GHC.Exts
import GHC.Word
import Numeric (showHex)

-- Reference Implementation

-- count trailing zeros
ctzRI :: FiniteBits a => a -> Word
ctzRI x = fromIntegral $ go 0
  where
    go i | i >= w      = i
         | testBit x i = i
         | otherwise   = go (i+1)

    w = finiteBitSize x

-- count leading zeros
clzRI :: FiniteBits a => a -> Word
clzRI x = fromIntegral $ (w-1) - go (w-1)
  where
    go i | i < 0       = i -- no bit set
         | testBit x i = i
         | otherwise   = go (i-1)

    w = finiteBitSize x

clzRI32, ctzRI32 :: Word -> Word
clzRI32 x = clzRI (fromIntegral x :: Word32)
ctzRI32 x = ctzRI (fromIntegral x :: Word32)

clzRI16, ctzRI16 :: Word -> Word
clzRI16 x = clzRI (fromIntegral x :: Word16)
ctzRI16 x = ctzRI (fromIntegral x :: Word16)

clzRI8, ctzRI8 :: Word -> Word
clzRI8 x = clzRI (fromIntegral x :: Word8)
ctzRI8 x = ctzRI (fromIntegral x :: Word8)

-- Implementation Under Test
ctzIUT, clzIUT :: Word -> Word
ctzIUT (W# x#) = W# (ctz# x#)
clzIUT (W# x#) = W# (clz# x#)

ctzIUT8, clzIUT8 :: Word -> Word
ctzIUT8 (W# x#) = W# (ctz8# x#)
clzIUT8 (W# x#) = W# (clz8# x#)

ctzIUT16, clzIUT16 :: Word -> Word
ctzIUT16 (W# x#) = W# (ctz16# x#)
clzIUT16 (W# x#) = W# (clz16# x#)

ctzIUT32, clzIUT32 :: Word -> Word
ctzIUT32 (W# x#) = W# (ctz32# x#)
clzIUT32 (W# x#) = W# (clz32# x#)

ctzIUT64, clzIUT64 :: Word64 -> Word
ctzIUT64 (W64# x#) = W# (ctz64# x#)
clzIUT64 (W64# x#) = W# (clz64# x#)

main :: IO ()
main = do
    forM_ testpats $ \w64 -> do
        let w = fromIntegral w64 :: Word

        check "clz"   clzRI   clzIUT   w
        check "clz8"  clzRI8  clzIUT8  w
        check "clz16" clzRI16 clzIUT16 w
        check "clz32" clzRI32 clzIUT32 w
        check "clz64" clzRI   clzIUT64 w64

        check "ctz"   ctzRI   ctzIUT   w
        check "ctz8"  ctzRI8  ctzIUT8  w
        check "ctz16" ctzRI16 ctzIUT16 w
        check "ctz32" ctzRI32 ctzIUT32 w
        check "ctz64" ctzRI   ctzIUT64 w64

    putStrLn $ concat ["tested ", show (length testpats), " patterns"]

  where
    -- try to construct some interesting patterns
    testpats :: [Word64]
    testpats = [ bit i - 1 | i <- [0..63] ] ++
               [ complement (bit i - 1) | i <- [0..63] ] ++
               [ bit i .|. bit j | i <- [0..63], j <- [0..i] ]

    check s fri fiut v = unless (vri == viut) $ do
        putStrLn $ concat [ "FAILED ", s, " for x=0x", showHex v ""
                          , " (RI=", show vri, " IUT=", show viut, ")"
                          ]
      where
        vri = fri v
        viut = fiut v


import Data.Word

x :: Word
x = 10

y :: Word
y = 11

test = case x - y of
         5 -> "C"
         -1 -> "A"
         _  -> "B"
main = putStrLn $ show test


-- Test case of known literal with wraparound
test = case 1 :: Int of
         0x10000000000000001 -> "A"
         _  -> "B"
test2 = case 0x10000000000000001 :: Int of
         1 -> "A"
         _  -> "B"
main = putStrLn $ test ++ test2


-- Don't wrap literals that will be used at type Integer
f :: Integer -> Int
f n = case n of
  0x100000000000000000000000 -> 1
  0 -> 2
  _ -> 3

main = print (f (read "0"))


{-# LANGUAGE MagicHash #-}

import T9577_A

import GHC.Exts (Ptr(..), Addr#)

main = print (foo == Ptr "foo"#)


{-# LANGUAGE MagicHash #-}

module T9577_A where

import GHC.Exts (Ptr(..), Addr#)

foo = Ptr "foo"#


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

import GHC.Exts (Double(D#), Float(F#), word2Double#, word2Float#)

main :: IO ()
main = do
    print (D# (word2Double# 0##))
    -- 4294967295 is 2^32 - 1, the largest 32-bit integer, and can be
    -- stored in a 64-bit IEEE floating-point value without loss of
    -- precision.
    print (D# (word2Double# 4294967295##))
    print (F# (word2Float# 0##))
    -- 16777216 is 2^24, which is the largest integer which can be
    -- stored in a 32-bit IEEE floating-point value without loss of
    -- precision
    print (F# (word2Float# 16777216##))


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

import GHC.Exts (Double(D#), Float(F#), word2Double#, word2Float#)

main :: IO ()
main = do
    print (D# (word2Double# 0##))
    -- 9007199254740992 is 2^53, which is the largest integer which
    -- can be stored in a 64-bit IEEE floating-point value without
    -- loss of precision.
    print (D# (word2Double# 9007199254740992##))
    print (F# (word2Float# 0##))
    -- 16777216 is 2^24, which is the largest integer which can be
    -- stored in a 32-bit IEEE floating-point value without loss of
    -- precision
    print (F# (word2Float# 16777216##))


{-# LANGUAGE DeriveFunctor #-}

module Data.Trie.Naive
  ( Trie
  , singleton
  , singletonString
  , lookup
  , parser
  , fromList
  , fromListAppend
  , fromStringList
  ) where

import Prelude hiding (lookup)

import Data.Semigroup (Semigroup)
import Data.Word (Word8)
import Data.Map (Map)
import Data.Bifunctor (second)
import Packed.Bytes (Bytes)
import qualified Data.Char
import qualified GHC.OldList as L
import qualified Packed.Bytes.Parser as P
import qualified Packed.Bytes as B
import qualified Data.Semigroup as SG
import qualified Data.Map.Strict as M

data Trie a = Trie (Maybe a) (Map Word8 (Trie a))
  deriving (Functor)

instance Semigroup a => Semigroup (Trie a) where
  (<>) = append

instance Semigroup a => Monoid (Trie a) where
  mempty = Trie Nothing M.empty
  mappend = (SG.<>)

append :: Semigroup a => Trie a -> Trie a -> Trie a
append (Trie v1 m1) (Trie v2 m2) = Trie
  (SG.getOption (SG.Option v1 SG.<> SG.Option v2))
  (M.unionWith append m1 m2)

singleton :: Bytes -> a -> Trie a
singleton k v = B.foldr (\b r -> Trie Nothing (M.singleton b r)) (Trie (Just v) M.empty) k

singletonString :: String -> a -> Trie a
singletonString k v = L.foldr (\c r -> Trie Nothing (M.singleton (c2w c) r)) (Trie (Just v) M.empty) k

lookup :: Bytes -> Trie a -> Maybe a
lookup k t0 = case B.foldr lookupStep (Just t0) k of
  Nothing -> Nothing
  Just (Trie v _) -> v

lookupStep :: Word8 -> Maybe (Trie a) -> Maybe (Trie a)
lookupStep w Nothing = Nothing
lookupStep w (Just (Trie _ m)) = M.lookup w m

parser :: Trie (P.Parser a) -> P.Parser a
parser (Trie mp m) = case mp of
  Just p -> p
  Nothing -> do
    w <- P.any
    case M.lookup w m of
      Nothing -> P.failure
      Just t -> parser t

fromList :: [(Bytes,a)] -> Trie a
fromList = fmap SG.getFirst . fromListAppend . map (second SG.First)

fromListAppend :: Semigroup a => [(Bytes,a)] -> Trie a
fromListAppend = foldMap (uncurry singleton)

fromStringList :: [(String,a)] -> Trie a
fromStringList = fmap SG.getFirst . fromStringListAppend . map (second SG.First)

fromStringListAppend :: Semigroup a => [(String,a)] -> Trie a
fromStringListAppend = foldMap (uncurry singletonString)

c2w :: Char -> Word8
c2w = fromIntegral . Data.Char.ord


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

{-# OPTIONS_GHC
 -fno-warn-unsafe
 -fno-warn-implicit-prelude
 -fno-warn-missing-import-lists
 -O2
#-}

module Packed.Bytes
  ( Bytes(..)
  , pack
  , unpack
  , length
    -- * Folds
  , foldr
    -- * Unsliced Byte Arrays
  , fromByteArray
  ) where

import Prelude hiding (take,length,replicate,drop,null,concat,foldr)

import Data.Primitive (ByteArray(..))
import Data.Word (Word8)
import Control.Monad.ST (runST, ST)
import qualified Data.Primitive as PM
import qualified GHC.OldList as L

data Bytes = Bytes
  {-# UNPACK #-} !ByteArray -- payload
  {-# UNPACK #-} !Int -- offset
  {-# UNPACK #-} !Int -- length

instance Show Bytes where
  show x = "pack " ++ show (unpack x)

pack :: [Word8] -> Bytes
pack bs = let arr = packByteArray bs in Bytes arr 0 (lengthByteArray arr)

unpack :: Bytes -> [Word8]
unpack (Bytes arr off len) = go off
  where
  go :: Int -> [Word8]
  go !ix = if ix < len + off
    then PM.indexByteArray arr ix : go (ix + 1)
    else []

fromByteArray :: ByteArray -> Bytes
fromByteArray ba = Bytes ba 0 (lengthByteArray ba)

length :: Bytes -> Int
length (Bytes _ _ len) = len

foldr :: (Word8 -> a -> a) -> a -> Bytes -> a
foldr f a0 (Bytes arr off0 len) = go off0 where
  !end = off0 + len
  go !ix = if ix < end
    then f (PM.indexByteArray arr ix) (go (ix + 1))
    else a0

packByteArray :: [Word8] -> ByteArray
packByteArray ws0 = runST $ do
  marr <- PM.newByteArray (L.length ws0)
  let go [] !_ = return ()
      go (w : ws) !ix = PM.writeByteArray marr ix w >> go ws (ix + 1)
  go ws0 0
  PM.unsafeFreezeByteArray marr

unpackByteArray :: ByteArray -> [Word8]
unpackByteArray arr = go 0 where
  go :: Int -> [Word8]
  go !ix = if ix < lengthByteArray arr
    then PM.indexByteArray arr ix : go (ix + 1)
    else []

lengthByteArray :: ByteArray -> Int
lengthByteArray = PM.sizeofByteArray


{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeInType #-}
{-# LANGUAGE UnboxedSums #-}
{-# LANGUAGE UnboxedTuples #-}

{-# OPTIONS_GHC
 -Weverything
 -fno-warn-unsafe
 -fno-warn-implicit-prelude
 -fno-warn-missing-import-lists
 -fno-warn-noncanonical-monoid-instances
 -O2
#-}

module Packed.Bytes.Parser
  ( Parser(..)
  , Result(..)
  , Leftovers(..)
  , parseStreamST
  , any
  , failure
  ) where

import Control.Applicative
import Data.Primitive (ByteArray(..))
import GHC.Int (Int(I#))
import GHC.ST (ST(..),runST)
import GHC.Types (TYPE)
import GHC.Word (Word8(W8#))
import Packed.Bytes (Bytes(..))
import Packed.Bytes.Stream.ST (ByteStream(..))
import Prelude hiding (any,replicate)

import qualified Data.Primitive as PM
import qualified Control.Monad

import GHC.Exts (Int#,ByteArray#,Word#,State#,(+#),(-#),(>#),indexWord8Array#)

type Bytes# = (# ByteArray#, Int#, Int# #)
type Maybe# (a :: TYPE r) = (# (# #) | a #)
type Leftovers# s = (# Bytes# , ByteStream s #)
type Result# s a = (# Maybe# (Leftovers# s), Maybe# a #)

data Result s a = Result
  { resultLeftovers :: !(Maybe (Leftovers s))
  , resultValue :: !(Maybe a)
  }

data Leftovers s = Leftovers
  { leftoversChunk :: {-# UNPACK #-} !Bytes
    -- ^ The last chunk pulled from the stream
  , leftoversStream :: ByteStream s
    -- ^ The remaining stream
  }

data PureResult a = PureResult
  { pureResultLeftovers :: {-# UNPACK #-} !Bytes
  , pureResultValue :: !(Maybe a)
  } deriving (Show)

emptyByteArray :: ByteArray
emptyByteArray = runST (PM.newByteArray 0 >>= PM.unsafeFreezeByteArray)

parseStreamST :: ByteStream s -> Parser a -> ST s (Result s a)
parseStreamST stream (Parser f) = ST $ \s0 ->
  case f (# | (# (# unboxByteArray emptyByteArray, 0#, 0# #), stream #) #) s0 of
    (# s1, r #) -> (# s1, boxResult r #)

boxResult :: Result# s a -> Result s a
boxResult (# leftovers, val #) = case val of
  (# (# #) | #) -> Result (boxLeftovers leftovers) Nothing
  (# | a #) -> Result (boxLeftovers leftovers) (Just a)

boxLeftovers :: Maybe# (Leftovers# s) -> Maybe (Leftovers s)
boxLeftovers (# (# #) | #) = Nothing
boxLeftovers (# | (# theBytes, stream #) #) = Just (Leftovers (boxBytes theBytes) stream)

instance Functor Parser where
  fmap = mapParser

-- Remember to write liftA2 by hand at some point.
instance Applicative Parser where
  pure = pureParser
  (<*>) = Control.Monad.ap

instance Monad Parser where
  return = pure
  (>>=) = bindLifted

newtype Parser a = Parser
  { getParser :: forall s.
       Maybe# (Leftovers# s)
    -> State# s
    -> (# State# s, Result# s a #)
  }

nextNonEmpty :: ByteStream s -> State# s -> (# State# s, Maybe# (Leftovers# s) #)
nextNonEmpty (ByteStream f) s0 = case f s0 of
  (# s1, r #) -> case r of
    (# (# #) | #) -> (# s1, (# (# #) | #) #)
    (# | (# theBytes@(# _,_,len #), stream #) #) -> case len of
      0# -> nextNonEmpty stream s1
      _ -> (# s1, (# | (# theBytes, stream #) #) #)

withNonEmpty :: forall s b.
     Maybe# (Leftovers# s)
  -> State# s
  -> (State# s -> (# State# s, Result# s b #))
  -> (Word# -> Bytes# -> ByteStream s -> State# s -> (# State# s, Result# s b #))
     -- The first argument is a Word8, not a full machine word.
     -- The second argument is the complete,non-empty chunk
     -- with the head byte still intact.
  -> (# State# s, Result# s b #)
withNonEmpty (# (# #) | #) s0 g _ = g s0
withNonEmpty (# | (# bytes0@(# arr0,off0,len0 #), stream0 #) #) s0 g f = case len0 ># 0# of
  1# -> f (indexWord8Array# arr0 off0) bytes0 stream0 s0
  _ -> case nextNonEmpty stream0 s0 of
    (# s1, r #) -> case r of
      (# (# #) | #) -> g s1
      (# | (# bytes1@(# arr1, off1, _ #), stream1 #) #) ->
        f (indexWord8Array# arr1 off1) bytes1 stream1 s1

-- | Consume the next byte from the input.
any :: Parser Word8
any = Parser go where
  go :: Maybe# (Leftovers# s) -> State# s -> (# State# s, Result# s Word8 #)
  go m s0 = withNonEmpty m s0
    (\s -> (# s, (# (# (# #) | #), (# (# #) | #) #) #))
    (\theByte theBytes stream s ->
      (# s, (# (# | (# unsafeDrop# 1# theBytes, stream #) #), (# | W8# theByte #) #) #)
    )

-- TODO: improve this
mapParser :: (a -> b) -> Parser a -> Parser b
mapParser f p = bindLifted p (pureParser . f)

pureParser :: a -> Parser a
pureParser a = Parser $ \leftovers0 s0 ->
  (# s0, (# leftovers0, (# | a #) #) #)

bindLifted :: Parser a -> (a -> Parser b) -> Parser b
bindLifted (Parser f) g = Parser $ \leftovers0 s0 -> case f leftovers0 s0 of
  (# s1, (# leftovers1, val #) #) -> case val of
    (# (# #) | #) -> (# s1, (# leftovers1, (# (# #) | #) #) #)
    (# | x #) -> case g x of
      Parser k -> k leftovers1 s1

-- This assumes that the Bytes is longer than the index. It also does
-- not eliminate zero-length references to byte arrays.
unsafeDrop# :: Int# -> Bytes# -> Bytes#
unsafeDrop# i (# arr, off, len #) = (# arr, off +# i, len -# i #)

unboxByteArray :: ByteArray -> ByteArray#
unboxByteArray (ByteArray arr) = arr

boxBytes :: Bytes# -> Bytes
boxBytes (# a, b, c #) = Bytes (ByteArray a) (I# b) (I# c)

failure :: Parser a
failure = Parser (\m s -> (# s, (# m, (# (# #) | #) #) #))


{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE UnboxedTuples #-}
{-# LANGUAGE UnboxedSums #-}

{-# OPTIONS_GHC -O2 #-}

module Packed.Bytes.Stream.ST
  ( ByteStream(..)
  , empty
  , unpack
  , fromBytes
  ) where

import Data.Primitive (Array,ByteArray(..))
import Data.Semigroup (Semigroup)
import Data.Word (Word8)
import GHC.Exts (RealWorld,State#,Int#,ByteArray#)
import GHC.Int (Int(I#))
import GHC.ST (ST(..))
import Packed.Bytes (Bytes(..))
import System.IO (Handle)
import qualified Data.Primitive as PM
import qualified Data.Semigroup as SG
import qualified Packed.Bytes as B

type Bytes# = (# ByteArray#, Int#, Int# #)

newtype ByteStream s = ByteStream
  (State# s -> (# State# s, (# (# #) | (# Bytes# , ByteStream s #) #) #) )

fromBytes :: Bytes -> ByteStream s
fromBytes b = ByteStream
  (\s0 -> (# s0, (# | (# unboxBytes b, empty #) #) #))

nextChunk :: ByteStream s -> ST s (Maybe (Bytes,ByteStream s))
nextChunk (ByteStream f) = ST $ \s0 -> case f s0 of
  (# s1, r #) -> case r of
    (# (# #) | #) -> (# s1, Nothing #)
    (# | (# theBytes, theStream #) #) -> (# s1, Just (boxBytes theBytes, theStream) #)

empty :: ByteStream s
empty = ByteStream (\s -> (# s, (# (# #) | #) #) )

boxBytes :: Bytes# -> Bytes
boxBytes (# a, b, c #) = Bytes (ByteArray a) (I# b) (I# c)

unboxBytes :: Bytes -> Bytes#
unboxBytes (Bytes (ByteArray a) (I# b) (I# c)) = (# a,b,c #)

unpack :: ByteStream s -> ST s [Word8]
unpack stream = ST (unpackInternal stream)

unpackInternal :: ByteStream s -> State# s -> (# State# s, [Word8] #)
unpackInternal (ByteStream f) s0 = case f s0 of
  (# s1, r #) -> case r of
    (# (# #) | #) -> (# s1, [] #)
    (# | (# bytes, stream #) #) -> case unpackInternal stream s1 of
      (# s2, ws #) -> (# s2, B.unpack (boxBytes bytes) ++ ws #)


import qualified Parser as Parser

main :: IO ()
main = print (iterate Parser.byteParserBadOnce 5 !! 100000)


{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE BinaryLiterals #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeInType #-}
{-# LANGUAGE UnboxedSums #-}
{-# LANGUAGE UnboxedTuples #-}

{-# OPTIONS_GHC -Wall #-}

module Parser
  ( byteParserBadOnce
  ) where

import Control.Monad.ST (runST)
import Data.Word (Word8)
import Packed.Bytes (Bytes)
import Packed.Bytes.Parser (Parser)
import Packed.Bytes.Stream.ST (ByteStream)
import qualified Data.Char
import qualified Packed.Bytes as B
import qualified Packed.Bytes.Parser as P
import qualified Packed.Bytes.Stream.ST as Stream

-- from common directory
import qualified Data.Trie.Naive as Naive

snmptrapdNaive :: Naive.Trie (Parser Word)
snmptrapdNaive = Naive.fromStringList
  [ ("STRING: ", P.any >>= \_ -> return 5)
  ]

runExampleParser :: Parser a -> (forall s. ByteStream s) -> (Maybe a, Maybe String)
runExampleParser parser stream = runST $ do
  P.Result mleftovers r <- P.parseStreamST stream parser
  mextra <- case mleftovers of
    Nothing -> return Nothing
    Just (P.Leftovers chunk remainingStream) -> do
      bs <- Stream.unpack remainingStream
      return (Just (map word8ToChar (B.unpack chunk ++ bs)))
  return (r,mextra)

byteParserBadOnce :: Int -> Int
byteParserBadOnce x = do
  let sample = ("STRING: _6_ " ++ show x)
      stream = Stream.fromBytes (s2b sample)
      expected = 6
      (r,mextra) = runExampleParser (Naive.parser snmptrapdNaive) stream
      a1 = if Nothing == mextra then 1 else 0
      a2 = if Just expected == r then 1 else 0
   in a1 + (a2 + x)

s2b :: String -> Bytes
s2b = B.pack . map charToWord8

charToWord8 :: Char -> Word8
charToWord8 = fromIntegral . Data.Char.ord

word8ToChar :: Word8 -> Char
word8ToChar = Data.Char.chr . fromIntegral


module Arithmetic where

import Control.Concurrent
import Control.Concurrent.MVar
import System.IO.Unsafe
import Utilities
import Converter
import Stream
import Data.Ratio
import Trit

-- Negate a stream of Gray code
negateGray :: Gray -> Gray
negateGray = fl

-- Multiply a Gray code stream by 2
-- The stream must represent a real number in (-1/2, 1/2) only
mul2 :: Gray -> Gray
mul2 (x:1:xs) = (x:fl xs)

-- Division by 2, the result is to be in (-1/2, 1/2)
div2 :: Gray -> Gray
div2 (x:xs) = x:1:(fl xs)

-- Addition by 1, the input must be in (-1,0)
plusOne :: Gray -> Gray
plusOne (0:xs) = 1:fl xs

-- Substraction by 1, the input must be in (0,1)
minusOne :: Gray -> Gray
minusOne (1:xs) = 0:fl xs

threadTesting :: Gray -> Gray -> IO Int
threadTesting xs ys = do
                    m <- newEmptyMVar
                    c1 <- forkIO (t1 m xs ys)
                    c2 <- forkIO (t2 m xs ys)
                    c3 <- forkIO (t3 m xs ys)
                    c4 <- forkIO (t4 m xs ys)
                    c5 <- forkIO (t5 m xs ys)
                    c6 <- forkIO (t6 m xs ys)
                    c <- takeMVar m
                    killThread c1
                    killThread c2
                    killThread c3
                    killThread c4
                    killThread c5
                    killThread c6
                    return c

addition :: Gray -> Gray -> IO Gray
addition xs ys = do
                                        c <- threadTesting xs ys
                                        case c of
                                           1 -> do
                                                   let tx = tail xs
                                                   let ty = tail ys
                                                   t <- unsafeInterleaveIO (addition  tx ty)
                                                   return (0:t)
                                           2 ->  do
                                                   let tx = tail xs
                                                   let ty = tail ys
                                                   t <- unsafeInterleaveIO (addition tx ty)
                                                   return (1:t)
                                           3 ->  do
                                                   let tx = tail xs
                                                   let ty = tail ys
                                                   cs <- unsafeInterleaveIO (addition tx (fl ty))
                                                   let c1 = cs !! 0
                                                   let c2 = tail cs
                                                   return (c1:1:fl c2)
                                           4 ->  do
                                                   let tx = tail xs
                                                   let ty = tail ys
                                                   (cs) <- unsafeInterleaveIO (addition (fl tx) ty)
                                                   let c1 = cs !! 0
                                                   let c2 = tail cs
                                                   return (c1:1:(fl c2))
                                           5 ->  do
                                                   let x1 = xs!!0
                                                   let y1 = ys!!0
                                                   let tx = (drop 2) xs
                                                   let ty = (drop 2) ys
                                                   cs <- unsafeInterleaveIO (addition (x1:(fl tx)) (y1:(fl ty)))
                                                   let c1 = cs !! 0
                                                   let c2 = tail cs
                                                   return (c1:(1:(fl c2)))
                                           6 ->  do
                                                   let x1 = xs !! 0
                                                   let tx = drop 3 xs
                                                   let ty = drop 2 ys
                                                   t <- unsafeInterleaveIO (addition (x1:1:tx) (1:fl ty))
                                                   return (0:t)
                                           7 ->  do
                                                   let x1 = xs !! 0
                                                   let tx = drop 3 xs
                                                   let ty = drop 2 ys
                                                   t <- unsafeInterleaveIO (addition (fl (x1:1:tx)) (1:(fl ty)))
                                                   return (1:t)
                                           8 ->  do
                                                   let x1 = xs !! 0
                                                   let y2 = ys !! 1
                                                   let tx = drop 3 xs
                                                   let ty = drop 3 ys
                                                   t <- unsafeInterleaveIO (addition (fl (x1:fl tx)) (fl (y2:fl ty)))
                                                   return (0:1:t)
                                           9 ->  do
                                                   let x1 = xs !! 0
                                                   let y2 = ys !! 1
                                                   let tx = drop 3 xs
                                                   let ty = drop 3 ys
                                                   t <- unsafeInterleaveIO (addition (x1:fl tx) (fl (y2:fl ty)))
                                                   return (1:1:t)
                                           10 ->  do
                                                   let y1 = ys !! 0
                                                   let ty = drop 3 ys
                                                   let tx = drop 2 xs
                                                   t <- unsafeInterleaveIO (addition (1:fl tx) (y1:1:ty))
                                                   return (0:t)
                                           11 ->  do
                                                   let y1 = ys !! 0
                                                   let ty = drop 3 ys
                                                   let tx = drop 2 xs
                                                   t <- unsafeInterleaveIO (addition (1:fl tx) (fl (y1:1:ty)))
                                                   return (1:t)
                                           12 ->  do
                                                   let y1 = ys !! 0
                                                   let x2 = xs !! 1
                                                   let tx = drop 3 xs
                                                   let ty = drop 3 ys
                                                   t <- unsafeInterleaveIO (addition (fl (x2:fl tx)) (fl (y1:fl ty)))
                                                   return (0:1:t)
                                           13 ->  do
                                                   let y1 = ys !! 0
                                                   let x2 = xs !! 1
                                                   let tx = drop 3 xs
                                                   let ty = drop 3 ys
                                                   t <- unsafeInterleaveIO (addition (fl (x2:fl tx)) (y1:fl ty))
                                                   return (1:1:t)

-- Compute (a-b)/2
substraction :: Gray -> Gray -> IO Gray
substraction xs ys = addition xs (negateGray ys)

t1 :: MVar Int -> Stream -> Stream -> IO()
t1 m (0:as) (0:bs) = putMVar m 1
t1 m (1:as) (1:bs) = putMVar m 2
t1 m (0:as) (1:bs) = putMVar m 3
t1 m (1:as) (0:bs) = putMVar m 4

t2 :: MVar Int -> Stream -> Stream -> IO()
t2 m (a:1:x) (b:1:y) = putMVar m 5
t2 m x y = yield

t3 m (a:1:0:x) (0:0:y) = putMVar m 6
t3 m (a:1:0:x) (1:0:y) = putMVar m 7
t3 m x y = yield

t4 m (a:1:0:x) (0:b:1:y) = putMVar m 8
t4 m (a:1:0:x) (1:b:1:y) = putMVar m 9
t4 m x y = yield

t5 m (0:0:x) (b:1:0:y) = putMVar m 10
t5 m (1:0:x) (b:1:0:y) = putMVar m 11
t5 m x y = yield

t6 m (0:a:1:x) (b:1:0:y) = putMVar m 12
t6 m (1:a:1:x) (b:1:0:y) = putMVar m 13
t6 m x y = yield

multiplyIO :: Gray -> Gray -> IO Gray
multiplyIO xs ys = do
                    s1 <- unsafeInterleaveIO (grayToSignIO xs)
                    s2 <- unsafeInterleaveIO (grayToSignIO ys)
                    let s = Trit.multiply s1 s2
                    let g = signToGray s
                    return g

start :: IO()
start = do
           c <- unsafeInterleaveIO(multiplyIO z1 z1)
           putStrLn (show c)

startA :: IO()
startA = do
           c <- unsafeInterleaveIO(addition (1:1:z0) (1:1:z0))
           putStrLn (show (take 30 c))

z0 = (0:z0)
z1 = (1:z1)

zl = 0:loop:z0

loop = loop
loop01 = 0:1:loop01


module Converter (rationalToGray, grayToSignIO, signToGray, Gray, startF, startC) where

import Stream
import Data.Ratio
import Control.Concurrent
import Control.Concurrent.MVar
import System.IO.Unsafe

type Gray = [Integer]
type State = (Integer, Integer)

-- Convert a rational number (in (-1,1)) to its Gray representation
rationalToGray :: Rational -> Gray
rationalToGray x
                |x<0            = f (negate' (rationalToStream (-x))) (0,0)
                |otherwise      = f (rationalToStream x) (0,0)

-- Function to implement the two heads Turing machine that convert a
-- signed-digit stream to the corresponding Gray-code representation
f :: Stream -> State -> Stream
f (x:xs) (0,0)
            |x==(-1)    = 0:f xs (0,0)
            |x==0       = c:1:ds
            |x==1       = 1:f xs (1,0)
            where c:ds = f xs (0,1)

f (x:xs) (0,1)
            |x==(-1)    = 0:f xs (1,0)
            |x==0       = c:0:ds
            |x==1       = 1:f xs (0,0)
            where c:ds = f xs (0,1)

f (x:xs) (1,0)
            |x==(-1)    = 1:f xs (0,0)
            |x==0       = c:1:ds
            |x==1       = 0:f xs (1,0)
            where c:ds = f xs (1,1)

f (x:xs) (1,1)
            |x==(-1)    = 1:f xs (1,0)
            |x==0       = c:0:ds
            |x==1       = 0:f xs (0,0)
            where c:ds = f xs (1,1)

-- Anotherway to convert from a rational to Gray code representation
-- Behave exactly the same like above
rationalToGray' :: Rational -> Gray
rationalToGray' x
                |x<0            = signToGray (negate' (rationalToStream (-x)))
                |otherwise      = signToGray (rationalToStream x)

-- Function to convert a signed-digit stream to Gray representation
-- Is much shorter than above
signToGray :: Stream -> Stream
signToGray (1:xs)       = 1:f'(signToGray xs)
signToGray ((-1):xs)    = 0:signToGray xs
signToGray (0:xs)       = c:1:(f' ds)
                        where c:ds = signToGray xs

-- Convert a Gray-code stream to the corresponding signed-digit representation
-- Make use of threads
grayToSignIO :: Stream -> IO Stream
grayToSignIO (x1:x2:xs) = do
                        c <- threadTesting(x1:x2:xs)
                        if (c==1)
                           then (do  co <- unsafeInterleaveIO (grayToSignIO (f'(x2:xs)))
                                     return (1:co))
                           else if (c==2)
                                   then (do co <- unsafeInterleaveIO (grayToSignIO (x2:xs))
                                            return ((-1):co))
                                   else (do co <- unsafeInterleaveIO (grayToSignIO (x1:f' xs))
                                            return (0:co))

-- Flip the first bit of an infinite stream
f' (x:xs) = (f'' x):xs
            where f'' 1 = 0
                  f'' 0 = 1

-- Launch two threads which run concurrently, test for the first digit of the stream (1, 0 or bottom)
-- As soon as one thread terminate, grab that result and proceed
threadTesting :: Stream -> IO Int
threadTesting xs = do   m <- newEmptyMVar
                        c1 <- forkIO (f1 m xs)
                        c2 <- forkIO (f2 m xs)
                        c <- takeMVar m
                        killThread c1
                        killThread c2
                        return c

-- Test case 1, when the first bit is either 1 or 0.
-- In case of bottom, f1 will never terminate, then f2 will definitely terminate
f1 :: MVar Int -> Stream -> IO()
f1 m (0:xs) = putMVar m 2
f1 m (1:xs) = putMVar m 1

-- Test case 2, when the first bit is completely ignored, esp in case it was a bottom
-- If the second bit is 1, then we can output, don't care value of the first bit
-- If the second bit is 0, then loop forever, give chances to f1 to terminate
f2 :: MVar Int -> Stream -> IO()
f2 m (c1:c2:xs)
                |c2==1          = putMVar m 3
                |otherwise      = yield

-- Testing
startC :: IO()
startC = do
            c<- unsafeInterleaveIO (grayToSignIO (1:1:z0))
            putStrLn (show (take 100 c))

startF = signToGray ((-1):1:z0)

z0 = 0:z0
loop' = loop'
z1' = (1:z1')


module Main where

import Arithmetic
import Trit
import Converter
import System.IO.Unsafe
import Data.Ratio
import Utilities
import Thread

main = startM1

startM1 :: IO()
startM1 = do
          c <- unsafeInterleaveIO (mult (rationalToGray (1%3)) (rationalToGray (0%1)))
          putStrLn (show  (take 100 (drop 1 c)))

mult :: Gray -> Gray -> IO Gray
mult xs ys = do
                                        c <- threadTesting1 xs ys
                                        case c of

                                           101 -> do
                                                   --putStrLn ("In case 101")
                                                   let tx = drop 2 xs
                                                   let ty = drop 2 ys
                                                   t1 <- unsafeInterleaveIO (addition tx ty)
                                                   t2 <- unsafeInterleaveIO (addition (fl t1) (1:t1))
                                                   t3 <- unsafeInterleaveIO (mult tx ty)
                                                   c' <- unsafeInterleaveIO (addition t2 (1:0:0:(fl t3)))
                                                   return c'

                                           102 -> do
                                                   --putStrLn ("In case 102")
                                                   let tx = drop 2 xs
                                                   let ty = drop 2 ys
                                                   t1 <- unsafeInterleaveIO (addition (fl tx) ty)
                                                   t2 <- unsafeInterleaveIO (addition tx ty)
                                                   t0 <- unsafeInterleaveIO (addition t1 (1:fl t2))
                                                   t3 <- unsafeInterleaveIO (mult tx ty)
                                                   c' <- unsafeInterleaveIO (addition t0 (1:1:0:fl t3))
                                                   return c'

                                           103 -> do
                                                   --putStrLn ("In case 103")
                                                   let tx = drop 2 xs
                                                   let ty = drop 2 ys
                                                   t <- unsafeInterleaveIO (mult (0:0:tx) (0:0:ty))
                                                   return (fl t)

                                           104 -> do
                                                   --putStrLn ("In case 104")
                                                   let tx = drop 2 xs
                                                   let ty = drop 2 ys
                                                   t <- unsafeInterleaveIO (mult (0:0:tx) (0:1:ty))
                                                   return (fl t)

                                           201 -> do
                                                   c' <- unsafeInterleaveIO (mult ys xs)
                                                   return c'

                                           202 -> do
                                                   --putStrLn ("In case 202")
                                                   let tx = drop 2 xs
                                                   let ty = drop 2 ys
                                                   t1 <- unsafeInterleaveIO (addition tx ty)
                                                   t2 <- unsafeInterleaveIO (addition t1 (0:fl t1))
                                                   t3 <- unsafeInterleaveIO (mult tx ty)
                                                   c' <- unsafeInterleaveIO (addition t2 (1:1:1:fl t3))
                                                   return c'

                                           203 -> do
                                                   --putStrLn ("In case 203")
                                                   let tx = drop 2 xs
                                                   let ty = drop 2 ys
                                                   t <- unsafeInterleaveIO (mult (0:1:tx) (0:0:ty))
                                                   return (fl t)

                                           204 -> do
                                                   --putStrLn ("In case 204")
                                                   let tx = drop 2 xs
                                                   let ty = drop 2 ys
                                                   t <- unsafeInterleaveIO (mult (0:1:tx) (0:1:ty))
                                                   return (fl t)

                                           30 ->  do
                                                   --putStrLn ("In case 30")
                                                   let y1 = ys !! 0
                                                   let tx = drop 2 xs
                                                   let ty = drop 3 ys
                                                   t1 <- unsafeInterleaveIO (addition ((f0' y1):1:ty) ((f0' y1):1:0:ty))
                                                   t0 <- unsafeInterleaveIO (mult tx (y1: fl ty))
                                                   let c4 = head t0
                                                   let d4 = fl (tail t0)
                                                   c' <- unsafeInterleaveIO (addition t1 (c4:1:0:0:d4))
                                                   return c'

                                           31 -> do
                                                  --putStrLn ("In case 31")
                                                  let tx = drop 2 xs
                                                  c' <- unsafeInterleaveIO (mult (0:0:tx) ys)
                                                  return (fl c')

                                           40 ->  do
                                                   --putStrLn ("In case 40")
                                                   let tx = drop 2 xs
                                                   let y2 = ys !! 1
                                                   let ty = drop 3 ys
                                                   t1 <- unsafeInterleaveIO (addition (y2:fl ty) tx)
                                                   t2 <- unsafeInterleaveIO (addition (fl t1) (1:y2:1:ty))
                                                   t0 <- unsafeInterleaveIO (mult tx (y2:fl ty))
                                                   let c2 = f0' (head t0)
                                                   let d2 = fl (tail t0)
                                                   c' <- unsafeInterleaveIO (addition t2 (1:c2:1:0:d2))
                                                   return c'

                                           41 ->  do
                                                   --putStrLn ("In case 41")
                                                   let tx = drop 2 xs
                                                   let y2 = ys !! 1
                                                   let ty = drop 3 ys
                                                   c' <- unsafeInterleaveIO (mult (0:0:tx) (0:y2:1:ty))
                                                   return (fl c')

                                           50 ->  do
                                                   --putStrLn ("In case 50")
                                                   let tx = drop 2 xs
                                                   let y2 = ys !! 1
                                                   let ty = drop 3 ys
                                                   t1 <- unsafeInterleaveIO (addition tx (fl (y2:fl ty)))
                                                   t2 <- unsafeInterleaveIO (addition t1 (0:y2:1:ty))
                                                   t0 <- unsafeInterleaveIO (mult (fl tx) (y2:fl ty))
                                                   let c1 = f0' (head t0)
                                                   let d1 = fl (tail t0)
                                                   c' <- unsafeInterleaveIO (addition t2 (1:c1:1:0:d1))
                                                   return c'

                                           51 ->  do
                                                   --putStrLn ("In case 51")
                                                   let tx = drop 2 xs
                                                   let y2 = ys !! 1
                                                   let ty = drop 3 ys
                                                   c' <- unsafeInterleaveIO (mult (0:1:tx) (0:y2:1:ty))
                                                   return (fl c')

                                           60 ->  do
                                                   --putStrLn ("In case 60")
                                                   let tx = drop 2 xs
                                                   let y1 = ys !! 0
                                                   let ty = drop 3 ys
                                                   t1 <- unsafeInterleaveIO (addition ((f0' y1):1:ty) (y1:1:0:ty))
                                                   t0 <- unsafeInterleaveIO (mult (fl tx) (y1:fl ty))
                                                   let c1 = head t0
                                                   let d1 = fl (tail t0)
                                                   c' <- unsafeInterleaveIO (addition t1 (c1:1:0:0:d1))
                                                   return c'

                                           61 ->  do
                                                   --putStrLn ("In case 61")
                                                   let tx = drop 2 xs
                                                   let y1 = ys !! 0
                                                   let ty = drop 3 ys
                                                   c' <- unsafeInterleaveIO (mult (0:1:tx) (y1:1:0:ty))
                                                   return (fl c')

                                           70 ->  do
                                                   --putStrLn ("In case 70")
                                                   c' <- unsafeInterleaveIO (mult ys xs)
                                                   return c'

                                           80 ->  do
                                                   --putStrLn ("In case 80")
                                                   let x2 = xs !! 1
                                                   let y2 = ys !! 1
                                                   let tx = drop 3 xs
                                                   let ty = drop 3 ys
                                                   t1 <- unsafeInterleaveIO (addition (x2:fl tx) (y2:fl ty))
                                                   t0 <- unsafeInterleaveIO (mult (x2:fl tx) (y2:fl ty))
                                                   let c1 = head (fl t1)
                                                   let d1 = tail (fl t1)
                                                   let c2 = f0' (head t0)
                                                   let d2 = fl (tail t0)
                                                   c' <- unsafeInterleaveIO (addition (c1:1:(fl d1)) (1:c2:1:0:d2))
                                                   return c'

                                           81 ->  do
                                                   --putStrLn ("In case 81")
                                                   let x2 = xs !! 1
                                                   let y2 = ys !! 1
                                                   let tx = drop 3 xs
                                                   let ty = drop 3 ys
                                                   c' <- unsafeInterleaveIO (mult (0:x2:1:tx) (0:y2:1:ty))
                                                   return (fl c')

                                           90 ->  do
                                                   --putStrLn ("In case 90")
                                                   let x2 = xs!!1
                                                   let y1 = ys!!0
                                                   let tx = drop 3 xs
                                                   let ty = drop 3 ys
                                                   t0 <- unsafeInterleaveIO (mult (x2:fl tx) (y1:fl ty))
                                                   let c1 = head t0
                                                   let d1 = fl (tail t0)
                                                   c' <- unsafeInterleaveIO (addition ((f0' y1):1:0:ty) (c1:1:0:0:d1))
                                                   return c'

                                           91 ->  do
                                                   --putStrLn ("In case 91")
                                                   let x2 = xs!!1
                                                   let y1 = ys!!0
                                                   let tx = drop 3 xs
                                                   let ty = drop 3 ys
                                                   c' <- unsafeInterleaveIO (mult (0:x2:1:tx) (y1:1:0:ty))
                                                   return (fl c')

                                           100 -> do
                                                  --putStrLn ("In case 100")
                                                  let x1 = head xs
                                                  let y1 = head ys
                                                  let tx = drop 3 xs
                                                  let ty = drop 3 ys
                                                  t0 <- unsafeInterleaveIO (mult (x1:fl tx) (y1:fl ty))
                                                  let c4 = head t0
                                                  let d4 = fl (tail t0)
                                                  return (c4:1:0:0:0:d4)

f0' 0 = 1
f0' 1 = 0


module Stream (Stream, carry, addStream, rationalToStream,
                streamToFloat, addFiniteStream, negate', average) where

import Data.Ratio

type Digit = Integer
type Stream = [Integer]

-- Convert from a Rational fraction to its stream representation
rationalToStream :: Rational -> Stream
rationalToStream x
        |t<1            = 0:rationalToStream t
        |otherwise      = 1:rationalToStream (t-1)
        where t = 2*x

-- Convert from a stream to the Float value
streamToFloat :: Stream -> Float
streamToFloat x =  f x (1)

f :: Stream -> Integer -> Float
f [] n = 0
f (y:ys) n = (fromIntegral)y/(fromIntegral(2^n)) + f ys (n+1)

-- Add two stream
addStream :: Stream -> Stream -> Stream
addStream (x1:x2:x3:xs) (y1:y2:y3:ys) = (u+c):(addStream (x2:x3:xs) (y2:y3:ys))
                                where u = interim x1 x2 y1 y2
                                      c = carry x2 x3 y2 y3

-- Compute carry, the C(i) value, given x(i) and y(i)
carry :: Digit -> Digit -> Digit -> Digit -> Digit
carry x1 x2 y1 y2
        |t>1                    =  1
        |t<(-1)                 = -1
        |t==1 && (minus1 x2 y2) =  0
        |t==1 && not (minus1 x2 y2) = 1
        |t==(-1) && (minus1 x2 y2) = -1
        |t==(-1) && not (minus1 x2 y2) = 0
        |t==0                           = 0
        where t = x1+y1

-- Computer the interim sum, the U(i) value, given x(i), y(i) and c(i)
interim :: Digit -> Digit -> Digit -> Digit -> Digit
interim x1 x2 y1 y2
                |t>1                    =  0
                |t<(-1)                 = 0
                |t==1 && (minus1 x2 y2) =  1
                |t==1 && not (minus1 x2 y2) = -1
                |t==(-1) && (minus1 x2 y2) = 1
                |t==(-1) && not (minus1 x2 y2) = -1
                |t==0                           = 0
                where t = x1+y1

-- Check if at least one of 2 digits is -1
minus1 :: Digit -> Digit -> Bool
minus1 x y = (x==(-1))|| (y==(-1))

-- Algin two stream so that they have the same length
align :: Stream -> Stream -> (Stream, Stream)
align xs ys
        |x>y            = (xs, (copy 0 (x-y)) ++ys)
        |otherwise      = ((copy 0 (y-x)) ++ xs, ys)
        where x = toInteger(length xs)
              y = toInteger(length ys)

-- Generate a list of x
copy :: Integer -> Integer -> [Integer]
copy x n = [x| i<- [1..n]]

-- Add two finite stream (to add the integral part)
addFiniteStream :: Stream -> Stream -> Stream
addFiniteStream xs ys = add' u v
                        where (u,v) = align xs ys

-- Utility function for addFinitieStream
add' :: Stream -> Stream -> Stream
add' u v = normalise (f u v)
       where f [] [] = []
             f (x:xs) (y:ys) = (x+y):f xs ys

-- Normalise the sum
normalise :: Stream -> Stream
normalise = foldr f [0]
            where f x (y:ys) = (u:v:ys)
                              where u = (x+y) `div` 2
                                    v = (x+y) `mod` 2

-- Negate a stream
negate' :: Stream -> Stream
negate' = map (*(-1))

-- Compute average of two stream
-- Using [-2,-1,0,1,2] to add, and then divide by 2
average :: Stream -> Stream -> Stream
average xs ys = div2 (add xs ys)

-- Addition of two streams, using [-2,-1,0,1,2]
add :: Stream -> Stream -> Stream
add (x:xs) (y:ys) = (x+y):(add xs ys)

-- Then divided by 2, [-2,-1,0,1,2] -> [-1,0,1]
div2 :: Stream -> Stream
div2 (2:xs)             = 1:div2 xs
div2 ((-2):xs)          = (-1):div2 xs
div2 (0:xs)             = 0:div2 xs
div2 (1:(-2):xs)        = div2 (0:0:xs)
div2 (1:(-1):xs)        = div2 (0:1:xs)
div2 (1:0:xs)           = div2 (0:2:xs)
div2 (1:1:xs)           = div2 (2:(-1):xs)
div2 (1:2:xs)           = div2 (2:0:xs)
div2 ((-1):(-2):xs)     = div2 ((-2):0:xs)
div2 ((-1):(-1):xs)     = div2 ((-2):1:xs)
div2 ((-1):0:xs)        = div2 (0:(-2):xs)
div2 ((-1):1:xs)        = div2 (0:(-1):xs)
div2 ((-1):2:xs)        = div2 (0:0:xs)

test = take 100 (average (rationalToStream (1%2)) (rationalToStream (1%3)))


module Thread (threadTesting1) where

import Control.Concurrent
import Control.Concurrent.MVar
import Stream
import Converter

threadTesting1 :: Gray -> Gray -> IO Int
threadTesting1 xs ys = do
                    m <- newEmptyMVar
                    c1 <- forkIO (t1 m xs ys)
                    c2 <- forkIO (t2 m xs ys)
                    c3 <- forkIO (t3 m xs ys)
                    c4 <- forkIO (t4 m xs ys)
                    c5 <- forkIO (t5 m xs ys)
                    c6 <- forkIO (t6 m xs ys)
                    c7 <- forkIO (t7 m xs ys)
                    c8 <- forkIO (t8 m xs ys)
                    c9 <- forkIO (t9 m xs ys)
                    c <- takeMVar m
                    killThread c1
                    killThread c2
                    killThread c3
                    killThread c4
                    killThread c5
                    killThread c6
                    killThread c7
                    killThread c8
                    killThread c9
                    return c

t1 :: MVar Int -> Stream -> Stream -> IO()
t1 m (0:0:x) (0:0:y) = putMVar m 101
t1 m (0:0:x) (0:1:y) = putMVar m 102
t1 m (0:0:x) (1:0:y) = putMVar m 103
t1 m (0:0:x) (1:1:y) = putMVar m 104

t1 m (0:1:x) (0:0:y) = putMVar m 201
t1 m (0:1:x) (0:1:y) = putMVar m 202
t1 m (0:1:x) (1:0:y) = putMVar m 203
t1 m (0:1:x) (1:1:y) = putMVar m 204

t1 m (1:0:x) (0:0:y) = putMVar m 103
t1 m (1:0:x) (0:1:y) = putMVar m 104
t1 m (1:0:x) (1:0:y) = putMVar m 101
t1 m (1:0:x) (1:1:y) = putMVar m 102

t1 m (1:1:x) (0:0:y) = putMVar m 203
t1 m (1:1:x) (0:1:y) = putMVar m 204
t1 m (1:1:x) (1:0:y) = putMVar m 201
t1 m (1:1:x) (1:1:y) = putMVar m 202

t2 :: MVar Int -> Stream -> Stream -> IO()
t2 m (0:0:x) (b:1:0:y) = putMVar m 30
t2 m (1:0:x) (b:1:0:y) = putMVar m 31
t2 m (0:1:x) (b:1:0:y) = putMVar m 60
t2 m (1:1:x) (b:1:0:y) = putMVar m 61
t2 m x y = yield

t3 m (0:0:x) (0:b:1:y) = putMVar m 40
t3 m (1:0:x) (1:b:1:y) = putMVar m 40
t3 m (0:0:x) (1:b:1:y) = putMVar m 41
t3 m (1:0:x) (0:b:1:y) = putMVar m 41

t3 m (0:1:x) (0:b:1:y) = putMVar m 50
t3 m (1:1:x) (1:b:1:y) = putMVar m 50
t3 m (0:1:x) (1:b:1:y) = putMVar m 51
t3 m (1:1:x) (0:b:1:y) = putMVar m 51
t3 m x y = yield

t4 m (0:a:1:y) (0:0:x) = putMVar m 70
t4 m (1:a:1:y) (1:0:x) = putMVar m 70
t4 m (1:a:1:y) (0:0:x) = putMVar m 70
t4 m (0:a:1:y) (1:0:x) = putMVar m 70
t4 m (0:a:1:y) (0:1:x) = putMVar m 70
t4 m (1:a:1:y) (1:1:x) = putMVar m 70
t4 m (1:a:1:y) (0:1:x) = putMVar m 70
t4 m (0:a:1:y) (1:1:x) = putMVar m 70
t4 m x y = yield

t5 m (a:1:0:y) (0:0:x) = putMVar m 70
t5 m (a:1:0:y) (1:0:x) = putMVar m 70
t5 m (a:1:0:y) (0:1:x) = putMVar m 70
t5 m (a:1:0:y) (1:1:x) = putMVar m 70
t5 m x y = yield

t6 m (0:a:1:x) (0:b:1:y) = putMVar m 80
t6 m (1:a:1:x) (1:b:1:y) = putMVar m 80
t6 m (0:a:1:x) (1:b:1:y) = putMVar m 81
t6 m (1:a:1:x) (0:b:1:y) = putMVar m 81
t6 m x y = yield

t7 m (0:a:1:x) (b:1:0:y) = putMVar m 90
t7 m (1:a:1:x) (b:1:0:y) = putMVar m 91
t7 m x y = yield

t8 m (a:1:0:x) (b:1:0:y) = putMVar m 100
t8 m x y = yield

t9 m (a:1:0:x) (0:b:1:y) = putMVar m 70
t9 m (a:1:0:x) (1:b:1:y) = putMVar m 70
t9 m x y = yield


module Trit (Trit, rationalToTrit, getIntegral, getFraction, getFraction',
                neg, addTrits, subTrits, shiftLeft, shiftRight, multiply
                ) where

import Stream
import Utilities
import Data.Ratio

type Mantissa = Stream
type Fraction = Stream
type Trit     = (Mantissa, Fraction)

-- Convert from a Rational number to its Trit representation (Integral, Fraction)
rationalToTrit :: Rational -> Trit
rationalToTrit x
                |x<1            = ([0], rationalToStream x)
                |otherwise      = (u', rationalToStream v)
                where   u = n `div` d
                        u' = toBinary u
                        v = x - (toRational u)
                        n = numerator x
                        d = denominator x

-- Get the integral part of Trit
getIntegral :: Trit -> Mantissa
getIntegral = fst

-- Get the fraction part of Trit, with n digit of the stream
getFraction :: Int -> Trit -> Stream
getFraction n = take n. snd

-- Get the fraction part of Trit
getFraction' :: Trit -> Stream
getFraction' = snd

-- Negate a Trit
neg :: Trit -> Trit
neg (a, b) = (negate' a, negate' b)

-- Add two Trits
addTrits :: Trit -> Trit -> Trit
addTrits (m1, (x1:x2:xs)) (m2, (y1:y2:ys)) = (u,addStream (x1:x2:xs) (y1:y2:ys))
                                           where u' = addFiniteStream m1 m2
                                                 c = [carry x1 x2 y1 y2]
                                                 u = addFiniteStream u' c

-- Substraction of 2 Trits
subTrits :: Trit -> Trit -> Trit
subTrits x y = addTrits x (neg y)

-- Shift left = *2 operation with Trit
shiftLeft :: Trit -> Trit
shiftLeft (x, (y:ys)) = (x++ [y], ys)

-- Shift right = /2 operation with Trit
shiftRight :: Trit -> Integer -> Trit
shiftRight (x, xs) 1 = (init x, (u:xs))
                    where u = last x
shiftRight (x, xs) n = shiftRight (init x, (u:xs)) (n-1)
                    where u = last x

-- Multiply a Trit stream by 1,0 or -1, simply return the stream
mulOneDigit :: Integer -> Stream -> Stream
mulOneDigit x xs
              |x==1      = xs
              |x==0      = zero'
              |otherwise = negate' xs
              where zero' = (0:zero')

-- Multiplication of two streams
multiply :: Stream -> Stream -> Stream
multiply (a0:a1:x) (b0:b1:y) = average p q
                               where p = average (a1*b0: (average (mulOneDigit b1 x)
                                                                 (mulOneDigit a1 y)))
                                                 (average (mulOneDigit b0 x)
                                                          (mulOneDigit a0 y))
                                     q = (a0*b0:a0*b1:a1*b1:(multiply x y))

start0 = take 30 (multiply (rationalToStream (1%2)) zo)

zo :: Stream
zo = 1:(-1):zero
     where zero = 0:zero

start1 = take 30 (average (rationalToStream (1%2)) (negate' (rationalToStream (1%4))))


module Utilities (toBinary, fl) where

import Stream
import Data.Ratio

-- Convert from an Integer to its signed-digit representation
toBinary :: Integer -> Stream
toBinary 0 = [0]
toBinary x = toBinary t ++ [x `mod` 2]
             where t = x `div` 2

fl :: Stream -> Stream
fl (x:xs) = (f x):xs
          where f 0 = 1
                f 1 = 0


module Event
where

data SysReq = SysReq

data SysRsp = SysRsp


module Scheduler
( runTIO
, module Event
, module Thread
, TTree
, TIO
)
where

import Event
import Thread
import Control.Concurrent
import System.IO

--------------------------------
type TTree = ThreadTree SysReq SysRsp IO
type TIO   = ContM SysReq SysRsp IO

runTIO :: [TIO ()] -> IO ()
runTIO l = runThreads $ map buildThread l

data World = World
    { mReadyQ :: ! (Chan (TTree))  }

max_steps = 1
worker_pure world=
  do
      t <- readChan readyq
      case t of
        (Atom _) -> return ()
        _ -> return ()
      exec_thread max_steps t
      return ()
 where
 readyq = mReadyQ world

 exec_thread 0 t =
  do putStr "."; hFlush stdout
     writeChan readyq t
 exec_thread c (Atom mx) =
     do
        x <- mx
        exec_thread (c-1) x
 exec_thread c (Stop) = return ()

runThreads :: [TTree] -> IO ()
runThreads l =
  do
     mready <- newChan
     writeList2Chan mready l
     let world = World mready
     multiloop world

loop_p world = do worker_pure world; loop_p world

multiloop world =
  do
        -- a mixture of bound threads & lightweight threads
        -- to make things interesting...
     forkOS (loop_p world)
     forkOS (loop_p world)
     forkOS (loop_p world)
     forkOS (loop_p world)
     forkOS (loop_p world)
     forkOS (loop_p world)
     forkIO (loop_p world)
     forkIO (loop_p world)
     forkIO (loop_p world)
     forkIO (loop_p world)
     forkIO (loop_p world)
     forkIO (loop_p world)
     forkIO (loop_p world)
     loop_p world


import Scheduler
import Foreign
import Foreign.C
import System.Random
import Control.Concurrent

expensive = f (500 :: Int)
  where f 0 = stop
        f n = do
              r <- atom $ getStdRandom (randomR (0,99::Int))
              r `seq` f $! n-1

main = do
  m <- newEmptyMVar
  forkIO (do
          runTIO $ map (\x->expensive) [1..500]
          putMVar m ())
  takeMVar m


module Thread
( ThreadTree (..)
, ContM (..)
, atom
, stop
, buildThread
)
where

----------------------------------
data ThreadTree req rsp m =
        Atom (m (ThreadTree req rsp m))
      | Stop
----------------------------------
newtype ContM req rsp m a = ContM ((a-> ThreadTree req rsp m)-> ThreadTree req rsp m)

instance Functor (ContM req rsp m) where
   fmap = undefined

instance Applicative (ContM req rsp m) where
   pure  = undefined
   (<*>) = undefined

instance Monad m => Monad (ContM req rsp m) where
   m >>= f = contmBind m f
   return  = contmReturn

contmBind :: (ContM req rsp m a) -> (a -> (ContM req rsp m b)) -> (ContM req rsp m b)
contmBind (ContM x) f =
    ContM(\y-> x (\z-> let ContM f' = f z in f' y))
contmReturn :: a -> (ContM req rsp m a)
contmReturn x = ContM(\c -> c x)

{-- how to build primitive ContM blocks... --}

atom :: Monad m => (m a) -> (ContM req rsp m a)
atom mx = ContM( \c -> Atom( do x <- mx; return (c x) ))

stop :: (ContM req rsp m a)
stop = ContM( \c -> Stop )

buildThread :: (ContM req rsp m a) -> ThreadTree req rsp m
buildThread (ContM f) = f (\c->Stop)

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


> module BackList2 where

> import Data.IORef
> import Control.Concurrent
> --import Control.Concurrent.STM

> import RefInterface

> data List r a = Node { val :: a, next :: (r (List r a)) }
>               | Head { next :: r (List r a) }
>               | DelNode (r (List r a))                  -- backpointer
>               | Null

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

  abbreviations

> newAtomic x = atomicRef (newRef x)

> readAtomic x = atomicRef (readRef x)

> writeAtomic ptr x = atomicRef (writeRef ptr x)

> -- we create a new list
> newList :: Ref r m => IO (ListHandle r a)
> newList =
>   do null <- newAtomic Null
>      hd <- newAtomic (Head {next = null })
>      hdPtr <- newAtomic hd
>      tailPtr <- newAtomic null
>      return (ListHandle {headList = hdPtr, tailList = tailPtr})

> find :: (Eq a, Ref r m) => ListHandle r a -> a -> IO Bool
> find (ListHandle {headList = ptrPtr})  i =
>   do startPtr <- atomicRef (readRef ptrPtr)
>      find2 startPtr i

NOTE: I thought we can catch the 'head' case here,
      so we don't need to check for 'head' in findNode,
      but this leads to a non-exhaustive pattern failure

> {-
>  do startptr <- atomically (
>          do ptr <- readTVar ptrPtr
>             Head {next = startptr} <- readTVar ptr
>             return startptr)
>     find2 startptr i
> -}

> find2 :: (Eq a, Ref r m) => r (List r a) -> a -> IO Bool
> find2 curNodePtr i =
>     do
>     { comp <- atomicRef (findNode curNodePtr i)
>     ; comp }

We atomically check for lhs and guards

f1 @ node(X,P,Next) \ find(X,P,R) <=> R=tt..
f2 @ nil(P) \ find(Y,P,R) <=> R=ff.
f3 @ node(X,P,Next) \ find(Y,P,R) <=> X /= Y | find(Y,Next,R).
f4 @ nodeDel(P,Q) \ find(X,P,R) <=> find(X,Q,R).

> findNode :: (Eq a, Ref r m) => r (List r a) -> a -> m (IO Bool)
> findNode curNodePtr x = do
>   { curNode <- readRef curNodePtr
>   ; case curNode of
>       Node {val = y, next = q} ->
>         if (y == x) then return (return True) -- f1
>         else return (find2 q x) -- f3
>       Null -> return (return False)    -- f2
>       Head p-> return (find2 p x)  --error "findNode: impossible"
>       DelNode p -> return (find2 p x)  -- f4
>  }

> -- we add a new node, by overwriting the null tail node
> -- we only need to adjust tailList but not headList because
> -- of the static Head
> -- we return the location of the newly added node
> addToTail :: Ref r m => ListHandle r a -> a -> IO (r (List r a))
> addToTail (ListHandle {tailList = tailPtrPtr}) x =
>   do tPtr <- atomicRef (
>                do null <- newRef Null
>                   tailPtr <- readRef tailPtrPtr
>                   writeRef tailPtr (Node {val = x, next = null})
>                   writeRef tailPtrPtr null
>                   return tailPtr
>              )
>      return tPtr

> delete :: (Eq a, Ref r m) => ListHandle r a -> a -> IO Bool
> delete (ListHandle {headList = ptrPtr})  i =
>  do prevPtr <- atomicRef (readRef ptrPtr)
>     delete2 prevPtr i

> delete2 :: (Eq a, Ref r m) => r (List r a) -> a -> IO Bool
> delete2 prevPtr i =
>     do
>     { comp <- atomicRef (deleteNode prevPtr i)
>     ; comp }

> deleteNode :: (Eq a,Ref r m) => r (List r a) -> a -> m (IO Bool)
> deleteNode prevPtr x =
>     do
>    { prevNode <- readRef prevPtr
>    ; case prevNode of
>        Null -> error "impossible case"
>        DelNode q -> return (delete2 q x)
>        nodeOrhead ->
>         do let curPtr = next prevNode
>            curNode <- readRef curPtr
>            case curNode of
>              Node {val = y, next= nextNode} ->
>               if (y /= x)
>               then return (delete2 curPtr x)
>               else -- (delink node)
>                 do writeRef curPtr (DelNode prevPtr)   -- add backpointer
>                    case prevNode of
>                      Head {} -> do writeRef prevPtr (Head {next = nextNode})
>                                    return (return True)
>                      Node {} -> do writeRef prevPtr
>                                       (Node {val = val prevNode, next = nextNode})
>                                    return (return True)
>              Null -> return (return False)
>              DelNode _ -> retryRef
>                   -- means that the prevNode points to next of delNode
>                   -- we simply retry therefore
>      }

printing and counting

> printList :: (Show a, Ref r m) => ListHandle r a -> IO ()
> printList (ListHandle {headList = ptrPtr}) =
>  do startptr <- atomicRef (
>          do ptr <- readRef ptrPtr
>             Head {next = startptr} <- readRef ptr
>             return startptr)
>     printListHelp startptr

> printListHelp :: (Show a, Ref r m) => r (List r a) -> IO ()
> printListHelp curNodePtr =
>   do { curNode <- atomicRef (readRef curNodePtr)
>      ; case curNode of
>          Null -> putStr "Nil"
>          Node {val = curval, next = curnext} ->
>             do { putStr (show curval  ++ " -> ")
>                ;  printListHelp curnext }
>          DelNode curnext ->
>             printListHelp curnext
>      }

> cntList :: (Show a, Ref r m) => ListHandle r a -> IO Int
> cntList (ListHandle {headList = ptrPtr}) =
>  do startptr <- atomicRef (
>          do ptr <- readRef ptrPtr
>             Head {next = startptr} <- readRef ptr
>             return startptr)
>     cntListHelp startptr 0

> cntListHelp :: (Show a, Ref r m) => r (List r a) -> Int -> IO Int
> cntListHelp curNodePtr i =
>   do { curNode <- atomicRef (readRef curNodePtr)
>      ; case curNode of
>          Null -> return i
>          Node {val = curval, next = curnext} ->
>             cntListHelp curnext (i+1)
>          DelNode curnext ->
>             cntListHelp curnext i
>      }