diff --git a/bench/misc.hs b/bench/misc.hs --- a/bench/misc.hs +++ b/bench/misc.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE TypeApplications #-} @@ -39,7 +40,9 @@ -- Amazing inference! -- m :: KnownNat k => DataFrame '[k,2,4] -> print $ m %* vec4 1 2.25 3 0.162 +#if !MIN_VERSION_GLASGOW_HASKELL(8,10,0,0) _ -> print "Failed to construct a DataFrame!" +#endif putStrLn "Constructing larger matrices" let x :: DataFrame Double '[4,5,2] x = DF4 (transpose $ DF2 diff --git a/easytensor.cabal b/easytensor.cabal --- a/easytensor.cabal +++ b/easytensor.cabal @@ -1,13 +1,13 @@ cabal-version: 1.24 --- This file has been generated from package.yaml by hpack version 0.31.1. +-- This file has been generated from package.yaml by hpack version 0.33.0. -- -- see: https://github.com/sol/hpack -- --- hash: 75fa5546720cb775f5ce9a26382fcd60253bba851441e469156242ee52655f97 +-- hash: 3c6d02c6fd2233f54c11cad29fb86ebe9dd802a64c7a3d880ee6d3bd047673ca name: easytensor -version: 2.1.0.0 +version: 2.1.1.0 synopsis: Pure, type-indexed haskell vector, matrix, and tensor library. description: Pure, type-indexed haskell vector, matrix, and tensor library. Features dimensionality type-checking for all operations. Generic n-dimensional versions are implemented using low-level prim ops. Allows ad-hoc replacement with fixed low-dimensionality vectors and matrices without changing user interface. Please see the README on GitHub at category: math, geometry diff --git a/src-base/Numeric/DataFrame/Internal/Backend/Family.hs b/src-base/Numeric/DataFrame/Internal/Backend/Family.hs --- a/src-base/Numeric/DataFrame/Internal/Backend/Family.hs +++ b/src-base/Numeric/DataFrame/Internal/Backend/Family.hs @@ -34,7 +34,8 @@ import Data.Constraint -import GHC.Base +import GHC.Base (Type) +import GHC.Exts (unsafeCoerce#) import Numeric.DataFrame.Internal.Backend.Family.ArrayBase import Numeric.DataFrame.Internal.Backend.Family.DoubleX2 diff --git a/src/Numeric/DataFrame/Internal/Mutable.hs b/src/Numeric/DataFrame/Internal/Mutable.hs --- a/src/Numeric/DataFrame/Internal/Mutable.hs +++ b/src/Numeric/DataFrame/Internal/Mutable.hs @@ -40,7 +40,8 @@ , getDataFrameSteps# ) where -import GHC.Base +import GHC.Base (Type) +import GHC.Exts import Numeric.DataFrame.Internal.PrimArray import Numeric.DataFrame.Type import Numeric.Dimensions diff --git a/src/Numeric/DataFrame/Type.hs b/src/Numeric/DataFrame/Type.hs --- a/src/Numeric/DataFrame/Type.hs +++ b/src/Numeric/DataFrame/Type.hs @@ -88,7 +88,8 @@ import Numeric.DataFrame.Internal.BackendI (DFBackend, KnownBackend) import qualified Numeric.DataFrame.Internal.BackendI as Backend - +-- See dimensions:Numeric.Dimensions.Dim +#define IS_UNSOUND_MATCHING_810_900 (MIN_VERSION_GLASGOW_HASKELL(8,10,0,0) && !MIN_VERSION_GLASGOW_HASKELL(9,1,0,0)) -- | Keep data in a primitive data frame -- and maintain information about Dimensions in the type system @@ -241,7 +242,7 @@ | D :* (Dims :: Dims ns) <- dims `inSpaceOf` df , Dict <- inferKnownBackend @t @ns = XFrame (df ! i) - (!) _ _ = error "IndexFrame: impossible pattern" + (!) _ _ = error "IndexFrame: impossible arguments" instance (RepresentableList ts, All PrimBytes ts) => IndexFrame (ts :: [Type]) (xd :: XNat) xds where @@ -259,7 +260,7 @@ getTsEvs ((_ :: Proxy a) :* as') | Dict <- getTsEvs @_ @d @ds as' , Dict <- inferKnownBackend @a @ds = Dict - (!) _ _ = error "IndexFrame: impossible pattern" + (!) _ _ = error "IndexFrame: impossible arguments" {- | This type family describes two strategies for dealing with dimensions when @@ -496,6 +497,9 @@ = Read.parens . Read.prec 10 $ do Read.lift . Read.expect . Read.Ident $ "DF" ++ show (dimVal d) packDF' (<*> Read.step (readPrecFixedDF ds)) pure +#if IS_UNSOUND_MATCHING_810_900 +readPrecFixedDF _ = error "Numeric.DataFrame.Type.readPrecFixedDF: impossible arguments" +#endif {- The first argument is, in fact, a @dimsBound@, but covered in the same @[XNat]@ @@ -621,6 +625,9 @@ xs <- readFixedMultiDF ts (dims @ns) case inferKnownBackend @ts @ns of Dict -> return $ XFrame (x :*: xs) +#if IS_UNSOUND_MATCHING_810_900 +readBoundedMultiDF _ _ = error "Numeric.DataFrame.Type.readBoundedMultiDF: impossible arguments" +#endif readSomeMultiDF :: forall (ts :: [Type]) . (All Read ts, All PrimBytes ts) @@ -811,7 +818,7 @@ , Dict <- inferKnownBackend @t @(d ': ds) , Dict <- inferKnownBackend @t @ds = go d - | otherwise = error "Numeric.DataFrame.Type.packDF: impossible args" + | otherwise = error "Numeric.DataFrame.Type.packDF: impossible arguments" where go :: (Dimensions ds, KnownBackend t ds, KnownBackend t (d ': ds)) => Dim d @@ -876,7 +883,7 @@ unpackDF c | d :* Dims <- dims @(d ': ds) = unpackDF' (go d) - | otherwise = error "Numeric.DataFrame.Type.unpackDF: impossible args" + | otherwise = error "Numeric.DataFrame.Type.unpackDF: impossible arguments" where go :: forall a . (a ~ Dict (Dimensions ds, KnownBackend t ds)) => Dim d -> a @@ -906,7 +913,9 @@ packDF' k z | d :* _ <- dims @(d ': ds) = go d (z (packDF @t @d @ds)) - | otherwise = error "Numeric.DataFrame.Type.packDF': impossible args" +#if !MIN_VERSION_GLASGOW_HASKELL(9,0,0,0) + | otherwise = error "Numeric.DataFrame.Type.packDF': impossible arguments" +#endif where go :: forall n . Dim n -> c (PackDF t ds n (DataFrame t (d ': ds))) -> c (DataFrame t (d ': ds)) @@ -949,7 +958,7 @@ f consume (I# o) = consume (I# (o -# td)) (fromElems cd o arr) in k Dict f (I# (off +# td *# (n -# 1#))) ) - | otherwise = error "Numeric.DataFrame.Type.unpackDF: impossible args" + | otherwise = error "Numeric.DataFrame.Type.unpackDF: impossible arguments" -- | Append one DataFrame to another, sum up the first dimension. @@ -968,7 +977,9 @@ , Dict <- inferKnownBackend @t @(m :+ ds) , Dict <- inferKnownBackend @t @((n + m) :+ ds) = unsafeAppendPB - | otherwise = error "Numeri.DataFrame.Type/appendDF: impossible arguments" +#if !MIN_VERSION_GLASGOW_HASKELL(9,0,0,0) + | otherwise = error "Numeri.DataFrame.Type.appendDF: impossible arguments" +#endif -- | Append a small DataFrame to a big DataFrame on the left. -- @@ -986,7 +997,9 @@ , Dict <- inferKnownBackend @t @ds , Dict <- inferKnownBackend @t @((n + 1) :+ ds) = unsafeAppendPB - | otherwise = error "Numeri.DataFrame.Type/consDF: impossible arguments" +#if !MIN_VERSION_GLASGOW_HASKELL(9,0,0,0) + | otherwise = error "Numeri.DataFrame.Type.consDF: impossible arguments" +#endif -- | Append a small DataFrame to a big DataFrame on the right. -- @@ -1004,8 +1017,9 @@ , Dict <- inferKnownBackend @t @ds , Dict <- inferKnownBackend @t @((n + 1) :+ ds) = unsafeAppendPB - | otherwise = error "Numeri.DataFrame.Type/snocDF: impossible arguments" - +#if !MIN_VERSION_GLASGOW_HASKELL(9,0,0,0) + | otherwise = error "Numeri.DataFrame.Type.snocDF: impossible arguments" +#endif -- | Unsafely copy two PrimBytes values into a third one. unsafeAppendPB :: forall x y z @@ -1049,14 +1063,15 @@ => [DataFrame t ds] -> DataFrame t (XN 0 ': xds) fromList xs | Dx (D :: Dim n) <- someDimVal . fromIntegral $ length xs + , Dict <- Dict @(ds ~ UnMap N xds) -- just to make GHC not complain about unused constraints. , Dict <- inferKnownBackend @t @(n ': ds) , Dict <- unsafeEqTypes @_ @ds @(DimsBound xds) , Dict <- inferExactFixedDims (dims @ds) = XFrame (fromListWithDefault @t @n @ds undefined xs) +#if !MIN_VERSION_GLASGOW_HASKELL(9,0,0,0) | otherwise - = case Dict @(ds ~ UnMap N xds) of - Dict -> -- just make GHC not complain about unused constraints. - error "Numeri.DataFrame.Type/fromList: impossible arguments" + = error "Numeri.DataFrame.Type.fromList: impossible arguments" +#endif -- | Try to convert between @XNat@-indexed DataFrames. -- @@ -1112,7 +1127,7 @@ ) of (# _, r #) -> fromElems steps 0# r | otherwise - = error "Numeri.DataFrame.Type/asDiag: impossible arguments" + = error "Numeri.DataFrame.Type.asDiag: impossible arguments" {-# INLINE asDiag #-} -- Need this for @packDF'@ to make @Int -> c z@ a proper second-order type @@ -1136,10 +1151,16 @@ (\g -> Off . f $ k . runOff g) (Off . const . z) ) v +#if IS_UNSOUND_MATCHING_810_900 + _ -> error "DataFrame.gfoldl: impossible arguments" +#endif gunfold k z _ = case typeableDims @ds of U -> k (z S) D :* (Dims :: Dims ns) -> case inferTypeableCons @ds of Dict -> packDF' k z +#if IS_UNSOUND_MATCHING_810_900 + _ -> error "DataFrame.gunfold: impossible arguments" +#endif toConstr _ = case typeableDims @ds of U -> scalarFrameConstr d :* _ -> singleFrameConstr $ dimVal d @@ -1241,6 +1262,9 @@ where d2 = divDim d D2 d2' = d2 `plusDim` modDim d D2 +#if IS_UNSOUND_MATCHING_810_900 +fromSingleFrame _ _ = error "fromSingleFrame: impossible arguments" +#endif toSingleFrame :: forall (t :: Type) (ds :: [Nat]) (x :: Type) . PrimBytes t @@ -1280,6 +1304,9 @@ where d2 = divDim d D2 d2' = d2 `plusDim` modDim d D2 +#if IS_UNSOUND_MATCHING_810_900 +toSingleFrame _ _ = error "toSingleFrame: impossible arguments" +#endif {-# INLINE toSingleFrame #-} type family MultiFrameRepNil (ts :: [Type]) :: (Type -> Type) where diff --git a/src/Numeric/Matrix/Internal.hs b/src/Numeric/Matrix/Internal.hs --- a/src/Numeric/Matrix/Internal.hs +++ b/src/Numeric/Matrix/Internal.hs @@ -1,12 +1,11 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PolyKinds #-} -{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} @@ -205,7 +204,9 @@ | ((D :: Dim n) :* (D :: Dim m) :* U) <- dims @ns , Dict <- inferPrimElem df = XFrame (transpose df :: Matrix t m n) +#if !MIN_VERSION_GLASGOW_HASKELL(8,10,0,0) transpose _ = error "MatrixTranspose/transpose: impossible argument" +#endif instance (KnownDim n, PrimArray t (Matrix t n n), Num t) => SquareMatrix t n where diff --git a/src/Numeric/Matrix/QR.hs b/src/Numeric/Matrix/QR.hs --- a/src/Numeric/Matrix/QR.hs +++ b/src/Numeric/Matrix/QR.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} @@ -173,7 +174,9 @@ solveLowerTriangularR lqL (subDataFrameView i0 xPtr) (transpose lqQ %*) <$> unsafeFreezeDataFrame xPtr -- NB: make a stateful product for transposed mat - _ -> error "qrSolveR: impossible pattern" +#if !MIN_VERSION_GLASGOW_HASKELL(8,10,0,0) + _ -> error "Numeric.Matrix.QR.qrSolveR: impossible pattern" +#endif where dn = dim @n dm = dim @m @@ -224,8 +227,10 @@ solveLowerTriangularL xPtr lqL ewmap @t @ds @'[n] (sslice i0) <$> unsafeFreezeDataFrame xPtr - _ -> error "qrSolveL/compareDim: impossible pattern" - | otherwise = error "qrSolveL: impossible pattern" +#if !MIN_VERSION_GLASGOW_HASKELL(8,10,0,0) + _ -> error "Numeric.Matrix.QR.qrSolveL/compareDim: impossible pattern" +#endif + | otherwise = error "Numeric.Matrix.QR.qrSolveL: impossible pattern" where dn = dim @n dm = dim @m diff --git a/src/Numeric/PrimBytes.hs b/src/Numeric/PrimBytes.hs --- a/src/Numeric/PrimBytes.hs +++ b/src/Numeric/PrimBytes.hs @@ -1,20 +1,22 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UnboxedTuples #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeInType #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE UndecidableInstances #-} {- | Module : Numeric.PrimBytes Copyright : (c) Artem Chirkin @@ -86,10 +88,12 @@ import Data.Type.Equality ((:~:) (..)) import qualified Data.Type.List as L import Data.Type.Lits +import Foreign.C.Types import GHC.Exts import GHC.Generics import GHC.Int import GHC.IO (IO (..)) +import GHC.Stable import GHC.Word import Numeric.Dimensions import qualified Numeric.Tuple.Lazy as TL @@ -304,7 +308,7 @@ . ( PrimBytes a, Elem name (PrimFields a) , KnownSymbol name, Num b) => a -> b -bFieldOffsetOf a = fromIntegral (I# (byteFieldOffset (proxy# @Symbol @name) a)) +bFieldOffsetOf a = fromIntegral (I# (byteFieldOffset (proxy# :: Proxy# name) a)) -- | Same as `Foreign.Storable.peekElemOff`: peek an element @a@ by the offset -- measured in @byteSize a@. @@ -494,7 +498,11 @@ gwriteAddr p = coerce (gwriteAddr @f p) gbyteSize p = coerce (gbyteSize @f p) gbyteAlign p = coerce (gbyteAlign @f p) - gbyteFieldOffset p = coerce (gbyteFieldOffset @f p) + gbyteFieldOffset p = coerce' (gbyteFieldOffset @f p) + where + coerce' :: (Word# -> Int# -> Proxy# name -> f p -> Int#) + -> Word# -> Int# -> Proxy# name -> M1 i c f p -> Int# + coerce' = coerce instance (GPrimBytes f, GPrimBytes g) => GPrimBytes (f :*: g) where gfromBytes p t ps i ba = x :*: y @@ -932,7 +940,6 @@ writeArray mba i (D# x) = writeDoubleArray# mba i x {-# INLINE writeArray #-} - instance PrimBytes (Ptr a) where type PrimFields (Ptr a) = '[] getBytes (Ptr x) = case runRW# @@ -970,7 +977,80 @@ writeArray mba i (Ptr x) = writeAddrArray# mba i x {-# INLINE writeArray #-} +instance PrimBytes (FunPtr a) where + type PrimFields (FunPtr a) = '[] + getBytes (FunPtr x) = case runRW# + ( \s0 -> case newByteArray# SIZEOF_HSFUNPTR# s0 of + (# s1, marr #) -> case writeAddrArray# marr 0# x s1 of + s2 -> unsafeFreezeByteArray# marr s2 + ) of (# _, a #) -> a + {-# NOINLINE getBytes #-} + fromBytes off ba + = FunPtr (indexWord8ArrayAsAddr# ba off) + {-# INLINE fromBytes #-} + readBytes mba off s + = case readWord8ArrayAsAddr# mba off s of (# s', r #) -> (# s', FunPtr r #) + {-# INLINE readBytes #-} + writeBytes mba off (FunPtr x) + = writeWord8ArrayAsAddr# mba off x + {-# INLINE writeBytes #-} + readAddr a s + = case readAddrOffAddr# a 0# s of (# s', x #) -> (# s', FunPtr x #) + {-# INLINE readAddr #-} + writeAddr (FunPtr x) a + = writeAddrOffAddr# a 0# x + {-# INLINE writeAddr #-} + byteSize _ = SIZEOF_HSFUNPTR# + {-# INLINE byteSize #-} + byteAlign _ = ALIGNMENT_HSFUNPTR# + {-# INLINE byteAlign #-} + byteFieldOffset _ _ = negateInt# 1# + {-# INLINE byteFieldOffset #-} + indexArray ba i = FunPtr (indexAddrArray# ba i) + {-# INLINE indexArray #-} + readArray mba i s + = case readAddrArray# mba i s of (# s', x #) -> (# s', FunPtr x #) + {-# INLINE readArray #-} + writeArray mba i (FunPtr x) = writeAddrArray# mba i x + {-# INLINE writeArray #-} +instance PrimBytes (StablePtr a) where + type PrimFields (StablePtr a) = '[] + getBytes (StablePtr x) = case runRW# + ( \s0 -> case newByteArray# SIZEOF_HSSTABLEPTR# s0 of + (# s1, marr #) -> case writeStablePtrArray# marr 0# x s1 of + s2 -> unsafeFreezeByteArray# marr s2 + ) of (# _, a #) -> a + {-# NOINLINE getBytes #-} + fromBytes off ba + = StablePtr (indexWord8ArrayAsStablePtr# ba off) + {-# INLINE fromBytes #-} + readBytes mba off s + = case readWord8ArrayAsStablePtr# mba off s of (# s', r #) -> (# s', StablePtr r #) + {-# INLINE readBytes #-} + writeBytes mba off (StablePtr x) + = writeWord8ArrayAsStablePtr# mba off x + {-# INLINE writeBytes #-} + readAddr a s + = case readStablePtrOffAddr# a 0# s of (# s', x #) -> (# s', StablePtr x #) + {-# INLINE readAddr #-} + writeAddr (StablePtr x) a + = writeStablePtrOffAddr# a 0# x + {-# INLINE writeAddr #-} + byteSize _ = SIZEOF_HSSTABLEPTR# + {-# INLINE byteSize #-} + byteAlign _ = ALIGNMENT_HSSTABLEPTR# + {-# INLINE byteAlign #-} + byteFieldOffset _ _ = negateInt# 1# + {-# INLINE byteFieldOffset #-} + indexArray ba i = StablePtr (indexStablePtrArray# ba i) + {-# INLINE indexArray #-} + readArray mba i s + = case readStablePtrArray# mba i s of (# s', x #) -> (# s', StablePtr x #) + {-# INLINE readArray #-} + writeArray mba i (StablePtr x) = writeStablePtrArray# mba i x + {-# INLINE writeArray #-} + instance PrimBytes Int8 where type PrimFields Int8 = '[] getBytes (I8# x) = case runRW# @@ -1325,6 +1405,33 @@ writeArray = unsafeCoerce# (writeArray @Word) {-# INLINE writeArray #-} +deriving instance PrimBytes CChar +deriving instance PrimBytes CSChar +deriving instance PrimBytes CUChar +deriving instance PrimBytes CShort +deriving instance PrimBytes CUShort +deriving instance PrimBytes CInt +deriving instance PrimBytes CUInt +deriving instance PrimBytes CLong +deriving instance PrimBytes CULong +deriving instance PrimBytes CPtrdiff +deriving instance PrimBytes CSize +deriving instance PrimBytes CWchar +deriving instance PrimBytes CSigAtomic +deriving instance PrimBytes CLLong +deriving instance PrimBytes CULLong +deriving instance PrimBytes CBool +deriving instance PrimBytes CIntPtr +deriving instance PrimBytes CUIntPtr +deriving instance PrimBytes CIntMax +deriving instance PrimBytes CUIntMax +deriving instance PrimBytes CClock +deriving instance PrimBytes CTime +deriving instance PrimBytes CUSeconds +deriving instance PrimBytes CSUSeconds +deriving instance PrimBytes CFloat +deriving instance PrimBytes CDouble + anyList :: forall (k :: Type) (xs :: [k]) . RepresentableList xs => [Any] anyList = unsafeCoerce# (tList @xs) @@ -1463,10 +1570,10 @@ where go :: L.All PrimBytes ds => MutableByteArray# s -> Int# -> TS.Tuple ds -> TypeList ds -> State# s -> State# s - go _ _ _ Empty s = s go mb n (TS.Id x :* xs) (_ :* ts@TypeList) s | n' <- roundUpInt n (byteAlign x) = go mb (n' +# byteSize x) xs ts (writeBytes mb (off +# n') x s) + go _ _ _ _ s = s {-# INLINE writeBytes #-} readAddr addr = go 0# (tList @xs) where @@ -1484,10 +1591,10 @@ where go :: L.All PrimBytes ds => Int# -> TS.Tuple ds -> TypeList ds -> State# s -> State# s - go _ _ Empty s = s go n (TS.Id x :* xs) (_ :* ts@TypeList) s | n' <- roundUpInt n (byteAlign x) = go (n' +# byteSize x) xs ts (writeAddr x (plusAddr# addr n') s) + go _ _ _ s = s {-# INLINE writeAddr #-} byteSize _ = go 0# 1# (tList @xs) where @@ -1652,6 +1759,10 @@ writeWord8ArrayAsAddr# mba off = writeAddrArray# mba (uncheckedIShiftRL# off OFFSHIFT_P#) {-# INLINE writeWord8ArrayAsAddr# #-} +writeWord8ArrayAsStablePtr# :: MutableByteArray# d -> Int# -> StablePtr# a -> State# d -> State# d +writeWord8ArrayAsStablePtr# mba off = writeStablePtrArray# mba (uncheckedIShiftRL# off OFFSHIFT_P#) +{-# INLINE writeWord8ArrayAsStablePtr# #-} + writeWord8ArrayAsFloat# :: MutableByteArray# d -> Int# -> Float# -> State# d -> State# d writeWord8ArrayAsFloat# mba off = writeFloatArray# mba (uncheckedIShiftRL# off OFFSHIFT_F#) {-# INLINE writeWord8ArrayAsFloat# #-} @@ -1700,6 +1811,10 @@ readWord8ArrayAsAddr# mba off = readAddrArray# mba (uncheckedIShiftRL# off OFFSHIFT_P#) {-# INLINE readWord8ArrayAsAddr# #-} +readWord8ArrayAsStablePtr# :: MutableByteArray# d -> Int# -> State# d -> (# State# d, StablePtr# a #) +readWord8ArrayAsStablePtr# mba off = readStablePtrArray# mba (uncheckedIShiftRL# off OFFSHIFT_P#) +{-# INLINE readWord8ArrayAsStablePtr# #-} + readWord8ArrayAsFloat# :: MutableByteArray# d -> Int# -> State# d -> (# State# d, Float# #) readWord8ArrayAsFloat# mba off = readFloatArray# mba (uncheckedIShiftRL# off OFFSHIFT_F#) {-# INLINE readWord8ArrayAsFloat# #-} @@ -1747,6 +1862,10 @@ indexWord8ArrayAsAddr# :: ByteArray# -> Int# -> Addr# indexWord8ArrayAsAddr# ba off = indexAddrArray# ba (uncheckedIShiftRL# off OFFSHIFT_P#) {-# INLINE indexWord8ArrayAsAddr# #-} + +indexWord8ArrayAsStablePtr# :: ByteArray# -> Int# -> StablePtr# a +indexWord8ArrayAsStablePtr# ba off = indexStablePtrArray# ba (uncheckedIShiftRL# off OFFSHIFT_P#) +{-# INLINE indexWord8ArrayAsStablePtr# #-} indexWord8ArrayAsFloat# :: ByteArray# -> Int# -> Float# indexWord8ArrayAsFloat# ba off = indexFloatArray# ba (uncheckedIShiftRL# off OFFSHIFT_F#) diff --git a/src/Numeric/Subroutine/Sort.hs b/src/Numeric/Subroutine/Sort.hs --- a/src/Numeric/Subroutine/Sort.hs +++ b/src/Numeric/Subroutine/Sort.hs @@ -1,10 +1,10 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PolyKinds #-} -{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} @@ -50,6 +50,7 @@ -> XFrame (sortBy compare df') | otherwise -> error "sort/DimXNat -- impossible pattern" +{-# ANN sort "HLint: ignore Use sort" #-} -- | Sort a @DataFrame@ along the first dimension using given comparison function. sortBy :: forall (t :: Type) n ns @@ -110,7 +111,7 @@ instance SortBy 3 where sortByInplace cmp xs = join $ - go <$> (unsafeDupableInterleaveST (oneMoreDataFrame a)) + go <$> unsafeDupableInterleaveST (oneMoreDataFrame a) <*> cmp a b <*> cmp b c <*> cmp a c where a = subDataFrameView' (Idx 0 :* U) xs @@ -220,7 +221,9 @@ sortByInplace cmp (XSTFrame xs) | D :* _ <- dims `inSpaceOf` xs = sortByInplace (\x y -> cmp (castDataFrame x) (castDataFrame y)) xs +#if !MIN_VERSION_GLASGOW_HASKELL(9,0,0,0) | otherwise = error "sortByInplace: impossible pattern" +#endif -- | Swap contents of two DataFrames diff --git a/test/Numeric/Arbitraries.hs b/test/Numeric/Arbitraries.hs --- a/test/Numeric/Arbitraries.hs +++ b/test/Numeric/Arbitraries.hs @@ -7,7 +7,6 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE GADTs #-} -{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PartialTypeSignatures #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE QuasiQuotes #-} @@ -41,6 +40,9 @@ import qualified Numeric.Tuple.Lazy as LT import qualified Numeric.Tuple.Strict as ST +-- See dimensions:Numeric.Dimensions.Dim +#define IS_UNSOUND_MATCHING_810_900 (MIN_VERSION_GLASGOW_HASKELL(8,10,0,0) && !MIN_VERSION_GLASGOW_HASKELL(9,1,0,0)) + -- | Maximum number of elements in SomeDims lists maxDims :: Word maxDims = 5 @@ -514,6 +516,9 @@ case ds of (Dims :: Dims ds) -> case inferKnownBackend @ts @ds of Dict -> SomeDataFrame <$> arbitrary @(DataFrame ts ds) +#if IS_UNSOUND_MATCHING_810_900 + _ -> error "Numeric.Arbitraries.Arbitrary.arbitratry/ds: impossible pattern" +#endif shrink (SomeDataFrame df) = SomeDataFrame <$> shrink df @@ -534,6 +539,9 @@ case ds of XDims (Dims :: Dims ds) -> case inferKnownBackend @ts @ds of Dict -> XFrame <$> arbitrary @(DataFrame ts ds) +#if IS_UNSOUND_MATCHING_810_900 + _ -> error "Numeric.Arbitraries.Arbitrary.arbitratry/ds: impossible pattern" +#endif shrink (XFrame df) = XFrame <$> shrink df diff --git a/test/Numeric/Matrix/BidiagonalTest.hs b/test/Numeric/Matrix/BidiagonalTest.hs --- a/test/Numeric/Matrix/BidiagonalTest.hs +++ b/test/Numeric/Matrix/BidiagonalTest.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} @@ -99,9 +100,9 @@ v = bdV prop_bidiagonalSimple :: Property -prop_bidiagonalSimple = once . conjoin $ map prop_bidiagonal $ xs +prop_bidiagonalSimple = once . conjoin $ map prop_bidiagonal xs where - mkM :: Dims ([n,m]) -> [Double] -> DataFrame Double '[XN 1, XN 1] + mkM :: Dims [n,m] -> [Double] -> DataFrame Double '[XN 1, XN 1] mkM ds | Just (XDims ds'@Dims) <- constrainDims ds :: Maybe (Dims '[XN 1, XN 1]) = XFrame . fromFlatList ds' 0 @@ -133,7 +134,9 @@ | n@D :* m@D :* U <- dims `inSpaceOf` x , D <- minDim n m = validateBidiagonal x (bidiagonalHouseholder x) +#if !MIN_VERSION_GLASGOW_HASKELL(8,10,0,0) prop_bidiagonal _ = property False +#endif diff --git a/test/Numeric/Matrix/LUTest.hs b/test/Numeric/Matrix/LUTest.hs --- a/test/Numeric/Matrix/LUTest.hs +++ b/test/Numeric/Matrix/LUTest.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} @@ -86,7 +87,9 @@ where mkM :: Dim (n :: Nat) -> [t] -> SomeSquareMatrix AnyMatrix t mkM (d@D :: Dim n) = SSM . fromFlatList (d :* d :* U) 0 +#if !MIN_VERSION_GLASGOW_HASKELL(8,10,0,0) mkM _ = error "manualMats: bad dims" +#endif variants :: Num a => [a] -> [[a]] variants as = rotateList as ++ rotateList (map negate as) diff --git a/test/Numeric/Matrix/QRTest.hs b/test/Numeric/Matrix/QRTest.hs --- a/test/Numeric/Matrix/QRTest.hs +++ b/test/Numeric/Matrix/QRTest.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} @@ -115,7 +116,7 @@ ] ] where - mkM :: Dims ([n,m]) -> [Double] -> DataFrame Double '[XN 1, XN 1] + mkM :: Dims [n,m] -> [Double] -> DataFrame Double '[XN 1, XN 1] mkM ds | Just (XDims ds'@Dims) <- constrainDims ds :: Maybe (Dims '[XN 1, XN 1]) = XFrame . fromFlatList ds' 0 @@ -131,7 +132,9 @@ | n@D :* m@D :* U <- dims `inSpaceOf` x , D <- minDim n m = validateLQ x (lq x) +#if !MIN_VERSION_GLASGOW_HASKELL(8,10,0,0) prop_lq _ = property False +#endif prop_qrSimple :: Property prop_qrSimple = once . conjoin $ map prop_qr manualMats @@ -141,7 +144,9 @@ | n@D :* m@D :* U <- dims `inSpaceOf` x , D <- minDim n m = validateQR x (qr x) +#if !MIN_VERSION_GLASGOW_HASKELL(8,10,0,0) prop_qr _ = property False +#endif testQRSolve :: forall t n m diff --git a/test/Numeric/Matrix/SVDTest.hs b/test/Numeric/Matrix/SVDTest.hs --- a/test/Numeric/Matrix/SVDTest.hs +++ b/test/Numeric/Matrix/SVDTest.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} @@ -142,7 +143,7 @@ dfs :: [DataFrame Double '[XN 1, XN 1]] dfs = xs where - mkM :: Dims ([n,m]) -> [Double] -> DataFrame Double '[XN 1, XN 1] + mkM :: Dims [n,m] -> [Double] -> DataFrame Double '[XN 1, XN 1] mkM ds | Just (XDims ds'@Dims) <- constrainDims ds :: Maybe (Dims '[XN 1, XN 1]) = XFrame . fromFlatList ds' 0 @@ -173,7 +174,9 @@ prop_svd (XFrame x) | n@D :* m@D :* U <- dims `inSpaceOf` x , D <- minDim n m = validateSVD 1 x (svd x) +#if !MIN_VERSION_GLASGOW_HASKELL(8,10,0,0) prop_svd _ = error "prop_svd: impossible pattern" +#endif return [] diff --git a/test/Numeric/PrimBytesTest.hs b/test/Numeric/PrimBytesTest.hs --- a/test/Numeric/PrimBytesTest.hs +++ b/test/Numeric/PrimBytesTest.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -Wno-orphans #-} {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DefaultSignatures #-} @@ -22,6 +23,7 @@ import Data.Int import Data.Type.Lits import Data.Word +import Foreign.C.Types import Foreign.Marshal import Foreign.Ptr import Foreign.Storable @@ -107,6 +109,9 @@ peek = bPeek poke = bPoke +instance Arbitrary CBool where + arbitrary = CBool <$> arbitrary + instance Arbitrary (Ptr Dummy) where arbitrary = intPtrToPtr . IntPtr <$> arbitrary @@ -300,13 +305,13 @@ , off <- byteOffset v = conjoin [ counterexample "pos" $ pos v === fromBytes - (off +# byteFieldOffset (proxy# @Symbol @"pos") v) ba + (off +# byteFieldOffset (proxy# :: Proxy# "pos") v) ba , counterexample "norm" $ norm v === fromBytes - (off +# byteFieldOffset (proxy# @Symbol @"norm") v) ba + (off +# byteFieldOffset (proxy# :: Proxy# "norm") v) ba , counterexample "tex" $ tex v === fromBytes - (off +# byteFieldOffset (proxy# @Symbol @"tex") v) ba + (off +# byteFieldOffset (proxy# :: Proxy# "tex") v) ba , counterexample "extraFloats" $ extraFloats v === fromBytes - (off +# byteFieldOffset (proxy# @Symbol @"extraFloats") v) ba + (off +# byteFieldOffset (proxy# :: Proxy# "extraFloats") v) ba ] @@ -316,6 +321,12 @@ '[ Word8, Word16, Word32, Word64, Word , Int8, Int16, Int32, Int64, Int , Char, Double, Float + , CChar, CSChar, CUChar, CShort, CUShort + , CInt, CUInt, CLong, CULong + , CPtrdiff, CSize, CWchar, CSigAtomic + , CLLong, CULLong, CBool, CIntPtr, CUIntPtr + , CIntMax, CUIntMax, CClock, CTime + , CUSeconds, CSUSeconds, CFloat, CDouble , Vertex Double Float Char , Vertex Word8 Double Int16 , Vertex Word16 Word32 Word64 @@ -343,34 +354,74 @@ , '(Word16, Word32, Word64) , '(Int64, Int8, Int32) , '(Float, Char, Char) + , '(CChar, CInt, CPtrdiff) + , '(CSChar, CUInt, CSize) + , '(CUChar, CLong, CWchar) + , '(CShort, CULong, CSigAtomic) + , '(CUShort, CLLong, CIntMax) + , '(CULLong, CUIntMax, CUSeconds) + , '(CBool, CClock, CSUSeconds) + , '(CIntPtr, CTime, CFloat) + , '(CUIntPtr, CDouble, CDouble) ] -instance SamePrimRep a (ST.Tuple '[a]) where - convert a = a ST.:$ U -instance SamePrimRep (a,b) (ST.Tuple '[a,b]) where - convert (a, b) = a ST.:$ b ST.:$ U -instance SamePrimRep (a,b,c) (ST.Tuple '[a,b,c]) where - convert (a, b, c) = a ST.:$ b ST.:$ c ST.:$ U -instance SamePrimRep (a,b,c,d) (ST.Tuple '[a,b,c,d]) where - convert (a, b, c, d) = a ST.:$ b ST.:$ c ST.:$ d ST.:$ U -instance SamePrimRep (a,b,c,d,e) (ST.Tuple '[a,b,c,d,e]) where - convert (a, b, c, d, e) = a ST.:$ b ST.:$ c ST.:$ d ST.:$ e ST.:$ U +instance SamePrimRep a a where + convert = id -instance SamePrimRep a (LT.Tuple '[a]) where - convert a = a LT.:$ U -instance SamePrimRep (a,b) (LT.Tuple '[a,b]) where - convert (a, b) = a LT.:$ b LT.:$ U -instance SamePrimRep (a,b,c) (LT.Tuple '[a,b,c]) where - convert (a, b, c) = a LT.:$ b LT.:$ c LT.:$ U -instance SamePrimRep (a,b,c,d) (LT.Tuple '[a,b,c,d]) where - convert (a, b, c, d) = a LT.:$ b LT.:$ c LT.:$ d LT.:$ U -instance SamePrimRep (a,b,c,d,e) (LT.Tuple '[a,b,c,d,e]) where - convert (a, b, c, d, e) = a LT.:$ b LT.:$ c LT.:$ d LT.:$ e LT.:$ U +instance SamePrimRep a a' => SamePrimRep a (ST.Tuple '[a']) where + convert a = convert a ST.:$ U +instance (SamePrimRep a a', SamePrimRep b b') => SamePrimRep (a,b) (ST.Tuple '[a',b']) where + convert (a, b) = convert a ST.:$ convert b ST.:$ U +instance (SamePrimRep a a', SamePrimRep b b', SamePrimRep c c') => SamePrimRep (a,b,c) (ST.Tuple '[a',b',c']) where + convert (a, b, c) = convert a ST.:$ convert b ST.:$ convert c ST.:$ U +instance (SamePrimRep a a', SamePrimRep b b', SamePrimRep c c', SamePrimRep d d') => SamePrimRep (a,b,c,d) (ST.Tuple '[a',b',c',d']) where + convert (a, b, c, d) = convert a ST.:$ convert b ST.:$ convert c ST.:$ convert d ST.:$ U +instance (SamePrimRep a a', SamePrimRep b b', SamePrimRep c c', SamePrimRep d d', SamePrimRep e e') => SamePrimRep (a,b,c,d,e) (ST.Tuple '[a',b',c',d',e']) where + convert (a, b, c, d, e) = convert a ST.:$ convert b ST.:$ convert c ST.:$ convert d ST.:$ convert e ST.:$ U +instance SamePrimRep a a' => SamePrimRep a (LT.Tuple '[a']) where + convert a = convert a LT.:$ U +instance (SamePrimRep a a', SamePrimRep b b') => SamePrimRep (a,b) (LT.Tuple '[a',b']) where + convert (a, b) = convert a LT.:$ convert b LT.:$ U +instance (SamePrimRep a a', SamePrimRep b b', SamePrimRep c c') => SamePrimRep (a,b,c) (LT.Tuple '[a',b',c']) where + convert (a, b, c) = convert a LT.:$ convert b LT.:$ convert c LT.:$ U +instance (SamePrimRep a a', SamePrimRep b b', SamePrimRep c c', SamePrimRep d d') => SamePrimRep (a,b,c,d) (LT.Tuple '[a',b',c',d']) where + convert (a, b, c, d) = convert a LT.:$ convert b LT.:$ convert c LT.:$ convert d LT.:$ U +instance (SamePrimRep a a', SamePrimRep b b', SamePrimRep c c', SamePrimRep d d', SamePrimRep e e') => SamePrimRep (a,b,c,d,e) (LT.Tuple '[a',b',c',d',e']) where + convert (a, b, c, d, e) = convert a LT.:$ convert b LT.:$ convert c LT.:$ convert d LT.:$ convert e LT.:$ U + instance SamePrimRep (Maybe a) (Either () a) where convert (Just a) = Right a convert Nothing = Left () +instance SamePrimRep CChar Int8 where convert (CChar v) = v +instance SamePrimRep CSChar Int8 where convert (CSChar v) = v +instance SamePrimRep CSChar CChar where convert (CSChar v) = CChar v +instance SamePrimRep CUChar Word8 where convert (CUChar v) = v +instance SamePrimRep CShort Int16 where convert (CShort v) = v +instance SamePrimRep CUShort Word16 where convert (CUShort v) = v +instance SamePrimRep CInt Int32 where convert (CInt v) = v +instance SamePrimRep CUInt Word32 where convert (CUInt v) = v +instance SamePrimRep CLong Int64 where convert (CLong v) = v +instance SamePrimRep CULong Word64 where convert (CULong v) = v +instance SamePrimRep CPtrdiff Int64 where convert (CPtrdiff v) = v +instance SamePrimRep CSize Word64 where convert (CSize v) = v +instance SamePrimRep CWchar Int32 where convert (CWchar v) = v +instance SamePrimRep CSigAtomic Int32 where convert (CSigAtomic v) = v +instance SamePrimRep CLLong Int64 where convert (CLLong v) = v +instance SamePrimRep CULLong Word64 where convert (CULLong v) = v +instance SamePrimRep CBool Word8 where convert (CBool v) = v +instance SamePrimRep CIntPtr Int64 where convert (CIntPtr v) = v +instance SamePrimRep CUIntPtr Word64 where convert (CUIntPtr v) = v +instance SamePrimRep CIntMax Int64 where convert (CIntMax v) = v +instance SamePrimRep CUIntMax Word64 where convert (CUIntMax v) = v +instance SamePrimRep CClock Int64 where convert (CClock v) = v +instance SamePrimRep CTime Int64 where convert (CTime v) = v +instance SamePrimRep CUSeconds Word32 where convert (CUSeconds v) = v +instance SamePrimRep CSUSeconds Int64 where convert (CSUSeconds v) = v +instance SamePrimRep CFloat Float where convert (CFloat v) = v +instance SamePrimRep CDouble Double where convert (CDouble v) = v + type SamePrimRepTypes = '[ '( (Word, Double), ST.Tuple '[Word, Double] ) , '( (Double, Word8, Word8, Word8, Maybe Float) @@ -379,6 +430,13 @@ , LT.Tuple '[Word8, Int16, Word32, Either (Either Double Float) Int] ) , '( Maybe Float, Either () Float) , '( Maybe Double, Either () Double) + , '( (CChar, CSChar, CSChar, CUChar), ST.Tuple '[Int8, Int8, CChar, Word8] ) + , '( (CShort, CUShort, CInt, CUInt), LT.Tuple '[Int16, Word16, Int32, Word32] ) + , '( (CLong, CULong, CPtrdiff, CSize), ST.Tuple '[Int64, Word64, Int64, Word64] ) + , '( (CWchar, CSigAtomic, CLLong, CULLong), LT.Tuple '[Int32, Int32, Int64, Word64] ) + , '( (CBool, CIntPtr, CUIntPtr, CIntMax, CUIntMax), ST.Tuple '[Word8, Int64, Word64, Int64, Word64] ) + , '( (CClock, CTime, CUSeconds, CSUSeconds), LT.Tuple '[Int64, Int64, Word32, Int64] ) + , '( (CFloat, CDouble), ST.Tuple '[Float, Double] ) ] return [] -- this is for $testWithTypes diff --git a/test/Spec/Util.hs b/test/Spec/Util.hs --- a/test/Spec/Util.hs +++ b/test/Spec/Util.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TemplateHaskell #-} @@ -29,7 +30,9 @@ where mkProp :: [Type] -> Exp -> ExpQ mkProp ts ex - = let qe = pure ex :: ExpQ + = let qe :: ExpQ + qe = pure ex + qs :: ExpQ qs = litE . stringL $ unlines ["Tested with types:", pprint ts] in [e| property ( counterexample $qs $qe ) |] @@ -87,6 +90,7 @@ funTypes :: [TypeQ] funTypes = (\ns -> fmap (subtTyVars (map ConT ns)) ) <$> tyNames <*> [infoType <$> reify fName] + mkDecl :: Q Name -> Q Type -> Q Exp -> DecsQ mkDecl qn qt qe = do n <- qn sequence @@ -124,10 +128,17 @@ substTyVar x y (ForallT vs ctx t) = ForallT (remVar vs) (ctx >>= substOrRemove) (substTyVar x y t) where +#if __GLASGOW_HASKELL__ >= 900 + thisVar :: TyVarBndr a -> Bool + thisVar (PlainTV n _) = n == x + thisVar (KindedTV n _ _) = n == x + remVar :: [TyVarBndr a] -> [TyVarBndr a] +#else thisVar :: TyVarBndr -> Bool thisVar (PlainTV n) = n == x thisVar (KindedTV n _) = n == x remVar :: [TyVarBndr] -> [TyVarBndr] +#endif remVar = filter (not . thisVar) substOrRemove p = let p' = substTyVar x y p @@ -141,8 +152,13 @@ substTyVar _ _ t = t findFirstTyVar :: Type -> Maybe Name +#if __GLASGOW_HASKELL__ >= 900 +findFirstTyVar (ForallT (PlainTV n _:_) _ _) = Just n +findFirstTyVar (ForallT (KindedTV n _ _:_) _ _) = Just n +#else findFirstTyVar (ForallT (PlainTV n:_) _ _) = Just n findFirstTyVar (ForallT (KindedTV n _:_) _ _) = Just n +#endif findFirstTyVar (ForallT [] ctx t) = getFirst (foldMap (First . findFirstTyVar) ctx) <|> findFirstTyVar t findFirstTyVar (AppT t1 t2) = findFirstTyVar t1 <|> findFirstTyVar t2