text:
module Statistics.Quantile.Util where

import Pipes
import qualified Pipes.Prelude as P

import Statistics.Quantile.Types
import System.IO

tmpDir :: FilePath
tmpDir = "/var/tmp/"

selectFromHandle :: Quantile
                 -> Selector IO
                 -> Handle
                 -> IO Double
selectFromHandle q (Selector select) hin = do
  select q $ streamHandle hin

streamHandle :: Handle -> Stream IO
streamHandle hin = Stream (P.fromHandle hin >-> P.map read)

takeStream :: Int -> Stream IO -> Stream IO
takeStream n (Stream p) = Stream $ p >-> P.take n

max_stars_repo_name: fractalcat/slides

max_issues_repo_name: fractalcat/slides

max_forks_repo_name: fractalcat/slides


text:
-- example 3.20

import Statistics.Distribution
import Statistics.Distribution.Poisson

-- Let a ten-square-yard sampling region be a unit area; the mean density is 5 per square yard:
pd :: PoissonDistribution
pd = poisson 5.0

p :: Int -> Double
p = probability pd

main = do
  putStrLn $ "the probability that none of the regions will contain: P(X<1) = P(X=0): "
          ++ show (p 0)

ext: hs

max_stars_repo_name: raydsameshima/Stat

max_issues_repo_name: raydsameshima/Stat

max_forks_repo_name: raydsameshima/Stat


text:
{-# LANGUAGE FlexibleContexts #-}

-- |
-- Module    : Statistics.Sample.Normalize
-- Copyright : (c) 2017 Gregory W. Schwartz
-- License   : BSD3
--
-- Maintainer  : gsch@mail.med.upenn.edu
-- Stability   : experimental
-- Portability : portable
--
-- Functions for normalizing samples.

module Statistics.Sample.Normalize
    (
      standardize
    ) where

import Statistics.Sample
import qualified Data.Vector.Generic  as G
import qualified Data.Vector          as V
import qualified Data.Vector.Unboxed  as U
import qualified Data.Vector.Storable as S

-- | /O(n)/ Normalize a sample using standard scores:
--
--   \[ z = \frac{x - \mu}{\sigma} \]
--
--   Where μ is sample mean and σ is standard deviation computed from
--   unbiased variance estimation. If sample to small to compute σ or
--   it's equal to 0 @Nothing@ is returned.
standardize :: (G.Vector v Double) => v Double -> Maybe (v Double)
standardize xs
  | G.length xs < 2 = Nothing
  | sigma == 0      = Nothing
  | otherwise       = Just $ G.map (\x -> (x - mu) / sigma) xs
  where
    mu    = mean   xs
    sigma = stdDev xs
{-# INLINABLE  standardize #-}
{-# SPECIALIZE standardize :: V.Vector Double -> Maybe (V.Vector Double) #-}
{-# SPECIALIZE standardize :: U.Vector Double -> Maybe (U.Vector Double) #-}
{-# SPECIALIZE standardize :: S.Vector Double -> Maybe (S.Vector Double) #-}


text:
{-# OPTIONS_GHC -Wall #-}
{-# LANGUAGE BangPatterns #-}

module Numeric.MCMC.Langevin (
          MarkovChain(..), Options(..)
        , runChain
        ) where

import Control.Monad
import Control.Monad.Trans
import Control.Monad.Reader
import Control.Monad.Primitive
import Control.Arrow
import System.Random.MWC
import System.Random.MWC.Distributions
import Data.List
import Statistics.Distribution
import Statistics.Distribution.Normal hiding (standard)
import GHC.Float

-- | State of the Markov chain.  Current parameter values are held in 'theta',
--   while accepts counts the number of proposals accepted.
data MarkovChain = MarkovChain { theta   :: [Double]
                               , accepts :: {-# UNPACK #-} !Int }

-- | Options for the chain.  The target (expected to be a log density), its
--   gradient, and a step size tuning parameter.
data Options = Options { _target  :: [Double] -> Double
                       , _gTarget :: [Double] -> [Double]
                       , _eps     :: {-# UNPACK #-} !Double }

-- | A result with this type has a view of the chain options.
type ViewsOptions = ReaderT Options

-- | Display the current state.
instance Show MarkovChain where
    show config = filter (`notElem` "[]") $ show (map double2Float (theta config))

-- | Density function for an isotropic Gaussian.  The (identity) covariance
--   matrix is multiplied by the scalar 'sig'.
isoGauss :: [Double] -> [Double] -> Double -> Double
isoGauss xs mu sig = foldl1' (*) (zipWith density nds xs)
    where nds = map (`normalDistr` sig) mu
{-# INLINE isoGauss #-}

-- | Mean function for the discretized Langevin diffusion.
localMean :: Monad m
          => [Double]                -- Current state
          -> ViewsOptions m [Double] -- Localized mean
localMean t = do
    Options _ gTarget e <- ask
    return $! zipWith (+) t (map (* (0.5 * e^(2 :: Int))) (gTarget t))
{-# INLINE localMean #-}

-- | Perturb the state, creating a new proposal.
perturb :: PrimMonad m
        => [Double]                   -- Current state
        -> Gen (PrimState m)          -- MWC PRNG
        -> ViewsOptions m [Double]    -- Resulting perturbation.
perturb t g = do
    Options _ _ e <- ask
    zs    <- replicateM (length t) (lift $ standard g)
    t0    <- localMean t
    let perturbedState = zipWith (+) t0 t1
        t1 = map (* e) zs
    return $! perturbedState
{-# INLINE perturb #-}

-- | Perform a Metropolis accept/reject step.
metropolisStep :: PrimMonad m
               => MarkovChain                -- Current state
               -> Gen (PrimState m)          -- MWC PRNG
               -> ViewsOptions m MarkovChain -- New state
metropolisStep state g = do
    Options target _ e <- ask
    let (t0, nacc) = (theta &&& accepts) state
    zc           <- lift $ uniformR (0, 1) g
    proposal     <- perturb t0 g
    t0Mean       <- localMean t0
    proposalMean <- localMean proposal
    let mc = if   zc < acceptProb
             then (proposal, 1)
             else (t0,       0)

        acceptProb = if isNaN val then 0 else val where val = arRatio

        arRatio = exp . min 0 $
            target proposal + log (isoGauss proposal t0Mean (e^(2 :: Int)))
          - target t0       - log (isoGauss t0 proposalMean (e^(2 :: Int)))

    return $! MarkovChain (fst mc) (nacc + snd mc)
{-# INLINE metropolisStep #-}

-- | Diffuse through states.
runChain :: Options         -- Options of the Markov chain.
         -> Int             -- Number of epochs to iterate the chain.
         -> Int             -- Print every nth iteration
         -> MarkovChain     -- Initial state of the Markov chain.
         -> Gen RealWorld   -- MWC PRNG
         -> IO MarkovChain  -- End state of the Markov chain, wrapped in IO.
runChain = go
  where go o n t !c g | n == 0 = return c
                      | n `rem` t /= 0 = do
                            r <- runReaderT (metropolisStep c g) o
                            go o (n - 1) t r g
                      | otherwise = do
                            r <- runReaderT (metropolisStep c g) o
                            print r
                            go o (n - 1) t r g
{-# INLINE runChain #-}

max_stars_repo_name: jtobin/lazy-langevin

max_issues_repo_name: jtobin/lazy-langevin

max_forks_repo_name: jtobin/lazy-langevin


text:
module RankReductionTests
  ( testRankReduction
  ) where

import Data.List (sort)
import HABQTlib.Data
import HABQTlib.Data.Particle
import qualified Numeric.LinearAlgebra as LA
import StateGenTests (arbPropDensityMatrix)
import qualified System.Random.MWC as MWC
import qualified Test.QuickCheck as QC
import Test.QuickCheck
  ( Args(..)
  , Positive(..)
  , Property
  , (.&&.)
  , (===)
  , ioProperty
  , quickCheckWith
  , stdArgs
  )
import TestHelpers

sortSVDprop :: Positive Int -> Positive Int -> Property
sortSVDprop (Positive r) (Positive c) =
  ioProperty $ do
    r1 <- LA.randn r c
    r2 <- LA.randn r c
    let rm = LA.toComplex (r1, r2)
        (u, s) = LA.leftSV rm
        sorted = sort (LA.toList s) == (reverse . LA.toList) s
        normU = (LA.norm_2 . head . LA.toColumns) u
    return $ sorted && abs (normU - 1) < 1e-6

truncateProp' :: Rank -> WeighedDensityMatrix -> Property
truncateProp' rank wdm@(WeighedDensityMatrix (w, _)) =
  let WeighedDensityMatrix (wt, dmt) = truncateRank rank wdm
      preservesWeight = abs (2 * (w - wt) / (w + wt)) <= 1e-12
      (_, s, _) = LA.compactSVD . getDensityMatrix $ dmt
      setsRank = rank === LA.size s
      validDM = arbPropDensityMatrix dmt
   in preservesWeight .&&. setsRank .&&. validDM

truncateProp :: Property
truncateProp =
  let gen = do
        (dim, rank) <- arbDimRank
        wdm <- arbWDM dim rank
        newRank <- QC.suchThat QC.arbitrary (\x -> x > 0 && x <= rank)
        return (newRank, wdm)
   in QC.forAll gen (uncurry truncateProp')

testTruncation :: IO ()
testTruncation = do
  putStrLn "Testing density matrix rank reduction:"
  quickCheckWith stdArgs {maxSuccess = 1000} truncateProp

particleReductionProp :: MWC.GenIO -> Positive Int -> Positive Int -> Property
particleReductionProp gen (Positive dim) (Positive num) =
  ioProperty $ do
    r <- MWC.uniformR (1, dim) gen
    particles <- genParticles dim r num
    let WeighedDensityMatrix (w, dm) = reduceParticlesToMean particles
        dimProp = dim === LA.rows (getDensityMatrix dm)
        rankProp = r === getRank dm
        validProp = arbPropDensityMatrix dm
        weightProp = abs (w - 1) < 1e-12
    return $ dimProp .&&. rankProp .&&. validProp .&&. weightProp

testSVDsort :: IO ()
testSVDsort = do
  putStrLn "Testing singular value sort:"
  quickCheckWith stdArgs {maxSuccess = 1000} sortSVDprop
  putStrLn "Testing particle vector reduction:"
  gen <- MWC.createSystemRandom
  quickCheckWith stdArgs {maxSuccess = 1000} (particleReductionProp gen)

testRankReduction :: IO ()
testRankReduction = do
  testSVDsort
  testTruncation

max_stars_repo_name: Belinsky-L-V/HABQT

max_issues_repo_name: Belinsky-L-V/HABQT

max_forks_repo_name: Belinsky-L-V/HABQT


text:
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}

--
-- Copyright (c) 2019, ERICSSON AB
-- All rights reserved.
--
-- Redistribution and use in source and binary forms, with or without
-- modification, are permitted provided that the following conditions are met:
--
--     * Redistributions of source code must retain the above copyright notice,
--       this list of conditions and the following disclaimer.
--     * Redistributions in binary form must reproduce the above copyright
--       notice, this list of conditions and the following disclaimer in the
--       documentation and/or other materials provided with the distribution.
--     * Neither the name of the ERICSSON AB nor the names of its contributors
--       may be used to endorse or promote products derived from this software
--       without specific prior written permission.
--
-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
-- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
-- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
-- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
-- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
-- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
-- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
-- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
--

module Feldspar.Core.Language where

import Feldspar.Core.Reify
import Feldspar.Core.Representation as R
import Feldspar.Core.Types as T
import Feldspar.Core.Constructs (Data(..), Syntax(..), SyntacticFeld(..))
import Feldspar.Core.Middleend.FromTypeUtil (untypeType, literal)
import Feldspar.Core.NestedTuples

import Feldspar.Range
import Feldspar.Core.Collection
import Feldspar.Core.Interpretation hiding (SizeProp, sizeProp, literal)

import Control.Monad.Cont (runCont, cont)
import Data.Typeable (Typeable)
import Control.Applicative
import Control.Monad (zipWithM_)
import Data.Complex (Complex)
import Data.Int
import Data.IORef
import Data.List (genericLength)
import Data.Patch
import Data.Word
import Data.Hash (Hashable)

import qualified Data.ByteString.Char8 as B
import qualified Data.Bits as B
import Prelude.EDSL
import Prelude (Float, Double, Rational, ($), foldr)
import qualified Prelude as P

--------------------------------------------------
-- Array.hs
--------------------------------------------------

parallel :: Type a => Data Length -> (Data Index -> Data a) -> Data [a]
parallel n f = sugarSym2 R.Parallel n f

sequential :: (Type a, Syntax s) =>
              Data Length -> s -> (Data Index -> s -> (Data a,s)) -> Data [a]
sequential = sugarSym3 Sequential

append :: Type a => Data [a] -> Data [a] -> Data [a]
append = sugarSym2 Append

getLength :: Type a => Data [a] -> Data Length
getLength = sugarSym1 GetLength

-- | Change the length of the vector to the supplied value. If the supplied
-- length is greater than the old length, the new elements will have undefined
-- value.
setLength :: Type a => Data Length -> Data [a] -> Data [a]
setLength = sugarSym2 SetLength

getIx :: Type a => Data [a] -> Data Index -> Data a
getIx = sugarSym2 GetIx

setIx :: Type a => Data [a] -> Data Index -> Data a -> Data [a]
setIx = sugarSym3 SetIx

type instance Elem      (Data [a]) = Data a
type instance CollIndex (Data [a]) = Data Index
type instance CollSize  (Data [a]) = Data Length

instance Type a => Indexed (Data [a])
  where
    (!) = getIx

instance Type a => Sized (Data [a])
  where
    collSize    = getLength
    setCollSize = setLength

instance (Type a, Type b) => CollMap (Data [a]) (Data [b])
  where
    collMap f arr = parallel (getLength arr) (f . getIx arr)

-- | Array patch
(|>) :: (Sized a, CollMap a a) =>
    Patch (CollSize a) (CollSize a) -> Patch (Elem a) (Elem a) -> Patch a a
(sizePatch |> elemPatch) a =
    collMap elemPatch $ setCollSize (sizePatch (collSize a)) a

--------------------------------------------------
-- Binding.hs
--------------------------------------------------

-- | Share an expression in the scope of a function
share :: (Syntax a, Syntax b) => a -> (a -> b) -> b
share = sugarSym2 Let

-- | Share the intermediate result when composing functions
(.<) :: (Syntax b, Syntax c) => (b -> c) -> (a -> b) -> a -> c
(.<) f g a = share (g a) f

infixr 9 .<

-- | Share an expression in the scope of a function
($<) :: (Syntax a, Syntax b) => (a -> b) -> a -> b
($<) = flip share

infixr 0 $<

--------------------------------------------------
-- Bits.hs
--------------------------------------------------

infixl 5 .<<.,.>>.
infixl 4 ⊕

class (Type a, B.Bits a, Integral a, Bounded a, Size a ~ Range a) => Bits a
  where
    -- * Logical operations
    (.&.)         :: Data a -> Data a -> Data a
    (.&.)         = sugarSym2 BAnd
    (.|.)         :: Data a -> Data a -> Data a
    (.|.)         = sugarSym2 BOr
    xor           :: Data a -> Data a -> Data a
    xor           = sugarSym2 BXor
    complement    :: Data a -> Data a
    complement    = sugarSym1 Complement

    -- * Bitwise operations
    bit           :: Data Index -> Data a
    bit           = sugarSym1 Bit
    setBit        :: Data a -> Data Index -> Data a
    setBit        = sugarSym2 SetBit
    clearBit      :: Data a -> Data Index -> Data a
    clearBit      = sugarSym2 ClearBit
    complementBit :: Data a -> Data Index -> Data a
    complementBit = sugarSym2 ComplementBit
    testBit       :: Data a -> Data Index -> Data Bool
    testBit       = sugarSym2 TestBit

    -- * Movement operations
    shiftLU       :: Data a -> Data Index -> Data a
    shiftLU       = sugarSym2 ShiftLU
    shiftRU       :: Data a -> Data Index -> Data a
    shiftRU       = sugarSym2 ShiftRU
    shiftL        :: Data a -> Data IntN -> Data a
    shiftL        = sugarSym2 ShiftL
    shiftR        :: Data a -> Data IntN -> Data a
    shiftR        = sugarSym2 ShiftR
    rotateLU      :: Data a -> Data Index -> Data a
    rotateLU      = sugarSym2 RotateLU
    rotateRU      :: Data a -> Data Index -> Data a
    rotateRU      = sugarSym2 RotateRU
    rotateL       :: Data a -> Data IntN -> Data a
    rotateL       = sugarSym2 RotateL
    rotateR       :: Data a -> Data IntN -> Data a
    rotateR       = sugarSym2 RotateR
    reverseBits   :: Data a -> Data a
    reverseBits   = sugarSym1 ReverseBits

    -- * Query operations
    bitScan       :: Data a -> Data Index
    bitScan       = sugarSym1 BitScan
    bitCount      :: Data a -> Data Index
    bitCount      = sugarSym1 BitCount

    bitSize       :: Data a -> Data Index
    bitSize       = value . bitSize'
    bitSize'      :: Data a -> Index
    bitSize'      = const $ P.fromIntegral $ finiteBitSize (undefined :: a)

    isSigned      :: Data a -> Data Bool
    isSigned      = value . isSigned'
    isSigned'     :: Data a -> Bool
    isSigned'     = const $ B.isSigned (undefined :: a)

finiteBitSize :: (B.FiniteBits b) => b -> Int
finiteBitSize = B.finiteBitSize

instance Bits Word8
instance Bits Word16
instance Bits Word32
instance Bits Word64
instance Bits WordN
instance Bits Int8
instance Bits Int16
instance Bits Int32
instance Bits Int64
instance Bits IntN

-- * Combinators

(⊕)    :: (Bits a) => Data a -> Data a -> Data a
(⊕)    =  xor
(.<<.) :: (Bits a) => Data a -> Data Index -> Data a
(.<<.) =  shiftLU
(.>>.) :: (Bits a) => Data a -> Data Index -> Data a
(.>>.) =  shiftRU

-- | Set all bits to one
allOnes :: Bits a => Data a
allOnes = complement 0

-- | Set the `n` lowest bits to one
oneBits :: Bits a => Data Index -> Data a
oneBits n = complement (allOnes .<<. n)

-- | Extract the `k` lowest bits
lsbs :: Bits a => Data Index -> Data a -> Data a
lsbs k i = i .&. oneBits k

--------------------------------------------------
-- Complex.hs
--------------------------------------------------

complex :: (Numeric a, P.RealFloat a) => Data a -> Data a -> Data (Complex a)
complex = sugarSym2 MkComplex

realPart :: (Numeric a, P.RealFloat a) => Data (Complex a) -> Data a
realPart = sugarSym1 RealPart

imagPart :: (Numeric a, P.RealFloat a) => Data (Complex a) -> Data a
imagPart = sugarSym1 ImagPart

conjugate :: (Numeric a, P.RealFloat a) => Data (Complex a) -> Data (Complex a)
conjugate = sugarSym1 Conjugate

mkPolar :: (Numeric a, P.RealFloat a)
    => Data a  -- ^ Amplitude
    -> Data a  -- ^ Angle
    -> Data (Complex a)
mkPolar = sugarSym2 MkPolar

cis :: (Numeric a, P.RealFloat a) => Data a -> Data (Complex a)
cis = sugarSym1 Cis

magnitude :: (Numeric a, P.RealFloat a) => Data (Complex a) -> Data a
magnitude = sugarSym1 Magnitude

phase :: (Numeric a, P.RealFloat a) => Data (Complex a) -> Data a
phase = sugarSym1 Phase

polar :: (Numeric a, P.RealFloat a) => Data (Complex a) -> (Data a, Data a)
polar c = (magnitude c, phase c)

infixl 6 +.

(+.) :: (Numeric a, P.RealFloat a) => Data a -> Data a -> Data (Complex a)
(+.) = complex

iunit :: (Numeric a, P.RealFloat a) => Data (Complex a)
iunit = 0 +. 1

--------------------------------------------------
-- Condition.hs
--------------------------------------------------

condition :: (Syntax a) => Data Bool -> a -> a -> a
condition c t f = sugarSym3 Condition c t f

-- | Condition operator. Use as follows:
-- > cond1 ? ex1 $
-- > cond2 ? ex2 $
-- > cond3 ? ex3 $
-- >   exDefault
(?) :: (Syntax a) => Data Bool -> a -> a -> a
(?) = condition

infixl 1 ?

--------------------------------------------------
-- ConditionM.hs
--------------------------------------------------

ifM :: Syntax a => Data Bool -> M a -> M a -> M a
ifM = sugarSym3 ConditionM

whenM :: Data Bool -> M () -> M ()
whenM c ma = ifM c ma (return ())

unlessM :: Data Bool -> M () -> M ()
unlessM c = ifM c (return ())

--------------------------------------------------
-- Conversion.hs
--------------------------------------------------

i2f :: (Integral a, Numeric b, P.RealFloat b) => Data a -> Data b
i2f = i2n

f2i :: (Integral a, Numeric b, P.RealFloat b) => Data b -> Data a
f2i = sugarSym1 F2I

i2n :: (Integral a, Numeric b) => Data a -> Data b
i2n = sugarSym1 I2N

b2i :: Integral a => Data Bool -> Data a
b2i = sugarSym1 B2I

truncate :: (Integral a, Numeric b, P.RealFloat b) => Data b -> Data a
truncate = f2i

round :: (Integral a, Numeric b, P.RealFloat b) => Data b -> Data a
round = sugarSym1 Round

ceiling :: (Integral a, Numeric b, P.RealFloat b) => Data b -> Data a
ceiling = sugarSym1 Ceiling

floor :: (Integral a, Numeric b, P.RealFloat b) => Data b -> Data a
floor = sugarSym1 Floor

--------------------------------------------------
-- Elements.hs
--------------------------------------------------

materialize :: Type a => Data Length -> Data (Elements a) -> Data [a]
materialize = sugarSym2 EMaterialize

write :: Type a => Data Index -> Data a -> Data (Elements a)
write = sugarSym2 EWrite

par :: Type a => Data (Elements a) -> Data (Elements a) -> Data (Elements a)
par = sugarSym2 EPar

parFor :: Type a => Data Length -> (Data Index -> Data (Elements a)) -> Data (Elements a)
parFor = sugarSym2 EparFor

skip :: Type a => Data (Elements a)
skip = sugarSym0 ESkip

--------------------------------------------------
-- Eq.hs
--------------------------------------------------

infix 4 ==
infix 4 /=

-- | Redefinition of the standard 'P.Eq' class for Feldspar
class (Type a) => Eq a
  where
    (==) :: Data a -> Data a -> Data Bool
    (==) = sugarSym2 Equal
    (/=) :: Data a -> Data a -> Data Bool
    (/=) = sugarSym2 NotEqual

instance Eq ()
instance Eq Bool
instance Eq Float
instance Eq Double
instance Eq Word8
instance Eq Word16
instance Eq Word32
instance Eq Word64
instance Eq WordN
instance Eq Int8
instance Eq Int16
instance Eq Int32
instance Eq Int64
instance Eq IntN

instance (Eq a, Eq b)                               => Eq (a,b)
instance (Eq a, Eq b, Eq c)                         => Eq (a,b,c)
instance (Eq a, Eq b, Eq c, Eq d)                   => Eq (a,b,c,d)
instance (Eq a, Eq b, Eq c, Eq d, Eq e)             => Eq (a,b,c,d,e)
instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f)       => Eq (a,b,c,d,e,f)
instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g) => Eq (a,b,c,d,e,f,g)

instance (Eq a, P.RealFloat a) => Eq (Complex a)

--------------------------------------------------
-- Error.hs
--------------------------------------------------

undef :: Syntax a => a
undef = sugarSym0 Undefined

-- | Assert that the condition holds or fail with message
assertMsg :: Syntax a => String -> Data Bool -> a -> a
assertMsg s = sugarSym2 (Assert s)

-- | Assert that the condition holds, the conditions string representation is used as the message
assert :: Syntax a => Data Bool -> a -> a
assert cond = assertMsg (show cond) cond

err :: Syntax a => String -> a
err msg = assertMsg msg false undef

--------------------------------------------------
-- FFI.hs
--------------------------------------------------

{- Omitted
foreignImport :: ( Type (DenResult a)
                 , SyntacticN c b
                 , ApplySym a b FeldDomain
                 )
              => String -> Denotation a -> c
foreignImport name f = sugarSymF (ForeignImport name f)
-}

--------------------------------------------------
-- Floating.hs
--------------------------------------------------

-- Make new class, with "Data" in all the types

infixr 8 **

class (Fraction a, P.Floating a) => Floating a where
  pi        :: Data a
  pi        =  sugarSym0 Pi
  exp       :: Data a -> Data a
  exp       =  sugarSym1 Exp
  sqrt      :: Data a -> Data a
  sqrt      =  sugarSym1 Sqrt
  log       :: Data a -> Data a
  log       =  sugarSym1 Log
  (**)      :: Data a -> Data a -> Data a
  (**)      =  sugarSym2 Pow
  logBase   :: Data a -> Data a -> Data a
  logBase   =  sugarSym2 LogBase
  sin       :: Data a -> Data a
  sin       =  sugarSym1 Sin
  tan       :: Data a -> Data a
  tan       =  sugarSym1 Tan
  cos       :: Data a -> Data a
  cos       =  sugarSym1 Cos
  asin      :: Data a -> Data a
  asin      =  sugarSym1 Asin
  atan      :: Data a -> Data a
  atan      =  sugarSym1 Atan
  acos      :: Data a -> Data a
  acos      =  sugarSym1 Acos
  sinh      :: Data a -> Data a
  sinh      =  sugarSym1 Sinh
  tanh      :: Data a -> Data a
  tanh      =  sugarSym1 Tanh
  cosh      :: Data a -> Data a
  cosh      =  sugarSym1 Cosh
  asinh     :: Data a -> Data a
  asinh     =  sugarSym1 Asinh
  atanh     :: Data a -> Data a
  atanh     =  sugarSym1 Atanh
  acosh     :: Data a -> Data a
  acosh     =  sugarSym1 Acosh

instance Floating Float
instance Floating Double

instance (Fraction a, P.RealFloat a) => Floating (Complex a)

π :: Floating a => Data a
π = pi
--------------------------------------------------
-- Fractional.hs
--------------------------------------------------

-- | Fractional types. The relation to the standard 'Fractional' class is
-- @instance `Fraction` a => `Fractional` (`Data` a)@
class (Fractional a, Numeric a) => Fraction a
  where
    fromRationalFrac :: Rational -> Data a
    fromRationalFrac = value . fromRational

    divFrac :: Data a -> Data a -> Data a
    divFrac = sugarSym2 DivFrac

instance Fraction Float
instance Fraction Double

instance (Fraction a, P.RealFloat a) => Fraction (Complex a)

instance (Fraction a) => Fractional (Data a)
  where
    fromRational = fromRationalFrac
    (/)          = divFrac

--------------------------------------------------
-- Future.hs
--------------------------------------------------

newtype Future a = Future { unFuture :: Data (FVal (Internal a)) }

later :: (Syntax a, Syntax b) => (a -> b) -> Future a -> Future b
later f = future . f . await

pval :: (Syntax a, Syntax b) => (a -> b) -> a -> b
pval f x = await $ force $ future (f x)

instance Syntax a => Syntactic (Future a)
  where
    type Internal (Future a) = FVal (Internal a)
    desugar = desugar . unFuture
    sugar   = Future . sugar

future :: Syntax a => a -> Future a
future = sugarSym1 MkFuture

await :: Syntax a => Future a -> a
await = sugarSym1 Await

--------------------------------------------------
-- Integral.hs
--------------------------------------------------

class (Ord a, Numeric a, BoundedInt a, P.Integral a, Size a ~ Range a) => Integral a
  where
    quot :: Data a -> Data a -> Data a
    quot = sugarSym2 Quot
    rem  :: Data a -> Data a -> Data a
    rem  = sugarSym2 Rem
    div  :: Data a -> Data a -> Data a
    div  = sugarSym2 Div
    mod  :: Data a -> Data a -> Data a
    mod  = sugarSym2 Mod
    (^)  :: Data a -> Data a -> Data a
    (^)  = sugarSym2 IExp

divSem :: Integral a
       => Data a -> Data a -> Data a
divSem x y = (x > 0 && y < 0 || x < 0 && y > 0) && rem x y /= 0 ?   quot x y P.- 1
                                                                P.$ quot x y

instance Integral Word8
instance Integral Word16
instance Integral Word32
instance Integral Word64
instance Integral WordN
instance Integral Int8
instance Integral Int16
instance Integral Int32
instance Integral Int64
instance Integral IntN

--------------------------------------------------
-- Literal.hs
--------------------------------------------------

false :: Data Bool
false = value False

true :: Data Bool
true = value True

instance Syntactic ()
  where
    type Internal () = ()
    desugar _ = ASTF (toCExpr $ toAExpr $ Literal ()) 0 -- Maybe more helpers?
    sugar _ = ()

--------------------------------------------------
-- Logic.hs
--------------------------------------------------

infixr 3 &&
infixr 3 &&*
infixr 2 ||
infixr 2 ||*

not :: Data Bool -> Data Bool
not = sugarSym1 Not

(&&) :: Data Bool -> Data Bool -> Data Bool
(&&) = sugarSym2 And

(||) :: Data Bool -> Data Bool -> Data Bool
(||) = sugarSym2 Or

-- | Lazy conjunction, second argument only evaluated if necessary
(&&*) :: Data Bool -> Data Bool -> Data Bool
a &&* b =  a ? b $ false

-- | Lazy disjunction, second argument only evaluated if necessary
(||*) :: Data Bool -> Data Bool -> Data Bool
a ||* b = a ? true $ b

--------------------------------------------------
-- Loop.hs
--------------------------------------------------

forLoop :: Syntax a => Data Length -> a -> (Data Index -> a -> a) -> a
forLoop = sugarSym3 ForLoop

whileLoop :: Syntax a => a -> (a -> Data Bool) -> (a -> a) -> a
whileLoop = sugarSym3 WhileLoop

--------------------------------------------------
-- LoopM.hs
--------------------------------------------------

forM :: (Syntax a) => Data Length -> (Data Index -> M a) -> M ()
forM = sugarSym2 For

whileM :: Syntax a => M (Data Bool) -> M a -> M ()
whileM = sugarSym2 While

--------------------------------------------------
-- MutableArray.hs
--------------------------------------------------

-- | Create a new 'Mutable' Array and intialize all elements
newArr :: Type a => Data Length -> Data a -> M (Data (MArr a))
newArr = sugarSym2 NewArr

-- | Create a new 'Mutable' Array but leave the elements un-initialized
newArr_ :: Type a => Data Length -> M (Data (MArr a))
newArr_ = sugarSym1 NewArr_

-- | Create a new 'Mutable' Array and initialize with elements from the
-- list
newListArr :: forall a. Type a => [Data a] -> M (Data (MArr a))
newListArr xs = do arr <- newArr_ (value $ genericLength xs)
                   zipWithM_ (setArr arr . value) [0..] xs
                   return arr

-- | Extract the element at index
getArr :: Type a => Data (MArr a) -> Data Index -> M (Data a)
getArr = sugarSym2 GetArr

-- | Replace the value at index
setArr :: Type a => Data (MArr a) -> Data Index -> Data a -> M ()
setArr = sugarSym3 SetArr

-- | Modify the element at index
modifyArr :: Type a
          => Data (MArr a) -> Data Index -> (Data a -> Data a) -> M ()
modifyArr arr i f = getArr arr i >>= setArr arr i . f

-- | Query the length of the array
arrLength :: Type a => Data (MArr a) -> M (Data Length)
arrLength = sugarSym1 ArrLength

-- | Modify all elements
mapArray :: Type a => (Data a -> Data a) -> Data (MArr a) -> M (Data (MArr a))
mapArray f arr = do
    len <- arrLength arr
    forArr len (flip (modifyArr arr) f)
    return arr

forArr :: Syntax a => Data Length -> (Data Index -> M a) -> M ()
forArr = sugarSym2 For

-- | Swap two elements
swap :: Type a
     => Data (MArr a) -> Data Index -> Data Index -> M ()
swap a i1 i2 = do
    tmp <- getArr a i1
    getArr a i2 >>= setArr a i1
    setArr a i2 tmp

--------------------------------------------------
-- Mutable.hs
--------------------------------------------------

newtype M a = M { unM :: Mon Mut a }
  deriving (Functor, Applicative, Monad)

instance Syntax a => Syntactic (M a)
  where
    type Internal (M a) = Mut (Internal a)
    desugar = desugar . unM
    sugar   = M . sugar

instance P.Eq (Mut a) where
 (==) = undefined

instance Show (Mut a) where
  show = undefined

runMutable :: Syntax a => M a -> a
runMutable = sugarSym1 Run

when :: Data Bool -> M () -> M ()
when = sugarSym2 When

unless :: Data Bool -> M () -> M ()
unless = when . not

instance Type a => Type (Mut a)
  where
    typeRep       = T.MutType typeRep
    sizeOf as     = undefined
    toTarget n as = undefined

--------------------------------------------------
-- MutableReference.hs
--------------------------------------------------

newtype Ref a = Ref { unRef :: Data (IORef (Internal a)) }

instance Syntax a => Syntactic (Ref a)
  where
    type Internal (Ref a) = IORef (Internal a)
    desugar = desugar . unRef
    sugar   = Ref . sugar

newRef :: Syntax a => a -> M (Ref a)
newRef = sugarSym1 NewRef

getRef :: Syntax a => Ref a -> M a
getRef = sugarSym1 GetRef

setRef :: Syntax a => Ref a -> a -> M ()
setRef = sugarSym2 SetRef

modifyRef :: Syntax a => Ref a -> (a -> a) -> M ()
modifyRef = sugarSym2 ModRef

--------------------------------------------------
-- MutableToPure.hs
--------------------------------------------------

withArray :: (Type a, Syntax b) => Data (MArr a) -> (Data [a] -> M b) -> M b
withArray = sugarSym2 WithArray

runMutableArray :: Type a => M (Data (MArr a)) -> Data [a]
runMutableArray = sugarSym1 RunMutableArray

freezeArray :: Type a => Data (MArr a) -> M (Data [a])
freezeArray marr = withArray marr return

thawArray :: Type a => Data [a] -> M (Data (MArr a))
thawArray arr = do
  marr <- newArr_ (getLength arr)
  forM (getLength arr) (\ix ->
    setArr marr ix (getIx arr ix)
   )
  return marr

--------------------------------------------------
-- Nested tuples
--------------------------------------------------

class SyntacticTup a where
    type InternalTup a
    desugarTup :: RTuple a -> ASTF (RTuple (InternalTup a))
    sugarTup   :: ASTF (RTuple (InternalTup a)) -> RTuple a

instance (Type (Internal a), Type (RTuple (InternalTup b)), Syntactic a, SyntacticTup b, Typeable (InternalTup b))
         => SyntacticTup (a :* b) where
    type InternalTup (a :* b) = Internal a :* InternalTup b
    desugarTup (x :* xs) = sugarSym2 Cons x xs
    sugarTup e = sugar (sugarSym1 Car $ Data e) :* sugarTup (sugarSym1 Cdr $ Data e)

instance SyntacticTup TNil where
    type InternalTup TNil = TNil
    desugarTup TNil = sugarSym0 Nil
    sugarTup _ = TNil

instance SyntacticTup a => Syntactic (RTuple a) where
    type Internal (RTuple a) = RTuple (InternalTup a)
    desugar t = desugarTup t
    sugar e = sugarTup e

car :: (Syntax a, SyntacticTup b, Type (RTuple (InternalTup b)), Typeable (InternalTup b))
    => RTuple (a :* b) -> a
car = sugarSym1 Car

cdr :: (Syntax a, SyntacticTup b, Type (RTuple (InternalTup b)), Typeable (InternalTup b))
    => RTuple (a :* b) -> RTuple b
cdr = sugarSym1 Cdr

instance (P.Eq (Tuple (InternalTup a)),
          Type (RTuple (InternalTup a)),
          Type (InternalTup a),
          SyntacticTup a)
      => Syntactic (Tuple a) where
    type Internal (Tuple a) = Tuple (InternalTup a)
    desugar (Tuple x) = sugarSym1 Tup x
    sugar e = Tuple $ sugar $ sugarSym1 UnTup e

--------------------------------------------------
-- NoInline.hs
--------------------------------------------------

noInline :: Syntax a => a -> a
noInline = sugarSym1 NoInline

--------------------------------------------------
-- Num.hs
--------------------------------------------------

-- There are three possibilities for making a `Num` instance for `Data`:
--   1. instance (Type a, Num a, Num (Size a)) => Num (Data a)
--   2. instance Num (Data Word8)
--      instance Num (Data Word16)
--      instance Num (Data Word32)
--      ...
--   3. The implementation in this module
-- #1 has the problem with #1 that it leaks implementation details.
-- #2 has the problem that it is verbose: The methods have to be implemented in each instance
-- (which, of course, can be taken care of using TemplateHaskell).
-- #3 avoids the above problems, but does so at the expense of having two numeric classes, which may
-- be confusing to the user.

class (Type a, Num a, Num (Size a), Hashable a) => Numeric a
  where
    fromIntegerNum :: Integer -> Data a
    fromIntegerNum =  value . fromInteger
    absNum         :: Data a -> Data a
    absNum         =  sugarSym1 Abs
    signumNum      :: Data a -> Data a
    signumNum      =  sugarSym1 Sign
    addNum         :: Data a -> Data a -> Data a
    addNum         =  sugarSym2 Add
    subNum         :: Data a -> Data a -> Data a
    subNum         =  sugarSym2 Sub
    mulNum         :: Data a -> Data a -> Data a
    mulNum         =  sugarSym2 Mul

instance Numeric Word8
instance Numeric Word16
instance Numeric Word32
instance Numeric Word64
instance Numeric WordN
instance Numeric Int8
instance Numeric Int16
instance Numeric Int32
instance Numeric Int64
instance Numeric IntN

instance Numeric Float
instance Numeric Double

instance (Type a, P.RealFloat a, Hashable a) => Numeric (Complex a)

instance (Numeric a) => Num (Data a)
  where
    fromInteger = fromIntegerNum
    abs         = absNum
    signum      = signumNum
    (+)         = addNum
    (-)         = subNum
    (*)         = mulNum

--------------------------------------------------
-- Ord.hs
--------------------------------------------------

infix 4 <
infix 4 >
infix 4 <=
infix 4 >=

-- | Redefinition of the standard 'Prelude.Ord' class for Feldspar
class (Eq a, P.Ord a, P.Ord (Size a)) => Ord a where
  (<)  :: Data a -> Data a -> Data Bool
  (<)  =  sugarSym2 LTH
  (>)  :: Data a -> Data a -> Data Bool
  (>)  =  sugarSym2 GTH

  (<=) :: Data a -> Data a -> Data Bool
  (<=) =  sugarSym2 LTE
  (>=) :: Data a -> Data a -> Data Bool
  (>=) =  sugarSym2 GTE

  min :: Data a -> Data a -> Data a
  min = sugarSym2 Min
  max :: Data a -> Data a -> Data a
  max = sugarSym2 Max

instance Ord ()
instance Ord Bool
instance Ord Word8
instance Ord Int8
instance Ord Word16
instance Ord Int16
instance Ord Word32
instance Ord Int32
instance Ord Word64
instance Ord Int64
instance Ord WordN
instance Ord IntN
instance Ord Float
instance Ord Double
--------------------------------------------------
-- Par.hs
--------------------------------------------------

newtype P a = P { unP :: Mon Par a }
  deriving (Functor, Applicative, Monad)

instance Syntax a => Syntactic (P a)
  where
    type Internal (P a) = Par (Internal a)
    desugar = desugar . unP
    sugar   = P . sugar

newtype IVar a = IVar { unIVar :: Data (IV (Internal a)) }

instance Syntax a => Syntactic (IVar a)
  where
    type Internal (IVar a) = IV (Internal a)
    desugar = desugar . unIVar
    sugar   = IVar . sugar

instance P.Eq (Par a) where
 (==) = undefined

instance Show (Par a) where
  show = undefined

instance Type a => Type (Par a)
  where
    typeRep       = T.ParType typeRep
    sizeOf as     = undefined
    toTarget n as = undefined

--------------------------------------------------
-- RealFloat.hs
--------------------------------------------------

-- Make new class, with "Data" in all the types

class (Type a, P.RealFloat a) => RealFloat a where
  atan2 :: Data a -> Data a -> Data a
  atan2 = sugarSym2 Atan2

instance RealFloat Float
instance RealFloat Double

--------------------------------------------------
-- Save.hs
--------------------------------------------------

-- | Tracing execution of Feldspar expressions

-- | An identity function that guarantees that the result will be computed as a
-- sub-result of the whole program. This is useful to prevent certain
-- optimizations.
-- Exception: Currently constant folding does not respect 'save'.
save :: Syntax a => a -> a
save = sugarSym1 Save

-- | Equivalent to 'save'. When applied to a lazy data structure, 'force' (and
-- 'save') has the effect of forcing evaluation of the whole structure.
force :: Syntax a => a -> a
force = save

--------------------------------------------------
-- SizeProp.hs
--------------------------------------------------

-- | The functions in this module can be used to help size inference (which, in
-- turn, helps deriving upper bounds of array sizes and helps optimization).

-- | An identity function affecting the abstract size information used during
-- optimization. The application of a 'SizeCap' is a /guarantee/ (by the caller)
-- that the argument is within a certain size (determined by the creator of the
-- 'SizeCap', e.g. 'sizeProp').
-- /Warning: If the guarantee is not fulfilled, optimizations become unsound!/
-- In general, the size of the resulting value is the intersection of the cap
-- size and the size obtained by ordinary size inference. That is, a 'SizeCap'
-- can only make the size more precise, not less precise.
type SizeCap a = Data a -> Data a

-- | @sizeProp prop a b@: A guarantee that @b@ is within the size @(prop sa)@,
-- where @sa@ is the size of @a@.
sizeProp :: (Syntax a, Type b) =>
    (Size (Internal a) -> Size b) -> a -> SizeCap b
sizeProp f = sugarSym2 (PropSize $ EqBox f) -- TODO

-- | A guarantee that the argument is within the given size
cap :: Type a => Size a -> SizeCap a
cap sz = sizeProp (const sz) (Data $ desugar ())

-- | @notAbove a b@: A guarantee that @b <= a@ holds
notAbove :: (Type a, Bounded a, Size a ~ Range a) => Data a -> SizeCap a
notAbove = sizeProp (Range minBound . upperBound)

-- | @notBelow a b@: A guarantee that @b >= a@ holds
notBelow :: (Type a, Bounded a, Size a ~ Range a) => Data a -> SizeCap a
notBelow = sizeProp (flip Range maxBound . lowerBound)

-- | @between l u a@: A guarantee that @l <= a <= u@ holds
between :: (Type a, Bounded a, Size a ~ Range a) =>
    Data a -> Data a -> SizeCap a
between l u = notBelow l . notAbove u

--------------------------------------------------
-- SourceInfo.hs
--------------------------------------------------
{- Omitted
-- | Source-code annotations

data SourceInfo1 a = SourceInfo1 SourceInfo

-- | Annotate an expression with information about its source code
sourceData :: Type a => SourceInfo1 a -> Data a -> Data a
sourceData info = sugarSym1 (Decor info Id)
-}

--------------------------------------------------
-- Switch.hs
--------------------------------------------------

-- | Select between the cases based on the value of the scrutinee.
-- If no match is found return the first argument
switch :: (Eq (Internal a), Hashable (Internal a), Syntax a, Syntax b)
       => b -> [(Internal a, b)] -> a -> b
switch def [] _ = def
switch def cs s = let s' = resugar s
                  in sugarSym1 Switch (foldr (\(c,a) b -> value c == s' ? a $ b) def cs)

--------------------------------------------------
-- Tuple.hs
--------------------------------------------------

instance (Syntax a, Syntax b) => Syntactic (a, b) where
  type Internal (a, b) = (Internal a, Internal b)
  sugar e = (sugar $ sugarSym1 Sel1 $ Data e,
             sugar $ sugarSym1 Sel2 $ Data e)
  desugar (x,y) = full $ op2f Tup2 @@ x @@ y

instance ( Syntax a, Syntax b, Syntax c )
      => Syntactic (a, b, c)
  where
    type Internal (a, b, c) =
                  ( Internal a, Internal b, Internal c )
    sugar e = ( sugar $ sugarSym1 Sel1  $ Data e
              , sugar $ sugarSym1 Sel2  $ Data e
              , sugar $ sugarSym1 Sel3  $ Data e
              )
    desugar (a, b, c)
          = full $ op2f Tup3 @@ a @@ b @@ c

instance ( Syntax a, Syntax b, Syntax c, Syntax d )
      => Syntactic (a, b, c, d)
  where
    type Internal (a, b, c, d) =
                  ( Internal a, Internal b, Internal c, Internal d )
    sugar e = ( sugar $ sugarSym1 Sel1  $ Data e
              , sugar $ sugarSym1 Sel2  $ Data e
              , sugar $ sugarSym1 Sel3  $ Data e
              , sugar $ sugarSym1 Sel4  $ Data e
              )
    desugar (a, b, c, d)
          = full $ op2f Tup4 @@ a @@ b @@ c @@ d

instance ( Syntax a, Syntax b, Syntax c, Syntax d
         , Syntax e
         )
      => Syntactic (a, b, c, d, e)
  where
    type Internal (a, b, c, d, e) =
                  ( Internal a, Internal b, Internal c, Internal d
                  , Internal e
                  )
    sugar e = ( sugar $ sugarSym1 Sel1  $ Data e
              , sugar $ sugarSym1 Sel2  $ Data e
              , sugar $ sugarSym1 Sel3  $ Data e
              , sugar $ sugarSym1 Sel4  $ Data e
              , sugar $ sugarSym1 Sel5  $ Data e
              )
    desugar (a, b, c, d, e)
          = full $ op2f Tup5 @@ a @@ b @@ c @@ d @@ e

instance ( Syntax a, Syntax b, Syntax c, Syntax d
         , Syntax e, Syntax f
         )
      => Syntactic (a, b, c, d, e, f)
  where
    type Internal (a, b, c, d, e, f) =
                  ( Internal a, Internal b, Internal c, Internal d
                  , Internal e, Internal f
                  )
    sugar e = ( sugar $ sugarSym1 Sel1  $ Data e
              , sugar $ sugarSym1 Sel2  $ Data e
              , sugar $ sugarSym1 Sel3  $ Data e
              , sugar $ sugarSym1 Sel4  $ Data e
              , sugar $ sugarSym1 Sel5  $ Data e
              , sugar $ sugarSym1 Sel6  $ Data e
              )
    desugar (a, b, c, d, e, f)
          = full $ op2f Tup6 @@ a @@ b @@ c @@ d @@ e @@ f

instance ( Syntax a, Syntax b, Syntax c, Syntax d
         , Syntax e, Syntax f, Syntax g
         )
      => Syntactic (a, b, c, d, e, f, g)
  where
    type Internal (a, b, c, d, e, f, g) =
                  ( Internal a, Internal b, Internal c, Internal d
                  , Internal e, Internal f, Internal g
                  )
    sugar e = ( sugar $ sugarSym1 Sel1  $ Data e
              , sugar $ sugarSym1 Sel2  $ Data e
              , sugar $ sugarSym1 Sel3  $ Data e
              , sugar $ sugarSym1 Sel4  $ Data e
              , sugar $ sugarSym1 Sel5  $ Data e
              , sugar $ sugarSym1 Sel6  $ Data e
              , sugar $ sugarSym1 Sel7  $ Data e
              )
    desugar (a, b, c, d, e, f, g)
          = full $ op2f Tup7 @@ a @@ b @@ c @@ d @@ e @@ f @@ g

instance ( Syntax a, Syntax b, Syntax c, Syntax d
         , Syntax e, Syntax f, Syntax g, Syntax h
         )
      => Syntactic (a, b, c, d, e, f, g, h)
  where
    type Internal (a, b, c, d, e, f, g, h) =
                  ( Internal a, Internal b, Internal c, Internal d
                  , Internal e, Internal f, Internal g, Internal h
                  )
    sugar e = ( sugar $ sugarSym1 Sel1  $ Data e
              , sugar $ sugarSym1 Sel2  $ Data e
              , sugar $ sugarSym1 Sel3  $ Data e
              , sugar $ sugarSym1 Sel4  $ Data e
              , sugar $ sugarSym1 Sel5  $ Data e
              , sugar $ sugarSym1 Sel6  $ Data e
              , sugar $ sugarSym1 Sel7  $ Data e
              , sugar $ sugarSym1 Sel8  $ Data e
              )
    desugar (a, b, c, d, e, f, g, h)
          = full $ op2f Tup8 @@ a @@ b @@ c @@ d @@ e @@ f @@ g @@ h

instance ( Syntax a, Syntax b, Syntax c, Syntax d
         , Syntax e, Syntax f, Syntax g, Syntax h
         , Syntax i
         )
      => Syntactic (a, b, c, d, e, f, g, h, i)
  where
    type Internal (a, b, c, d, e, f, g, h, i) =
                  ( Internal a, Internal b, Internal c, Internal d
                  , Internal e, Internal f, Internal g, Internal h
                  , Internal i
                  )
    sugar e = ( sugar $ sugarSym1 Sel1  $ Data e
              , sugar $ sugarSym1 Sel2  $ Data e
              , sugar $ sugarSym1 Sel3  $ Data e
              , sugar $ sugarSym1 Sel4  $ Data e
              , sugar $ sugarSym1 Sel5  $ Data e
              , sugar $ sugarSym1 Sel6  $ Data e
              , sugar $ sugarSym1 Sel7  $ Data e
              , sugar $ sugarSym1 Sel8  $ Data e
              , sugar $ sugarSym1 Sel9  $ Data e
              )
    desugar (a, b, c, d, e, f, g, h, i)
          = full $ op2f Tup9 @@ a @@ b @@ c @@ d @@ e @@ f @@ g @@ h @@ i

instance ( Syntax a, Syntax b, Syntax c, Syntax d
         , Syntax e, Syntax f, Syntax g, Syntax h
         , Syntax i, Syntax j
         )
      => Syntactic (a, b, c, d, e, f, g, h, i, j)
  where
    type Internal (a, b, c, d, e, f, g, h, i, j) =
                  ( Internal a, Internal b, Internal c, Internal d
                  , Internal e, Internal f, Internal g, Internal h
                  , Internal i, Internal j
                  )
    sugar e = ( sugar $ sugarSym1 Sel1  $ Data e
              , sugar $ sugarSym1 Sel2  $ Data e
              , sugar $ sugarSym1 Sel3  $ Data e
              , sugar $ sugarSym1 Sel4  $ Data e
              , sugar $ sugarSym1 Sel5  $ Data e
              , sugar $ sugarSym1 Sel6  $ Data e
              , sugar $ sugarSym1 Sel7  $ Data e
              , sugar $ sugarSym1 Sel8  $ Data e
              , sugar $ sugarSym1 Sel9  $ Data e
              , sugar $ sugarSym1 Sel10 $ Data e
              )
    desugar (a, b, c, d, e, f, g, h, i, j)
          = full $ op2f Tup10 @@ a @@ b @@ c @@ d @@ e @@ f @@ g @@ h @@ i @@ j

instance ( Syntax a, Syntax b, Syntax c, Syntax d
         , Syntax e, Syntax f, Syntax g, Syntax h
         , Syntax i, Syntax j, Syntax k
         )
      => Syntactic (a, b, c, d, e, f, g, h, i, j, k)
  where
    type Internal (a, b, c, d, e, f, g, h, i, j, k) =
                  ( Internal a, Internal b, Internal c, Internal d
                  , Internal e, Internal f, Internal g, Internal h
                  , Internal i, Internal j, Internal k
                  )
    sugar e = ( sugar $ sugarSym1 Sel1  $ Data e
              , sugar $ sugarSym1 Sel2  $ Data e
              , sugar $ sugarSym1 Sel3  $ Data e
              , sugar $ sugarSym1 Sel4  $ Data e
              , sugar $ sugarSym1 Sel5  $ Data e
              , sugar $ sugarSym1 Sel6  $ Data e
              , sugar $ sugarSym1 Sel7  $ Data e
              , sugar $ sugarSym1 Sel8  $ Data e
              , sugar $ sugarSym1 Sel9  $ Data e
              , sugar $ sugarSym1 Sel10 $ Data e
              , sugar $ sugarSym1 Sel11 $ Data e
              )
    desugar (a, b, c, d, e, f, g, h, i, j, k)
          = full $ op2f Tup11 @@ a @@ b @@ c @@ d @@ e @@ f @@ g @@ h @@ i @@ j
                              @@ k

instance ( Syntax a, Syntax b, Syntax c, Syntax d
         , Syntax e, Syntax f, Syntax g, Syntax h
         , Syntax i, Syntax j, Syntax k, Syntax l
         )
      => Syntactic (a, b, c, d, e, f, g, h, i, j, k, l)
  where
    type Internal (a, b, c, d, e, f, g, h, i, j, k, l) =
                  ( Internal a, Internal b, Internal c, Internal d
                  , Internal e, Internal f, Internal g, Internal h
                  , Internal i, Internal j, Internal k, Internal l
                  )
    sugar e = ( sugar $ sugarSym1 Sel1  $ Data e
              , sugar $ sugarSym1 Sel2  $ Data e
              , sugar $ sugarSym1 Sel3  $ Data e
              , sugar $ sugarSym1 Sel4  $ Data e
              , sugar $ sugarSym1 Sel5  $ Data e
              , sugar $ sugarSym1 Sel6  $ Data e
              , sugar $ sugarSym1 Sel7  $ Data e
              , sugar $ sugarSym1 Sel8  $ Data e
              , sugar $ sugarSym1 Sel9  $ Data e
              , sugar $ sugarSym1 Sel10 $ Data e
              , sugar $ sugarSym1 Sel11 $ Data e
              , sugar $ sugarSym1 Sel12 $ Data e
              )
    desugar (a, b, c, d, e, f, g, h, i, j, k, l)
          = full $ op2f Tup12 @@ a @@ b @@ c @@ d @@ e @@ f @@ g @@ h @@ i @@ j
                              @@ k @@ l

instance ( Syntax a, Syntax b, Syntax c, Syntax d
         , Syntax e, Syntax f, Syntax g, Syntax h
         , Syntax i, Syntax j, Syntax k, Syntax l
         , Syntax m
         )
      => Syntactic (a, b, c, d, e, f, g, h, i, j, k, l, m)
  where
    type Internal (a, b, c, d, e, f, g, h, i, j, k, l, m) =
                  ( Internal a, Internal b, Internal c, Internal d
                  , Internal e, Internal f, Internal g, Internal h
                  , Internal i, Internal j, Internal k, Internal l
                  , Internal m
                  )
    sugar e = ( sugar $ sugarSym1 Sel1  $ Data e
              , sugar $ sugarSym1 Sel2  $ Data e
              , sugar $ sugarSym1 Sel3  $ Data e
              , sugar $ sugarSym1 Sel4  $ Data e
              , sugar $ sugarSym1 Sel5  $ Data e
              , sugar $ sugarSym1 Sel6  $ Data e
              , sugar $ sugarSym1 Sel7  $ Data e
              , sugar $ sugarSym1 Sel8  $ Data e
              , sugar $ sugarSym1 Sel9  $ Data e
              , sugar $ sugarSym1 Sel10 $ Data e
              , sugar $ sugarSym1 Sel11 $ Data e
              , sugar $ sugarSym1 Sel12 $ Data e
              , sugar $ sugarSym1 Sel13 $ Data e
              )
    desugar (a, b, c, d, e, f, g, h, i, j, k, l, m)
          = full $ op2f Tup13 @@ a @@ b @@ c @@ d @@ e @@ f @@ g @@ h @@ i @@ j
                              @@ k @@ l @@ m

instance ( Syntax a, Syntax b, Syntax c, Syntax d
         , Syntax e, Syntax f, Syntax g, Syntax h
         , Syntax i, Syntax j, Syntax k, Syntax l
         , Syntax m, Syntax n
         )
      => Syntactic (a, b, c, d, e, f, g, h, i, j, k, l, m, n)
  where
    type Internal (a, b, c, d, e, f, g, h, i, j, k, l, m, n) =
                  ( Internal a, Internal b, Internal c, Internal d
                  , Internal e, Internal f, Internal g, Internal h
                  , Internal i, Internal j, Internal k, Internal l
                  , Internal m, Internal n
                  )
    sugar e = ( sugar $ sugarSym1 Sel1  $ Data e
              , sugar $ sugarSym1 Sel2  $ Data e
              , sugar $ sugarSym1 Sel3  $ Data e
              , sugar $ sugarSym1 Sel4  $ Data e
              , sugar $ sugarSym1 Sel5  $ Data e
              , sugar $ sugarSym1 Sel6  $ Data e
              , sugar $ sugarSym1 Sel7  $ Data e
              , sugar $ sugarSym1 Sel8  $ Data e
              , sugar $ sugarSym1 Sel9  $ Data e
              , sugar $ sugarSym1 Sel10 $ Data e
              , sugar $ sugarSym1 Sel11 $ Data e
              , sugar $ sugarSym1 Sel12 $ Data e
              , sugar $ sugarSym1 Sel13 $ Data e
              , sugar $ sugarSym1 Sel14 $ Data e
              )
    desugar (a, b, c, d, e, f, g, h, i, j, k, l, m, n)
          = full $ op2f Tup14 @@ a @@ b @@ c @@ d @@ e @@ f @@ g @@ h @@ i @@ j
                              @@ k @@ l @@ m @@ n

instance ( Syntax a, Syntax b, Syntax c, Syntax d
         , Syntax e, Syntax f, Syntax g, Syntax h
         , Syntax i, Syntax j, Syntax k, Syntax l
         , Syntax m, Syntax n, Syntax o
         )
      => Syntactic (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o)
  where
    type Internal (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) =
                  ( Internal a, Internal b, Internal c, Internal d
                  , Internal e, Internal f, Internal g, Internal h
                  , Internal i, Internal j, Internal k, Internal l
                  , Internal m, Internal n, Internal o
                  )
    sugar e = ( sugar $ sugarSym1 Sel1  $ Data e
              , sugar $ sugarSym1 Sel2  $ Data e
              , sugar $ sugarSym1 Sel3  $ Data e
              , sugar $ sugarSym1 Sel4  $ Data e
              , sugar $ sugarSym1 Sel5  $ Data e
              , sugar $ sugarSym1 Sel6  $ Data e
              , sugar $ sugarSym1 Sel7  $ Data e
              , sugar $ sugarSym1 Sel8  $ Data e
              , sugar $ sugarSym1 Sel9  $ Data e
              , sugar $ sugarSym1 Sel10 $ Data e
              , sugar $ sugarSym1 Sel11 $ Data e
              , sugar $ sugarSym1 Sel12 $ Data e
              , sugar $ sugarSym1 Sel13 $ Data e
              , sugar $ sugarSym1 Sel14 $ Data e
              , sugar $ sugarSym1 Sel15 $ Data e
              )
    desugar (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o)
          = full $ op2f Tup15 @@ a @@ b @@ c @@ d @@ e @@ f @@ g @@ h @@ i @@ j
                              @@ k @@ l @@ m @@ n @@ o

-------------------------------------------------
-- Functions
-------------------------------------------------

instance (Type (Internal a), TypeF (Internal b), Syntactic a, Syntactic b) => Syntactic (a -> b) where
  type Internal (a -> b) = Internal a -> Internal b
  sugar e = undefined
  desugar f = ASTF func (i+1)
    where ASTF ce i = desugar $ f (sugar $ ASTF (toCExpr $ toAExpr $ Variable v) 0)
          (m1,e1) = catchBindings [varNum v] ce
          func = (m1, toAExpr $ Lambda v e1)
          v = Var (P.fromIntegral i + hashBase) B.empty

-------------------------------------------------
-- Converting Haskell values to Feldspar
-------------------------------------------------

value :: (Syntax a, Hashable (Internal a)) => Internal a -> a
value v = sugar $ ASTF (flattenCSE $ toCExpr $ toAExpr $ Literal v) 0

-------------------------------------------------
-- Support functions for monads
-------------------------------------------------

-- | One-layer desugaring of monadic actions
desugarMonad
    :: ( Monad m
       , Typeable m
       , Typeable a
       , Type (m a)
       , Type a
       , Size a ~ Size (m a)
       )
    => Mon m (ASTF a) -> ASTF (m a)
desugarMonad = flip runCont (sugarSym1 Return) . unMon

-- | One-layer sugaring of monadic actions
sugarMonad
    :: ( Monad m
       , Typeable m
       , Typeable a
       -- , pVar a
       , Type (m a)
       , Type a
       , Size a ~ Size (m a)
       )
    => ASTF (m a) -> Mon m (ASTF a)
sugarMonad ma = Mon $ cont $ sugarSym2 Bind ma

instance ( Syntactic a
         , Monad m
         , Typeable m
         , Typeable (Internal a)
         -- , pVar (Internal a)
         , Type (Internal a)
         , Type (m (Internal a))
         , Size (Internal a) ~ Size (m (Internal a))
         ) =>
           Syntactic (Mon m a)
  where
    type Internal (Mon m a) = m (Internal a)
    desugar = desugarMonad . fmap desugar
    sugar   = fmap sugar   . sugarMonad

-------------------------------------------------
-- Support functions
-------------------------------------------------
-- | Convert a CSE map, an Expr and an Int to an ASTF
full :: TypeF b => (CSEExpr (Expr b), Int) -> ASTF b
full (ce, i) = ASTF (flattenCSE $ transCSEExpr toAExpr ce) i

infixl 5 @@

-- Construct an application
(@@) :: (Syntactic a, TypeF (Internal a), TypeF b)
     => (CSEExpr (Expr (Internal a -> b)), Int) -> a -> (CSEExpr (Expr b), Int)
(cf,i) @@ e = go $ desugar e
  where go (ASTF ce j) = (applyCSE cf ce, P.max i j)

-- | Convenience wrappers for sugarSym
sugarSym0 :: (Syntactic a, TypeF (Internal a)) => Op (Internal a) -> a
sugarSym0 op         = unFull $ sugarSym op
sugarSym1
  :: (TypeF (Internal a), TypeF (Internal b), Syntactic a, Syntactic b)
  => Op (Internal a -> Internal b) -> a -> b
sugarSym1 op a       = unFull $ sugarSym op a
sugarSym2
  :: (TypeF (Internal a), TypeF (Internal b), TypeF (Internal c),
      Syntactic a, Syntactic b, Syntactic c) =>
     Op (Internal a -> Internal b -> Internal c) -> a -> b -> c
sugarSym2 op a b     = unFull $ sugarSym op a b
sugarSym3
  :: (TypeF (Internal a), TypeF (Internal b), TypeF (Internal c),
      TypeF (Internal d), Syntactic a, Syntactic b, Syntactic c,
      Syntactic d) =>
     Op (Internal a -> Internal b -> Internal c -> Internal d)
     -> a -> b -> c -> d
sugarSym3 op a b c   = unFull $ sugarSym op a b c
sugarSym4
  :: (TypeF (Internal a), TypeF (Internal b), TypeF (Internal c),
      TypeF (Internal d), TypeF (Internal e), Syntactic a, Syntactic b,
      Syntactic c, Syntactic d, Syntactic e) =>
     Op
       (Internal a
        -> Internal b -> Internal c -> Internal d -> Internal e)
     -> a -> b -> c -> d -> e
sugarSym4 op a b c d = unFull $ sugarSym op a b c d

-- | Convert an 'Op' to a function that builds the corresponding syntax tree
sugarSym :: SugarF a => Op (SugarT a) -> a
sugarSym = sugarF . op2f

-- | Mark an application as full rather than partial
newtype FFF a = FFF a

-- | Force the argument to be a full applicaton, resolving the
--   overloading in sugarSym
unFull :: FFF a -> a
unFull (FFF x) = x

op2f :: Op a -> (RCSExpr a, Int)
op2f op = (toCExpr $ Operator op, 0)

type RCSExpr a = CSEExpr (Expr a)

-- | Support for the overloaded sugarSym function
class SugarF a where
  type SugarT a
  sugarF :: (RCSExpr (SugarT a), Int) -> a

instance (Syntactic b, TypeF (Internal b), TypeF (SugarT c), SugarF c) => SugarF (b -> c) where
  type SugarT (b -> c) = Internal b -> SugarT c
  sugarF f = \ e -> sugarF $ f @@ e

instance (Syntactic b, TypeF (Internal b)) => SugarF (FFF b) where
  type SugarT (FFF b) = Internal b
  sugarF (ce,i) = FFF $ sugar $ ASTF (flattenCSE $ transCSEExpr toAExpr ce) i

max_stars_repo_name: pjonsson/feldspar-language

max_issues_repo_name: pjonsson/feldspar-language

max_forks_repo_name: pjonsson/feldspar-language


text:
{-# LANGUAGE CPP, FlexibleContexts #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE Trustworthy #-}

#if __GLASGOW_HASKELL__ >= 706
{-# LANGUAGE PolyKinds #-}
#endif

#if MIN_VERSION_base(4,8,0)
#define HAS_NATURAL
#define HAS_VOID
#endif

#if MIN_VERSION_base(4,7,0)
#define HAS_FIXED_CONSTRUCTOR
#endif

-----------------------------------------------------------------------------
-- |
-- Module      : Data.Binary.Class
-- Copyright   : Lennart Kolmodin
-- License     : BSD3-style (see LICENSE)
--
-- Maintainer  : Lennart Kolmodin <kolmodin@gmail.com>
-- Stability   : unstable
-- Portability : portable to Hugs and GHC. Requires the FFI and some flexible instances
--
-- Typeclass and instances for binary serialization.
--
-----------------------------------------------------------------------------

module Data.Binary.Class (

    -- * The Binary class
      Binary(..)

    -- * Support for generics
    , GBinaryGet(..)
    , GBinaryPut(..)

    ) where

import Data.Word
import Data.Bits
import Data.Int
import Data.Complex (Complex(..))
#ifdef HAS_VOID
import Data.Void
#endif

import Data.Binary.Put
import Data.Binary.Get

#if ! MIN_VERSION_base(4,8,0)
import Control.Applicative
import Data.Monoid (mempty)
#endif
import qualified Data.Monoid as Monoid
import Data.Monoid ((<>))
#if MIN_VERSION_base(4,8,0)
import Data.Functor.Identity (Identity (..))
#endif
#if MIN_VERSION_base(4,9,0)
import qualified Data.List.NonEmpty as NE
import qualified Data.Semigroup     as Semigroup
#endif
import Control.Monad

import Data.ByteString.Lazy (ByteString)
import qualified Data.ByteString.Lazy as L
import qualified Data.ByteString.Builder.Prim as Prim

import Data.List    (unfoldr, foldl')

-- And needed for the instances:
#if MIN_VERSION_base(4,10,0)
import Type.Reflection
import Type.Reflection.Unsafe
import Data.Kind (Type)
import GHC.Exts (RuntimeRep(..), VecCount, VecElem)
#endif
import qualified Data.ByteString as B
#if MIN_VERSION_bytestring(0,10,4)
import qualified Data.ByteString.Short as BS
#endif
import qualified Data.Map        as Map
import qualified Data.Set        as Set
import qualified Data.IntMap     as IntMap
import qualified Data.IntSet     as IntSet
import qualified Data.Ratio      as R

import qualified Data.Tree as T

import Data.Array.Unboxed

import GHC.Generics

#ifdef HAS_NATURAL
import Numeric.Natural
#endif

import qualified Data.Fixed as Fixed

--
-- This isn't available in older Hugs or older GHC
--
import qualified Data.Sequence as Seq
import qualified Data.Foldable as Fold

import GHC.Fingerprint

import Data.Version (Version(..))

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

-- Factored into two classes because this makes GHC optimize the
-- instances faster.  This doesn't matter for builds of binary,
-- but it matters a lot for end-users who write 'instance Binary T'.
-- See also: https://ghc.haskell.org/trac/ghc/ticket/9630
class GBinaryPut f where
    gput :: f t -> Put

class GBinaryGet f where
    gget :: Get (f t)

-- | The 'Binary' class provides 'put' and 'get', methods to encode and
-- decode a Haskell value to a lazy 'ByteString'. It mirrors the 'Read' and
-- 'Show' classes for textual representation of Haskell types, and is
-- suitable for serialising Haskell values to disk, over the network.
--
-- For decoding and generating simple external binary formats (e.g. C
-- structures), Binary may be used, but in general is not suitable
-- for complex protocols. Instead use the 'Put' and 'Get' primitives
-- directly.
--
-- Instances of Binary should satisfy the following property:
--
-- > decode . encode == id
--
-- That is, the 'get' and 'put' methods should be the inverse of each
-- other. A range of instances are provided for basic Haskell types.
--
class Binary t where
    -- | Encode a value in the Put monad.
    put :: t -> Put
    -- | Decode a value in the Get monad
    get :: Get t

    -- | Encode a list of values in the Put monad.
    -- The default implementation may be overridden to be more efficient
    -- but must still have the same encoding format.
    putList :: [t] -> Put
    putList = defaultPutList

    default put :: (Generic t, GBinaryPut (Rep t)) => t -> Put
    put = gput . from

    default get :: (Generic t, GBinaryGet (Rep t)) => Get t
    get = to `fmap` gget

{-# INLINE defaultPutList #-}
defaultPutList :: Binary a => [a] -> Put
defaultPutList xs = put (length xs) <> mapM_ put xs

------------------------------------------------------------------------
-- Simple instances

#ifdef HAS_VOID
-- Void never gets written nor reconstructed since it's impossible to have a
-- value of that type

-- | /Since: 0.8.0.0/
instance Binary Void where
    put     = absurd
    get     = mzero
#endif

-- The () type need never be written to disk: values of singleton type
-- can be reconstructed from the type alone
instance Binary () where
    put ()  = mempty
    get     = return ()

-- Bools are encoded as a byte in the range 0 .. 1
instance Binary Bool where
    put     = putWord8 . fromIntegral . fromEnum
    get     = getWord8 >>= toBool
      where
        toBool 0 = return False
        toBool 1 = return True
        toBool c = fail ("Could not map value " ++ show c ++ " to Bool")

-- Values of type 'Ordering' are encoded as a byte in the range 0 .. 2
instance Binary Ordering where
    put     = putWord8 . fromIntegral . fromEnum
    get     = getWord8 >>= toOrd
      where
        toOrd 0 = return LT
        toOrd 1 = return EQ
        toOrd 2 = return GT
        toOrd c = fail ("Could not map value " ++ show c ++ " to Ordering")

------------------------------------------------------------------------
-- Words and Ints

-- Words8s are written as bytes
instance Binary Word8 where
    put     = putWord8
    {-# INLINE putList #-}
    putList xs =
        put (length xs)
        <> putBuilder (Prim.primMapListFixed Prim.word8 xs)
    get     = getWord8

-- Words16s are written as 2 bytes in big-endian (network) order
instance Binary Word16 where
    put     = putWord16be
    {-# INLINE putList #-}
    putList xs =
        put (length xs)
        <> putBuilder (Prim.primMapListFixed Prim.word16BE xs)
    get     = getWord16be

-- Words32s are written as 4 bytes in big-endian (network) order
instance Binary Word32 where
    put     = putWord32be
    {-# INLINE putList #-}
    putList xs =
        put (length xs)
        <> putBuilder (Prim.primMapListFixed Prim.word32BE xs)
    get     = getWord32be

-- Words64s are written as 8 bytes in big-endian (network) order
instance Binary Word64 where
    put     = putWord64be
    {-# INLINE putList #-}
    putList xs =
        put (length xs)
        <> putBuilder (Prim.primMapListFixed Prim.word64BE xs)
    get     = getWord64be

-- Int8s are written as a single byte.
instance Binary Int8 where
    put     = putInt8
    {-# INLINE putList #-}
    putList xs =
        put (length xs)
        <> putBuilder (Prim.primMapListFixed Prim.int8 xs)
    get     = getInt8

-- Int16s are written as a 2 bytes in big endian format
instance Binary Int16 where
    put     = putInt16be
    {-# INLINE putList #-}
    putList xs =
        put (length xs)
        <> putBuilder (Prim.primMapListFixed Prim.int16BE xs)
    get     = getInt16be

-- Int32s are written as a 4 bytes in big endian format
instance Binary Int32 where
    put     = putInt32be
    {-# INLINE putList #-}
    putList xs =
        put (length xs)
        <> putBuilder (Prim.primMapListFixed Prim.int32BE xs)
    get     = getInt32be

-- Int64s are written as a 8 bytes in big endian format
instance Binary Int64 where
    put     = putInt64be
    {-# INLINE putList #-}
    putList xs =
        put (length xs)
        <> putBuilder (Prim.primMapListFixed Prim.int64BE xs)
    get     = getInt64be

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

-- Words are are written as Word64s, that is, 8 bytes in big endian format
instance Binary Word where
    put     = putWord64be . fromIntegral
    {-# INLINE putList #-}
    putList xs =
        put (length xs)
        <> putBuilder (Prim.primMapListFixed Prim.word64BE (map fromIntegral xs))
    get     = liftM fromIntegral getWord64be

-- Ints are are written as Int64s, that is, 8 bytes in big endian format
instance Binary Int where
    put     = putInt64be . fromIntegral
    {-# INLINE putList #-}
    putList xs =
        put (length xs)
        <> putBuilder (Prim.primMapListFixed Prim.int64BE (map fromIntegral xs))
    get     = liftM fromIntegral getInt64be

------------------------------------------------------------------------
--
-- Portable, and pretty efficient, serialisation of Integer
--

-- Fixed-size type for a subset of Integer
type SmallInt = Int32

-- Integers are encoded in two ways: if they fit inside a SmallInt,
-- they're written as a byte tag, and that value.  If the Integer value
-- is too large to fit in a SmallInt, it is written as a byte array,
-- along with a sign and length field.

instance Binary Integer where

    {-# INLINE put #-}
    put n | n >= lo && n <= hi =
        putBuilder (Prim.primFixed (Prim.word8 Prim.>*< Prim.int32BE) (0, fromIntegral n))
     where
        lo = fromIntegral (minBound :: SmallInt) :: Integer
        hi = fromIntegral (maxBound :: SmallInt) :: Integer

    put n =
        putWord8 1
        <> put sign
        <> put (unroll (abs n))         -- unroll the bytes
     where
        sign = fromIntegral (signum n) :: Word8

    {-# INLINE get #-}
    get = do
        tag <- get :: Get Word8
        case tag of
            0 -> liftM fromIntegral (get :: Get SmallInt)
            _ -> do sign  <- get
                    bytes <- get
                    let v = roll bytes
                    return $! if sign == (1 :: Word8) then v else - v

-- | /Since: 0.8.0.0/
#ifdef HAS_FIXED_CONSTRUCTOR
instance Binary (Fixed.Fixed a) where
  put (Fixed.MkFixed a) = put a
  get = Fixed.MkFixed `liftM` get
#else
instance forall a. Fixed.HasResolution a => Binary (Fixed.Fixed a) where
  -- Using undefined :: Maybe a as a proxy, as Data.Proxy is introduced only in base-4.7
  put x = put (truncate (x * fromInteger (Fixed.resolution (undefined :: Maybe a))) :: Integer)
  get = (\x -> fromInteger x / fromInteger (Fixed.resolution (undefined :: Maybe a))) `liftM` get
#endif

--
-- Fold and unfold an Integer to and from a list of its bytes
--
unroll :: (Integral a, Bits a) => a -> [Word8]
unroll = unfoldr step
  where
    step 0 = Nothing
    step i = Just (fromIntegral i, i `shiftR` 8)

roll :: (Integral a, Bits a) => [Word8] -> a
roll   = foldl' unstep 0 . reverse
  where
    unstep a b = a `shiftL` 8 .|. fromIntegral b

#ifdef HAS_NATURAL
-- Fixed-size type for a subset of Natural
type NaturalWord = Word64

-- | /Since: 0.7.3.0/
instance Binary Natural where
    {-# INLINE put #-}
    put n | n <= hi =
        putWord8 0
        <> put (fromIntegral n :: NaturalWord)  -- fast path
     where
        hi = fromIntegral (maxBound :: NaturalWord) :: Natural

    put n =
        putWord8 1
        <> put (unroll (abs n))         -- unroll the bytes

    {-# INLINE get #-}
    get = do
        tag <- get :: Get Word8
        case tag of
            0 -> liftM fromIntegral (get :: Get NaturalWord)
            _ -> do bytes <- get
                    return $! roll bytes
#endif

{-

--
-- An efficient, raw serialisation for Integer (GHC only)
--

-- TODO  This instance is not architecture portable.  GMP stores numbers as
-- arrays of machine sized words, so the byte format is not portable across
-- architectures with different endianness and word size.

import Data.ByteString.Base (toForeignPtr,unsafePackAddress, memcpy)
import GHC.Base     hiding (ord, chr)
import GHC.Prim
import GHC.Ptr (Ptr(..))
import GHC.IOBase (IO(..))

instance Binary Integer where
    put (S# i)    = putWord8 0 >> put (I# i)
    put (J# s ba) = do
        putWord8 1
        put (I# s)
        put (BA ba)

    get = do
        b <- getWord8
        case b of
            0 -> do (I# i#) <- get
                    return (S# i#)
            _ -> do (I# s#) <- get
                    (BA a#) <- get
                    return (J# s# a#)

instance Binary ByteArray where

    -- Pretty safe.
    put (BA ba) =
        let sz   = sizeofByteArray# ba   -- (primitive) in *bytes*
            addr = byteArrayContents# ba
            bs   = unsafePackAddress (I# sz) addr
        in put bs   -- write as a ByteString. easy, yay!

    -- Pretty scary. Should be quick though
    get = do
        (fp, off, n@(I# sz)) <- liftM toForeignPtr get      -- so decode a ByteString
        assert (off == 0) $ return $ unsafePerformIO $ do
            (MBA arr) <- newByteArray sz                    -- and copy it into a ByteArray#
            let to = byteArrayContents# (unsafeCoerce# arr) -- urk, is this safe?
            withForeignPtr fp $ \from -> memcpy (Ptr to) from (fromIntegral n)
            freezeByteArray arr

-- wrapper for ByteArray#
data ByteArray = BA  {-# UNPACK #-} !ByteArray#
data MBA       = MBA {-# UNPACK #-} !(MutableByteArray# RealWorld)

newByteArray :: Int# -> IO MBA
newByteArray sz = IO $ \s ->
  case newPinnedByteArray# sz s of { (# s', arr #) ->
  (# s', MBA arr #) }

freezeByteArray :: MutableByteArray# RealWorld -> IO ByteArray
freezeByteArray arr = IO $ \s ->
  case unsafeFreezeByteArray# arr s of { (# s', arr' #) ->
  (# s', BA arr' #) }

-}

instance (Binary a,Integral a) => Binary (R.Ratio a) where
    put r = put (R.numerator r) <> put (R.denominator r)
    get = liftM2 (R.%) get get

instance Binary a => Binary (Complex a) where
    {-# INLINE put #-}
    put (r :+ i) = put (r, i)
    {-# INLINE get #-}
    get = (\(r,i) -> r :+ i) <$> get

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

-- Char is serialised as UTF-8
instance Binary Char where
    put = putCharUtf8
    putList str = put (length str) <> putStringUtf8 str
    get = do
        let getByte = liftM (fromIntegral :: Word8 -> Int) get
            shiftL6 = flip shiftL 6 :: Int -> Int
        w <- getByte
        r <- case () of
                _ | w < 0x80  -> return w
                  | w < 0xe0  -> do
                                    x <- liftM (xor 0x80) getByte
                                    return (x .|. shiftL6 (xor 0xc0 w))
                  | w < 0xf0  -> do
                                    x <- liftM (xor 0x80) getByte
                                    y <- liftM (xor 0x80) getByte
                                    return (y .|. shiftL6 (x .|. shiftL6
                                            (xor 0xe0 w)))
                  | otherwise -> do
                                x <- liftM (xor 0x80) getByte
                                y <- liftM (xor 0x80) getByte
                                z <- liftM (xor 0x80) getByte
                                return (z .|. shiftL6 (y .|. shiftL6
                                        (x .|. shiftL6 (xor 0xf0 w))))
        getChr r
      where
        getChr w
          | w <= 0x10ffff = return $! toEnum $ fromEnum w
          | otherwise = fail "Not a valid Unicode code point!"

------------------------------------------------------------------------
-- Instances for the first few tuples

instance (Binary a, Binary b) => Binary (a,b) where
    {-# INLINE put #-}
    put (a,b)           = put a <> put b
    {-# INLINE get #-}
    get                 = liftM2 (,) get get

instance (Binary a, Binary b, Binary c) => Binary (a,b,c) where
    {-# INLINE put #-}
    put (a,b,c)         = put a <> put b <> put c
    {-# INLINE get #-}
    get                 = liftM3 (,,) get get get

instance (Binary a, Binary b, Binary c, Binary d) => Binary (a,b,c,d) where
    {-# INLINE put #-}
    put (a,b,c,d)       = put a <> put b <> put c <> put d
    {-# INLINE get #-}
    get                 = liftM4 (,,,) get get get get

instance (Binary a, Binary b, Binary c, Binary d, Binary e) => Binary (a,b,c,d,e) where
    {-# INLINE put #-}
    put (a,b,c,d,e)     = put a <> put b <> put c <> put d <> put e
    {-# INLINE get #-}
    get                 = liftM5 (,,,,) get get get get get

--
-- and now just recurse:
--

instance (Binary a, Binary b, Binary c, Binary d, Binary e, Binary f)
        => Binary (a,b,c,d,e,f) where
    {-# INLINE put #-}
    put (a,b,c,d,e,f)   = put (a,(b,c,d,e,f))
    {-# INLINE get #-}
    get                 = do (a,(b,c,d,e,f)) <- get ; return (a,b,c,d,e,f)

instance (Binary a, Binary b, Binary c, Binary d, Binary e, Binary f, Binary g)
        => Binary (a,b,c,d,e,f,g) where
    {-# INLINE put #-}
    put (a,b,c,d,e,f,g) = put (a,(b,c,d,e,f,g))
    {-# INLINE get #-}
    get                 = do (a,(b,c,d,e,f,g)) <- get ; return (a,b,c,d,e,f,g)

instance (Binary a, Binary b, Binary c, Binary d, Binary e,
          Binary f, Binary g, Binary h)
        => Binary (a,b,c,d,e,f,g,h) where
    {-# INLINE put #-}
    put (a,b,c,d,e,f,g,h) = put (a,(b,c,d,e,f,g,h))
    {-# INLINE get #-}
    get                   = do (a,(b,c,d,e,f,g,h)) <- get ; return (a,b,c,d,e,f,g,h)

instance (Binary a, Binary b, Binary c, Binary d, Binary e,
          Binary f, Binary g, Binary h, Binary i)
        => Binary (a,b,c,d,e,f,g,h,i) where
    {-# INLINE put #-}
    put (a,b,c,d,e,f,g,h,i) = put (a,(b,c,d,e,f,g,h,i))
    {-# INLINE get #-}
    get                     = do (a,(b,c,d,e,f,g,h,i)) <- get ; return (a,b,c,d,e,f,g,h,i)

instance (Binary a, Binary b, Binary c, Binary d, Binary e,
          Binary f, Binary g, Binary h, Binary i, Binary j)
        => Binary (a,b,c,d,e,f,g,h,i,j) where
    {-# INLINE put #-}
    put (a,b,c,d,e,f,g,h,i,j) = put (a,(b,c,d,e,f,g,h,i,j))
    {-# INLINE get #-}
    get                       = do (a,(b,c,d,e,f,g,h,i,j)) <- get ; return (a,b,c,d,e,f,g,h,i,j)

------------------------------------------------------------------------
-- Container types

#if MIN_VERSION_base(4,8,0)
instance Binary a => Binary (Identity a) where
  put (Identity x) = put x
  get = Identity <$> get
#endif

instance Binary a => Binary [a] where
    put = putList
    get = do n <- get :: Get Int
             getMany n

-- | 'getMany n' get 'n' elements in order, without blowing the stack.
getMany :: Binary a => Int -> Get [a]
getMany n = go [] n
 where
    go xs 0 = return $! reverse xs
    go xs i = do x <- get
                 -- we must seq x to avoid stack overflows due to laziness in
                 -- (>>=)
                 x `seq` go (x:xs) (i-1)
{-# INLINE getMany #-}

instance (Binary a) => Binary (Maybe a) where
    put Nothing  = putWord8 0
    put (Just x) = putWord8 1 <> put x
    get = do
        w <- getWord8
        case w of
            0 -> return Nothing
            _ -> liftM Just get

instance (Binary a, Binary b) => Binary (Either a b) where
    put (Left  a) = putWord8 0 <> put a
    put (Right b) = putWord8 1 <> put b
    get = do
        w <- getWord8
        case w of
            0 -> liftM Left  get
            _ -> liftM Right get

------------------------------------------------------------------------
-- ByteStrings (have specially efficient instances)

instance Binary B.ByteString where
    put bs = put (B.length bs)
             <> putByteString bs
    get    = get >>= getByteString

--
-- Using old versions of fps, this is a type synonym, and non portable
--
-- Requires 'flexible instances'
--
instance Binary ByteString where
    put bs = put (fromIntegral (L.length bs) :: Int)
             <> putLazyByteString bs
    get    = get >>= getLazyByteString

#if MIN_VERSION_bytestring(0,10,4)
instance Binary BS.ShortByteString where
   put bs = put (BS.length bs)
            <> putShortByteString bs
   get = get >>= fmap BS.toShort . getByteString
#endif

------------------------------------------------------------------------
-- Maps and Sets

instance (Binary a) => Binary (Set.Set a) where
    put s = put (Set.size s) <> mapM_ put (Set.toAscList s)
    get   = liftM Set.fromDistinctAscList get

instance (Binary k, Binary e) => Binary (Map.Map k e) where
    put m = put (Map.size m) <> mapM_ put (Map.toAscList m)
    get   = liftM Map.fromDistinctAscList get

instance Binary IntSet.IntSet where
    put s = put (IntSet.size s) <> mapM_ put (IntSet.toAscList s)
    get   = liftM IntSet.fromDistinctAscList get

instance (Binary e) => Binary (IntMap.IntMap e) where
    put m = put (IntMap.size m) <> mapM_ put (IntMap.toAscList m)
    get   = liftM IntMap.fromDistinctAscList get

------------------------------------------------------------------------
-- Queues and Sequences

--
-- This is valid Hugs, but you need the most recent Hugs
--

instance (Binary e) => Binary (Seq.Seq e) where
    put s = put (Seq.length s) <> Fold.mapM_ put s
    get = do n <- get :: Get Int
             rep Seq.empty n get
      where rep xs 0 _ = return $! xs
            rep xs n g = xs `seq` n `seq` do
                           x <- g
                           rep (xs Seq.|> x) (n-1) g

------------------------------------------------------------------------
-- Floating point

instance Binary Double where
    put d = put (decodeFloat d)
    get   = do
        x <- get
        y <- get
        return $! encodeFloat x y

instance Binary Float where
    put f = put (decodeFloat f)
    get   =  do
        x <- get
        y <- get
        return $! encodeFloat x y

------------------------------------------------------------------------
-- Trees

instance (Binary e) => Binary (T.Tree e) where
    put (T.Node r s) = put r <> put s
    get = liftM2 T.Node get get

------------------------------------------------------------------------
-- Arrays

instance (Binary i, Ix i, Binary e) => Binary (Array i e) where
    put a =
        put (bounds a)
        <> put (rangeSize $ bounds a) -- write the length
        <> mapM_ put (elems a)        -- now the elems.
    get = do
        bs <- get
        n  <- get                  -- read the length
        xs <- getMany n            -- now the elems.
        return (listArray bs xs)

--
-- The IArray UArray e constraint is non portable. Requires flexible instances
--
instance (Binary i, Ix i, Binary e, IArray UArray e) => Binary (UArray i e) where
    put a =
        put (bounds a)
        <> put (rangeSize $ bounds a) -- now write the length
        <> mapM_ put (elems a)
    get = do
        bs <- get
        n  <- get
        xs <- getMany n
        return (listArray bs xs)

------------------------------------------------------------------------
-- Fingerprints

-- | /Since: 0.7.6.0/
instance Binary Fingerprint where
    put (Fingerprint x1 x2) = put x1 <> put x2
    get = do
        x1 <- get
        x2 <- get
        return $! Fingerprint x1 x2

------------------------------------------------------------------------
-- Version

-- | /Since: 0.8.0.0/
instance Binary Version where
    put (Version br tags) = put br <> put tags
    get = Version <$> get <*> get

------------------------------------------------------------------------
-- Data.Monoid datatypes

-- | /Since: 0.8.4.0/
instance Binary a => Binary (Monoid.Dual a) where
  get = fmap Monoid.Dual get
  put = put . Monoid.getDual

-- | /Since: 0.8.4.0/
instance Binary Monoid.All where
  get = fmap Monoid.All get
  put = put . Monoid.getAll

-- | /Since: 0.8.4.0/
instance Binary Monoid.Any where
  get = fmap Monoid.Any get
  put = put . Monoid.getAny

-- | /Since: 0.8.4.0/
instance Binary a => Binary (Monoid.Sum a) where
  get = fmap Monoid.Sum get
  put = put . Monoid.getSum

-- | /Since: 0.8.4.0/
instance Binary a => Binary (Monoid.Product a) where
  get = fmap Monoid.Product get
  put = put . Monoid.getProduct

-- | /Since: 0.8.4.0/
instance Binary a => Binary (Monoid.First a) where
  get = fmap Monoid.First get
  put = put . Monoid.getFirst

-- | /Since: 0.8.4.0/
instance Binary a => Binary (Monoid.Last a) where
  get = fmap Monoid.Last get
  put = put . Monoid.getLast

#if MIN_VERSION_base(4,8,0)
-- | /Since: 0.8.4.0/
instance Binary (f a) => Binary (Monoid.Alt f a) where
  get = fmap Monoid.Alt get
  put = put . Monoid.getAlt
#endif

#if MIN_VERSION_base(4,9,0)
------------------------------------------------------------------------
-- Data.Semigroup datatypes

-- | /Since: 0.8.4.0/
instance Binary a => Binary (Semigroup.Min a) where
  get = fmap Semigroup.Min get
  put = put . Semigroup.getMin

-- | /Since: 0.8.4.0/
instance Binary a => Binary (Semigroup.Max a) where
  get = fmap Semigroup.Max get
  put = put . Semigroup.getMax

-- | /Since: 0.8.4.0/
instance Binary a => Binary (Semigroup.First a) where
  get = fmap Semigroup.First get
  put = put . Semigroup.getFirst

-- | /Since: 0.8.4.0/
instance Binary a => Binary (Semigroup.Last a) where
  get = fmap Semigroup.Last get
  put = put . Semigroup.getLast

-- | /Since: 0.8.4.0/
instance Binary a => Binary (Semigroup.Option a) where
  get = fmap Semigroup.Option get
  put = put . Semigroup.getOption

-- | /Since: 0.8.4.0/
instance Binary m => Binary (Semigroup.WrappedMonoid m) where
  get = fmap Semigroup.WrapMonoid get
  put = put . Semigroup.unwrapMonoid

-- | /Since: 0.8.4.0/
instance (Binary a, Binary b) => Binary (Semigroup.Arg a b) where
  get                     = liftM2 Semigroup.Arg get get
  put (Semigroup.Arg a b) = put a <> put b

------------------------------------------------------------------------
-- Non-empty lists

-- | /Since: 0.8.4.0/
instance Binary a => Binary (NE.NonEmpty a) where
  get = fmap NE.fromList get
  put = put . NE.toList
#endif

------------------------------------------------------------------------
-- Typeable/Reflection

#if MIN_VERSION_base(4,10,0)

-- $typeable-instances
--
-- 'Binary' instances for GHC's "Type.Reflection", "Data.Typeable", and
-- kind-system primitives are only provided with @base-4.10.0@ (shipped with GHC
-- 8.2.1). In prior GHC releases some of these instances were provided by
-- 'GHCi.TH.Binary' in the @ghci@ package.
--
-- These include instances for,
--
-- * 'VecCount'
-- * 'VecElem'
-- * 'RuntimeRep'
-- * 'KindRep'
-- * 'TypeLitSort'
-- * 'TyCon'
-- * 'TypeRep'
-- * 'SomeTypeRep' (also known as 'Data.Typeable.TypeRep')
--

-- | @since 0.8.5.0. See #typeable-instances#
instance Binary VecCount where
    put = putWord8 . fromIntegral . fromEnum
    get = toEnum . fromIntegral <$> getWord8

-- | @since 0.8.5.0. See #typeable-instances#
instance Binary VecElem where
    put = putWord8 . fromIntegral . fromEnum
    get = toEnum . fromIntegral <$> getWord8

-- | @since 0.8.5.0. See #typeable-instances#
instance Binary RuntimeRep where
    put (VecRep a b)    = putWord8 0 >> put a >> put b
    put (TupleRep reps) = putWord8 1 >> put reps
    put (SumRep reps)   = putWord8 2 >> put reps
    put LiftedRep       = putWord8 3
    put UnliftedRep     = putWord8 4
    put IntRep          = putWord8 5
    put WordRep         = putWord8 6
    put Int64Rep        = putWord8 7
    put Word64Rep       = putWord8 8
    put AddrRep         = putWord8 9
    put FloatRep        = putWord8 10
    put DoubleRep       = putWord8 11
#if __GLASGOW_HASKELL__ >= 807
    put Int8Rep         = putWord8 12
    put Word8Rep        = putWord8 13
    put Int16Rep        = putWord8 14
    put Word16Rep       = putWord8 15
#endif

    get = do
        tag <- getWord8
        case tag of
          0  -> VecRep <$> get <*> get
          1  -> TupleRep <$> get
          2  -> SumRep <$> get
          3  -> pure LiftedRep
          4  -> pure UnliftedRep
          5  -> pure IntRep
          6  -> pure WordRep
          7  -> pure Int64Rep
          8  -> pure Word64Rep
          9  -> pure AddrRep
          10 -> pure FloatRep
          11 -> pure DoubleRep
#if __GLASGOW_HASKELL__ >= 807
          12 -> pure Int8Rep
          13 -> pure Word8Rep
          14 -> pure Int16Rep
          15 -> pure Word16Rep
#endif
          _  -> fail "GHCi.TH.Binary.putRuntimeRep: invalid tag"

-- | @since 0.8.5.0. See #typeable-instances#
instance Binary TyCon where
    put tc = do
        put (tyConPackage tc)
        put (tyConModule tc)
        put (tyConName tc)
        put (tyConKindArgs tc)
        put (tyConKindRep tc)
    get = mkTyCon <$> get <*> get <*> get <*> get <*> get

-- | @since 0.8.5.0. See #typeable-instances#
instance Binary KindRep where
    put (KindRepTyConApp tc k) = putWord8 0 >> put tc >> put k
    put (KindRepVar bndr) = putWord8 1 >> put bndr
    put (KindRepApp a b) = putWord8 2 >> put a >> put b
    put (KindRepFun a b) = putWord8 3 >> put a >> put b
    put (KindRepTYPE r) = putWord8 4 >> put r
    put (KindRepTypeLit sort r) = putWord8 5 >> put sort >> put r

    get = do
        tag <- getWord8
        case tag of
          0 -> KindRepTyConApp <$> get <*> get
          1 -> KindRepVar <$> get
          2 -> KindRepApp <$> get <*> get
          3 -> KindRepFun <$> get <*> get
          4 -> KindRepTYPE <$> get
          5 -> KindRepTypeLit <$> get <*> get
          _ -> fail "GHCi.TH.Binary.putKindRep: invalid tag"

-- | @since 0.8.5.0. See #typeable-instances#
instance Binary TypeLitSort where
    put TypeLitSymbol = putWord8 0
    put TypeLitNat = putWord8 1
    get = do
        tag <- getWord8
        case tag of
          0 -> pure TypeLitSymbol
          1 -> pure TypeLitNat
          _ -> fail "GHCi.TH.Binary.putTypeLitSort: invalid tag"

putTypeRep :: TypeRep a -> Put
-- Special handling for TYPE, (->), and RuntimeRep due to recursive kind
-- relations.
-- See Note [Mutually recursive representations of primitive types]
putTypeRep rep  -- Handle Type specially since it's so common
  | Just HRefl <- rep `eqTypeRep` (typeRep :: TypeRep Type)
  = put (0 :: Word8)
putTypeRep (Con' con ks) = do
    put (1 :: Word8)
    put con
    put ks
putTypeRep (App f x) = do
    put (2 :: Word8)
    putTypeRep f
    putTypeRep x
putTypeRep (Fun arg res) = do
    put (3 :: Word8)
    putTypeRep arg
    putTypeRep res
putTypeRep _ = fail "GHCi.TH.Binary.putTypeRep: Impossible"

getSomeTypeRep :: Get SomeTypeRep
getSomeTypeRep = do
    tag <- get :: Get Word8
    case tag of
        0 -> return $ SomeTypeRep (typeRep :: TypeRep Type)
        1 -> do con <- get :: Get TyCon
                ks <- get :: Get [SomeTypeRep]
                return $ SomeTypeRep $ mkTrCon con ks
        2 -> do SomeTypeRep f <- getSomeTypeRep
                SomeTypeRep x <- getSomeTypeRep
                case typeRepKind f of
                  Fun arg res ->
                      case arg `eqTypeRep` typeRepKind x of
                        Just HRefl -> do
                            case typeRepKind res `eqTypeRep` (typeRep :: TypeRep Type) of
                                Just HRefl -> return $ SomeTypeRep $ mkTrApp f x
                                _ -> failure "Kind mismatch" []
                        _ -> failure "Kind mismatch"
                             [ "Found argument of kind:      " ++ show (typeRepKind x)
                             , "Where the constructor:       " ++ show f
                             , "Expects an argument of kind: " ++ show arg
                             ]
                  _ -> failure "Applied non-arrow type"
                       [ "Applied type: " ++ show f
                       , "To argument:  " ++ show x
                       ]
        3 -> do SomeTypeRep arg <- getSomeTypeRep
                SomeTypeRep res <- getSomeTypeRep
                case typeRepKind arg `eqTypeRep` (typeRep :: TypeRep Type) of
                  Just HRefl ->
                      case typeRepKind res `eqTypeRep` (typeRep :: TypeRep Type) of
                        Just HRefl -> return $ SomeTypeRep $ Fun arg res
                        Nothing -> failure "Kind mismatch" []
                  Nothing -> failure "Kind mismatch" []
        _ -> failure "Invalid SomeTypeRep" []
  where
    failure description info =
        fail $ unlines $ [ "GHCi.TH.Binary.getSomeTypeRep: "++description ]
                      ++ map ("    "++) info

instance Typeable a => Binary (TypeRep (a :: k)) where
    put = putTypeRep
    get = do
        SomeTypeRep rep <- getSomeTypeRep
        case rep `eqTypeRep` expected of
          Just HRefl -> pure rep
          Nothing    -> fail $ unlines
                        [ "GHCi.TH.Binary: Type mismatch"
                        , "    Deserialized type: " ++ show rep
                        , "    Expected type:     " ++ show expected
                        ]
     where expected = typeRep :: TypeRep a

instance Binary SomeTypeRep where
    put (SomeTypeRep rep) = putTypeRep rep
    get = getSomeTypeRep
#endif

max_stars_repo_name: bgamari/binary

max_issues_repo_name: bgamari/binary

max_forks_repo_name: bgamari/binary