Initial commit

bundled/Basement/Compat/AMP.hs

@@ -0,0 +1,16 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE RebindableSyntax #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE CPP             #-}
+{-# LANGUAGE ConstraintKinds #-}
+-- a compat module for ghc < 7.10 to handle the AMP change smoothly
+module Basement.Compat.AMP
+    ( AMPMonad
+    ) where
+
+import Basement.Compat.Base
+
+{-# DEPRECATED AMPMonad "use Monad" #-}
+type AMPMonad m = Monad m

bundled/Basement/Compat/Base.hs

@@ -0,0 +1,99 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE RebindableSyntax #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+-- |
+-- Module      : Basement.Compat.Base
+-- License     : BSD-style
+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>
+-- Stability   : experimental
+-- Portability : portable
+--
+-- internal re-export of all the good base bits
+module Basement.Compat.Base
+    ( (Prelude.$)
+    , (Prelude.$!)
+    , (Prelude.&&)
+    , (Prelude.||)
+    , (Control.Category..)
+    , (Control.Applicative.<$>)
+    , Prelude.not
+    , Prelude.otherwise
+    , Prelude.fst
+    , Prelude.snd
+    , Control.Category.id
+    , Prelude.maybe
+    , Prelude.either
+    , Prelude.flip
+    , Prelude.const
+    , Prelude.error
+    , Prelude.and
+    , Prelude.undefined
+    , Prelude.seq
+    , Prelude.Show (..)
+    , Prelude.Ord (..)
+    , Prelude.Eq (..)
+    , Prelude.Bounded (..)
+    , Prelude.Enum (..)
+    , Prelude.Functor (..)
+    , Control.Applicative.Applicative (..)
+    , Prelude.Monad (..)
+    , Control.Monad.when
+    , Control.Monad.unless
+    , Prelude.Maybe (..)
+    , Prelude.Ordering (..)
+    , Prelude.Bool (..)
+    , Prelude.Int
+    , Prelude.Integer
+    , Prelude.Char
+    , Basement.Compat.NumLiteral.Integral (..)
+    , Basement.Compat.NumLiteral.Fractional (..)
+    , Basement.Compat.NumLiteral.HasNegation (..)
+    , Data.Int.Int8, Data.Int.Int16, Data.Int.Int32, Data.Int.Int64
+    , Data.Word.Word8, Data.Word.Word16, Data.Word.Word32, Data.Word.Word64, Data.Word.Word
+    , Prelude.Double, Prelude.Float
+    , Prelude.IO
+    , Basement.Compat.IsList.IsList (..)
+    , GHC.Exts.IsString (..)
+    , GHC.Generics.Generic
+    , Prelude.Either (..)
+    , Data.Data.Data (..)
+    , Data.Data.mkNoRepType
+    , Data.Data.DataType
+    , Basement.Compat.Typeable.Typeable
+    , Data.Monoid.Monoid (..)
+    , (Data.Monoid.<>)
+    , Control.Exception.Exception
+    , Control.Exception.throw
+    , Control.Exception.throwIO
+    , GHC.Ptr.Ptr(..)
+    , ifThenElse
+    , internalError
+    ) where
+
+import qualified Prelude
+import qualified Control.Category
+import qualified Control.Applicative
+import qualified Control.Exception
+import qualified Control.Monad
+import qualified Data.Monoid
+import qualified Data.Data
+import qualified Data.Word
+import qualified Data.Int
+import qualified Basement.Compat.IsList
+import qualified Basement.Compat.NumLiteral
+import qualified Basement.Compat.Typeable
+import qualified GHC.Exts
+import qualified GHC.Generics
+import qualified GHC.Ptr
+import           GHC.Exts (fromString)
+
+-- | Only to use internally for internal error cases
+internalError :: [Prelude.Char] -> a
+internalError s = Prelude.error ("Internal Error: the impossible happened: " Prelude.++ s)
+
+-- | for support of if .. then .. else
+ifThenElse :: Prelude.Bool -> a -> a -> a
+ifThenElse Prelude.True  e1 _  = e1
+ifThenElse Prelude.False _  e2 = e2

bundled/Basement/Compat/Bifunctor.hs

@@ -0,0 +1,122 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE RebindableSyntax #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+-- |
+-- Module      : Basement.Compat.Bifunctor
+-- License     : BSD-style
+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>
+-- Stability   : experimental
+-- Portability : portable
+--
+-- A bifunctor is a type constructor that takes
+-- two type arguments and is a functor in /both/ arguments. That
+-- is, unlike with 'Functor', a type constructor such as 'Either'
+-- does not need to be partially applied for a 'Bifunctor'
+-- instance, and the methods in this class permit mapping
+-- functions over the 'Left' value or the 'Right' value,
+-- or both at the same time.
+--
+-- Formally, the class 'Bifunctor' represents a bifunctor
+-- from @Hask@ -> @Hask@.
+--
+-- Intuitively it is a bifunctor where both the first and second
+-- arguments are covariant.
+--
+-- You can define a 'Bifunctor' by either defining 'bimap' or by
+-- defining both 'first' and 'second'.
+--
+{-# LANGUAGE CPP #-}
+module Basement.Compat.Bifunctor
+  ( Bifunctor(..)
+  ) where
+
+#if MIN_VERSION_base(4,8,0)
+
+import Data.Bifunctor (Bifunctor(..))
+
+#else
+
+import           Control.Applicative ( Const(..) )
+import           GHC.Generics ( K1(..) )
+import qualified Prelude as P
+
+class Bifunctor p where
+    {-# MINIMAL bimap | first, second #-}
+
+    -- | Map over both arguments at the same time.
+    --
+    -- @'bimap' f g ≡ 'first' f '.' 'second' g@
+    --
+    -- ==== __Examples__
+    --
+    -- >>> bimap toUpper (+1) ('j', 3)
+    -- ('J',4)
+    --
+    -- >>> bimap toUpper (+1) (Left 'j')
+    -- Left 'J'
+    --
+    -- >>> bimap toUpper (+1) (Right 3)
+    -- Right 4
+    bimap :: (a -> b) -> (c -> d) -> p a c -> p b d
+    bimap f g = first f P.. second g
+
+    -- | Map covariantly over the first argument.
+    --
+    -- @'first' f ≡ 'bimap' f 'id'@
+    --
+    -- ==== __Examples__
+    --
+    -- >>> first toUpper ('j', 3)
+    -- ('J',3)
+    --
+    -- >>> first toUpper (Left 'j')
+    -- Left 'J'
+    first :: (a -> b) -> p a c -> p b c
+    first f = bimap f P.id
+
+    -- | Map covariantly over the second argument.
+    --
+    -- @'second' ≡ 'bimap' 'id'@
+    --
+    -- ==== __Examples__
+    -- >>> second (+1) ('j', 3)
+    -- ('j',4)
+    --
+    -- >>> second (+1) (Right 3)
+    -- Right 4
+    second :: (b -> c) -> p a b -> p a c
+    second = bimap P.id
+
+
+instance Bifunctor (,) where
+    bimap f g ~(a, b) = (f a, g b)
+
+instance Bifunctor ((,,) x1) where
+    bimap f g ~(x1, a, b) = (x1, f a, g b)
+
+instance Bifunctor ((,,,) x1 x2) where
+    bimap f g ~(x1, x2, a, b) = (x1, x2, f a, g b)
+
+instance Bifunctor ((,,,,) x1 x2 x3) where
+    bimap f g ~(x1, x2, x3, a, b) = (x1, x2, x3, f a, g b)
+
+instance Bifunctor ((,,,,,) x1 x2 x3 x4) where
+    bimap f g ~(x1, x2, x3, x4, a, b) = (x1, x2, x3, x4, f a, g b)
+
+instance Bifunctor ((,,,,,,) x1 x2 x3 x4 x5) where
+    bimap f g ~(x1, x2, x3, x4, x5, a, b) = (x1, x2, x3, x4, x5, f a, g b)
+
+
+instance Bifunctor P.Either where
+    bimap f _ (P.Left a) = P.Left (f a)
+    bimap _ g (P.Right b) = P.Right (g b)
+
+instance Bifunctor Const where
+    bimap f _ (Const a) = Const (f a)
+
+instance Bifunctor (K1 i) where
+    bimap f _ (K1 c) = K1 (f c)
+
+#endif

bundled/Basement/Compat/C/Types.hs

@@ -0,0 +1,28 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE RebindableSyntax #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# Language CPP #-}
+-- |
+-- Module      : Basement.Compat.C.Types
+-- License     : BSD-style
+-- Maintainer  : Foundation
+--
+-- Literal support for Integral and Fractional
+-- {-# LANGUAGE TypeSynonymInstances #-}
+-- {-# LANGUAGE FlexibleInstances #-}
+module Basement.Compat.C.Types
+    ( CChar(..), CSChar(..), CUChar(..)
+    , CShort(..), CUShort(..), CInt(..), CUInt(..), CLong(..), CULong(..)
+    , CPtrdiff(..), CSize(..), CWchar(..), CSigAtomic(..), CLLong(..), CULLong(..)
+#if MIN_VERSION_base(4,10,0)
+    , CBool(..)
+#endif
+    , CIntPtr(..), CUIntPtr(..), CIntMax(..), CUIntMax(..)
+    , CClock(..), CTime(..), CUSeconds(..), CSUSeconds(..), CFloat(..), CDouble
+    , COff(..), CMode(..)
+    ) where
+
+import Foreign.C.Types
+import System.Posix.Types

bundled/Basement/Compat/CallStack.hs

@@ -0,0 +1,29 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE RebindableSyntax #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE ImplicitParams #-}
+{-# LANGUAGE ConstraintKinds #-}
+module Basement.Compat.CallStack
+    ( HasCallStack
+    ) where
+
+#if MIN_VERSION_base(4,9,0)
+
+import GHC.Stack (HasCallStack)
+
+#elif MIN_VERSION_base(4,8,1)
+
+import qualified GHC.Stack
+
+type HasCallStack = (?callStack :: GHC.Stack.CallStack)
+
+#else
+
+import GHC.Exts (Constraint)
+
+type HasCallStack = (() :: Constraint)
+
+#endif

bundled/Basement/Compat/ExtList.hs

@@ -0,0 +1,52 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE RebindableSyntax #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE CPP #-}
+module Basement.Compat.ExtList
+    ( length
+    , null
+    , sum
+    , reverse
+    , (!!)
+    ) where
+
+import Basement.Compat.Base
+import Basement.Numerical.Additive
+import Basement.Types.OffsetSize
+import qualified GHC.List as List
+
+-- | Compute the size of the list
+length :: [a] -> CountOf a
+#if MIN_VERSION_base(4,8,0)
+length = CountOf . List.foldl' (\c _ -> c+1) 0
+#else
+length = CountOf . loop 0
+  where loop !acc []     = acc
+        loop !acc (_:xs) = loop (1+acc) xs
+#endif
+
+null :: [a] -> Bool
+null []    = True
+null (_:_) = False
+
+-- | Sum the element in a list
+sum :: Additive n => [n] -> n
+sum []     = azero
+sum (i:is) = loop i is
+  where
+    loop !acc [] = acc
+    loop !acc (x:xs) = loop (acc+x) xs
+    {-# INLINE loop #-}
+
+reverse :: [a] -> [a]
+reverse l =  go l []
+  where
+    go []     acc = acc
+    go (x:xs) acc = go xs (x:acc)
+
+(!!) :: [a] -> Offset a -> a
+[]    !! _  = error "invalid offset for !!"
+(x:_) !! 0  = x
+(_:xs) !! i = xs !! pred i

bundled/Basement/Compat/Identity.hs

@@ -0,0 +1,42 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE RebindableSyntax #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+-- |
+-- Module      : Basement.Compat.Identity
+-- License     : BSD-style
+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>
+-- Stability   : experimental
+-- Portability : portable
+--
+-- Identity re-export, with a compat wrapper for older version of base that
+-- do not have Data.Functor.Identity
+{-# LANGUAGE CPP #-}
+module Basement.Compat.Identity
+    ( Identity(..)
+    ) where
+
+#if MIN_VERSION_base(4,8,0)
+
+import Data.Functor.Identity
+
+#else
+
+import Basement.Compat.Base
+
+newtype Identity a = Identity { runIdentity :: a }
+    deriving (Eq, Ord)
+
+instance Functor Identity where
+    fmap f (Identity a) = Identity (f a)
+
+instance Applicative Identity where
+    pure a = Identity a
+    (<*>) fab fa = Identity $ runIdentity fab (runIdentity fa)
+
+instance Monad Identity where
+    return    = pure
+    ma >>= mb = mb (runIdentity ma)
+
+#endif

bundled/Basement/Compat/IsList.hs

@@ -0,0 +1,41 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE RebindableSyntax #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+-- |
+-- Module      : Basement.Compat.IsList
+-- License     : BSD-style
+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>
+-- Stability   : experimental
+-- Portability : portable
+--
+-- compat friendly version of IsList
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE CPP #-}
+module Basement.Compat.IsList
+    ( IsList(..)
+    ) where
+
+#if MIN_VERSION_base(4,7,0)
+
+import           GHC.Exts
+
+#else
+
+import qualified Prelude
+
+class IsList l where
+  type Item l
+  fromList  :: [Item l] -> l
+  toList    :: l -> [Item l]
+
+  fromListN :: Prelude.Int -> [Item l] -> l
+  fromListN _ = fromList
+
+instance IsList [a] where
+    type Item [a] = a
+    fromList = Prelude.id
+    toList   = Prelude.id
+
+#endif

bundled/Basement/Compat/MonadTrans.hs

@@ -0,0 +1,55 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE RebindableSyntax #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+-- |
+-- Module      : Basement.Compat.MonadTrans
+-- License     : BSD-style
+-- Maintainer  : Psychohistorians
+-- Stability   : experimental
+-- Portability : portable
+--
+-- An internal and really simple monad transformers,
+-- without any bells and whistse.
+module Basement.Compat.MonadTrans
+    ( State(..)
+    , Reader(..)
+    ) where
+
+import Basement.Compat.Base
+import Control.Monad ((>=>))
+
+-- | Simple State monad
+newtype State s m a = State { runState :: s -> m (a, s) }
+
+instance Monad m => Functor (State s m) where
+    fmap f fa = State $ runState fa >=> (\(a, s2) -> return (f a, s2))
+instance Monad m => Applicative (State s m) where
+    pure a = State $ \st -> return (a,st)
+    fab <*> fa = State $ \s1 -> do
+        (ab,s2) <- runState fab s1
+        (a,s3)  <- runState fa s2
+        return (ab a, s3)
+instance Monad m => Monad (State r m) where
+    return = pure
+    ma >>= mb = State $ \s1 -> do
+        (a,s2) <- runState ma s1
+        runState (mb a) s2
+
+-- | Simple Reader monad
+newtype Reader r m a = Reader { runReader :: r -> m a }
+
+instance Monad m => Functor (Reader r m) where
+    fmap f fa = Reader $ runReader fa >=> (\a -> return (f a))
+instance Monad m => Applicative (Reader r m) where
+    pure a = Reader $ \_ -> return a
+    fab <*> fa = Reader $ \r -> do
+        a  <- runReader fa r
+        ab <- runReader fab r
+        return $ ab a
+instance Monad m => Monad (Reader r m) where
+    return = pure
+    ma >>= mb = Reader $ \r -> do
+        a <- runReader ma r
+        runReader (mb a) r

bundled/Basement/Compat/Natural.hs

@@ -0,0 +1,66 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE RebindableSyntax #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+module Basement.Compat.Natural
+    ( Natural
+    , integerToNatural
+    , naturalToInteger
+    ) where
+
+#if MIN_VERSION_base(4,8,0)
+
+import Numeric.Natural
+import Prelude (Integer, abs, fromInteger, toInteger)
+
+#else
+
+import Prelude (Show(..),Eq,Ord,Enum,Num(..),Real(..),Integral(..),Integer,error,(<), (>), otherwise, toInteger)
+import Data.Bits
+import Data.Typeable
+
+newtype Natural = Natural Integer
+    deriving (Eq,Ord,Enum,Typeable,Bits)
+
+instance Show Natural where
+    show (Natural i) = show i
+
+-- re-create the buggy Num instance for Natural
+instance Num Natural where
+    fromInteger n
+        | n < 0     = error "natural should be positive: "
+        | otherwise = Natural n
+    (+) (Natural a) (Natural b) = Natural (a + b)
+    (-) (Natural a) (Natural b)
+        | r < 0     = error "natural should be positve"
+        | otherwise = Natural (a - b)
+      where r = (a - b)
+    (*) (Natural a) (Natural b) = Natural (a * b)
+    abs n = n
+    negate n = n
+    signum (Natural n)
+        | n > 0     = 1
+        | otherwise = 0
+
+instance Real Natural where
+    toRational (Natural n) = toRational n
+
+instance Integral Natural where
+    toInteger (Natural n) = n
+    divMod (Natural n) (Natural e) = let (a,b) = n `quotRem` e in (Natural a, Natural b)
+    quotRem (Natural n) (Natural e) = let (a,b) = n `quotRem` e in (Natural a, Natural b)
+    quot (Natural n) (Natural e) = Natural (n `quot` e)
+    rem (Natural n) (Natural e) = Natural (n `rem` e)
+    div = quot
+    mod = rem
+
+#endif
+
+integerToNatural :: Integer -> Natural
+integerToNatural i = fromInteger (abs i)
+
+naturalToInteger :: Natural -> Integer
+naturalToInteger n = toInteger n

bundled/Basement/Compat/NumLiteral.hs

@@ -0,0 +1,200 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE RebindableSyntax #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# Language CPP #-}
+-- |
+-- Module      : Basement.Compat.NumLiteral
+-- License     : BSD-style
+-- Maintainer  : Foundation
+--
+-- Literal support for Integral and Fractional
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE FlexibleInstances #-}
+module Basement.Compat.NumLiteral
+    ( Integral(..)
+    , Fractional(..)
+    , HasNegation(..)
+    ) where
+
+import           Prelude (Int, Integer, Rational, Float, Double)
+import           Data.Word (Word8, Word16, Word32, Word64, Word)
+import           Data.Int (Int8, Int16, Int32, Int64)
+import           Basement.Compat.C.Types
+import qualified Prelude
+import           Basement.Compat.Natural
+import           Foreign.Ptr (IntPtr)
+
+-- | Integral Literal support
+--
+-- e.g. 123 :: Integer
+--      123 :: Word8
+class Integral a where
+    fromInteger :: Integer -> a
+
+-- | Fractional Literal support
+--
+-- e.g. 1.2  :: Double
+--      0.03 :: Float
+class Fractional a where
+    fromRational :: Rational -> a
+
+-- | Negation support
+--
+-- e.g. -(f x)
+class HasNegation a where
+    negate :: a -> a
+
+instance Integral Integer where
+    fromInteger a = a
+instance Integral Natural where
+    fromInteger a = Prelude.fromInteger a
+instance Integral Int where
+    fromInteger a = Prelude.fromInteger a
+instance Integral Word where
+    fromInteger a = Prelude.fromInteger a
+instance Integral Word8 where
+    fromInteger a = Prelude.fromInteger a
+instance Integral Word16 where
+    fromInteger a = Prelude.fromInteger a
+instance Integral Word32 where
+    fromInteger a = Prelude.fromInteger a
+instance Integral Word64 where
+    fromInteger a = Prelude.fromInteger a
+instance Integral Int8 where
+    fromInteger a = Prelude.fromInteger a
+instance Integral Int16 where
+    fromInteger a = Prelude.fromInteger a
+instance Integral Int32 where
+    fromInteger a = Prelude.fromInteger a
+instance Integral Int64 where
+    fromInteger a = Prelude.fromInteger a
+instance Integral IntPtr where
+    fromInteger a = Prelude.fromInteger a
+
+instance Integral Float where
+    fromInteger a = Prelude.fromInteger a
+instance Integral Double where
+    fromInteger a = Prelude.fromInteger a
+
+instance Integral CChar where
+    fromInteger a = Prelude.fromInteger a
+instance Integral CSChar where
+    fromInteger a = Prelude.fromInteger a
+instance Integral CUChar where
+    fromInteger a = Prelude.fromInteger a
+instance Integral CShort where
+    fromInteger a = Prelude.fromInteger a
+instance Integral CUShort where
+    fromInteger a = Prelude.fromInteger a
+instance Integral CInt where
+    fromInteger a = Prelude.fromInteger a
+instance Integral CUInt where
+    fromInteger a = Prelude.fromInteger a
+instance Integral CLong where
+    fromInteger a = Prelude.fromInteger a
+instance Integral CULong where
+    fromInteger a = Prelude.fromInteger a
+instance Integral CPtrdiff where
+    fromInteger a = Prelude.fromInteger a
+instance Integral CSize where
+    fromInteger a = Prelude.fromInteger a
+instance Integral CWchar where
+    fromInteger a = Prelude.fromInteger a
+instance Integral CSigAtomic where
+    fromInteger a = Prelude.fromInteger a
+instance Integral CLLong where
+    fromInteger a = Prelude.fromInteger a
+instance Integral CULLong where
+    fromInteger a = Prelude.fromInteger a
+#if MIN_VERSION_base(4, 10, 0)
+instance Integral CBool where
+    fromInteger a = Prelude.fromInteger a
+#endif
+instance Integral CIntPtr where
+    fromInteger a = Prelude.fromInteger a
+instance Integral CUIntPtr where
+    fromInteger a = Prelude.fromInteger a
+instance Integral CIntMax where
+    fromInteger a = Prelude.fromInteger a
+instance Integral CUIntMax where
+    fromInteger a = Prelude.fromInteger a
+instance Integral CClock where
+    fromInteger a = Prelude.fromInteger a
+instance Integral CTime where
+    fromInteger a = Prelude.fromInteger a
+instance Integral CUSeconds where
+    fromInteger a = Prelude.fromInteger a
+instance Integral CSUSeconds where
+    fromInteger a = Prelude.fromInteger a
+instance Integral COff where
+    fromInteger a = Prelude.fromInteger a
+instance Integral CFloat where
+    fromInteger a = Prelude.fromInteger a
+instance Integral CDouble where
+    fromInteger a = Prelude.fromInteger a
+
+instance HasNegation Integer where
+    negate = Prelude.negate
+instance HasNegation Int where
+    negate = Prelude.negate
+instance HasNegation Int8 where
+    negate = Prelude.negate
+instance HasNegation Int16 where
+    negate = Prelude.negate
+instance HasNegation Int32 where
+    negate = Prelude.negate
+instance HasNegation Int64 where
+    negate = Prelude.negate
+instance HasNegation Word where
+    negate = Prelude.negate
+instance HasNegation Word8 where
+    negate = Prelude.negate
+instance HasNegation Word16 where
+    negate = Prelude.negate
+instance HasNegation Word32 where
+    negate = Prelude.negate
+instance HasNegation Word64 where
+    negate = Prelude.negate
+
+instance HasNegation Float where
+    negate = Prelude.negate
+instance HasNegation Double where
+    negate = Prelude.negate
+
+instance HasNegation CChar where
+    negate = Prelude.negate
+instance HasNegation CSChar where
+    negate = Prelude.negate
+instance HasNegation CShort where
+    negate = Prelude.negate
+instance HasNegation CInt where
+    negate = Prelude.negate
+instance HasNegation CLong where
+    negate = Prelude.negate
+instance HasNegation CPtrdiff where
+    negate = Prelude.negate
+instance HasNegation CWchar where
+    negate = Prelude.negate
+instance HasNegation CLLong where
+    negate = Prelude.negate
+instance HasNegation CIntMax where
+    negate = Prelude.negate
+
+instance HasNegation CFloat where
+    negate = Prelude.negate
+instance HasNegation CDouble where
+    negate = Prelude.negate
+
+instance Fractional Rational where
+    fromRational a = Prelude.fromRational a
+instance Fractional Float where
+    fromRational a = Prelude.fromRational a
+instance Fractional Double where
+    fromRational a = Prelude.fromRational a
+
+instance Fractional CFloat where
+    fromRational a = Prelude.fromRational a
+instance Fractional CDouble where
+    fromRational a = Prelude.fromRational a

bundled/Basement/Compat/PrimTypes.hs

@@ -0,0 +1,41 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE RebindableSyntax #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+-- |
+-- Module      : Basement.Compat.PrimTypes
+-- License     : BSD-style
+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>
+-- Stability   : experimental
+-- Portability : portable
+--
+{-# LANGUAGE MagicHash #-}
+module Basement.Compat.PrimTypes
+    ( FileSize#
+    , Offset#
+    , CountOf#
+    , Bool#
+    , Pinned#
+    ) where
+
+import GHC.Prim
+
+-- | File size in bytes
+type FileSize# = Word64#
+
+-- | Offset in a bytearray, string, type alias
+--
+-- for code documentation purpose only, just a simple type alias on Int#
+type Offset# = Int#
+
+-- | CountOf in bytes type alias
+--
+-- for code documentation purpose only, just a simple type alias on Int#
+type CountOf# = Int#
+
+-- | Lowlevel Boolean
+type Bool# = Int#
+
+-- | Pinning status
+type Pinned# = Bool#

bundled/Basement/Compat/Primitive.hs

@@ -0,0 +1,318 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE RebindableSyntax #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+-- |
+-- Module      : Basement.Compat.Primitive
+-- License     : BSD-style
+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>
+-- Stability   : experimental
+-- Portability : portable
+--
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE UnboxedTuples #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE UnliftedFFITypes #-}
+module Basement.Compat.Primitive
+    ( bool#
+    , PinnedStatus(..), toPinnedStatus#
+    , compatMkWeak#
+    , compatIsByteArrayPinned#
+    , compatIsMutableByteArrayPinned#
+    , unsafeCoerce#
+    , Word(..)
+    , Word8#
+    , Word16#
+    , Word32#
+    , Int8#
+    , Int16#
+    , Int32#
+    -- word upper sizing
+    , word8ToWord16#
+    , word8ToWord32#
+    , word8ToWord#
+    , word16ToWord8#
+    , word16ToWord32#
+    , word16ToWord#
+    , word32ToWord#
+    -- word down sizing
+    , word32ToWord8#
+    , word32ToWord16#
+    , wordToWord32#
+    , wordToWord16#
+    , wordToWord8#
+    -- int upper sizing
+    , int8ToInt16#
+    , int8ToInt32#
+    , int8ToInt#
+    , int16ToInt32#
+    , int16ToInt#
+    , int32ToInt#
+    -- int down sizing
+    , intToInt8#
+    , intToInt16#
+    , intToInt32#
+    -- other
+    , word8ToInt#
+    , word8ToInt16#
+    , word8ToInt32#
+    , charToWord32#
+    , word8ToChar#
+    , word16ToChar#
+    , word32ToChar#
+    , wordToChar#
+
+    -- word8 ops
+    , plusWord8#
+    -- word16 ops
+    , uncheckedShiftRLWord16#
+    , plusWord16#
+    -- word32 ops
+    , uncheckedShiftRLWord32#
+    , plusWord32#
+    -- int8 ops
+    , plusInt8#
+    -- int16 ops
+    , plusInt16#
+    -- int32 ops
+    , plusInt32#
+    ) where
+
+
+import qualified Prelude
+import           GHC.Exts hiding (Word8#, Word16#, Word32#, Int8#, Int16#, Int32#, plusWord8#, plusWord16#, plusInt8#, plusInt16#)
+import           GHC.Prim hiding (Word8#, Word16#, Word32#, Int8#, Int16#, Int32#, plusWord8#, plusWord16#, plusInt8#, plusInt16#)
+import           GHC.Word
+import           GHC.IO
+
+import           Basement.Compat.PrimTypes
+
+#if __GLASGOW_HASKELL__ >= 902
+import           GHC.Exts (Word8#, Word16#, Word32#, Int8#, Int16#, Int32#, plusWord8#, plusWord16#, plusInt8#, plusInt16#)
+#endif
+
+--  GHC 9.2  | Base 4.16
+--  GHC 9.0  | Base 4.15
+--  GHC 8.8  | Base 4.13 4.14
+--  GHC 8.6  | Base 4.12
+--  GHC 8.4  | Base 4.11
+--  GHC 8.2  | Base 4.10
+--  GHC 8.0  | Base 4.9
+--  GHC 7.10 | Base 4.8
+--  GHC 7.8  | Base 4.7
+--  GHC 7.6  | Base 4.6
+--  GHC 7.4  | Base 4.5
+--
+--  More complete list:
+--  https://wiki.haskell.org/Base_package
+
+-- | Flag record whether a specific byte array is pinned or not
+data PinnedStatus = Pinned | Unpinned
+    deriving (Prelude.Eq)
+
+toPinnedStatus# :: Pinned# -> PinnedStatus
+toPinnedStatus# 0# = Unpinned
+toPinnedStatus# _  = Pinned
+
+-- | turn an Int# into a Bool
+bool# :: Int# -> Prelude.Bool
+bool# v = isTrue# v
+{-# INLINE bool# #-}
+
+-- | A mkWeak# version that keep working on 8.0
+--
+-- signature change in ghc-prim:
+-- * 0.4: mkWeak# :: o -> b -> c                                             -> State# RealWorld -> (#State# RealWorld, Weak# b#)
+-- * 0.5 :mkWeak# :: o -> b -> (State# RealWorld -> (#State# RealWorld, c#)) -> State# RealWorld -> (#State# RealWorld, Weak# b#)
+--
+compatMkWeak# :: o -> b -> Prelude.IO () -> State# RealWorld -> (#State# RealWorld, Weak# b #)
+compatMkWeak# o b c s = mkWeak# o b (case c of { IO f -> f }) s
+{-# INLINE compatMkWeak# #-}
+
+#if __GLASGOW_HASKELL__ >= 802
+compatIsByteArrayPinned# :: ByteArray# -> Pinned#
+compatIsByteArrayPinned# ba = isByteArrayPinned# ba
+
+compatIsMutableByteArrayPinned# :: MutableByteArray# s -> Pinned#
+compatIsMutableByteArrayPinned# ba = isMutableByteArrayPinned# ba
+#else
+foreign import ccall unsafe "basement_is_bytearray_pinned"
+    compatIsByteArrayPinned# :: ByteArray# -> Pinned#
+
+foreign import ccall unsafe "basement_is_bytearray_pinned"
+    compatIsMutableByteArrayPinned# :: MutableByteArray# s -> Pinned#
+#endif
+
+#if __GLASGOW_HASKELL__ >= 902
+
+word8ToWord16# :: Word8# -> Word16#
+word8ToWord16# a = wordToWord16# (word8ToWord# a)
+
+word8ToWord32# :: Word8# -> Word32#
+word8ToWord32# a = wordToWord32# (word8ToWord# a)
+
+word16ToWord8# :: Word16# -> Word8#
+word16ToWord8# a = wordToWord8# (word16ToWord# a)
+
+word16ToWord32# :: Word16# -> Word32#
+word16ToWord32# a = wordToWord32# (word16ToWord# a)
+
+word32ToWord8# :: Word32# -> Word8#
+word32ToWord8# a = wordToWord8# (word32ToWord# a)
+
+word32ToWord16# :: Word32# -> Word16#
+word32ToWord16# a = wordToWord16# (word32ToWord# a)
+
+int8ToInt16# :: Int8# -> Int16#
+int8ToInt16# i = intToInt16# (int8ToInt# i)
+
+int8ToInt32# :: Int8# -> Int32#
+int8ToInt32# i = intToInt32# (int8ToInt# i)
+
+int16ToInt32# :: Int16# -> Int32#
+int16ToInt32# i = intToInt32# (int16ToInt# i)
+
+word8ToInt16# :: Word8# -> Int16#
+word8ToInt16# i = intToInt16# (word2Int# (word8ToWord# i))
+
+word8ToInt32# :: Word8# -> Int32#
+word8ToInt32# i = intToInt32# (word2Int# (word8ToWord# i))
+
+word8ToInt# :: Word8# -> Int#
+word8ToInt# i = word2Int# (word8ToWord# i)
+
+charToWord32# :: Char# -> Word32#
+charToWord32# ch = wordToWord32# (int2Word# (ord# ch))
+
+word8ToChar# :: Word8# -> Char#
+word8ToChar# ch = chr# (word2Int# (word8ToWord# ch))
+
+word16ToChar# :: Word16# -> Char#
+word16ToChar# ch = chr# (word2Int# (word16ToWord# ch))
+
+word32ToChar# :: Word32# -> Char#
+word32ToChar# ch = chr# (word2Int# (word32ToWord# ch))
+
+wordToChar# :: Word# -> Char#
+wordToChar# ch = chr# (word2Int# ch)
+
+#else
+type Word8# = Word#
+type Word16# = Word#
+type Word32# = Word#
+
+type Int8# = Int#
+type Int16# = Int#
+type Int32# = Int#
+
+word8ToWord16# :: Word8# -> Word16#
+word8ToWord16# a = a
+
+word8ToWord32# :: Word8# -> Word32#
+word8ToWord32# a = a
+
+word8ToWord# :: Word8# -> Word#
+word8ToWord# a = a
+
+word16ToWord32# :: Word16# -> Word32#
+word16ToWord32# a = a
+
+word16ToWord8# :: Word16# -> Word8#
+word16ToWord8# w = narrow8Word# w
+
+word16ToWord# :: Word16# -> Word#
+word16ToWord# a = a
+
+word32ToWord8# :: Word32# -> Word8#
+word32ToWord8# w = narrow8Word# w
+
+word32ToWord16# :: Word32# -> Word16#
+word32ToWord16# w = narrow16Word# w
+
+word32ToWord# :: Word32# -> Word#
+word32ToWord# a = a
+
+wordToWord32# :: Word# -> Word32#
+wordToWord32# w = narrow32Word# w
+
+wordToWord16# :: Word# -> Word16#
+wordToWord16# w = narrow16Word# w
+
+wordToWord8# :: Word# -> Word8#
+wordToWord8# w = narrow8Word# w
+
+charToWord32# :: Char# -> Word32#
+charToWord32# ch = int2Word# (ord# ch)
+
+word8ToInt16# :: Word8# -> Int16#
+word8ToInt16# w = word2Int# w
+
+word8ToInt32# :: Word8# -> Int32#
+word8ToInt32# w = word2Int# w
+
+word8ToInt# :: Word8# -> Int#
+word8ToInt# w = word2Int# w
+
+word8ToChar# :: Word8# -> Char#
+word8ToChar# w = chr# (word2Int# w)
+
+word16ToChar# :: Word16# -> Char#
+word16ToChar# w = chr# (word2Int# w)
+
+word32ToChar# :: Word32# -> Char#
+word32ToChar# w = chr# (word2Int# w)
+
+wordToChar# :: Word# -> Char#
+wordToChar# ch = chr# (word2Int# ch)
+
+int8ToInt16# :: Int8# -> Int16#
+int8ToInt16# a = a
+
+int8ToInt32# :: Int8# -> Int32#
+int8ToInt32# a = a
+
+int8ToInt# :: Int8# -> Int#
+int8ToInt# a = a
+
+int16ToInt32# :: Int16# -> Int32#
+int16ToInt32# a = a
+
+int16ToInt# :: Int16# -> Int#
+int16ToInt# a = a
+
+int32ToInt# :: Int32# -> Int#
+int32ToInt# a = a
+
+intToInt8# :: Int# -> Int8#
+intToInt8# i = narrow8Int# i
+
+intToInt16# :: Int# -> Int16#
+intToInt16# i = narrow16Int# i
+
+intToInt32# :: Int# -> Int32#
+intToInt32# i = narrow32Int# i
+
+uncheckedShiftRLWord16# = uncheckedShiftRL#
+
+uncheckedShiftRLWord32# = uncheckedShiftRL#
+
+plusWord8# :: Word8# -> Word8# -> Word8#
+plusWord8# a b = narrow8Word# (plusWord# a b)
+
+plusWord16# :: Word16# -> Word16# -> Word16#
+plusWord16# a b = narrow16Word# (plusWord# a b)
+
+plusWord32# :: Word32# -> Word32# -> Word32#
+plusWord32# a b = narrow32Word# (plusWord# a b)
+
+plusInt8# :: Int8# -> Int8# -> Int8#
+plusInt8# a b = narrow8Int# (a +# b)
+
+plusInt16# :: Int16# -> Int16# -> Int16#
+plusInt16# a b = narrow16Int# (a +# b)
+
+plusInt32# :: Int32# -> Int32# -> Int32#
+plusInt32# a b = narrow32Int# (a +# b)
+
+#endif

bundled/Basement/Compat/Semigroup.hs

@@ -0,0 +1,170 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE RebindableSyntax #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE CPP #-}
+#if !(MIN_VERSION_base(4,9,0))
+{-# LANGUAGE DefaultSignatures #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+#endif
+module Basement.Compat.Semigroup
+    ( Semigroup(..)
+    , ListNonEmpty(..)
+    ) where
+
+#if MIN_VERSION_base(4,9,0)
+import           Data.Semigroup
+import qualified Data.List.NonEmpty as LNE
+
+type ListNonEmpty = LNE.NonEmpty
+#else
+import Prelude
+import Data.Data (Data)
+import Data.Monoid (Monoid(..))
+import GHC.Generics (Generic)
+import Data.Typeable
+
+-- errorWithoutStackTrace
+
+infixr 6 <>
+infixr 5 :|
+
+data ListNonEmpty a = a :| [a]
+  deriving ( Eq, Ord, Show, Read, Data, Typeable, Generic )
+
+-- | The class of semigroups (types with an associative binary operation).
+--
+-- @since 4.9.0.0
+class Semigroup a where
+  -- | An associative operation.
+  --
+  -- @
+  -- (a '<>' b) '<>' c = a '<>' (b '<>' c)
+  -- @
+  --
+  -- If @a@ is also a 'Monoid' we further require
+  --
+  -- @
+  -- ('<>') = 'mappend'
+  -- @
+  (<>) :: a -> a -> a
+
+  default (<>) :: Monoid a => a -> a -> a
+  (<>) = mappend
+
+  -- | Reduce a non-empty list with @\<\>@
+  --
+  -- The default definition should be sufficient, but this can be
+  -- overridden for efficiency.
+  --
+  sconcat :: ListNonEmpty a -> a
+  sconcat (a :| as) = go a as where
+    go b (c:cs) = b <> go c cs
+    go b []     = b
+
+  -- | Repeat a value @n@ times.
+  --
+  -- Given that this works on a 'Semigroup' it is allowed to fail if
+  -- you request 0 or fewer repetitions, and the default definition
+  -- will do so.
+  --
+  -- By making this a member of the class, idempotent semigroups and monoids can
+  -- upgrade this to execute in /O(1)/ by picking
+  -- @stimes = stimesIdempotent@ or @stimes = stimesIdempotentMonoid@
+  -- respectively.
+  stimes :: Integral b => b -> a -> a
+  stimes y0 x0
+    | y0 <= 0   = errorWithoutStackTrace "stimes: positive multiplier expected"
+    | otherwise = f x0 y0
+    where
+      f x y
+        | even y = f (x <> x) (y `quot` 2)
+        | y == 1 = x
+        | otherwise = g (x <> x) (pred y  `quot` 2) x
+      g x y z
+        | even y = g (x <> x) (y `quot` 2) z
+        | y == 1 = x <> z
+        | otherwise = g (x <> x) (pred y `quot` 2) (x <> z)
+
+instance Semigroup a => Semigroup (Maybe a) where
+  Nothing <> b       = b
+  a       <> Nothing = a
+  Just a  <> Just b  = Just (a <> b)
+  stimes _ Nothing  = Nothing
+  stimes n (Just a) = case compare n 0 of
+    LT -> errorWithoutStackTrace "stimes: Maybe, negative multiplier"
+    EQ -> Nothing
+    GT -> Just (stimes n a)
+
+instance Semigroup [a] where
+    (<>) = (++)
+
+instance Semigroup (Either a b) where
+  Left _ <> b = b
+  a      <> _ = a
+  stimes = stimesIdempotent
+
+instance (Semigroup a, Semigroup b) => Semigroup (a, b) where
+  (a,b) <> (a',b') = (a<>a',b<>b')
+  stimes n (a,b) = (stimes n a, stimes n b)
+
+instance (Semigroup a, Semigroup b, Semigroup c) => Semigroup (a, b, c) where
+  (a,b,c) <> (a',b',c') = (a<>a',b<>b',c<>c')
+  stimes n (a,b,c) = (stimes n a, stimes n b, stimes n c)
+
+instance (Semigroup a, Semigroup b, Semigroup c, Semigroup d)
+         => Semigroup (a, b, c, d) where
+  (a,b,c,d) <> (a',b',c',d') = (a<>a',b<>b',c<>c',d<>d')
+  stimes n (a,b,c,d) = (stimes n a, stimes n b, stimes n c, stimes n d)
+
+instance (Semigroup a, Semigroup b, Semigroup c, Semigroup d, Semigroup e)
+         => Semigroup (a, b, c, d, e) where
+  (a,b,c,d,e) <> (a',b',c',d',e') = (a<>a',b<>b',c<>c',d<>d',e<>e')
+  stimes n (a,b,c,d,e) =
+      (stimes n a, stimes n b, stimes n c, stimes n d, stimes n e)
+
+-- | This is a valid definition of 'stimes' for a 'Monoid'.
+--
+-- Unlike the default definition of 'stimes', it is defined for 0
+-- and so it should be preferred where possible.
+stimesMonoid :: (Integral b, Monoid a) => b -> a -> a
+stimesMonoid n x0 = case compare n 0 of
+  LT -> errorWithoutStackTrace "stimesMonoid: negative multiplier"
+  EQ -> mempty
+  GT -> f x0 n
+    where
+      f x y
+        | even y = f (x `mappend` x) (y `quot` 2)
+        | y == 1 = x
+        | otherwise = g (x `mappend` x) (pred y  `quot` 2) x
+      g x y z
+        | even y = g (x `mappend` x) (y `quot` 2) z
+        | y == 1 = x `mappend` z
+        | otherwise = g (x `mappend` x) (pred y `quot` 2) (x `mappend` z)
+
+-- | This is a valid definition of 'stimes' for an idempotent 'Monoid'.
+--
+-- When @mappend x x = x@, this definition should be preferred, because it
+-- works in /O(1)/ rather than /O(log n)/
+stimesIdempotentMonoid :: (Integral b, Monoid a) => b -> a -> a
+stimesIdempotentMonoid n x = case compare n 0 of
+  LT -> errorWithoutStackTrace "stimesIdempotentMonoid: negative multiplier"
+  EQ -> mempty
+  GT -> x
+
+-- | This is a valid definition of 'stimes' for an idempotent 'Semigroup'.
+--
+-- When @x <> x = x@, this definition should be preferred, because it
+-- works in /O(1)/ rather than /O(log n)/.
+stimesIdempotent :: Integral b => b -> a -> a
+stimesIdempotent n x
+  | n <= 0 = errorWithoutStackTrace "stimesIdempotent: positive multiplier expected"
+  | otherwise = x
+
+#if !MIN_VERSION_base(4,9,0)
+errorWithoutStackTrace = error
+#endif
+
+#endif

bundled/Basement/Compat/Typeable.hs

@@ -0,0 +1,42 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE RebindableSyntax #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+-- |
+-- Module      : Basement.Compat.Typeable
+-- License     : BSD-style
+-- Maintainer  : Nicolas Di Prima <nicolas@primetype.co.uk>
+-- Stability   : statble
+-- Portability : portable
+--
+-- conveniently provide support for legacy and modern base
+--
+
+{-# LANGUAGE CPP #-}
+
+module Basement.Compat.Typeable
+    (
+#if MIN_VERSION_base(4,7,0)
+      Typeable
+#else
+      Typeable(..)
+    , typeRep
+#endif
+    ) where
+
+#if !MIN_VERSION_base(4,7,0)
+import Data.Proxy (Proxy(..))
+import qualified Prelude (undefined)
+#endif
+import Data.Typeable
+
+#if !MIN_VERSION_base(4,7,0)
+-- this function does not exist prior base 4.7
+typeRep :: Typeable a => Proxy a -> TypeRep
+typeRep = typeRep' Prelude.undefined
+  where
+    typeRep' :: Typeable a => a -> Proxy a -> TypeRep
+    typeRep' a _ = typeOf a
+    {-# INLINE typeRep' #-}
+#endif