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

-- Commentary of Integer library is located on the wiki:
-- http://ghc.haskell.org/trac/ghc/wiki/Commentary/Libraries/Integer
--
-- It gives an in-depth description of implementation details and
-- decisions.

-----------------------------------------------------------------------------
-- |
-- Module      :  GHC.Integer.Type
-- Copyright   :  (c) Ian Lynagh 2007-2012
-- License     :  BSD3
--
-- Maintainer  :  igloo@earth.li
-- Stability   :  internal
-- Portability :  non-portable (GHC Extensions)
--
-- A simple definition of the 'Integer' type.
--
-----------------------------------------------------------------------------

#include "MachDeps.h"

module GHC.Integer.Type where

import GHC.Prim
import GHC.Classes
import GHC.Types
import GHC.Tuple ()
#if WORD_SIZE_IN_BITS < 64
import GHC.IntWord64
#endif

data Integer = Positive !Positive | Negative !Positive | Naught

-------------------------------------------------------------------
-- The hard work is done on positive numbers

-- Least significant bit is first

-- Positive's have the property that they contain at least one Bit,
-- and their last Bit is One.
type Positive = Digits
type Positives = List Positive

data Digits = Some !Digit !Digits
            | None
type Digit = Word#

-- XXX Could move [] above us
data List a = Nil | Cons a (List a)

mkInteger :: Bool   -- non-negative?
          -> [Int]  -- absolute value in 31 bit chunks, least significant first
                    -- ideally these would be Words rather than Ints, but
                    -- we don't have Word available at the moment.
          -> Integer
mkInteger nonNegative is = let abs = f is
                           in if nonNegative then abs else negateInteger abs
    where f [] = Naught
          f (I# i : is') = smallInteger i `orInteger` shiftLInteger (f is') 31#

errorInteger :: Integer
errorInteger = Positive errorPositive

errorPositive :: Positive
errorPositive = Some 47## None -- Random number

{-# NOINLINE smallInteger #-}
smallInteger :: Int# -> Integer
smallInteger i = if isTrue# (i >=# 0#) then wordToInteger (int2Word# i)
                 else -- XXX is this right for -minBound?
                      negateInteger (wordToInteger (int2Word# (negateInt# i)))

{-# NOINLINE wordToInteger #-}
wordToInteger :: Word# -> Integer
wordToInteger w = if isTrue# (w `eqWord#` 0##)
                  then Naught
                  else Positive (Some w None)

{-# NOINLINE integerToWord #-}
integerToWord :: Integer -> Word#
integerToWord (Positive (Some w _)) = w
integerToWord (Negative (Some w _)) = 0## `minusWord#` w
-- Must be Naught by the invariant:
integerToWord _ = 0##

{-# NOINLINE integerToInt #-}
integerToInt :: Integer -> Int#
integerToInt i = word2Int# (integerToWord i)

#if WORD_SIZE_IN_BITS == 64
-- Nothing
#elif WORD_SIZE_IN_BITS == 32
{-# NOINLINE integerToWord64 #-}
integerToWord64 :: Integer -> Word64#
integerToWord64 i = int64ToWord64# (integerToInt64 i)

{-# NOINLINE word64ToInteger #-}
word64ToInteger:: Word64# -> Integer
word64ToInteger w = if isTrue# (w `eqWord64#` wordToWord64# 0##)
                    then Naught
                    else Positive (word64ToPositive w)

{-# NOINLINE integerToInt64 #-}
integerToInt64 :: Integer -> Int64#
integerToInt64 Naught = intToInt64# 0#
integerToInt64 (Positive p) = word64ToInt64# (positiveToWord64 p)
integerToInt64 (Negative p)
    = negateInt64# (word64ToInt64# (positiveToWord64 p))

{-# NOINLINE int64ToInteger #-}
int64ToInteger :: Int64# -> Integer
int64ToInteger i
 = if isTrue# (i `eqInt64#` intToInt64# 0#)
   then Naught
   else if isTrue# (i `gtInt64#` intToInt64# 0#)
   then Positive (word64ToPositive (int64ToWord64# i))
   else Negative (word64ToPositive (int64ToWord64# (negateInt64# i)))
#else
#error WORD_SIZE_IN_BITS not supported
#endif

oneInteger :: Integer
oneInteger = Positive onePositive

negativeOneInteger :: Integer
negativeOneInteger = Negative onePositive

twoToTheThirtytwoInteger :: Integer
twoToTheThirtytwoInteger = Positive twoToTheThirtytwoPositive

{-# NOINLINE encodeDoubleInteger #-}
encodeDoubleInteger :: Integer -> Int# -> Double#
encodeDoubleInteger (Positive ds0) e0 = f 0.0## ds0 e0
    where f !acc None        (!_) = acc
          f !acc (Some d ds) !e   = f (acc +## encodeDouble# d e)
                                      ds
                                      -- XXX We assume that this adding to e
                                      -- isn't going to overflow
                                      (e +# WORD_SIZE_IN_BITS#)
encodeDoubleInteger (Negative ds) e
    = negateDouble# (encodeDoubleInteger (Positive ds) e)
encodeDoubleInteger Naught _ = 0.0##

foreign import ccall unsafe "__word_encodeDouble"
        encodeDouble# :: Word# -> Int# -> Double#

{-# NOINLINE encodeFloatInteger #-}
encodeFloatInteger :: Integer -> Int# -> Float#
encodeFloatInteger (Positive ds0) e0 = f 0.0# ds0 e0
    where f !acc None        (!_) = acc
          f !acc (Some d ds) !e   = f (acc `plusFloat#` encodeFloat# d e)
                                      ds
                                      -- XXX We assume that this adding to e
                                      -- isn't going to overflow
                                      (e +# WORD_SIZE_IN_BITS#)
encodeFloatInteger (Negative ds) e
    = negateFloat# (encodeFloatInteger (Positive ds) e)
encodeFloatInteger Naught _ = 0.0#

foreign import ccall unsafe "__word_encodeFloat"
    encodeFloat# :: Word# -> Int# -> Float#

{-# NOINLINE decodeFloatInteger #-}
decodeFloatInteger :: Float# -> (# Integer, Int# #)
decodeFloatInteger f = case decodeFloat_Int# f of
                       (# mant, exp #) -> (# smallInteger mant, exp #)

-- XXX This could be optimised better, by either (word-size dependent)
-- using single 64bit value for the mantissa, or doing the multiplication
-- by just building the Digits directly
{-# NOINLINE decodeDoubleInteger #-}
decodeDoubleInteger :: Double# -> (# Integer, Int# #)
decodeDoubleInteger d
 = case decodeDouble_2Int# d of
   (# mantSign, mantHigh, mantLow, exp #) ->
       (# (smallInteger mantSign) `timesInteger`
          (  (wordToInteger mantHigh `timesInteger` twoToTheThirtytwoInteger)
             `plusInteger` wordToInteger mantLow),
          exp #)

{-# NOINLINE doubleFromInteger #-}
doubleFromInteger :: Integer -> Double#
doubleFromInteger Naught = 0.0##
doubleFromInteger (Positive p) = doubleFromPositive p
doubleFromInteger (Negative p) = negateDouble# (doubleFromPositive p)

{-# NOINLINE floatFromInteger #-}
floatFromInteger :: Integer -> Float#
floatFromInteger Naught = 0.0#
floatFromInteger (Positive p) = floatFromPositive p
floatFromInteger (Negative p) = negateFloat# (floatFromPositive p)

{-# NOINLINE andInteger #-}
andInteger :: Integer -> Integer -> Integer
Naught     `andInteger` (!_)       = Naught
(!_)       `andInteger` Naught     = Naught
Positive x `andInteger` Positive y = digitsToInteger (x `andDigits` y)
{-
To calculate x & -y we need to calculate
    x & twosComplement y
The (imaginary) sign bits are 0 and 1, so &ing them give 0, i.e. positive.
Note that
    twosComplement y
has infinitely many 1s, but x has a finite number of digits, so andDigits
will return a finite result.
-}
Positive x `andInteger` Negative y = let y' = twosComplementPositive y
                                         z = y' `andDigitsOnes` x
                                     in digitsToInteger z
Negative x `andInteger` Positive y = Positive y `andInteger` Negative x
{-
To calculate -x & -y, naively we need to calculate
    twosComplement (twosComplement x & twosComplement y)
but
    twosComplement x & twosComplement y
has infinitely many 1s, so this won't work. Thus we use de Morgan's law
to get
    -x & -y = !(!(-x) | !(-y))
            = !(!(twosComplement x) | !(twosComplement y))
            = !(!(!x + 1) | (!y + 1))
            = !((x - 1) | (y - 1))
but the result is negative, so we need to take the two's complement of
this in order to get the magnitude of the result.
    twosComplement !((x - 1) | (y - 1))
            = !(!((x - 1) | (y - 1))) + 1
            = ((x - 1) | (y - 1)) + 1
-}
-- We don't know that x and y are /strictly/ greater than 1, but
-- minusPositive gives us the required answer anyway.
Negative x `andInteger` Negative y = let x' = x `minusPositive` onePositive
                                         y' = y `minusPositive` onePositive
                                         z = x' `orDigits` y'
                                         -- XXX Cheating the precondition:
                                         z' = succPositive z
                                     in digitsToNegativeInteger z'

{-# NOINLINE orInteger #-}
orInteger :: Integer -> Integer -> Integer
Naught     `orInteger` (!i)       = i
(!i)       `orInteger` Naught     = i
Positive x `orInteger` Positive y = Positive (x `orDigits` y)
{-
x | -y = - (twosComplement (x | twosComplement y))
       = - (twosComplement !(!x & !(twosComplement y)))
       = - (twosComplement !(!x & !(!y + 1)))
       = - (twosComplement !(!x & (y - 1)))
       = - ((!x & (y - 1)) + 1)
-}
Positive x `orInteger` Negative y = let x' = flipBits x
                                        y' = y `minusPositive` onePositive
                                        z = x' `andDigitsOnes` y'
                                        z' = succPositive z
                                    in digitsToNegativeInteger z'
Negative x `orInteger` Positive y = Positive y `orInteger` Negative x
{-
-x | -y = - (twosComplement (twosComplement x | twosComplement y))
        = - (twosComplement !(!(twosComplement x) & !(twosComplement y)))
        = - (twosComplement !(!(!x + 1) & !(!y + 1)))
        = - (twosComplement !((x - 1) & (y - 1)))
        = - (((x - 1) & (y - 1)) + 1)
-}
Negative x `orInteger` Negative y = let x' = x `minusPositive` onePositive
                                        y' = y `minusPositive` onePositive
                                        z = x' `andDigits` y'
                                        z' = succPositive z
                                    in digitsToNegativeInteger z'

{-# NOINLINE xorInteger #-}
xorInteger :: Integer -> Integer -> Integer
Naught     `xorInteger` (!i)       = i
(!i)       `xorInteger` Naught     = i
Positive x `xorInteger` Positive y = digitsToInteger (x `xorDigits` y)
{-
x ^ -y = - (twosComplement (x ^ twosComplement y))
       = - (twosComplement !(x ^ !(twosComplement y)))
       = - (twosComplement !(x ^ !(!y + 1)))
       = - (twosComplement !(x ^ (y - 1)))
       = - ((x ^ (y - 1)) + 1)
-}
Positive x `xorInteger` Negative y = let y' = y `minusPositive` onePositive
                                         z = x `xorDigits` y'
                                         z' = succPositive z
                                     in digitsToNegativeInteger z'
Negative x `xorInteger` Positive y = Positive y `xorInteger` Negative x
{-
-x ^ -y = twosComplement x ^ twosComplement y
        = (!x + 1) ^ (!y + 1)
        = (!x + 1) ^ (!y + 1)
        = !(!x + 1) ^ !(!y + 1)
        = (x - 1) ^ (y - 1)
-}
Negative x `xorInteger` Negative y = let x' = x `minusPositive` onePositive
                                         y' = y `minusPositive` onePositive
                                         z = x' `xorDigits` y'
                                     in digitsToInteger z

{-# NOINLINE complementInteger #-}
complementInteger :: Integer -> Integer
complementInteger x = negativeOneInteger `minusInteger` x

{-# NOINLINE shiftLInteger #-}
shiftLInteger :: Integer -> Int# -> Integer
shiftLInteger (Positive p) i = Positive (shiftLPositive p i)
shiftLInteger (Negative n) i = Negative (shiftLPositive n i)
shiftLInteger Naught       _ = Naught

{-# NOINLINE shiftRInteger #-}
shiftRInteger :: Integer -> Int# -> Integer
shiftRInteger (Positive p)   i = shiftRPositive p i
shiftRInteger j@(Negative _) i
    = complementInteger (shiftRInteger (complementInteger j) i)
shiftRInteger Naught         _ = Naught

{-# NOINLINE popCountInteger #-}
popCountInteger :: Integer -> Int#
popCountInteger (Positive p) = popCountPositive p
popCountInteger Naught       = 0#
popCountInteger (Negative n) = negateInt# (popCountPositive n)

popCountPositive :: Positive -> Int#
popCountPositive p = word2Int# (go 0## p)
  where
  go :: Word# -> Positive -> Word#
  go acc# None = acc#
  go acc# (Some d ds) = go (popCnt# d `plusWord#` acc#) ds

{-# NOINLINE bitInteger #-}
-- | 'Integer' for which only /n/-th bit is set. Undefined behaviour
-- for negative /n/ values.
bitInteger :: Int# -> Integer
bitInteger i# = if isTrue# (i# <# 0#)
                then Naught
                else Positive (bitPositive i#)

-- Assumes 0 <= i
bitPositive :: Int# -> Positive
bitPositive i#
    = if isTrue# (i# >=# WORD_SIZE_IN_BITS#)
      then Some 0## (bitPositive (i# -# WORD_SIZE_IN_BITS#))
      else Some (uncheckedShiftL# 1## i#) None

{-# NOINLINE testBitInteger #-}
testBitInteger :: Integer -> Int# -> Bool
testBitInteger (!_) i# | isTrue# (i# <# 0#) = False
testBitInteger Naught       _  = False
testBitInteger (Positive p) i# = isTrue# (testBitPositive p i#)
  where
  -- Straightforward decrement of 'j#' by the word size stopping when
  -- 'j#' is less than the word size or the number runs out.
  testBitPositive :: Positive -> Int# -> Int#
  testBitPositive None          _ = 0#
  testBitPositive (Some w# ws)  j#
    = if isTrue# (j# >=# WORD_SIZE_IN_BITS#)
      then testBitPositive ws (j# -# WORD_SIZE_IN_BITS#)
      else neWord# (uncheckedShiftL# 1## j# `and#` w#) 0##
testBitInteger (Negative n) i# = isTrue# (testBitNegative n i#)
  where
  -- For negative numbers, we want to inspect the correct bit of the two's
  -- complement. Like for positive numbers, we walk down the words until
  -- 'j#' is less than the word size (or the number runs out).
  testBitNegative :: Positive -> Int# -> Int#
  testBitNegative (Some 0## ws) j#
    -- If the number starts (on the low end) with a bunch of '0##' and 'j#'
    -- falls in those, we know that @n - 1@ would have flipped all those
    -- bits, so @!(n - 1) & i@ is false.
    = if isTrue# (j# >=# WORD_SIZE_IN_BITS#)
      then testBitNegative ws (j# -# WORD_SIZE_IN_BITS#)
      else 1#
  testBitNegative (Some w# ws) j#
    -- Yet, as soon as we find something that isn't a '0##', we can subtract
    -- and forget about the 1 altogether!
    = testBitNegativeMinus1 (Some (w# `minusWord#` 1##) ws) j#
  testBitNegative None _ = 0# -- XXX Can't happen due to Positive's invariant

  testBitNegativeMinus1 :: Positive -> Int# -> Int#
  testBitNegativeMinus1 None         _ = 1#
  testBitNegativeMinus1 (Some w# ws) j#
    = if isTrue# (j# >=# WORD_SIZE_IN_BITS#)
      then testBitNegativeMinus1 ws (j# -# WORD_SIZE_IN_BITS#)
      else neWord# (uncheckedShiftL# 1## j# `and#` not# w#) 0##

twosComplementPositive :: Positive -> DigitsOnes
twosComplementPositive p = flipBits (p `minusPositive` onePositive)

flipBits :: Digits -> DigitsOnes
flipBits ds = DigitsOnes (flipBitsDigits ds)

flipBitsDigits :: Digits -> Digits
flipBitsDigits None = None
flipBitsDigits (Some w ws) = Some (not# w) (flipBitsDigits ws)

{-# NOINLINE negateInteger #-}
negateInteger :: Integer -> Integer
negateInteger (Positive p) = Negative p
negateInteger (Negative p) = Positive p
negateInteger Naught       = Naught

-- Note [Avoid patError]
{-# NOINLINE plusInteger #-}
plusInteger :: Integer -> Integer -> Integer
Positive p1    `plusInteger` Positive p2 = Positive (p1 `plusPositive` p2)
Negative p1    `plusInteger` Negative p2 = Negative (p1 `plusPositive` p2)
Positive p1    `plusInteger` Negative p2
    = case p1 `comparePositive` p2 of
      GT -> Positive (p1 `minusPositive` p2)
      EQ -> Naught
      LT -> Negative (p2 `minusPositive` p1)
Negative p1    `plusInteger` Positive p2
    = Positive p2 `plusInteger` Negative p1
Naught         `plusInteger` Naught         = Naught
Naught         `plusInteger` i@(Positive _) = i
Naught         `plusInteger` i@(Negative _) = i
i@(Positive _) `plusInteger` Naught         = i
i@(Negative _) `plusInteger` Naught         = i

{-# NOINLINE minusInteger #-}
minusInteger :: Integer -> Integer -> Integer
i1 `minusInteger` i2 = i1 `plusInteger` negateInteger i2

{-# NOINLINE timesInteger #-}
timesInteger :: Integer -> Integer -> Integer
Positive p1 `timesInteger` Positive p2 = Positive (p1 `timesPositive` p2)
Negative p1 `timesInteger` Negative p2 = Positive (p1 `timesPositive` p2)
Positive p1 `timesInteger` Negative p2 = Negative (p1 `timesPositive` p2)
Negative p1 `timesInteger` Positive p2 = Negative (p1 `timesPositive` p2)
(!_)        `timesInteger` (!_)        = Naught

{-# NOINLINE divModInteger #-}
divModInteger :: Integer -> Integer -> (# Integer, Integer #)
n `divModInteger` d =
    case n `quotRemInteger` d of
        (# q, r #) ->
            if signumInteger r `eqInteger`
               negateInteger (signumInteger d)
            then (# q `minusInteger` oneInteger, r `plusInteger` d #)
            else (# q, r #)

{-# NOINLINE divInteger #-}
divInteger :: Integer -> Integer -> Integer
n `divInteger` d = quotient
    where (# quotient, _ #) = n `divModInteger` d

{-# NOINLINE modInteger #-}
modInteger :: Integer -> Integer -> Integer
n `modInteger` d = modulus
    where (# _, modulus #) = n `divModInteger` d

{-# NOINLINE quotRemInteger #-}
quotRemInteger :: Integer -> Integer -> (# Integer, Integer #)
Naught      `quotRemInteger` (!_)        = (# Naught, Naught #)
(!_)        `quotRemInteger` Naught
    = (# errorInteger, errorInteger #) -- XXX Can't happen
-- XXX _            `quotRemInteger` Naught     = error "Division by zero"
Positive p1 `quotRemInteger` Positive p2 = p1 `quotRemPositive` p2
Negative p1 `quotRemInteger` Positive p2 = case p1 `quotRemPositive` p2 of
                                           (# q, r #) ->
                                               (# negateInteger q,
                                                  negateInteger r #)
Positive p1 `quotRemInteger` Negative p2 = case p1 `quotRemPositive` p2 of
                                           (# q, r #) ->
                                               (# negateInteger q, r #)
Negative p1 `quotRemInteger` Negative p2 = case p1 `quotRemPositive` p2 of
                                           (# q, r #) ->
                                               (# q, negateInteger r #)

{-# NOINLINE quotInteger #-}
quotInteger :: Integer -> Integer -> Integer
x `quotInteger` y = case x `quotRemInteger` y of
                    (# q, _ #) -> q

{-# NOINLINE remInteger #-}
remInteger :: Integer -> Integer -> Integer
x `remInteger` y = case x `quotRemInteger` y of
                   (# _, r #) -> r

{-# NOINLINE gcdInteger #-}
gcdInteger :: Integer -> Integer -> Integer
gcdInteger (Positive a) (Positive b) = Positive (gcdPositive a b)
gcdInteger (Positive a) (Negative b) = Positive (gcdPositive a b)
gcdInteger (Negative a) (Positive b) = Positive (gcdPositive a b)
gcdInteger (Negative a) (Negative b) = Positive (gcdPositive a b)
gcdInteger Naught                  b = absInteger b
gcdInteger a                  Naught = absInteger a

gcdPositive :: Positive -> Positive -> Positive
gcdPositive p1 p2 = case p1 `quotRemPositive` p2 of
                        (# _, Positive r #) -> gcdPositive p2 r
                        (# _, Naught     #) -> p2
                        (# _, Negative _ #) -> errorPositive -- XXX Can't happen

{-# NOINLINE lcmInteger #-}
lcmInteger :: Integer -> Integer -> Integer
lcmInteger (Positive a) (Positive b) = Positive (lcmPositive a b)
lcmInteger (Positive a) (Negative b) = Positive (lcmPositive a b)
lcmInteger (Negative a) (Positive b) = Positive (lcmPositive a b)
lcmInteger (Negative a) (Negative b) = Positive (lcmPositive a b)
lcmInteger Naught                  _ = Naught
lcmInteger _                  Naught = Naught

lcmPositive :: Positive -> Positive -> Positive
lcmPositive p1 p2 = case p1 `quotRemPositive` (p1 `gcdPositive` p2) of
                        (# Positive q, _ #) -> q `timesPositive` p2
                        (# _,          _ #) -> errorPositive -- XXX Can't happen

{-# NOINLINE compareInteger #-}
compareInteger :: Integer -> Integer -> Ordering
Positive x `compareInteger` Positive y = x `comparePositive` y
Positive _ `compareInteger` (!_)       = GT
Naught     `compareInteger` Naught     = EQ
Naught     `compareInteger` Negative _ = GT
Negative x `compareInteger` Negative y = y `comparePositive` x
(!_)       `compareInteger` (!_)       = LT

{-# NOINLINE eqInteger# #-}
eqInteger# :: Integer -> Integer -> Int#
x `eqInteger#` y = case x `compareInteger` y of
                        EQ -> 1#
                        _  -> 0#

{-# NOINLINE neqInteger# #-}
neqInteger# :: Integer -> Integer -> Int#
x `neqInteger#` y = case x `compareInteger` y of
                         EQ -> 0#
                         _  -> 1#

{-# INLINE eqInteger  #-}
{-# INLINE neqInteger #-}
eqInteger, neqInteger :: Integer -> Integer -> Bool
eqInteger  a b = isTrue# (a `eqInteger#`  b)
neqInteger a b = isTrue# (a `neqInteger#` b)

instance  Eq Integer  where
    (==) = eqInteger
    (/=) = neqInteger

{-# NOINLINE ltInteger# #-}
ltInteger# :: Integer -> Integer -> Int#
x `ltInteger#` y = case x `compareInteger` y of
                        LT -> 1#
                        _  -> 0#

{-# NOINLINE gtInteger# #-}
gtInteger# :: Integer -> Integer -> Int#
x `gtInteger#` y = case x `compareInteger` y of
                        GT -> 1#
                        _  -> 0#

{-# NOINLINE leInteger# #-}
leInteger# :: Integer -> Integer -> Int#
x `leInteger#` y = case x `compareInteger` y of
                        GT -> 0#
                        _  -> 1#

{-# NOINLINE geInteger# #-}
geInteger# :: Integer -> Integer -> Int#
x `geInteger#` y = case x `compareInteger` y of
                        LT -> 0#
                        _  -> 1#

{-# INLINE leInteger #-}
{-# INLINE ltInteger #-}
{-# INLINE geInteger #-}
{-# INLINE gtInteger #-}
leInteger, gtInteger, ltInteger, geInteger :: Integer -> Integer -> Bool
leInteger a b = isTrue# (a `leInteger#` b)
gtInteger a b = isTrue# (a `gtInteger#` b)
ltInteger a b = isTrue# (a `ltInteger#` b)
geInteger a b = isTrue# (a `geInteger#` b)

instance Ord Integer where
    (<=) = leInteger
    (>)  = gtInteger
    (<)  = ltInteger
    (>=) = geInteger
    compare = compareInteger

{-# NOINLINE absInteger #-}
absInteger :: Integer -> Integer
absInteger (Negative x) = Positive x
absInteger x = x

{-# NOINLINE signumInteger #-}
signumInteger :: Integer -> Integer
signumInteger (Negative _) = negativeOneInteger
signumInteger Naught       = Naught
signumInteger (Positive _) = oneInteger

{-# NOINLINE hashInteger #-}
hashInteger :: Integer -> Int#
hashInteger = integerToInt

-------------------------------------------------------------------
-- The hard work is done on positive numbers

onePositive :: Positive
onePositive = Some 1## None

halfBoundUp, fullBound :: () -> Digit
lowHalfMask :: () -> Digit
highHalfShift :: () -> Int#
twoToTheThirtytwoPositive :: Positive
#if WORD_SIZE_IN_BITS == 64
halfBoundUp   () = 0x8000000000000000##
fullBound     () = 0xFFFFFFFFFFFFFFFF##
lowHalfMask   () = 0xFFFFFFFF##
highHalfShift () = 32#
twoToTheThirtytwoPositive = Some 0x100000000## None
#elif WORD_SIZE_IN_BITS == 32
halfBoundUp   () = 0x80000000##
fullBound     () = 0xFFFFFFFF##
lowHalfMask   () = 0xFFFF##
highHalfShift () = 16#
twoToTheThirtytwoPositive = Some 0## (Some 1## None)
#else
#error Unhandled WORD_SIZE_IN_BITS
#endif

digitsMaybeZeroToInteger :: Digits -> Integer
digitsMaybeZeroToInteger None = Naught
digitsMaybeZeroToInteger ds = Positive ds

digitsToInteger :: Digits -> Integer
digitsToInteger ds = case removeZeroTails ds of
                     None -> Naught
                     ds' -> Positive ds'

digitsToNegativeInteger :: Digits -> Integer
digitsToNegativeInteger ds = case removeZeroTails ds of
                             None -> Naught
                             ds' -> Negative ds'

removeZeroTails :: Digits -> Digits
removeZeroTails (Some w ds) = if isTrue# (w `eqWord#` 0##)
                              then case removeZeroTails ds of
                                   None -> None
                                   ds' -> Some w ds'
                              else Some w (removeZeroTails ds)
removeZeroTails None = None

#if WORD_SIZE_IN_BITS < 64
word64ToPositive :: Word64# -> Positive
word64ToPositive w
 = if isTrue# (w `eqWord64#` wordToWord64# 0##)
   then None
   else Some (word64ToWord# w) (word64ToPositive (w `uncheckedShiftRL64#` 32#))

positiveToWord64 :: Positive -> Word64#
positiveToWord64 None = wordToWord64# 0## -- XXX Can't happen
positiveToWord64 (Some w None) = wordToWord64# w
positiveToWord64 (Some low (Some high _))
    = wordToWord64# low `or64#` (wordToWord64# high `uncheckedShiftL64#` 32#)
#endif

-- Note [Avoid patError]
comparePositive :: Positive -> Positive -> Ordering
Some x xs `comparePositive` Some y ys = case xs `comparePositive` ys of
                                        EQ ->      if isTrue# (x `ltWord#` y) then LT
                                              else if isTrue# (x `gtWord#` y) then GT
                                              else                                 EQ
                                        res -> res
None      `comparePositive` None      = EQ
(Some {}) `comparePositive` None      = GT
None      `comparePositive` (Some {}) = LT

plusPositive :: Positive -> Positive -> Positive
plusPositive x0 y0 = addWithCarry 0## x0 y0
 where -- digit `elem` [0, 1]
       -- Note [Avoid patError]
       addWithCarry :: Digit -> Positive -> Positive -> Positive
       addWithCarry c None            None            = addOnCarry c None
       addWithCarry c xs@(Some {})    None            = addOnCarry c xs
       addWithCarry c None            ys@(Some {})    = addOnCarry c ys
       addWithCarry c xs@(Some x xs') ys@(Some y ys')
        = if isTrue# (x `ltWord#` y) then addWithCarry c ys xs
          -- Now x >= y
          else if isTrue# (y `geWord#` halfBoundUp ())
               -- So they are both at least halfBoundUp, so we subtract
               -- halfBoundUp from each and thus carry 1
               then case x `minusWord#` halfBoundUp () of
                    x' ->
                     case y `minusWord#` halfBoundUp () of
                     y' ->
                      case x' `plusWord#` y' `plusWord#` c of
                      this ->
                       Some this withCarry
          else if isTrue# (x `geWord#` halfBoundUp ())
               then case x `minusWord#` halfBoundUp () of
                    x' ->
                     case x' `plusWord#` y `plusWord#` c of
                     z ->
                      -- We've taken off halfBoundUp, so now we need to
                      -- add it back on
                      if isTrue# (z `ltWord#` halfBoundUp ())
                       then Some (z `plusWord#`  halfBoundUp ()) withoutCarry
                       else Some (z `minusWord#` halfBoundUp ()) withCarry
          else Some (x `plusWord#` y `plusWord#` c) withoutCarry
           where withCarry    = addWithCarry 1## xs' ys'
                 withoutCarry = addWithCarry 0## xs' ys'

       -- digit `elem` [0, 1]
       addOnCarry :: Digit -> Positive -> Positive
       addOnCarry (!c) (!ws) = if isTrue# (c `eqWord#` 0##)
                               then ws
                               else succPositive ws

-- digit `elem` [0, 1]
succPositive :: Positive -> Positive
succPositive None = Some 1## None
succPositive (Some w ws) = if isTrue# (w `eqWord#` fullBound ())
                           then Some 0## (succPositive ws)
                           else Some (w `plusWord#` 1##) ws

-- Requires x > y
-- In recursive calls, x >= y and x == y => result is None
-- Note [Avoid patError]
minusPositive :: Positive -> Positive -> Positive
Some x xs `minusPositive` Some y ys
 = if isTrue# (x `eqWord#` y)
   then case xs `minusPositive` ys of
        None -> None
        s -> Some 0## s
   else if isTrue# (x `gtWord#` y) then
        Some (x `minusWord#` y) (xs `minusPositive` ys)
   else case (fullBound () `minusWord#` y) `plusWord#` 1## of
        z -> -- z = 2^n - y, calculated without overflow
         case z `plusWord#` x of
         z' -> -- z = 2^n + (x - y), calculated without overflow
          Some z' ((xs `minusPositive` ys) `minusPositive` onePositive)
xs@(Some {}) `minusPositive` None      = xs
None         `minusPositive` None      = None
None         `minusPositive` (Some {}) = errorPositive -- XXX Can't happen
-- XXX None `minusPositive` _ = error "minusPositive: Requirement x > y not met"

-- Note [Avoid patError]
timesPositive :: Positive -> Positive -> Positive
-- XXX None's can't happen here:
None            `timesPositive` None        = errorPositive
None            `timesPositive` (Some {})   = errorPositive
(Some {})       `timesPositive` None        = errorPositive
-- x and y are the last digits in Positive numbers, so are not 0:
xs@(Some x xs') `timesPositive` ys@(Some y ys')
 = case xs' of
   None ->
       case ys' of
           None ->
               x `timesDigit` y
           Some {} ->
               ys `timesPositive` xs
   Some {} ->
       case ys' of
       None ->
           -- y is the last digit in a Positive number, so is not 0.
           let zs = Some 0## (xs' `timesPositive` ys)
           in -- We could actually skip this test, and everything would
              -- turn out OK. We already play tricks like that in timesPositive.
              if isTrue# (x `eqWord#` 0##)
              then zs
              else (x `timesDigit` y) `plusPositive` zs
       Some {} ->
           (Some x None `timesPositive` ys) `plusPositive`
           Some 0## (xs' `timesPositive` ys)

{-
-- Requires arguments /= 0
Suppose we have 2n bits in a Word. Then
    x = 2^n xh + xl
    y = 2^n yh + yl
    x * y = (2^n xh + xl) * (2^n yh + yl)
          = 2^(2n) (xh yh)
          + 2^n    (xh yl)
          + 2^n    (xl yh)
          +        (xl yl)
                   ~~~~~~~ - all fit in 2n bits
-}
timesDigit :: Digit -> Digit -> Positive
timesDigit (!x) (!y)
 = case splitHalves x of
   (# xh, xl #) ->
    case splitHalves y of
    (# yh, yl #) ->
     case xh `timesWord#` yh of
     xhyh ->
      case splitHalves (xh `timesWord#` yl) of
      (# xhylh, xhyll #) ->
       case xhyll `uncheckedShiftL#` highHalfShift () of
       xhyll' ->
        case splitHalves (xl `timesWord#` yh) of
        (# xlyhh, xlyhl #) ->
         case xlyhl `uncheckedShiftL#` highHalfShift () of
         xlyhl' ->
          case xl `timesWord#` yl of
          xlyl ->
           -- Add up all the high word results. As the result fits in
           -- 4n bits this can't overflow.
           case xhyh `plusWord#` xhylh `plusWord#` xlyhh of
           high ->
           -- low: xhyll<<n + xlyhl<<n + xlyl
            -- From this point we might make (Some 0 None), but we know
            -- that the final result will be positive and the addition
            -- will work out OK, so everything will work out in the end.
            -- One thing we do need to be careful of is avoiding returning
            -- Some 0 (Some 0 None) + Some n None, as this will result in
            -- Some n (Some 0 None) instead of Some n None.
            let low = Some xhyll' None `plusPositive`
                      Some xlyhl' None `plusPositive`
                      Some xlyl   None
            in if isTrue# (high `eqWord#` 0##)
               then low
               else Some 0## (Some high None) `plusPositive` low

splitHalves :: Digit -> (# {- High -} Digit, {- Low -} Digit #)
splitHalves (!x) = (# x `uncheckedShiftRL#` highHalfShift (),
                      x `and#` lowHalfMask () #)

-- Assumes 0 <= i
shiftLPositive :: Positive -> Int# -> Positive
shiftLPositive p i
    = if isTrue# (i >=# WORD_SIZE_IN_BITS#)
      then shiftLPositive (Some 0## p) (i -# WORD_SIZE_IN_BITS#)
      else smallShiftLPositive p i

-- Assumes 0 <= i < WORD_SIZE_IN_BITS#
smallShiftLPositive :: Positive -> Int# -> Positive
smallShiftLPositive (!p) 0# = p
smallShiftLPositive (!p) (!i) =
    case WORD_SIZE_IN_BITS# -# i of
    j -> let f carry None = if isTrue# (carry `eqWord#` 0##)
                            then None
                            else Some carry None
             f carry (Some w ws) = case w `uncheckedShiftRL#` j of
                                   carry' ->
                                    case w `uncheckedShiftL#` i of
                                    me ->
                                     Some (me `or#` carry) (f carry' ws)
         in f 0## p

-- Assumes 0 <= i
shiftRPositive :: Positive -> Int# -> Integer
shiftRPositive None _ = Naught
shiftRPositive p@(Some _ q) i
    = if isTrue# (i >=# WORD_SIZE_IN_BITS#)
      then shiftRPositive q (i -# WORD_SIZE_IN_BITS#)
      else smallShiftRPositive p i

-- Assumes 0 <= i < WORD_SIZE_IN_BITS#
smallShiftRPositive :: Positive -> Int# -> Integer
smallShiftRPositive (!p) (!i) =
    if isTrue# (i ==# 0#)
    then Positive p
    else case smallShiftLPositive p (WORD_SIZE_IN_BITS# -# i) of
         Some _ p'@(Some _ _) -> Positive p'
         _                    -> Naught

-- Long division
quotRemPositive :: Positive -> Positive -> (# Integer, Integer #)
(!xs) `quotRemPositive` (!ys)
    = case f xs of
      (# d, m #) -> (# digitsMaybeZeroToInteger d,
                       digitsMaybeZeroToInteger m #)
    where
          subtractors :: Positives
          subtractors = mkSubtractors (WORD_SIZE_IN_BITS# -# 1#)

          mkSubtractors (!n) = if isTrue# (n ==# 0#)
                               then Cons ys Nil
                               else Cons (ys `smallShiftLPositive` n)
                                         (mkSubtractors (n -# 1#))

          -- The main function. Go the end of xs, then walk
          -- back trying to divide the number we accumulate by ys.
          f :: Positive -> (# Digits, Digits #)
          f None = (# None, None #)
          f (Some z zs)
              = case f zs of
                (# ds, m #) ->
                    let -- We need to avoid making (Some Zero None) here
                        m' = some z m
                    in case g 0## subtractors m' of
                       (# d, m'' #) ->
                        (# some d ds, m'' #)

          g :: Digit -> Positives -> Digits -> (# Digit, Digits #)
          g (!d) Nil             (!m) = (# d, m #)
          g (!d) (Cons sub subs) (!m)
              = case d `uncheckedShiftL#` 1# of
                d' ->
                 case m `comparePositive` sub of
                 LT -> g d' subs m
                 _  -> g (d' `plusWord#` 1##)
                         subs
                         (m `minusPositive` sub)

some :: Digit -> Digits -> Digits
some (!w) None  = if isTrue# (w `eqWord#` 0##) then None else Some w None
some (!w) (!ws) = Some w ws

-- Note [Avoid patError]
andDigits :: Digits -> Digits -> Digits
andDigits None          None          = None
andDigits (Some {})     None          = None
andDigits None          (Some {})     = None
andDigits (Some w1 ws1) (Some w2 ws2) = Some (w1 `and#` w2) (andDigits ws1 ws2)

-- DigitsOnes is just like Digits, only None is really 0xFFFFFFF...,
-- i.e. ones off to infinity. This makes sense when we want to "and"
-- a DigitOnes with a Digits, as the latter will bound the size of the
-- result.
newtype DigitsOnes = DigitsOnes Digits

-- Note [Avoid patError]
andDigitsOnes :: DigitsOnes -> Digits -> Digits
andDigitsOnes (DigitsOnes None)          None          = None
andDigitsOnes (DigitsOnes None)          ws2@(Some {}) = ws2
andDigitsOnes (DigitsOnes (Some {}))     None          = None
andDigitsOnes (DigitsOnes (Some w1 ws1)) (Some w2 ws2)
    = Some (w1 `and#` w2) (andDigitsOnes (DigitsOnes ws1) ws2)

-- Note [Avoid patError]
orDigits :: Digits -> Digits -> Digits
orDigits None          None          = None
orDigits None          ds@(Some {})  = ds
orDigits ds@(Some {})  None          = ds
orDigits (Some w1 ds1) (Some w2 ds2) = Some (w1 `or#` w2) (orDigits ds1 ds2)

-- Note [Avoid patError]
xorDigits :: Digits -> Digits -> Digits
xorDigits None          None          = None
xorDigits None          ds@(Some {})  = ds
xorDigits ds@(Some {})  None          = ds
xorDigits (Some w1 ds1) (Some w2 ds2) = Some (w1 `xor#` w2) (xorDigits ds1 ds2)

-- XXX We'd really like word2Double# for this
doubleFromPositive :: Positive -> Double#
doubleFromPositive None = 0.0##
doubleFromPositive (Some w ds)
    = case splitHalves w of
      (# h, l #) ->
       (doubleFromPositive ds *## (2.0## **## WORD_SIZE_IN_BITS_FLOAT##))
       +## (int2Double# (word2Int# h) *##
              (2.0## **## int2Double# (highHalfShift ())))
       +## int2Double# (word2Int# l)

-- XXX We'd really like word2Float# for this
floatFromPositive :: Positive -> Float#
floatFromPositive None = 0.0#
floatFromPositive (Some w ds)
    = case splitHalves w of
      (# h, l #) ->
       (floatFromPositive ds `timesFloat#` (2.0# `powerFloat#` WORD_SIZE_IN_BITS_FLOAT#))
       `plusFloat#` (int2Float# (word2Int# h) `timesFloat#`
             (2.0# `powerFloat#` int2Float# (highHalfShift ())))
       `plusFloat#` int2Float# (word2Int# l)

{-
Note [Avoid patError]

If we use the natural set of definitions for functions, e.g.:

    orDigits None          ds            = ds
    orDigits ds            None          = ds
    orDigits (Some w1 ds1) (Some w2 ds2) = Some ... ...

then GHC may not be smart enough (especially when compiling with -O0)
to see that all the cases are handled, and will thus insert calls to
base:Control.Exception.Base.patError. But we are below base in the
package hierarchy, so this causes build failure!

We therefore help GHC out, by being more explicit about what all the
cases are:

    orDigits None          None          = None
    orDigits None          ds@(Some {})  = ds
    orDigits ds@(Some {})  None          = ds
    orDigits (Some w1 ds1) (Some w2 ds2) = Some ... ...
-}


{-# LANGUAGE CPP, MagicHash, UnboxedTuples, NoImplicitPrelude #-}
{-# OPTIONS_HADDOCK not-home #-}

#include "MachDeps.h"

-- (Hopefully) Fast integer logarithms to base 2.
-- integerLog2# and wordLog2# are of general usefulness,
-- the others are only needed for a fast implementation of
-- fromRational.
-- Since they are needed in GHC.Float, we must expose this
-- module, but it should not show up in the docs.

module GHC.Integer.Logarithms.Internals
    ( integerLog2#
    , integerLog2IsPowerOf2#
    , wordLog2#
    , roundingMode#
    ) where

import GHC.Prim
import GHC.Integer.Type
import GHC.Types

default ()

-- When larger word sizes become common, add support for those,
-- it's not hard, just tedious.
#if (WORD_SIZE_IN_BITS != 32) && (WORD_SIZE_IN_BITS != 64)

-- We don't know whether the word has 30 bits or 128 or even more,
-- so we can't start from the top, although that would be much more
-- efficient.
wordLog2# :: Word# -> Int#
wordLog2# w = go 8# w
  where
    go acc u = case u `uncheckedShiftRL#` 8# of
                0## -> case leadingZeros of
                        BA ba -> acc -# indexInt8Array# ba (word2Int# u)
                v   -> go (acc +# 8#) v

#else

-- This one at least can also be done efficiently.
-- wordLog2# 0## = -1#
{-# INLINE wordLog2# #-}
wordLog2# :: Word# -> Int#
wordLog2# w =
  case leadingZeros of
   BA lz ->
    let zeros u = indexInt8Array# lz (word2Int# u) in
#if WORD_SIZE_IN_BITS == 64
    case uncheckedShiftRL# w 56# of
     a ->
      if isTrue# (a `neWord#` 0##)
       then 64# -# zeros a
       else
        case uncheckedShiftRL# w 48# of
         b ->
          if isTrue# (b `neWord#` 0##)
           then 56# -# zeros b
           else
            case uncheckedShiftRL# w 40# of
             c ->
              if isTrue# (c `neWord#` 0##)
               then 48# -# zeros c
               else
                case uncheckedShiftRL# w 32# of
                 d ->
                  if isTrue# (d `neWord#` 0##)
                   then 40# -# zeros d
                   else
#endif
                    case uncheckedShiftRL# w 24# of
                     e ->
                      if isTrue# (e `neWord#` 0##)
                       then 32# -# zeros e
                       else
                        case uncheckedShiftRL# w 16# of
                         f ->
                          if isTrue# (f `neWord#` 0##)
                           then 24# -# zeros f
                           else
                            case uncheckedShiftRL# w 8# of
                             g ->
                              if isTrue# (g `neWord#` 0##)
                               then 16# -# zeros g
                               else  8# -# zeros w

#endif

-- Assumption: Integer is strictly positive,
-- otherwise return -1# arbitrarily
-- Going up in word-sized steps should not be too bad.
integerLog2# :: Integer -> Int#
integerLog2# (Positive digits) = step 0# digits
  where
    step acc (Some dig None) = acc +# wordLog2# dig
    step acc (Some _ digs)   =
        step (acc +# WORD_SIZE_IN_BITS#) digs
    step acc None = acc     -- should be impossible, throw error?
integerLog2# _ = negateInt# 1#

-- Again, integer should be strictly positive
integerLog2IsPowerOf2# :: Integer -> (# Int#, Int# #)
integerLog2IsPowerOf2# (Positive digits) = couldBe 0# digits
  where
    couldBe acc (Some dig None) =
        (# acc +# wordLog2# dig, word2Int# (and# dig (minusWord# dig 1##)) #)
    couldBe acc (Some dig digs) =
        if isTrue# (eqWord# dig 0##)
           then couldBe (acc +# WORD_SIZE_IN_BITS#) digs
           else noPower (acc +# WORD_SIZE_IN_BITS#) digs
    couldBe acc None = (# acc, 1# #) -- should be impossible, error?
    noPower acc (Some dig None) =
        (# acc +# wordLog2# dig, 1# #)
    noPower acc (Some _ digs)   =
        noPower (acc +# WORD_SIZE_IN_BITS#) digs
    noPower acc None = (# acc, 1# #) -- should be impossible, error?
integerLog2IsPowerOf2# _ = (# negateInt# 1#, 1# #)

-- Assumption: Integer and Int# are strictly positive, Int# is less
-- than logBase 2 of Integer, otherwise havoc ensues.
-- Used only for the numerator in fromRational when the denominator
-- is a power of 2.
-- The Int# argument is log2 n minus the number of bits in the mantissa
-- of the target type, i.e. the index of the first non-integral bit in
-- the quotient.
--
-- 0# means round down (towards zero)
-- 1# means we have a half-integer, round to even
-- 2# means round up (away from zero)
-- This function should probably be improved.
roundingMode# :: Integer -> Int# -> Int#
roundingMode# m h =
    case oneInteger `shiftLInteger` h of
      c -> case m `andInteger`
                ((c `plusInteger` c) `minusInteger` oneInteger) of
             r ->
               if c `ltInteger` r
                 then 2#
                 else if c `gtInteger` r
                        then 0#
                        else 1#

-- Lookup table
data BA = BA ByteArray#

leadingZeros :: BA
leadingZeros =
    let mkArr s =
          case newByteArray# 256# s of
            (# s1, mba #) ->
              case writeInt8Array# mba 0# 9# s1 of
                s2 ->
                  let fillA lim val idx st =
                        if isTrue# (idx ==# 256#)
                          then st
                          else if isTrue# (idx <# lim)
                                then case writeInt8Array# mba idx val st of
                                        nx -> fillA lim val (idx +# 1#) nx
                                else fillA (2# *# lim) (val -# 1#) idx st
                  in case fillA 2# 8# 1# s2 of
                      s3 -> case unsafeFreezeByteArray# mba s3 of
                              (# _, ba #) -> ba
    in case mkArr realWorld# of
        b -> BA b


{-# LANGUAGE NoImplicitPrelude #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  GHC.Integer.Simple.Internals
-- Copyright   :  (c) Ian Lynagh 2007-2008
-- License     :  BSD3
--
-- Maintainer  :  igloo@earth.li
-- Stability   :  internal
-- Portability :  non-portable (GHC Extensions)
--
-- A simple definition of the 'Integer' type.
--
-----------------------------------------------------------------------------

module GHC.Integer.Simple.Internals (
    module GHC.Integer.Type
 ) where

import GHC.Integer.Type


{-# LANGUAGE CPP, GADTs, OverloadedStrings #-}

{-
This is the proxy portion of iserv.

It acts as local bridge for GHC to call
a remote slave. This all might sound
confusing, so let's try to get some
naming down.

GHC is the actual Haskell compiler, that
acts as frontend to the code to be compiled.

iserv is the slave, that GHC delegates compilation
of TH to. As such it needs to be compiled for
and run on the Target. In the special case
where the Host and the Target are the same,
no proxy is needed. GHC and iserv communicate
via pipes.

iserv-proxy is the proxy instance to iserv.
The following illustration should make this
somewhat clear:

 .----- Host -----.     .- Target -.
 | GHC <--> proxy<+-----+>  iserv  |
 '----------------'  ^  '----------'
        ^            |
        |            '-- communication via sockets
        '--- communication via pipes

For now, we won't support multiple concurrent
invocations of the proxy instance, and that
behavior will be undefined, as this largely
depends on the capability of the iserv on the
target to spawn multiple process.  Spawning
multiple threads won't be sufficient, as the
GHC runtime has global state.

Also the GHC runtime needs to be able to
use the linker on the Target to link archives
and object files.

-}

module Main (main) where

import System.IO
import GHCi.Message
import GHCi.Utils
import GHCi.Signals

import Remote.Message

import Network.Socket
import Data.IORef
import Control.Monad
import System.Environment
import System.Exit
import Text.Printf
import GHC.Fingerprint (getFileHash)
import System.Directory
import System.FilePath (isAbsolute)

import Data.Binary
import qualified Data.ByteString as BS

dieWithUsage :: IO a
dieWithUsage = do
    prog <- getProgName
    die $ prog ++ ": " ++ msg
  where
#if defined(WINDOWS)
    msg = "usage: iserv <write-handle> <read-handle> <slave ip> [-v]"
#else
    msg = "usage: iserv <write-fd> <read-fd> <slave ip> [-v]"
#endif

main :: IO ()
main = do
  args <- getArgs
  (wfd1, rfd2, host_ip, port, rest) <-
      case args of
        arg0:arg1:arg2:arg3:rest -> do
            let wfd1 = read arg0
                rfd2 = read arg1
                ip   = arg2
                port = read arg3
            return (wfd1, rfd2, ip, port, rest)
        _ -> dieWithUsage

  verbose <- case rest of
    ["-v"] -> return True
    []     -> return False
    _      -> dieWithUsage

  when verbose $
    printf "GHC iserv starting (in: %d; out: %d)\n"
      (fromIntegral rfd2 :: Int) (fromIntegral wfd1 :: Int)
  inh  <- getGhcHandle rfd2
  outh <- getGhcHandle wfd1
  installSignalHandlers
  lo_ref <- newIORef Nothing
  let in_pipe = Pipe{pipeRead = inh, pipeWrite = outh, pipeLeftovers = lo_ref}

  when verbose $
    putStrLn ("Trying to connect to " ++ host_ip ++ ":" ++ (show port))
  out_pipe <- connectTo host_ip port >>= socketToPipe

  when verbose $
    putStrLn "Starting proxy"
  proxy verbose in_pipe out_pipe

-- | A hook, to transform outgoing (proxy -> slave)
-- messages prior to sending them to the slave.
hook :: Msg -> IO Msg
hook = return

-- | Forward a single @THMessage@ from the slave
-- to ghc, and read back the result from GHC.
--
--  @Message@s go from ghc to the slave.
--    ghc --- proxy --> slave               (@Message@)
--  @THMessage@s go from the slave to ghc
--    ghc <-- proxy --- slave               (@THMessage@)
--
fwdTHMsg :: (Binary a) => Pipe -> THMessage a -> IO a
fwdTHMsg local msg = do
  writePipe local (putTHMessage msg)
  readPipe local get

-- | Fowarard a @Message@ call and handle @THMessages@.
fwdTHCall :: (Binary a) => Bool -> Pipe -> Pipe -> Message a -> IO a
fwdTHCall verbose local remote msg = do
  writePipe remote (putMessage msg)
  -- wait for control instructions
  loopTH
  readPipe remote get
    where
      loopTH :: IO ()
      loopTH = do
        THMsg msg' <- readPipe remote getTHMessage
        when verbose $
          putStrLn ("| TH Msg: ghc <- proxy -- slave: " ++ show msg')
        res <- fwdTHMsg local msg'
        when verbose $
          putStrLn ("| Resp.:  ghc -- proxy -> slave: " ++ show res)
        writePipe remote (put res)
        case msg' of
          RunTHDone -> return ()
          _         -> loopTH

-- | Forwards a @Message@ call, and handle @SlaveMessage@.
-- Similar to @THMessages@, but @SlaveMessage@ are between
-- the slave and the proxy, and are not forwarded to ghc.
-- These message allow the Slave to query the proxy for
-- files.
--
--  ghc --- proxy --> slave  (@Message@)
--
--          proxy <-- slave  (@SlaveMessage@)
--
fwdLoadCall :: (Binary a, Show a) => Bool -> Pipe -> Pipe -> Message a -> IO a
fwdLoadCall verbose _ remote msg = do
  writePipe remote (putMessage msg)
  loopLoad
  readPipe remote get
  where
    truncateMsg :: Int -> String -> String
    truncateMsg n s | length s > n = take n s ++ "..."
                    | otherwise    = s
    reply :: (Binary a, Show a) => a -> IO ()
    reply m = do
      when verbose $
        putStrLn ("| Resp.:         proxy -> slave: "
                  ++ truncateMsg 80 (show m))
      writePipe remote (put m)
    loopLoad :: IO ()
    loopLoad = do
      SlaveMsg msg' <- readPipe remote getSlaveMessage
      when verbose $
        putStrLn ("| Sl Msg:        proxy <- slave: " ++ show msg')
      case msg' of
        Done -> return ()
        Missing path -> do
          reply =<< BS.readFile path
          loopLoad
        Have path remoteHash -> do
          localHash <- getFileHash path
          reply =<< if localHash == remoteHash
                    then return Nothing
                    else Just <$> BS.readFile path
          loopLoad

-- | The actual proxy. Conntect local and remote pipe,
-- and does some message handling.
proxy :: Bool -> Pipe -> Pipe -> IO ()
proxy verbose local remote = loop
  where
    fwdCall :: (Binary a, Show a) => Message a -> IO a
    fwdCall msg = do
      writePipe remote (putMessage msg)
      readPipe remote get

    -- reply to ghc.
    reply :: (Show a, Binary a) => a -> IO ()
    reply msg = do
      when verbose $
        putStrLn ("Resp.:    ghc <- proxy -- slave: " ++ show msg)
      writePipe local (put msg)

    loop = do
      (Msg msg) <- readPipe local getMessage
      when verbose $
        putStrLn ("Msg:      ghc -- proxy -> slave: " ++ show msg)
      (Msg msg') <- hook (Msg msg)
      case msg' of
        -- TH might send some message back to ghc.
        RunTH{} -> do
          resp <- fwdTHCall verbose local remote msg'
          reply resp
          loop
        RunModFinalizers{} -> do
          resp <- fwdTHCall verbose local remote msg'
          reply resp
          loop
        -- Load messages might send some messages back to the proxy, to
        -- requrest files that are not present on the device.
        LoadArchive{} -> do
          resp <- fwdLoadCall verbose local remote msg'
          reply resp
          loop
        LoadObj{} -> do
          resp <- fwdLoadCall verbose local remote msg'
          reply resp
          loop
        LoadDLL path | isAbsolute path -> do
          resp <- fwdLoadCall verbose local remote msg'
          reply resp
          loop
        Shutdown{}    -> fwdCall msg' >> return ()
        _other        -> fwdCall msg' >>= reply >> loop

connectTo :: String -> PortNumber -> IO Socket
connectTo host port = do
  let hints = defaultHints { addrFlags = [AI_NUMERICHOST, AI_NUMERICSERV]
                           , addrSocketType = Stream }
  addr:_ <- getAddrInfo (Just hints) (Just host) (Just (show port))
  sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)
  putStrLn $ "Created socket for " ++ host ++ ":" ++ show port
  connect sock (addrAddress addr)
  putStrLn "connected"
  return sock

-- | Turn a socket into an unbuffered pipe.
socketToPipe :: Socket -> IO Pipe
socketToPipe sock = do
  hdl <- socketToHandle sock ReadWriteMode
  hSetBuffering hdl NoBuffering

  lo_ref <- newIORef Nothing
  pure Pipe{ pipeRead = hdl, pipeWrite = hdl, pipeLeftovers = lo_ref }


{-# LANGUAGE RankNTypes, RecordWildCards, GADTs, ScopedTypeVariables #-}
module Lib (serv) where

import GHCi.Run
import GHCi.TH
import GHCi.Message

import Control.DeepSeq
import Control.Exception
import Control.Monad
import Data.Binary

import Text.Printf
import System.Environment (getProgName)

type MessageHook = Msg -> IO Msg

trace :: String -> IO ()
trace s = getProgName >>= \name -> printf "[%20s] %s\n" name s

serv :: Bool -> MessageHook -> Pipe -> (forall a .IO a -> IO a) -> IO ()
serv verbose hook pipe restore = loop
 where
  loop = do
    when verbose $ trace "reading pipe..."
    Msg msg <- readPipe pipe getMessage >>= hook

    discardCtrlC

    when verbose $ trace ("msg: " ++ (show msg))
    case msg of
      Shutdown -> return ()
      RunTH st q ty loc -> wrapRunTH $ runTH pipe st q ty loc
      RunModFinalizers st qrefs -> wrapRunTH $ runModFinalizerRefs pipe st qrefs
      _other -> run msg >>= reply

  reply :: forall a. (Binary a, Show a) => a -> IO ()
  reply r = do
    when verbose $ trace ("writing pipe: " ++ show r)
    writePipe pipe (put r)
    loop

  -- Run some TH code, which may interact with GHC by sending
  -- THMessage requests, and then finally send RunTHDone followed by a
  -- QResult.  For an overview of how TH works with Remote GHCi, see
  -- Note [Remote Template Haskell] in libraries/ghci/GHCi/TH.hs.
  wrapRunTH :: forall a. (Binary a, Show a) => IO a -> IO ()
  wrapRunTH io = do
    when verbose $ trace "wrapRunTH..."
    r <- try io
    when verbose $ trace "wrapRunTH done."
    when verbose $ trace "writing RunTHDone."
    writePipe pipe (putTHMessage RunTHDone)
    case r of
      Left e
        | Just (GHCiQException _ err) <- fromException e  -> do
           when verbose $ trace ("QFail " ++ show err)
           reply (QFail err :: QResult a)
        | otherwise -> do
           str <- showException e
           when verbose $ trace ("QException " ++ str)
           reply (QException str :: QResult a)
      Right a -> do
        when verbose $ trace "QDone"
        reply (QDone a)

  -- carefully when showing an exception, there might be other exceptions
  -- lurking inside it.  If so, we return the inner exception instead.
  showException :: SomeException -> IO String
  showException e0 = do
     when verbose $ trace "showException"
     r <- try $ evaluate (force (show (e0::SomeException)))
     case r of
       Left e -> showException e
       Right str -> return str

  -- throw away any pending ^C exceptions while we're not running
  -- interpreted code.  GHC will also get the ^C, and either ignore it
  -- (if this is GHCi), or tell us to quit with a Shutdown message.
  discardCtrlC = do
    when verbose $ trace "discardCtrlC"
    r <- try $ restore $ return ()
    case r of
      Left UserInterrupt -> return () >> discardCtrlC
      Left e -> throwIO e
      _ -> return ()


{-# LANGUAGE GADTs, StandaloneDeriving, ExistentialQuantification #-}

module Remote.Message
  ( SlaveMessage(..)
  , SlaveMsg(..)
  , putSlaveMessage
  , getSlaveMessage )
where

import GHC.Fingerprint (Fingerprint)
import Data.Binary
import Data.ByteString (ByteString)

-- | A @SlaveMessage a@ is message from the iserv process on the
-- target, requesting something from the Proxy of with result type @a@.
data SlaveMessage a where
  -- sends either a new file, or nothing if the file is acceptable.
  Have     :: FilePath -> Fingerprint -> SlaveMessage (Maybe ByteString)
  Missing  :: FilePath -> SlaveMessage ByteString
  Done     :: SlaveMessage ()

deriving instance Show (SlaveMessage a)

putSlaveMessage :: SlaveMessage a -> Put
putSlaveMessage m = case m of
  Have path sha  -> putWord8 0 >> put path >> put sha
  Missing path   -> putWord8 1 >> put path
  Done           -> putWord8 2

data SlaveMsg = forall a . (Binary a, Show a) => SlaveMsg (SlaveMessage a)

getSlaveMessage :: Get SlaveMsg
getSlaveMessage = do
  b <- getWord8
  case b of
    0 -> SlaveMsg <$> (Have   <$> get <*> get)
    1 -> SlaveMsg <$> Missing <$> get
    2 -> return (SlaveMsg Done)


{-# LANGUAGE ForeignFunctionInterface, GADTs, LambdaCase #-}
module Remote.Slave where

import Network.Socket

import Lib (serv)
import Remote.Message

import System.IO
import Control.Exception
import Control.Concurrent
import Control.Monad (when, forever)
import System.Directory
import System.FilePath (takeDirectory, (</>), dropTrailingPathSeparator,
                        isAbsolute, joinPath, splitPath)
import GHCi.ResolvedBCO

import Data.IORef
import GHCi.Message (Pipe(..), Msg(..), Message(..), readPipe, writePipe)

import Foreign.C.String

import Data.Binary
import GHC.Fingerprint (getFileHash)

import qualified Data.ByteString as BS

import Text.Printf
import System.Environment (getProgName)

trace :: String -> IO ()
trace s = getProgName >>= \name -> printf "[%20s] %s\n" name s

dropLeadingPathSeparator :: FilePath -> FilePath
dropLeadingPathSeparator p | isAbsolute p = joinPath (drop 1 (splitPath p))
                           | otherwise    = p

-- | Path concatenation that prevents a double path separator to appear in the
-- final path. "/foo/bar/" <//> "/baz/quux" == "/foo/bar/baz/quux"
(<//>) :: FilePath -> FilePath -> FilePath
lhs <//> rhs = dropTrailingPathSeparator lhs </> dropLeadingPathSeparator rhs
infixr 5 <//>

foreign export ccall startSlave :: Bool -> Int -> CString -> IO ()

-- | @startSlave@ is the exported slave function, that the
-- hosting application on the target needs to invoce to
-- start the slave process, and runs iserv.
startSlave :: Bool -> Int -> CString -> IO ()
startSlave verbose port s = do
  base_path <- peekCString s
  trace $ "DocRoot: " ++ base_path
  _ <- forkIO $ startSlave' verbose base_path (toEnum port)
  return ()

-- | @startSlave'@ provdes a blocking haskell interface, that
-- the hosting application on the target can use to start the
-- slave process.
startSlave' :: Bool -> String -> PortNumber -> IO ()
startSlave' verbose base_path port = do
  hSetBuffering stdin LineBuffering
  hSetBuffering stdout LineBuffering

  sock <- openSocket port

  forever $ do
    when verbose $ trace "Opening socket"
    pipe <- acceptSocket sock >>= socketToPipe
    putStrLn $ "Listening on port " ++ show port
    when verbose $ trace "Starting serv"
    uninterruptibleMask $ serv verbose (hook verbose base_path pipe) pipe
    when verbose $ trace "serv ended"
    return ()

-- | The iserv library may need access to files, specifically
-- archives and object files to be linked. If ghc and the slave
-- are on the same host, this is trivial, as the underlying
-- filestorage is the same.  If however the slave does not run
-- on the same host, the filestorage is not identical and we
-- need to request data from the host where ghc runs on.
--
-- If we however already have the requested file we need to make
-- sure that this file is the same one ghc sees. Hence we
-- calculate the Fingerprint of the file and send it back to the
-- host for comparison. The proxy will then send back either @Nothing@
-- indicating that the file on the host has the same Fingerprint, or
-- Maybe ByteString containing the payload to replace the existing
-- file with.
handleLoad :: Pipe -> FilePath -> FilePath -> IO ()
handleLoad pipe path localPath = do
  exists <- doesFileExist localPath
  if exists
    then getFileHash localPath >>= \hash -> proxyCall (Have path hash) >>= \case
      Nothing -> return ()
      Just bs -> BS.writeFile localPath bs
    else do
      createDirectoryIfMissing True (takeDirectory localPath)
      resp <- proxyCall (Missing path)
      BS.writeFile localPath resp

  proxyCall Done
  where
    proxyCall :: (Binary a, Show a) => SlaveMessage a -> IO a
    proxyCall msg = do
      writePipe pipe (putSlaveMessage msg)
      readPipe pipe get

-- | The hook we install in the @serv@ function from the
-- iserv library, to request archives over the wire.
hook :: Bool -> String -> Pipe -> Msg -> IO Msg
hook verbose base_path pipe m = case m of
  Msg (AddLibrarySearchPath p) -> do
    when verbose $ putStrLn ("Need Path: " ++ (base_path <//> p))
    createDirectoryIfMissing True (base_path <//> p)
    return $ Msg (AddLibrarySearchPath (base_path <//> p))
  Msg (LoadObj path) -> do
    when verbose $ putStrLn ("Need Obj: " ++ (base_path <//> path))
    handleLoad pipe path (base_path <//> path)
    return $ Msg (LoadObj (base_path <//> path))
  Msg (LoadArchive path) -> do
    handleLoad pipe path (base_path <//> path)
    return $ Msg (LoadArchive (base_path <//> path))
  -- when loading DLLs (.so, .dylib, .dll, ...) and these are provided
  -- as relative paths, the intention is to load a pre-existing system library,
  -- therefore we hook the LoadDLL call only for absolute paths to ship the
  -- dll from the host to the target.  On windows we assume that we don't
  -- want to copy libraries that are referenced in C:\ these are usually
  -- system libraries.
  Msg (LoadDLL path@('C':':':_)) -> do
    return m
  Msg (LoadDLL path) | isAbsolute path -> do
    when verbose $ trace ("Need DLL: " ++ (base_path <//> path))
    handleLoad pipe path (base_path <//> path)
    return $ Msg (LoadDLL (base_path <//> path))
  _other -> return m

--------------------------------------------------------------------------------
-- socket to pipe briding logic.
socketToPipe :: Socket -> IO Pipe
socketToPipe sock = do
  hdl <- socketToHandle sock ReadWriteMode
  hSetBuffering hdl NoBuffering

  lo_ref <- newIORef Nothing
  pure Pipe{ pipeRead = hdl, pipeWrite = hdl, pipeLeftovers = lo_ref }

openSocket :: PortNumber -> IO Socket
openSocket port = do
  sock <- socket AF_INET Stream 0
  setSocketOption sock ReuseAddr 1
  bind sock (SockAddrInet port iNADDR_ANY)
  listen sock 1
  return sock

acceptSocket :: Socket -> IO Socket
acceptSocket = fmap fst . accept


module Main (main) where

import Distribution.Simple

main :: IO ()
main = defaultMain


{- | The public face of Template Haskell

For other documentation, refer to:
<http://www.haskell.org/haskellwiki/Template_Haskell>

-}
module Language.Haskell.TH(
        -- * The monad and its operations
        Q,
        runQ,
        -- ** Administration: errors, locations and IO
        reportError,              -- :: String -> Q ()
        reportWarning,            -- :: String -> Q ()
        report,                   -- :: Bool -> String -> Q ()
        recover,          -- :: Q a -> Q a -> Q a
        location,         -- :: Q Loc
        Loc(..),
        runIO,            -- :: IO a -> Q a
        -- ** Querying the compiler
        -- *** Reify
        reify,            -- :: Name -> Q Info
        reifyModule,
        Info(..), ModuleInfo(..),
        InstanceDec,
        ParentName,
        SumAlt, SumArity,
        Arity,
        Unlifted,
        -- *** Language extension lookup
        Extension(..),
        extsEnabled, isExtEnabled,
        -- *** Name lookup
        lookupTypeName,  -- :: String -> Q (Maybe Name)
        lookupValueName, -- :: String -> Q (Maybe Name)
        -- *** Fixity lookup
        reifyFixity,
        -- *** Instance lookup
        reifyInstances,
        isInstance,
        -- *** Roles lookup
        reifyRoles,
        -- *** Annotation lookup
        reifyAnnotations, AnnLookup(..),
        -- *** Constructor strictness lookup
        reifyConStrictness,

        -- * Typed expressions
        TExp, unType,

        -- * Names
        Name, NameSpace,        -- Abstract
        -- ** Constructing names
        mkName,         -- :: String -> Name
        newName,        -- :: String -> Q Name
        -- ** Deconstructing names
        nameBase,       -- :: Name -> String
        nameModule,     -- :: Name -> Maybe String
        namePackage,    -- :: Name -> Maybe String
        nameSpace,      -- :: Name -> Maybe NameSpace
        -- ** Built-in names
        tupleTypeName, tupleDataName,   -- Int -> Name
        unboxedTupleTypeName, unboxedTupleDataName, -- :: Int -> Name
        unboxedSumTypeName, -- :: SumArity -> Name
        unboxedSumDataName, -- :: SumAlt -> SumArity -> Name

    -- * The algebraic data types
    -- | The lowercase versions (/syntax operators/) of these constructors are
    -- preferred to these constructors, since they compose better with
    -- quotations (@[| |]@) and splices (@$( ... )@)

    -- ** Declarations
        Dec(..), Con(..), Clause(..),
        SourceUnpackedness(..), SourceStrictness(..), DecidedStrictness(..),
        Bang(..), Strict, Foreign(..), Callconv(..), Safety(..), Pragma(..),
        Inline(..), RuleMatch(..), Phases(..), RuleBndr(..), AnnTarget(..),
        FunDep(..), TySynEqn(..), TypeFamilyHead(..),
        Fixity(..), FixityDirection(..), defaultFixity, maxPrecedence,
        PatSynDir(..), PatSynArgs(..),
    -- ** Expressions
        Exp(..), Match(..), Body(..), Guard(..), Stmt(..), Range(..), Lit(..),
    -- ** Patterns
        Pat(..), FieldExp, FieldPat,
    -- ** Types
        Type(..), TyVarBndr(..), TyLit(..), Kind, Cxt, Pred, Syntax.Role(..),
        FamilyResultSig(..), Syntax.InjectivityAnn(..), PatSynType,

    -- * Library functions
    module Language.Haskell.TH.Lib,

    -- * Pretty-printer
    Ppr(..), pprint, pprExp, pprLit, pprPat, pprParendType

   ) where

import Language.Haskell.TH.Syntax as Syntax
import Language.Haskell.TH.Lib
import Language.Haskell.TH.Ppr


-----------------------------------------------------------------------------
-- |
-- Module      :  Language.Haskell.TH.LanguageExtensions
-- Copyright   :  (c) The University of Glasgow 2015
-- License     :  BSD-style (see the file libraries/base/LICENSE)
--
-- Maintainer  :  libraries@haskell.org
-- Stability   :  experimental
-- Portability :  portable
--
-- Language extensions known to GHC
--
-----------------------------------------------------------------------------

module Language.Haskell.TH.LanguageExtensions
   ( Extension(..)
   ) where

-- This module exists primarily to avoid inserting a massive list of language
-- extensions into the already quite large Haddocks for Language.Haskell.TH

import GHC.LanguageExtensions.Type (Extension(..))


-- |
-- Language.Haskell.TH.Lib contains lots of useful helper functions for
-- generating and manipulating Template Haskell terms

-- Note: this module mostly re-exports functions from
-- Language.Haskell.TH.Lib.Internal, but if a change occurs to Template
-- Haskell which requires breaking the API offered in this module, we opt to
-- copy the old definition here, and make the changes in
-- Language.Haskell.TH.Lib.Internal. This way, we can retain backwards
-- compatibility while still allowing GHC to make changes as it needs.

module Language.Haskell.TH.Lib (
    -- All of the exports from this module should
    -- be "public" functions.  The main module TH
    -- re-exports them all.

    -- * Library functions
    -- ** Abbreviations
        InfoQ, ExpQ, TExpQ, DecQ, DecsQ, ConQ, TypeQ, KindQ, TyVarBndrQ,
        TyLitQ, CxtQ, PredQ, DerivClauseQ, MatchQ, ClauseQ, BodyQ, GuardQ,
        StmtQ, RangeQ, SourceStrictnessQ, SourceUnpackednessQ, BangQ,
        BangTypeQ, VarBangTypeQ, StrictTypeQ, VarStrictTypeQ, FieldExpQ, PatQ,
        FieldPatQ, RuleBndrQ, TySynEqnQ, PatSynDirQ, PatSynArgsQ,
        FamilyResultSigQ, DerivStrategyQ,

    -- ** Constructors lifted to 'Q'
    -- *** Literals
        intPrimL, wordPrimL, floatPrimL, doublePrimL, integerL, rationalL,
        charL, stringL, stringPrimL, charPrimL,
    -- *** Patterns
        litP, varP, tupP, unboxedTupP, unboxedSumP, conP, uInfixP, parensP,
        infixP, tildeP, bangP, asP, wildP, recP,
        listP, sigP, viewP,
        fieldPat,

    -- *** Pattern Guards
        normalB, guardedB, normalG, normalGE, patG, patGE, match, clause,

    -- *** Expressions
        dyn, varE, unboundVarE, labelE, implicitParamVarE, conE, litE, staticE,
        appE, appTypeE, uInfixE, parensE, infixE, infixApp, sectionL, sectionR,
        lamE, lam1E, lamCaseE, tupE, unboxedTupE, unboxedSumE, condE, multiIfE,
        letE, caseE, appsE, listE, sigE, recConE, recUpdE, stringE, fieldExp,
    -- **** Ranges
    fromE, fromThenE, fromToE, fromThenToE,

    -- ***** Ranges with more indirection
    arithSeqE,
    fromR, fromThenR, fromToR, fromThenToR,
    -- **** Statements
    doE, mdoE, compE,
    bindS, letS, noBindS, parS, recS,

    -- *** Types
        forallT, forallVisT, varT, conT, appT, appKindT, arrowT, infixT,
        uInfixT, parensT, equalityT, listT, tupleT, unboxedTupleT, unboxedSumT,
        sigT, litT, wildCardT, promotedT, promotedTupleT, promotedNilT,
        promotedConsT, implicitParamT,
    -- **** Type literals
    numTyLit, strTyLit,
    -- **** Strictness
    noSourceUnpackedness, sourceNoUnpack, sourceUnpack,
    noSourceStrictness, sourceLazy, sourceStrict,
    isStrict, notStrict, unpacked,
    bang, bangType, varBangType, strictType, varStrictType,
    -- **** Class Contexts
    cxt, classP, equalP,
    -- **** Constructors
    normalC, recC, infixC, forallC, gadtC, recGadtC,

    -- *** Kinds
    varK, conK, tupleK, arrowK, listK, appK, starK, constraintK,

    -- *** Type variable binders
    plainTV, kindedTV,

    -- *** Roles
    nominalR, representationalR, phantomR, inferR,

    -- *** Top Level Declarations
    -- **** Data
    valD, funD, tySynD, dataD, newtypeD,
    derivClause, DerivClause(..),
    stockStrategy, anyclassStrategy, newtypeStrategy,
    viaStrategy, DerivStrategy(..),
    -- **** Class
    classD, instanceD, instanceWithOverlapD, Overlap(..),
    sigD, standaloneDerivD, standaloneDerivWithStrategyD, defaultSigD,

    -- **** Role annotations
    roleAnnotD,
    -- **** Type Family / Data Family
    dataFamilyD, openTypeFamilyD, closedTypeFamilyD, dataInstD,
    newtypeInstD, tySynInstD,
    tySynEqn, injectivityAnn, noSig, kindSig, tyVarSig,

    -- **** Fixity
    infixLD, infixRD, infixND,

    -- **** Foreign Function Interface (FFI)
    cCall, stdCall, cApi, prim, javaScript,
    unsafe, safe, interruptible, forImpD,

    -- **** Functional dependencies
    funDep,

    -- **** Pragmas
    ruleVar, typedRuleVar,
    valueAnnotation, typeAnnotation, moduleAnnotation,
    pragInlD, pragSpecD, pragSpecInlD, pragSpecInstD, pragRuleD, pragAnnD,
    pragLineD, pragCompleteD,

    -- **** Pattern Synonyms
    patSynD, patSynSigD, unidir, implBidir, explBidir, prefixPatSyn,
    infixPatSyn, recordPatSyn,

    -- **** Implicit Parameters
    implicitParamBindD,

    -- ** Reify
    thisModule

   ) where

import Language.Haskell.TH.Lib.Internal hiding
  ( tySynD
  , dataD
  , newtypeD
  , classD
  , pragRuleD
  , dataInstD
  , newtypeInstD
  , dataFamilyD
  , openTypeFamilyD
  , closedTypeFamilyD
  , tySynEqn
  , forallC

  , forallT
  , sigT

  , plainTV
  , kindedTV
  , starK
  , constraintK

  , noSig
  , kindSig
  , tyVarSig

  , derivClause
  , standaloneDerivWithStrategyD

  , Role
  , InjectivityAnn
  )
import Language.Haskell.TH.Syntax

import Control.Monad (liftM2)
import Prelude

-- All definitions below represent the "old" API, since their definitions are
-- different in Language.Haskell.TH.Lib.Internal. Please think carefully before
-- deciding to change the APIs of the functions below, as they represent the
-- public API (as opposed to the Internal module, which has no API promises.)

-------------------------------------------------------------------------------
-- *   Dec

tySynD :: Name -> [TyVarBndr] -> TypeQ -> DecQ
tySynD tc tvs rhs = do { rhs1 <- rhs; return (TySynD tc tvs rhs1) }

dataD :: CxtQ -> Name -> [TyVarBndr] -> Maybe Kind -> [ConQ] -> [DerivClauseQ]
      -> DecQ
dataD ctxt tc tvs ksig cons derivs =
  do
    ctxt1 <- ctxt
    cons1 <- sequence cons
    derivs1 <- sequence derivs
    return (DataD ctxt1 tc tvs ksig cons1 derivs1)

newtypeD :: CxtQ -> Name -> [TyVarBndr] -> Maybe Kind -> ConQ -> [DerivClauseQ]
         -> DecQ
newtypeD ctxt tc tvs ksig con derivs =
  do
    ctxt1 <- ctxt
    con1 <- con
    derivs1 <- sequence derivs
    return (NewtypeD ctxt1 tc tvs ksig con1 derivs1)

classD :: CxtQ -> Name -> [TyVarBndr] -> [FunDep] -> [DecQ] -> DecQ
classD ctxt cls tvs fds decs =
  do
    decs1 <- sequence decs
    ctxt1 <- ctxt
    return $ ClassD ctxt1 cls tvs fds decs1

pragRuleD :: String -> [RuleBndrQ] -> ExpQ -> ExpQ -> Phases -> DecQ
pragRuleD n bndrs lhs rhs phases
  = do
      bndrs1 <- sequence bndrs
      lhs1   <- lhs
      rhs1   <- rhs
      return $ PragmaD $ RuleP n Nothing bndrs1 lhs1 rhs1 phases

dataInstD :: CxtQ -> Name -> [TypeQ] -> Maybe Kind -> [ConQ] -> [DerivClauseQ]
          -> DecQ
dataInstD ctxt tc tys ksig cons derivs =
  do
    ctxt1 <- ctxt
    ty1 <- foldl appT (conT tc) tys
    cons1 <- sequence cons
    derivs1 <- sequence derivs
    return (DataInstD ctxt1 Nothing ty1 ksig cons1 derivs1)

newtypeInstD :: CxtQ -> Name -> [TypeQ] -> Maybe Kind -> ConQ -> [DerivClauseQ]
             -> DecQ
newtypeInstD ctxt tc tys ksig con derivs =
  do
    ctxt1 <- ctxt
    ty1 <- foldl appT (conT tc) tys
    con1  <- con
    derivs1 <- sequence derivs
    return (NewtypeInstD ctxt1 Nothing ty1 ksig con1 derivs1)

dataFamilyD :: Name -> [TyVarBndr] -> Maybe Kind -> DecQ
dataFamilyD tc tvs kind
    = return $ DataFamilyD tc tvs kind

openTypeFamilyD :: Name -> [TyVarBndr] -> FamilyResultSig
                -> Maybe InjectivityAnn -> DecQ
openTypeFamilyD tc tvs res inj
    = return $ OpenTypeFamilyD (TypeFamilyHead tc tvs res inj)

closedTypeFamilyD :: Name -> [TyVarBndr] -> FamilyResultSig
                  -> Maybe InjectivityAnn -> [TySynEqnQ] -> DecQ
closedTypeFamilyD tc tvs result injectivity eqns =
  do eqns1 <- sequence eqns
     return (ClosedTypeFamilyD (TypeFamilyHead tc tvs result injectivity) eqns1)

tySynEqn :: (Maybe [TyVarBndr]) -> TypeQ -> TypeQ -> TySynEqnQ
tySynEqn tvs lhs rhs =
  do
    lhs1 <- lhs
    rhs1 <- rhs
    return (TySynEqn tvs lhs1 rhs1)

forallC :: [TyVarBndr] -> CxtQ -> ConQ -> ConQ
forallC ns ctxt con = liftM2 (ForallC ns) ctxt con

-------------------------------------------------------------------------------
-- *   Type

forallT :: [TyVarBndr] -> CxtQ -> TypeQ -> TypeQ
forallT tvars ctxt ty = do
    ctxt1 <- ctxt
    ty1   <- ty
    return $ ForallT tvars ctxt1 ty1

sigT :: TypeQ -> Kind -> TypeQ
sigT t k
  = do
      t' <- t
      return $ SigT t' k

-------------------------------------------------------------------------------
-- *   Kind

plainTV :: Name -> TyVarBndr
plainTV = PlainTV

kindedTV :: Name -> Kind -> TyVarBndr
kindedTV = KindedTV

starK :: Kind
starK = StarT

constraintK :: Kind
constraintK = ConstraintT

-------------------------------------------------------------------------------
-- *   Type family result

noSig :: FamilyResultSig
noSig = NoSig

kindSig :: Kind -> FamilyResultSig
kindSig = KindSig

tyVarSig :: TyVarBndr -> FamilyResultSig
tyVarSig = TyVarSig

-------------------------------------------------------------------------------
-- * Top Level Declarations

derivClause :: Maybe DerivStrategy -> [PredQ] -> DerivClauseQ
derivClause mds p = do
  p' <- cxt p
  return $ DerivClause mds p'

standaloneDerivWithStrategyD :: Maybe DerivStrategy -> CxtQ -> TypeQ -> DecQ
standaloneDerivWithStrategyD mds ctxt ty = do
  ctxt' <- ctxt
  ty'   <- ty
  return $ StandaloneDerivD mds ctxt' ty'