├── .gitignore ├── cabal.project ├── fixed-vector-QC ├── ChangeLog.md ├── fixed-vector-QC.cabal ├── LICENSE └── Data │ └── Vector │ └── Fixed │ └── Instances │ └── QuickCheck.hs ├── fixed-vector-aeson ├── ChangeLog.md ├── fixed-vector-aeson.cabal ├── LICENSE └── Data │ └── Vector │ └── Fixed │ └── Instances │ └── Aeson.hs ├── fixed-vector ├── Setup.hs ├── test │ ├── Inspect │ │ └── Obligations.hs │ ├── Doctests.hs │ └── inspect.hs ├── LICENSE ├── Data │ └── Vector │ │ ├── Fixed │ │ ├── Generic.hs │ │ ├── Primitive.hs │ │ ├── Strict.hs │ │ ├── Boxed.hs │ │ ├── Storable.hs │ │ ├── Mutable.hs │ │ ├── Unboxed.hs │ │ ├── Internal.hs │ │ └── Cont.hs │ │ └── Fixed.hs ├── fixed-vector.cabal └── ChangeLog.md ├── fixed-vector-binary ├── Setup.hs ├── ChangeLog.md ├── fixed-vector-binary.cabal ├── LICENSE └── Data │ └── Vector │ └── Fixed │ └── Instances │ └── Binary.hs ├── fixed-vector-cborg ├── Setup.hs ├── ChangeLog.md ├── fixed-vector-cborg.cabal ├── LICENSE └── Data │ └── Vector │ └── Fixed │ └── Instances │ └── CBOR.hs ├── fixed-vector-cereal ├── Setup.hs ├── ChangeLog.md ├── fixed-vector-cereal.cabal ├── LICENSE └── Data │ └── Vector │ └── Fixed │ └── Instances │ └── Cereal.hs ├── .hgignore ├── fixed-vector-test ├── test │ ├── main.hs │ └── TST │ │ ├── CBOR.hs │ │ ├── Binary.hs │ │ ├── Aeson.hs │ │ ├── Cereal.hs │ │ └── Util.hs ├── LICENSE └── fixed-vector-test.cabal ├── README.markdown ├── .hgtags └── .github └── workflows └── ci.yml /.gitignore: -------------------------------------------------------------------------------- 1 | TAGS 2 | dist 3 | dist-newstyle 4 | -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | packages: */*.cabal 2 | tests: true 3 | -------------------------------------------------------------------------------- /fixed-vector-QC/ChangeLog.md: -------------------------------------------------------------------------------- 1 | 2.0.0.0 2 | ------- 3 | * Initial release 4 | -------------------------------------------------------------------------------- /fixed-vector-aeson/ChangeLog.md: -------------------------------------------------------------------------------- 1 | 2.0.0.0 2 | ------- 3 | * Initial release 4 | -------------------------------------------------------------------------------- /fixed-vector/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /fixed-vector-binary/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /fixed-vector-cborg/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /fixed-vector-cereal/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /.hgignore: -------------------------------------------------------------------------------- 1 | dist 2 | test/optimization/.*\.(hi|hs.hcr|o) 3 | test/optimization/fuse-[^.]*$ 4 | \.cabal-sandbox 5 | cabal.sandbox.config -------------------------------------------------------------------------------- /fixed-vector-binary/ChangeLog.md: -------------------------------------------------------------------------------- 1 | 1.0.0.2 2 | ------- 3 | * GHC 8.6+ compatibility for tests as well 4 | 5 | 1.0.0.1 6 | ------- 7 | * GHC 8.6 compatibility 8 | 9 | 1.0.0.0 10 | ------- 11 | * Compatibility with fixed-vector-1.0 12 | 13 | 0.6.0.0 14 | ------- 15 | * Initial release 16 | -------------------------------------------------------------------------------- /fixed-vector-cborg/ChangeLog.md: -------------------------------------------------------------------------------- 1 | 1.0.0.2 2 | ------- 3 | * GHC 8.6+ compatibility for tests as well 4 | 5 | 1.0.0.1 6 | ------- 7 | * GHC 8.6 compatibility 8 | 9 | 1.0.0.0 10 | ------- 11 | * Compatibility with fixed-vector-1.0 12 | 13 | 0.6.0.0 14 | ------- 15 | * Initial release 16 | -------------------------------------------------------------------------------- /fixed-vector-cereal/ChangeLog.md: -------------------------------------------------------------------------------- 1 | 1.0.0.2 2 | ------- 3 | * GHC 8.6+ compatibility for tests as well 4 | 5 | 1.0.0.1 6 | ------- 7 | * GHC 8.6 compatibility 8 | 9 | 1.0.0.0 10 | ------- 11 | * Compatibility with fixed-vector-1.0 12 | 13 | 0.6.0.0 14 | ------- 15 | * Initial release 16 | -------------------------------------------------------------------------------- /fixed-vector-test/test/main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Test.Tasty 4 | import qualified TST.Cereal 5 | import qualified TST.Binary 6 | import qualified TST.CBOR 7 | import qualified TST.Aeson 8 | 9 | main :: IO () 10 | main = defaultMain $ testGroup "fixed-vector" 11 | [ TST.Cereal.tests 12 | , TST.Binary.tests 13 | , TST.CBOR.tests 14 | , TST.Aeson.tests 15 | ] 16 | -------------------------------------------------------------------------------- /fixed-vector/test/Inspect/Obligations.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MagicHash #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | -- | 4 | module Inspect.Obligations where 5 | 6 | import GHC.Exts 7 | import Test.Tasty.Inspection 8 | import Language.Haskell.TH (Name) 9 | 10 | 11 | -- We don't allocate arrays in he function. It covers opaque data 12 | -- types 13 | noArrayAlloc :: Name -> Obligation 14 | noArrayAlloc nm = doesNotUseAnyOf nm 15 | [ 'newByteArray# 16 | , 'newSmallArray# 17 | ] 18 | 19 | noAllocation :: Name -> Obligation 20 | noAllocation nm = mkObligation nm NoAllocation 21 | -------------------------------------------------------------------------------- /fixed-vector-test/test/TST/CBOR.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | module TST.CBOR where 3 | 4 | import Codec.Serialise 5 | import Data.Vector.Fixed.Instances.QuickCheck () 6 | import Data.Vector.Fixed.Instances.CBOR () 7 | import TST.Util 8 | 9 | tests :: TestTree 10 | tests 11 | = testGroup "CBOR" 12 | $ $(makeTest 'testCBOR [t| Int |]) 13 | 14 | testCBOR 15 | :: forall v a. ( Typeable a, Typeable v 16 | , Arbitrary (v a), Eq (v a), Show (v a), Serialise (v a) 17 | ) 18 | => Proxy v 19 | -> Proxy a 20 | -> TestTree 21 | testCBOR _ _ 22 | = testProperty (show $ typeOf (undefined :: v a)) 23 | $ \(v :: v a) -> v == (deserialise . serialise) v 24 | -------------------------------------------------------------------------------- /fixed-vector-test/test/TST/Binary.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | module TST.Binary (tests) where 3 | 4 | import Data.Binary 5 | import Data.Vector.Fixed.Instances.QuickCheck () 6 | import Data.Vector.Fixed.Instances.Binary () 7 | import TST.Util 8 | 9 | tests :: TestTree 10 | tests 11 | = testGroup "binary" 12 | $ $(makeTest 'testBinary [t| Int |]) 13 | 14 | testBinary 15 | :: forall v a. ( Typeable a, Typeable v 16 | , Arbitrary (v a), Eq (v a), Show (v a), Binary (v a) 17 | ) 18 | => Proxy v 19 | -> Proxy a 20 | -> TestTree 21 | testBinary _ _ 22 | = testProperty (show $ typeOf (undefined :: v a)) 23 | $ \(v :: v a) -> v == (decode . encode) v 24 | -------------------------------------------------------------------------------- /fixed-vector-test/test/TST/Aeson.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | module TST.Aeson where 3 | 4 | import Data.Aeson 5 | import Data.Vector.Fixed.Instances.QuickCheck () 6 | import Data.Vector.Fixed.Instances.Aeson () 7 | import TST.Util 8 | 9 | tests :: TestTree 10 | tests 11 | = testGroup "aeson" 12 | $ $(makeTest 'testAeson [t| Int |]) 13 | 14 | testAeson 15 | :: forall v a. ( Typeable a, Typeable v 16 | , Arbitrary (v a), Eq (v a), Show (v a), FromJSON (v a), ToJSON (v a) 17 | ) 18 | => Proxy v 19 | -> Proxy a 20 | -> TestTree 21 | testAeson _ _ 22 | = testProperty (show $ typeOf (undefined :: v a)) 23 | $ \(v :: v a) -> Just v == (decode . encode) v 24 | -------------------------------------------------------------------------------- /fixed-vector-test/test/TST/Cereal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | module TST.Cereal (tests) where 3 | 4 | import Data.Serialize 5 | import Data.Vector.Fixed.Instances.QuickCheck () 6 | import Data.Vector.Fixed.Instances.Cereal () 7 | import TST.Util 8 | 9 | tests :: TestTree 10 | tests 11 | = testGroup "cereal" 12 | $ $(makeTest 'testCereal [t| Int |]) 13 | 14 | testCereal 15 | :: forall v a. ( Typeable a, Typeable v 16 | , Arbitrary (v a), Eq (v a), Show (v a), Serialize (v a) 17 | ) 18 | => Proxy v 19 | -> Proxy a 20 | -> TestTree 21 | testCereal _ _ 22 | = testProperty (show $ typeOf (undefined :: v a)) 23 | $ \(v :: v a) -> Right v == (decode . encode) v 24 | 25 | 26 | -------------------------------------------------------------------------------- /fixed-vector-binary/fixed-vector-binary.cabal: -------------------------------------------------------------------------------- 1 | Name: fixed-vector-binary 2 | Version: 2.0.0.0 3 | Synopsis: Binary instances for fixed-vector 4 | Description: 5 | This package contains Binary instances for data types defined in 6 | fixed-vector package. 7 | 8 | Cabal-Version: >= 1.10 9 | License: BSD3 10 | License-File: LICENSE 11 | Author: Aleksey Khudyakov 12 | Maintainer: Aleksey Khudyakov 13 | Bug-reports: https://github.com/Shimuuar/fixed-vector/issues 14 | Category: Data 15 | Build-Type: Simple 16 | extra-source-files: 17 | ChangeLog.md 18 | 19 | tested-with: 20 | GHC ==8.10.7 21 | || ==9.0.1 22 | || ==9.2.8 23 | || ==9.4.7 24 | || ==9.6.6 25 | || ==9.8.2 26 | || ==9.10.1 27 | 28 | source-repository head 29 | type: git 30 | location: http://github.com/Shimuuar/fixed-vector 31 | 32 | Library 33 | Ghc-options: -Wall 34 | Default-Language: Haskell2010 35 | Build-Depends: base >=4.14 && <5 36 | , fixed-vector >=2.0 37 | , binary 38 | Exposed-modules: 39 | Data.Vector.Fixed.Instances.Binary 40 | -------------------------------------------------------------------------------- /fixed-vector-cereal/fixed-vector-cereal.cabal: -------------------------------------------------------------------------------- 1 | Name: fixed-vector-cereal 2 | Version: 2.0.0.0 3 | Synopsis: Cereal instances for fixed-vector 4 | Description: 5 | This package contains Cereal instances for data types defined in 6 | fixed-vector package. 7 | 8 | Cabal-Version: >= 1.10 9 | License: BSD3 10 | License-File: LICENSE 11 | Author: Aleksey Khudyakov 12 | Maintainer: Aleksey Khudyakov 13 | Bug-reports: https://github.com/Shimuuar/fixed-vector/issues 14 | Category: Data 15 | Build-Type: Simple 16 | extra-source-files: 17 | ChangeLog.md 18 | 19 | tested-with: 20 | GHC ==8.10.7 21 | || ==9.0.1 22 | || ==9.2.8 23 | || ==9.4.7 24 | || ==9.6.6 25 | || ==9.8.2 26 | || ==9.10.1 27 | 28 | source-repository head 29 | type: git 30 | location: http://github.com/Shimuuar/fixed-vector 31 | 32 | Library 33 | Ghc-options: -Wall 34 | Default-Language: Haskell2010 35 | Build-Depends: base >=4.14 && <5 36 | , fixed-vector >=2.0 37 | , cereal 38 | Exposed-modules: 39 | Data.Vector.Fixed.Instances.Cereal 40 | -------------------------------------------------------------------------------- /fixed-vector-QC/fixed-vector-QC.cabal: -------------------------------------------------------------------------------- 1 | Name: fixed-vector-QC 2 | Version: 2.0.0.0 3 | Synopsis: QuickCheck instances for fixed-vector 4 | Description: 5 | This package contains Arbitrary instances for data types defined in 6 | fixed-vector package. 7 | 8 | Cabal-Version: >= 1.10 9 | License: BSD3 10 | License-File: LICENSE 11 | Author: Aleksey Khudyakov 12 | Maintainer: Aleksey Khudyakov 13 | Bug-reports: https://github.com/Shimuuar/fixed-vector/issues 14 | Category: Data 15 | Build-Type: Simple 16 | extra-source-files: 17 | ChangeLog.md 18 | 19 | tested-with: 20 | GHC ==8.10.7 21 | || ==9.0.1 22 | || ==9.2.8 23 | || ==9.4.7 24 | || ==9.6.6 25 | || ==9.8.2 26 | || ==9.10.1 27 | 28 | source-repository head 29 | type: git 30 | location: http://github.com/Shimuuar/fixed-vector 31 | 32 | Library 33 | Ghc-options: -Wall 34 | Default-Language: Haskell2010 35 | Build-Depends: base >=4.14 && <5 36 | , fixed-vector >=2.0 37 | , QuickCheck >=2.13 38 | Exposed-modules: 39 | Data.Vector.Fixed.Instances.QuickCheck 40 | -------------------------------------------------------------------------------- /fixed-vector-cborg/fixed-vector-cborg.cabal: -------------------------------------------------------------------------------- 1 | Name: fixed-vector-cborg 2 | Version: 2.0.0.0 3 | Synopsis: Binary instances for fixed-vector 4 | Description: 5 | CBOR serialization instances for fixed-vector's types. Generic 6 | serialization functions are proviede as well 7 | 8 | Cabal-Version: >= 1.10 9 | License: BSD3 10 | License-File: LICENSE 11 | Author: Aleksey Khudyakov 12 | Maintainer: Aleksey Khudyakov 13 | Bug-reports: https://github.com/Shimuuar/fixed-vector/issues 14 | Category: Data 15 | Build-Type: Simple 16 | extra-source-files: 17 | ChangeLog.md 18 | 19 | tested-with: 20 | GHC ==8.10.7 21 | || ==9.0.1 22 | || ==9.2.8 23 | || ==9.4.7 24 | || ==9.6.6 25 | || ==9.8.2 26 | || ==9.10.1 27 | 28 | source-repository head 29 | type: git 30 | location: http://github.com/Shimuuar/fixed-vector 31 | 32 | Library 33 | Ghc-options: -Wall 34 | Default-Language: Haskell2010 35 | Build-Depends: base >=4.14 && <5 36 | , fixed-vector >=2.0 37 | , cborg 38 | , serialise 39 | Exposed-modules: 40 | Data.Vector.Fixed.Instances.CBOR 41 | -------------------------------------------------------------------------------- /fixed-vector-aeson/fixed-vector-aeson.cabal: -------------------------------------------------------------------------------- 1 | Name: fixed-vector-aeson 2 | Version: 2.0.0.0 3 | Synopsis: Aeson instances for fixed-vector 4 | Description: 5 | This package contains FromJSON and ToJSON instances for data types defined in 6 | fixed-vector package. 7 | 8 | Cabal-Version: >= 1.10 9 | License: BSD3 10 | License-File: LICENSE 11 | Author: Aleksey Khudyakov 12 | Maintainer: Aleksey Khudyakov 13 | Bug-reports: https://github.com/Shimuuar/fixed-vector/issues 14 | Category: Data 15 | Build-Type: Simple 16 | extra-source-files: 17 | ChangeLog.md 18 | 19 | tested-with: 20 | GHC ==8.10.7 21 | || ==9.0.1 22 | || ==9.2.8 23 | || ==9.4.7 24 | || ==9.6.6 25 | || ==9.8.2 26 | || ==9.10.1 27 | 28 | source-repository head 29 | type: git 30 | location: http://github.com/Shimuuar/fixed-vector 31 | 32 | Library 33 | Ghc-options: -Wall 34 | Default-Language: Haskell2010 35 | Build-Depends: base >=4.14 && <5 36 | , fixed-vector >=2.0 37 | , aeson >=2 38 | , vector 39 | Exposed-modules: 40 | Data.Vector.Fixed.Instances.Aeson 41 | -------------------------------------------------------------------------------- /README.markdown: -------------------------------------------------------------------------------- 1 | 2 | # Fixed-vector [![Build Status](https://travis-ci.org/Shimuuar/fixed-vector.png?branch=master)](https://travis-ci.org/Shimuuar/fixed-vector) 3 | 4 | Generic library for vectors with statically known size. It's able to work with 5 | product types where types of all elements are same. For example following type 6 | could be used: 7 | 8 | ```haskell 9 | data Vec3 a = Vec3 a a a 10 | ``` 11 | 12 | Tuples of same types work as well: 13 | 14 | ``` 15 | >>> sum (1,2,3) 16 | 6 17 | ``` 18 | 19 | Library provides set of vector parametrized by length. Boxed, unboxed and 20 | storable vectors are all supported. 21 | 22 | Basic idea is to establish isomorphism between N-element vector and its Church 23 | encoding (`∀r. (a → a → r) → r` for 2-element vector) and all functions work on 24 | Church-encoded vectors. This allows to decouple functions from representation of 25 | vectors and allows to implement deforestation. 26 | 27 | Downside of this approach is inability to work with vectors larger than tens of 28 | elements. If you need larger 29 | vectors [vector-sized](https://hackage.haskell.org/package/vector-sized) could provide 30 | similar functionality. 31 | 32 | 33 | # Get involved! 34 | 35 | Please report bugs via 36 | [github issue tracker](https://github.com/Shimuuar/fixed-vector/issues) 37 | 38 | 39 | 40 | # Authors 41 | 42 | Library is written and maintained by Aleksey Khudyakov 43 | -------------------------------------------------------------------------------- /fixed-vector/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) Aleksey Khudyakov 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions 7 | are met: 8 | 9 | 1. Redistributions of source code must retain the above copyright 10 | notice, this list of conditions and the following disclaimer. 11 | 12 | 2. Redistributions in binary form must reproduce the above copyright 13 | notice, this list of conditions and the following disclaimer in the 14 | documentation and/or other materials provided with the distribution. 15 | 16 | 3. Neither the name of the author nor the names of his contributors 17 | may be used to endorse or promote products derived from this software 18 | without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS 21 | OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 22 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 23 | DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR 24 | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 25 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 26 | OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 27 | HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, 28 | STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN 29 | ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 30 | POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /fixed-vector-QC/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) Aleksey Khudyakov 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions 7 | are met: 8 | 9 | 1. Redistributions of source code must retain the above copyright 10 | notice, this list of conditions and the following disclaimer. 11 | 12 | 2. Redistributions in binary form must reproduce the above copyright 13 | notice, this list of conditions and the following disclaimer in the 14 | documentation and/or other materials provided with the distribution. 15 | 16 | 3. Neither the name of the author nor the names of his contributors 17 | may be used to endorse or promote products derived from this software 18 | without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS 21 | OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 22 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 23 | DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR 24 | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 25 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 26 | OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 27 | HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, 28 | STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN 29 | ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 30 | POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /fixed-vector-aeson/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) Aleksey Khudyakov 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions 7 | are met: 8 | 9 | 1. Redistributions of source code must retain the above copyright 10 | notice, this list of conditions and the following disclaimer. 11 | 12 | 2. Redistributions in binary form must reproduce the above copyright 13 | notice, this list of conditions and the following disclaimer in the 14 | documentation and/or other materials provided with the distribution. 15 | 16 | 3. Neither the name of the author nor the names of his contributors 17 | may be used to endorse or promote products derived from this software 18 | without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS 21 | OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 22 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 23 | DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR 24 | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 25 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 26 | OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 27 | HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, 28 | STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN 29 | ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 30 | POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /fixed-vector-binary/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) Aleksey Khudyakov 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions 7 | are met: 8 | 9 | 1. Redistributions of source code must retain the above copyright 10 | notice, this list of conditions and the following disclaimer. 11 | 12 | 2. Redistributions in binary form must reproduce the above copyright 13 | notice, this list of conditions and the following disclaimer in the 14 | documentation and/or other materials provided with the distribution. 15 | 16 | 3. Neither the name of the author nor the names of his contributors 17 | may be used to endorse or promote products derived from this software 18 | without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS 21 | OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 22 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 23 | DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR 24 | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 25 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 26 | OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 27 | HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, 28 | STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN 29 | ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 30 | POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /fixed-vector-cborg/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) Aleksey Khudyakov 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions 7 | are met: 8 | 9 | 1. Redistributions of source code must retain the above copyright 10 | notice, this list of conditions and the following disclaimer. 11 | 12 | 2. Redistributions in binary form must reproduce the above copyright 13 | notice, this list of conditions and the following disclaimer in the 14 | documentation and/or other materials provided with the distribution. 15 | 16 | 3. Neither the name of the author nor the names of his contributors 17 | may be used to endorse or promote products derived from this software 18 | without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS 21 | OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 22 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 23 | DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR 24 | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 25 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 26 | OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 27 | HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, 28 | STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN 29 | ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 30 | POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /fixed-vector-cereal/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) Aleksey Khudyakov 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions 7 | are met: 8 | 9 | 1. Redistributions of source code must retain the above copyright 10 | notice, this list of conditions and the following disclaimer. 11 | 12 | 2. Redistributions in binary form must reproduce the above copyright 13 | notice, this list of conditions and the following disclaimer in the 14 | documentation and/or other materials provided with the distribution. 15 | 16 | 3. Neither the name of the author nor the names of his contributors 17 | may be used to endorse or promote products derived from this software 18 | without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS 21 | OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 22 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 23 | DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR 24 | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 25 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 26 | OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 27 | HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, 28 | STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN 29 | ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 30 | POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /fixed-vector-test/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) Aleksey Khudyakov 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions 7 | are met: 8 | 9 | 1. Redistributions of source code must retain the above copyright 10 | notice, this list of conditions and the following disclaimer. 11 | 12 | 2. Redistributions in binary form must reproduce the above copyright 13 | notice, this list of conditions and the following disclaimer in the 14 | documentation and/or other materials provided with the distribution. 15 | 16 | 3. Neither the name of the author nor the names of his contributors 17 | may be used to endorse or promote products derived from this software 18 | without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS 21 | OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 22 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 23 | DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR 24 | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 25 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 26 | OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 27 | HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, 28 | STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN 29 | ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 30 | POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /fixed-vector-test/fixed-vector-test.cabal: -------------------------------------------------------------------------------- 1 | Name: fixed-vector-test 2 | Version: 2.0.0.0 3 | Synopsis: Tests fixed-vector 4 | Description: 5 | All tests for instance packages are moved to separate package in order to 6 | simplify maintenance 7 | 8 | Cabal-Version: >= 1.10 9 | License: BSD3 10 | License-File: LICENSE 11 | Author: Aleksey Khudyakov 12 | Maintainer: Aleksey Khudyakov 13 | Bug-reports: https://github.com/Shimuuar/fixed-vector/issues 14 | Category: Data 15 | Build-Type: Simple 16 | 17 | Test-Suite fixed-vector-test 18 | Ghc-options: -Wall 19 | Default-Language: Haskell2010 20 | Default-Extensions: 21 | DataKinds 22 | TypeApplications 23 | ScopedTypeVariables 24 | RankNTypes 25 | Type: exitcode-stdio-1.0 26 | Hs-source-dirs: test 27 | Main-is: main.hs 28 | Other-modules: TST.Cereal 29 | TST.Binary 30 | TST.CBOR 31 | TST.Aeson 32 | TST.Util 33 | Build-Depends: base >=4.14 && <5 34 | , fixed-vector >=2 35 | , fixed-vector-QC >=2 36 | , fixed-vector-aeson >=2 37 | , fixed-vector-binary >=2 38 | , fixed-vector-cborg >=2 39 | , fixed-vector-cereal >=2 40 | -- 41 | , template-haskell 42 | , aeson 43 | , cereal 44 | , binary 45 | , tasty 46 | , serialise 47 | , tasty-quickcheck 48 | -------------------------------------------------------------------------------- /.hgtags: -------------------------------------------------------------------------------- 1 | e53d255caca571d3c5b1013572c34c604e28ac78 v0.1 2 | 4edcbe9e970d0580f15bec32227c61dfac3efeee v0.1.1 3 | 5504a5cf75372db29738fe553be0df25ccf2b646 v0.1.2 4 | 2cc47468385fe7f8fab4f12a77cebec5626e4815 v0.1.2.1 5 | 8084bc3aed46dc02c32f91948e0a572021722aa9 v0.2.0.0 6 | 35a3bd845679aabe757957fbe45c85ef3dce822f v0.3.0.0 7 | 1d247d8c1198f0dcf15ab2c1c2ce6be614998811 v0.3.0.1 8 | 3517cf5e97ea0a1fd61e292c7fa286863d73ff02 v0.4.0.0 9 | 6baadc97beb6fc1ff5d543b66a73b63d4c483c11 v0.4.1.0 10 | 16932557065bf9f692b9efb74a4ebfdb7a9cc974 v0.4.2.0 11 | d21f068e3b8da8e200ab86f3a3416dc7eecafd8c v0.4.3.0 12 | d516788c98b416684ecf5195d6844a9612c1b9f1 v0.4.4.0 13 | 81e0b7105a66952dca89b9886e55eeb1c4285ff1 v0.5.0.0 14 | e112a00c905faca41ab79bebe7527b6ba13493dd v0.5.1.0 15 | 504ae4bec92c40f02ba6b4c5bfea097981f7ded7 v0.5.1.1 16 | 2f3de94874ab925f017a81c3ec9c9049f5591e38 v0.5.1.2 17 | 863c4023c7a04fcd3ebf43d43f3908036b3bb3d0 v0.6.0.0 18 | bb5cc4f99b04dce27709e752c63f4f081fc683f2 fixed-vector-cereal-0.6.0.0 19 | 8a063c082f28237336530858b5b1cae99354b138 fixed-vector-binary-0.6.0.0 20 | 978fdc52432a4e3afac86dffe6b9e9689f61a567 fixed-vector-0.6.1.0 21 | e80e3066f5209340426f8b95fd1a6b11299651f9 fixed-vector-0.6.1.1 22 | ff1e4c072078336778203c54da96653f238ddf5d fixed-vector-0.6.2.0 23 | a0f4d946f89f95e2fa68a11dfdb0641b314967ce fixed-vector-0.6.3.0 24 | 0ee92d81b417fa98352c2067f1a1b01c05b3d011 fixed-vector-0.6.3.1 25 | 9f63e91f6b591b0a2134445612c68eee3b44543b fixed-vector-0.7.0.0 26 | 13f550f42aca5c5d962fa54c8beb28de025e663b fixed-vector-0.7.0.1 27 | a0ac56ebc73a08949b091517908f782148bff8f8 fixed-vector-0.7.0.2 28 | bd6ddda2ab2377df6a033e686238d8cdf4ddfa32 fixed-vector-0.7.0.3 29 | 5e15b1fb3a54dc57e0fdead0867b102bcd8b7216 fixed-vector-0.8.0.0 30 | 2052f880d80819e1f725010067188e4d70d5cdc3 fixed-vector-0.8.1.0 31 | -------------------------------------------------------------------------------- /fixed-vector/test/Doctests.hs: -------------------------------------------------------------------------------- 1 | module Main 2 | where 3 | 4 | import Test.DocTest 5 | import System.FilePath.Find ((==?), always, extension, find) 6 | 7 | find_sources :: IO [FilePath] 8 | find_sources = find always (extension ==? ".hs") "Data" 9 | 10 | main :: IO () 11 | main = do 12 | sources <- find_sources 13 | doctest $ exts ++ sources 14 | 15 | 16 | exts :: [String] 17 | exts = 18 | [ "-XBangPatterns" 19 | , "-XConstraintKinds" 20 | , "-XDataKinds" 21 | , "-XDeriveDataTypeable" 22 | , "-XDeriveFoldable" 23 | , "-XDeriveFunctor" 24 | , "-XDeriveGeneric" 25 | , "-XDeriveLift" 26 | , "-XDeriveTraversable" 27 | , "-XDerivingStrategies" 28 | , "-XDisambiguateRecordFields" 29 | , "-XDoAndIfThenElse" 30 | , "-XEmptyCase" 31 | , "-XEmptyDataDecls" 32 | , "-XEmptyDataDeriving" 33 | , "-XExistentialQuantification" 34 | , "-XExplicitNamespaces" 35 | , "-XFlexibleContexts" 36 | , "-XFlexibleInstances" 37 | , "-XForeignFunctionInterface" 38 | , "-XGADTs" 39 | , "-XGADTSyntax" 40 | , "-XGeneralisedNewtypeDeriving" 41 | , "-XImplicitPrelude" 42 | , "-XImportQualifiedPost" 43 | , "-XInstanceSigs" 44 | , "-XKindSignatures" 45 | , "-XLambdaCase" 46 | , "-XMonoLocalBinds" 47 | , "-XMonomorphismRestriction" 48 | , "-XMultiParamTypeClasses" 49 | , "-XNamedFieldPuns" 50 | , "-XNamedWildCards" 51 | , "-XNumericUnderscores" 52 | , "-XPatternGuards" 53 | , "-XPostfixOperators" 54 | , "-XRankNTypes" 55 | , "-XRelaxedPolyRec" 56 | , "-XRoleAnnotations" 57 | , "-XScopedTypeVariables" 58 | , "-XStandaloneDeriving" 59 | , "-XStandaloneKindSignatures" 60 | , "-XTupleSections" 61 | , "-XTypeApplications" 62 | , "-XTypeOperators" 63 | , "-XTypeSynonymInstances" 64 | -- 65 | , "-XDerivingVia" 66 | , "-XPatternSynonyms" 67 | , "-XViewPatterns" 68 | , "-XTypeFamilies" 69 | ] 70 | -------------------------------------------------------------------------------- /fixed-vector-QC/Data/Vector/Fixed/Instances/QuickCheck.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DerivingVia #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | {-# LANGUAGE StandaloneDeriving #-} 5 | {-# LANGUAGE TypeFamilies #-} 6 | {-# LANGUAGE UndecidableInstances #-} 7 | {-# OPTIONS_GHC -fno-warn-orphans #-} 8 | -- | Module with @aeson@ instances for data types defined in fixed 9 | -- vector 10 | module Data.Vector.Fixed.Instances.QuickCheck () where 11 | 12 | import Data.Vector.Fixed (Arity,ArityPeano,ViaFixed(..),Vector) 13 | import qualified Data.Vector.Fixed as F 14 | import qualified Data.Vector.Fixed.Boxed as FB 15 | import qualified Data.Vector.Fixed.Strict as FF 16 | import qualified Data.Vector.Fixed.Unboxed as FU 17 | import qualified Data.Vector.Fixed.Primitive as FP 18 | import qualified Data.Vector.Fixed.Storable as FS 19 | import Test.QuickCheck 20 | 21 | 22 | instance (Vector v a, Arbitrary a) => Arbitrary (ViaFixed v a) where 23 | arbitrary = F.replicateM arbitrary 24 | 25 | 26 | deriving via ViaFixed (FB.Vec n) a instance (Arity n, Arbitrary a) => Arbitrary (FB.Vec n a) 27 | deriving via ViaFixed (FF.Vec n) a instance (Arity n, Arbitrary a) => Arbitrary (FF.Vec n a) 28 | deriving via ViaFixed (FP.Vec n) a instance (Arity n, Arbitrary a, FP.Prim a) => Arbitrary (FP.Vec n a) 29 | deriving via ViaFixed (FS.Vec n) a instance (Arity n, Arbitrary a, FS.Storable a) => Arbitrary (FS.Vec n a) 30 | deriving via ViaFixed (FU.Vec n) a instance (Arity n, Arbitrary a, FU.Unbox n a) => Arbitrary (FU.Vec n a) 31 | 32 | deriving via ViaFixed (F.VecList n) a instance (Arity n, Arbitrary a) => Arbitrary (F.VecList n a) 33 | deriving via ViaFixed (F.VecPeano n) a instance (ArityPeano n, Arbitrary a) => Arbitrary (F.VecPeano n a) 34 | deriving via ViaFixed F.Only a instance (Arbitrary a) => Arbitrary (F.Only a) 35 | 36 | instance Arbitrary (F.Empty a) where 37 | arbitrary = pure F.Empty 38 | -------------------------------------------------------------------------------- /fixed-vector-binary/Data/Vector/Fixed/Instances/Binary.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DerivingVia #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE StandaloneDeriving #-} 4 | {-# LANGUAGE TypeFamilies #-} 5 | {-# LANGUAGE UndecidableInstances #-} 6 | {-# OPTIONS_GHC -fno-warn-orphans #-} 7 | -- | Module with binary instances for data types defined in fixed 8 | -- vector 9 | module Data.Vector.Fixed.Instances.Binary where 10 | 11 | import Data.Vector.Fixed (Arity,ArityPeano,ViaFixed(..),Vector) 12 | import qualified Data.Vector.Fixed as F 13 | import qualified Data.Vector.Fixed.Boxed as FB 14 | import qualified Data.Vector.Fixed.Strict as FF 15 | import qualified Data.Vector.Fixed.Unboxed as FU 16 | import qualified Data.Vector.Fixed.Primitive as FP 17 | import qualified Data.Vector.Fixed.Storable as FS 18 | import Data.Binary (Binary(..)) 19 | 20 | instance (Vector v a, Binary a) => Binary (ViaFixed v a) where 21 | put = F.mapM_ put 22 | get = F.replicateM get 23 | {-# INLINE put #-} 24 | {-# INLINE get #-} 25 | 26 | deriving via ViaFixed (FB.Vec n) a instance (Arity n, Binary a) => Binary (FB.Vec n a) 27 | deriving via ViaFixed (FF.Vec n) a instance (Arity n, Binary a) => Binary (FF.Vec n a) 28 | deriving via ViaFixed (FP.Vec n) a instance (Arity n, Binary a, FP.Prim a) => Binary (FP.Vec n a) 29 | deriving via ViaFixed (FS.Vec n) a instance (Arity n, Binary a, FS.Storable a) => Binary (FS.Vec n a) 30 | deriving via ViaFixed (FU.Vec n) a instance (Arity n, Binary a, FU.Unbox n a) => Binary (FU.Vec n a) 31 | 32 | deriving via ViaFixed (F.VecList n) a instance (Arity n, Binary a) => Binary (F.VecList n a) 33 | deriving via ViaFixed (F.VecPeano n) a instance (ArityPeano n, Binary a) => Binary (F.VecPeano n a) 34 | 35 | instance (Binary a) => Binary (F.Only a) where 36 | put (F.Only a) = put a 37 | get = F.Only `fmap` get 38 | 39 | instance Binary (F.Empty a) where 40 | put _ = return () 41 | get = return F.Empty 42 | -------------------------------------------------------------------------------- /fixed-vector-cereal/Data/Vector/Fixed/Instances/Cereal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DerivingVia #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE StandaloneDeriving #-} 4 | {-# LANGUAGE TypeFamilies #-} 5 | {-# LANGUAGE UndecidableInstances #-} 6 | {-# OPTIONS_GHC -fno-warn-orphans #-} 7 | -- | Module with cereal instances for data types defined in fixed 8 | -- vector 9 | module Data.Vector.Fixed.Instances.Cereal where 10 | 11 | import Data.Vector.Fixed (Arity,ArityPeano,ViaFixed(..),Vector) 12 | import qualified Data.Vector.Fixed as F 13 | import qualified Data.Vector.Fixed.Boxed as FB 14 | import qualified Data.Vector.Fixed.Strict as FF 15 | import qualified Data.Vector.Fixed.Unboxed as FU 16 | import qualified Data.Vector.Fixed.Primitive as FP 17 | import qualified Data.Vector.Fixed.Storable as FS 18 | import Data.Serialize (Serialize(..)) 19 | 20 | 21 | instance (Vector v a, Serialize a) => Serialize (ViaFixed v a) where 22 | put = F.mapM_ put 23 | get = F.replicateM get 24 | {-# INLINE put #-} 25 | {-# INLINE get #-} 26 | 27 | deriving via ViaFixed (FB.Vec n) a instance (Arity n, Serialize a) => Serialize (FB.Vec n a) 28 | deriving via ViaFixed (FF.Vec n) a instance (Arity n, Serialize a) => Serialize (FF.Vec n a) 29 | deriving via ViaFixed (FP.Vec n) a instance (Arity n, Serialize a, FP.Prim a) => Serialize (FP.Vec n a) 30 | deriving via ViaFixed (FS.Vec n) a instance (Arity n, Serialize a, FS.Storable a) => Serialize (FS.Vec n a) 31 | deriving via ViaFixed (FU.Vec n) a instance (Arity n, Serialize a, FU.Unbox n a) => Serialize (FU.Vec n a) 32 | 33 | deriving via ViaFixed (F.VecList n) a instance (Arity n, Serialize a) => Serialize (F.VecList n a) 34 | deriving via ViaFixed (F.VecPeano n) a instance (ArityPeano n, Serialize a) => Serialize (F.VecPeano n a) 35 | 36 | instance (Serialize a) => Serialize (F.Only a) where 37 | put (F.Only a) = put a 38 | get = F.Only `fmap` get 39 | 40 | instance Serialize (F.Empty a) where 41 | put _ = return () 42 | get = return F.Empty 43 | -------------------------------------------------------------------------------- /fixed-vector-test/test/TST/Util.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE QuasiQuotes #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | {-# LANGUAGE ViewPatterns #-} 4 | module TST.Util 5 | ( makeTest 6 | -- * Reexports 7 | , TestTree 8 | , Arbitrary 9 | , testGroup 10 | , testProperty 11 | , Proxy(..) 12 | , Typeable 13 | , typeOf 14 | ) where 15 | 16 | import Test.Tasty 17 | import Test.Tasty.QuickCheck 18 | 19 | import Data.Typeable 20 | import qualified Data.Vector.Fixed as F 21 | import qualified Data.Vector.Fixed.Unboxed as FU 22 | import qualified Data.Vector.Fixed.Boxed as FB 23 | import qualified Data.Vector.Fixed.Strict as FF 24 | import qualified Data.Vector.Fixed.Storable as FS 25 | import qualified Data.Vector.Fixed.Primitive as FP 26 | 27 | import Language.Haskell.TH 28 | 29 | 30 | -- | Use template haskell to generate all test cases 31 | makeTest 32 | :: Name -- ^ Name of function for generating tests 33 | -- Its type should be @Proxy v → Proxy a → TestTree@. 34 | -> TypeQ -- ^ Type of element to use 35 | -> ExpQ 36 | makeTest (varE -> test) ty = [| 37 | [ $(test) (Proxy @F.Empty) (Proxy :: Proxy $(ty)) 38 | , $(test) (Proxy @F.Only) (Proxy :: Proxy $(ty)) 39 | -- 40 | , $(test) (Proxy @(F.VecList 0)) (Proxy :: Proxy $(ty)) 41 | , $(test) (Proxy @(F.VecList 1)) (Proxy :: Proxy $(ty)) 42 | , $(test) (Proxy @(F.VecList 2)) (Proxy :: Proxy $(ty)) 43 | , $(test) (Proxy @(F.VecList 3)) (Proxy :: Proxy $(ty)) 44 | -- 45 | , $(test) (Proxy @(FU.Vec 0)) (Proxy :: Proxy $(ty)) 46 | , $(test) (Proxy @(FU.Vec 1)) (Proxy :: Proxy $(ty)) 47 | , $(test) (Proxy @(FU.Vec 2)) (Proxy :: Proxy $(ty)) 48 | , $(test) (Proxy @(FU.Vec 3)) (Proxy :: Proxy $(ty)) 49 | -- 50 | , $(test) (Proxy @(FB.Vec 0)) (Proxy :: Proxy $(ty)) 51 | , $(test) (Proxy @(FB.Vec 1)) (Proxy :: Proxy $(ty)) 52 | , $(test) (Proxy @(FB.Vec 2)) (Proxy :: Proxy $(ty)) 53 | , $(test) (Proxy @(FB.Vec 3)) (Proxy :: Proxy $(ty)) 54 | -- 55 | , $(test) (Proxy @(FF.Vec 0)) (Proxy :: Proxy $(ty)) 56 | , $(test) (Proxy @(FF.Vec 1)) (Proxy :: Proxy $(ty)) 57 | , $(test) (Proxy @(FF.Vec 2)) (Proxy :: Proxy $(ty)) 58 | , $(test) (Proxy @(FF.Vec 3)) (Proxy :: Proxy $(ty)) 59 | -- 60 | , $(test) (Proxy @(FS.Vec 0)) (Proxy :: Proxy $(ty)) 61 | , $(test) (Proxy @(FS.Vec 1)) (Proxy :: Proxy $(ty)) 62 | , $(test) (Proxy @(FS.Vec 2)) (Proxy :: Proxy $(ty)) 63 | , $(test) (Proxy @(FS.Vec 3)) (Proxy :: Proxy $(ty)) 64 | -- 65 | , $(test) (Proxy @(FP.Vec 0)) (Proxy :: Proxy $(ty)) 66 | , $(test) (Proxy @(FP.Vec 1)) (Proxy :: Proxy $(ty)) 67 | , $(test) (Proxy @(FP.Vec 2)) (Proxy :: Proxy $(ty)) 68 | , $(test) (Proxy @(FP.Vec 3)) (Proxy :: Proxy $(ty)) 69 | ] 70 | |] 71 | -------------------------------------------------------------------------------- /fixed-vector/Data/Vector/Fixed/Generic.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- More generic version of function from "Data.Vector.Fixed" 3 | -- module. They do not require that all vector have same type, only 4 | -- same length. All such functions have suffix /G/. 5 | module Data.Vector.Fixed.Generic ( 6 | -- * Mapping 7 | mapG 8 | , imapG 9 | , mapMG 10 | , imapMG 11 | -- * Zips 12 | , zipWithG 13 | , izipWithG 14 | , zipWithMG 15 | , izipWithMG 16 | ) where 17 | 18 | import Control.Monad (liftM) 19 | import Data.Vector.Fixed.Cont (Vector,Dim) 20 | import qualified Data.Vector.Fixed.Cont as C 21 | 22 | 23 | 24 | -- | Map over vector 25 | mapG :: (Vector v a, Vector w b, Dim v ~ Dim w) 26 | => (a -> b) -> v a -> w b 27 | {-# INLINE mapG #-} 28 | mapG f = C.vector 29 | . C.map f 30 | . C.cvec 31 | 32 | -- | Apply function to every element of the vector and its index. 33 | imapG :: (Vector v a, Vector w b, Dim v ~ Dim w) 34 | => (Int -> a -> b) -> v a -> w b 35 | {-# INLINE imapG #-} 36 | imapG f = C.vector 37 | . C.imap f 38 | . C.cvec 39 | 40 | -- | Monadic map over vector. 41 | mapMG :: (Vector v a, Vector w b, Dim w ~ Dim v, Monad m) 42 | => (a -> m b) -> v a -> m (w b) 43 | {-# INLINE mapMG #-} 44 | mapMG f = liftM C.vector 45 | . C.mapM f 46 | . C.cvec 47 | 48 | -- | Monadic map over vector. 49 | imapMG :: (Vector v a, Vector w b, Dim w ~ Dim v, Monad m) 50 | => (Int -> a -> m b) -> v a -> m (w b) 51 | {-# INLINE imapMG #-} 52 | imapMG f = liftM C.vector 53 | . C.imapM f 54 | . C.cvec 55 | 56 | 57 | -- | Zip two vector together using function. 58 | zipWithG :: (Vector v a, Vector w b, Vector u c, Dim v ~ Dim u, Dim v ~ Dim w) 59 | => (a -> b -> c) -> v a -> w b -> u c 60 | {-# INLINE zipWithG #-} 61 | zipWithG f v u = C.vector 62 | $ C.zipWith f (C.cvec v) (C.cvec u) 63 | 64 | -- | Zip two vector together using monadic function. 65 | zipWithMG :: (Vector v a, Vector w b, Vector u c, Dim v ~ Dim u, Dim v ~ Dim w, Monad m) 66 | => (a -> b -> m c) -> v a -> w b -> m (u c) 67 | {-# INLINE zipWithMG #-} 68 | zipWithMG f v u = liftM C.vector 69 | $ C.zipWithM f (C.cvec v) (C.cvec u) 70 | 71 | -- | Zip two vector together using function which takes element index 72 | -- as well. 73 | izipWithG :: (Vector v a, Vector w b, Vector u c, Dim v ~ Dim u, Dim v ~ Dim w) 74 | => (Int -> a -> b -> c) -> v a -> w b -> u c 75 | {-# INLINE izipWithG #-} 76 | izipWithG f v u = C.vector 77 | $ C.izipWith f (C.cvec v) (C.cvec u) 78 | 79 | -- | Zip two vector together using monadic function which takes element 80 | -- index as well.. 81 | izipWithMG :: (Vector v a, Vector w b, Vector u c, Dim v ~ Dim u, Dim v ~ Dim w, Monad m) 82 | => (Int -> a -> b -> m c) -> v a -> w b -> m (u c) 83 | {-# INLINE izipWithMG #-} 84 | izipWithMG f v u = liftM C.vector 85 | $ C.izipWithM f (C.cvec v) (C.cvec u) 86 | -------------------------------------------------------------------------------- /.github/workflows/ci.yml: -------------------------------------------------------------------------------- 1 | name: CI 2 | 3 | # Trigger the workflow on push or pull request, but only for the master branch 4 | on: 5 | pull_request: 6 | push: 7 | branches: [master] 8 | 9 | defaults: 10 | run: 11 | shell: bash 12 | 13 | # Cancel running actions when a new action on the same PR is started 14 | concurrency: 15 | group: ${{ github.workflow }}-${{ github.event.pull_request.number || github.ref }} 16 | cancel-in-progress: true 17 | 18 | jobs: 19 | cabal: 20 | name: ${{ matrix.os }} / ghc ${{ matrix.ghc }} 21 | runs-on: ${{ matrix.os }} 22 | strategy: 23 | matrix: 24 | include: 25 | # Linux 26 | - { cabal: "3.14", os: ubuntu-latest, ghc: "8.10.7" } 27 | - { cabal: "3.14", os: ubuntu-latest, ghc: "9.0.1" } 28 | - { cabal: "3.14", os: ubuntu-latest, ghc: "9.2.8" } 29 | - { cabal: "3.14", os: ubuntu-latest, ghc: "9.4.8" } 30 | - { cabal: "3.14", os: ubuntu-latest, ghc: "9.6.7" } 31 | - { cabal: "3.14", os: ubuntu-latest, ghc: "9.8.2" } 32 | - { cabal: "3.14", os: ubuntu-latest, ghc: "9.10.2" } 33 | - { cabal: "3.14", os: ubuntu-latest, ghc: "9.12.2" } 34 | fail-fast: false 35 | 36 | steps: 37 | # ---------------- 38 | - name: "Dummy" 39 | run: | 40 | echo M1 ${{ matrix.ghc }} 41 | echo M2 ${{ matrix.skip-bench }} 42 | # ---------------- 43 | - uses: actions/checkout@v4 44 | # ---------------- 45 | - uses: haskell-actions/setup@v2 46 | id: setup-haskell-cabal 47 | name: Setup Haskell 48 | with: 49 | ghc-version: ${{ matrix.ghc }} 50 | cabal-version: ${{ matrix.cabal }} 51 | # ---------------- 52 | - uses: actions/cache@v3 53 | name: Cache ~/.cabal/store 54 | with: 55 | path: ${{ steps.setup-haskell-cabal.outputs.cabal-store }} 56 | key: ${{ runner.os }}-${{ matrix.ghc }}--${{ github.Shah }} 57 | # ---------------- 58 | - name: Versions 59 | run: | 60 | cabal -V 61 | ghc -V 62 | # ---------------- 63 | - name: Make sdist 64 | run: | 65 | mkdir sdist 66 | for nm in fixed-vector*; do cabal sdist $nm -o sdist; done 67 | - name: Unpack 68 | run: | 69 | mkdir unpacked 70 | for nm in sdist/*; do tar -C unpacked -xf $nm; done 71 | cd unpacked 72 | echo "packages: */*.cabal" > cabal.project 73 | echo "tests: true" >> cabal.project 74 | # ---------------- 75 | - name: cabal check 76 | run: | 77 | for nm in fixed-vector-*; do (cd $nm; cabal check); done 78 | # ---------------- 79 | - name: Build 80 | run: | 81 | set -x 82 | if [ "${{ matrix.skip-test }}" == "" ]; then FLAG_TEST=--enable-test; fi 83 | if [ "${{ matrix.skip-bench }}" == "" ]; then FLAG_BENCH=--enable-benchmarks; fi 84 | cabal configure $FLAG_TEST $FLAG_BENCH 85 | cabal build all --write-ghc-environment-files=always 86 | # ---------------- 87 | - name: Test 88 | run: | 89 | cabal test all 90 | -------------------------------------------------------------------------------- /fixed-vector-cborg/Data/Vector/Fixed/Instances/CBOR.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DerivingVia #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE MagicHash #-} 4 | {-# LANGUAGE ScopedTypeVariables #-} 5 | {-# LANGUAGE StandaloneDeriving #-} 6 | {-# LANGUAGE TypeApplications #-} 7 | {-# LANGUAGE TypeFamilies #-} 8 | {-# LANGUAGE UndecidableInstances #-} 9 | {-# OPTIONS_GHC -fno-warn-orphans #-} 10 | -- | Module with binary instances for data types defined in fixed 11 | -- vector 12 | module Data.Vector.Fixed.Instances.CBOR where 13 | 14 | import Codec.Serialise 15 | import Codec.CBOR.Encoding (Encoding,encodeListLen,encodeNull) 16 | import Codec.CBOR.Decoding (Decoder,decodeListLenOf,decodeNull) 17 | import GHC.Exts (proxy#) 18 | 19 | import Data.Vector.Fixed (Arity,ArityPeano,Vector,ViaFixed) 20 | import qualified Data.Vector.Fixed as F 21 | import Data.Vector.Fixed.Cont (peanoToInt,Dim) 22 | import qualified Data.Vector.Fixed.Boxed as FB 23 | import qualified Data.Vector.Fixed.Strict as FF 24 | import qualified Data.Vector.Fixed.Unboxed as FU 25 | import qualified Data.Vector.Fixed.Primitive as FP 26 | import qualified Data.Vector.Fixed.Storable as FS 27 | 28 | 29 | instance (Vector v a, Serialise a) => Serialise (ViaFixed v a) where 30 | encode = encodeFixedVector 31 | decode = decodeFixedVector 32 | {-# INLINE encode #-} 33 | {-# INLINE decode #-} 34 | 35 | deriving via ViaFixed (FB.Vec n) a instance (Arity n, Serialise a) => Serialise (FB.Vec n a) 36 | deriving via ViaFixed (FF.Vec n) a instance (Arity n, Serialise a) => Serialise (FF.Vec n a) 37 | deriving via ViaFixed (FP.Vec n) a instance (Arity n, Serialise a, FP.Prim a) => Serialise (FP.Vec n a) 38 | deriving via ViaFixed (FS.Vec n) a instance (Arity n, Serialise a, FS.Storable a) => Serialise (FS.Vec n a) 39 | deriving via ViaFixed (FU.Vec n) a instance (Arity n, Serialise a, FU.Unbox n a) => Serialise (FU.Vec n a) 40 | 41 | deriving via ViaFixed (F.VecList n) a instance (Arity n, Serialise a) => Serialise (F.VecList n a) 42 | deriving via ViaFixed (F.VecPeano n) a instance (ArityPeano n, Serialise a) => Serialise (F.VecPeano n a) 43 | 44 | deriving via ViaFixed F.Only a instance (Serialise a) => Serialise (F.Only a) 45 | 46 | instance Serialise (F.Empty a) where 47 | encode = const encodeNull 48 | decode = F.Empty <$ decodeNull 49 | 50 | -- | Encode vector with statically known size as CBOR list. There's no 51 | -- type tag 52 | encodeFixedVector :: (F.Vector v a, Serialise a) => v a -> Encoding 53 | {-# INLINE encodeFixedVector #-} 54 | encodeFixedVector v = encodeListLen (fromIntegral $ F.length v) 55 | <> F.foldMap encode v 56 | 57 | -- | Decode vector with statically known size as CBOR list. There's no 58 | -- type tag 59 | decodeFixedVector :: forall v s a. (F.Vector v a, Serialise a) => Decoder s (v a) 60 | {-# INLINE decodeFixedVector #-} 61 | decodeFixedVector = do 62 | decodeListLenOf (fromIntegral $ peanoToInt (proxy# @(Dim v))) 63 | F.replicateM decode 64 | -------------------------------------------------------------------------------- /fixed-vector/test/inspect.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | {-# OPTIONS_GHC -fplugin=Test.Tasty.Inspection.Plugin #-} 3 | {-# OPTIONS_GHC -dsuppress-idinfo #-} 4 | module Main where 5 | 6 | import Test.Tasty 7 | import Test.Tasty.Inspection 8 | 9 | import Data.Vector.Fixed qualified as F 10 | import Data.Vector.Fixed.Unboxed qualified as FU 11 | import Data.Vector.Fixed.Boxed qualified as FB 12 | import Data.Vector.Fixed.Primitive qualified as FP 13 | 14 | import Inspect.Obligations 15 | 16 | 17 | 18 | simple_fusion_FU :: Int -> Int 19 | simple_fusion_FU n = F.sum $ F.generate @FU.Vec3 (*n) 20 | 21 | simple_fusion_FB :: Int -> Int 22 | simple_fusion_FB n = F.sum $ F.generate @FB.Vec3 (*n) 23 | 24 | simple_fusion_FP :: Int -> Int 25 | simple_fusion_FP n = F.sum $ F.generate @FP.Vec3 (*n) 26 | 27 | fuse_mapM_ :: IO () 28 | fuse_mapM_ = F.mapM_ print (F.mk3 1 2 3 :: FU.Vec3 Double) 29 | 30 | fuse_zipWith :: Int -> Int 31 | fuse_zipWith n = F.sum $ F.zipWith (*) v u 32 | where v,u :: FU.Vec3 Int 33 | v = F.generate (*2) 34 | u = F.replicate n 35 | 36 | fuse_zipWith_self :: Int -> Int 37 | fuse_zipWith_self n = F.sum $ F.zipWith (*) u u 38 | where u :: FU.Vec3 Int 39 | u = F.replicate n 40 | 41 | -- More involved example with zipWith. It stresses optimizer and could be 42 | -- used as a benchmark for optimization of compilation speed. 43 | fuse_zipWithParam :: FP.Vec 3 Int -> FP.Vec 3 Int -> FP.Vec 3 Int -> Int 44 | fuse_zipWithParam v1 v2 v3 = F.sum v12 + F.sum v13 + F.sum v23 where 45 | v12 = F.zipWith (*) v1 v2 46 | v13 = F.zipWith (*) v1 v3 47 | v23 = F.zipWith (*) v2 v3 48 | 49 | simple_foldl1 :: FP.Vec 4 Int -> Int 50 | simple_foldl1 = F.foldl1 (+) . F.map (\n -> n*n) 51 | 52 | 53 | ---------------------------------------------------------------- 54 | -- Tests 55 | ---------------------------------------------------------------- 56 | 57 | main :: IO () 58 | main = defaultMain $ testGroup "inspect" 59 | [ $(inspectObligations [ hasNoTypeClasses 60 | , noArrayAlloc 61 | ] 'simple_fusion_FU) 62 | , $(inspectObligations [ hasNoTypeClasses 63 | , noArrayAlloc 64 | ] 'simple_fusion_FB) 65 | , $(inspectObligations [ hasNoTypeClasses 66 | , noArrayAlloc 67 | ] 'simple_fusion_FP) 68 | , $(inspectObligations [ hasNoTypeClasses 69 | , noArrayAlloc 70 | ] 'fuse_mapM_) 71 | , testGroup "zipWith" 72 | -- NOTE: zipWith uses lists internally but they should get 73 | -- optimized away. Thus check that lists don't occur in core 74 | [ $(inspectObligations [ hasNoTypeClasses 75 | , flip hasNoType ''[] 76 | , noArrayAlloc 77 | ] 'fuse_zipWith) 78 | , $(inspectObligations [ hasNoTypeClasses 79 | , flip hasNoType ''[] 80 | -- FIXME: Does not fuse when used nonlinearly 81 | -- , noArrayAlloc 82 | ] 'fuse_zipWith_self) 83 | , $(inspectObligations [ hasNoTypeClasses 84 | , flip hasNoType ''[] 85 | , noArrayAlloc 86 | ] 'fuse_zipWithParam) 87 | , $(inspectObligations [ hasNoTypeClasses 88 | , noArrayAlloc 89 | ] 'simple_foldl1) 90 | ] 91 | ] 92 | -------------------------------------------------------------------------------- /fixed-vector/Data/Vector/Fixed/Primitive.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MagicHash #-} 2 | {-# LANGUAGE UndecidableInstances #-} 3 | -- | 4 | -- Unboxed vectors with fixed length. Vectors from 5 | -- "Data.Vector.Fixed.Unboxed" provide more flexibility at no 6 | -- performeance cost. 7 | module Data.Vector.Fixed.Primitive ( 8 | -- * Immutable 9 | Vec 10 | , Vec1 11 | , Vec2 12 | , Vec3 13 | , Vec4 14 | , Vec5 15 | -- * Mutable 16 | , MVec 17 | -- * Type classes 18 | , Prim 19 | ) where 20 | 21 | import Control.Monad 22 | import Control.DeepSeq (NFData(..)) 23 | import Data.Data 24 | import Data.Monoid (Monoid(..)) 25 | import Data.Semigroup (Semigroup(..)) 26 | import Data.Primitive.ByteArray 27 | import Data.Primitive 28 | import Data.Kind (Type) 29 | import Foreign.Storable (Storable) 30 | import GHC.TypeLits 31 | import GHC.Exts (proxy#) 32 | import Prelude (Show(..),Eq(..),Ord(..),Num(..)) 33 | import Prelude (($),($!),undefined,seq,(<$>)) 34 | 35 | 36 | import Data.Vector.Fixed hiding (index) 37 | import Data.Vector.Fixed.Mutable (Mutable, MVector(..), IVector(..), DimM, constructVec, inspectVec, index) 38 | import qualified Data.Vector.Fixed.Cont as C 39 | import Data.Vector.Fixed.Cont (ArityPeano(..)) 40 | 41 | 42 | ---------------------------------------------------------------- 43 | -- Data type 44 | ---------------------------------------------------------------- 45 | 46 | -- | Unboxed vector with fixed length 47 | newtype Vec (n :: Nat) (a :: Type) = Vec ByteArray 48 | 49 | -- | Mutable unboxed vector with fixed length 50 | newtype MVec (n :: Nat) s a = MVec (MutableByteArray s) 51 | 52 | type Vec1 = Vec 1 53 | type Vec2 = Vec 2 54 | type Vec3 = Vec 3 55 | type Vec4 = Vec 4 56 | type Vec5 = Vec 5 57 | 58 | type instance Mutable (Vec n) = MVec n 59 | type instance Dim (Vec n) = Peano n 60 | type instance DimM (MVec n) = Peano n 61 | 62 | 63 | ---------------------------------------------------------------- 64 | -- Instances 65 | ---------------------------------------------------------------- 66 | 67 | instance (Arity n, Prim a, NFData a) => NFData (Vec n a) where 68 | rnf x = seq x () 69 | 70 | deriving via ViaFixed (Vec n) a instance (Arity n, Prim a, Show a) => Show (Vec n a) 71 | deriving via ViaFixed (Vec n) a instance (Arity n, Prim a, Eq a) => Eq (Vec n a) 72 | deriving via ViaFixed (Vec n) a instance (Arity n, Prim a, Ord a) => Ord (Vec n a) 73 | deriving via ViaFixed (Vec n) a instance (Arity n, Prim a, Semigroup a) => Semigroup (Vec n a) 74 | deriving via ViaFixed (Vec n) a instance (Arity n, Prim a, Monoid a) => Monoid (Vec n a) 75 | deriving via ViaFixed (Vec n) a instance (Arity n, Prim a, Storable a) => Storable (Vec n a) 76 | 77 | instance (Arity n, Prim a) => MVector (MVec n) a where 78 | basicNew = do 79 | v <- newByteArray $! peanoToInt (proxy# @(Peano n)) 80 | * sizeOf (undefined :: a) 81 | return $ MVec v 82 | {-# INLINE basicNew #-} 83 | basicCopy (MVec dst) (MVec src) = copyMutableByteArray dst 0 src 0 (peanoToInt (proxy# @(Peano n))) 84 | {-# INLINE basicCopy #-} 85 | basicUnsafeRead (MVec v) i = readByteArray v i 86 | {-# INLINE basicUnsafeRead #-} 87 | basicUnsafeWrite (MVec v) i x = writeByteArray v i x 88 | {-# INLINE basicUnsafeWrite #-} 89 | 90 | instance (Arity n, Prim a) => IVector (Vec n) a where 91 | basicUnsafeFreeze (MVec v) = do { a <- unsafeFreezeByteArray v; return $! Vec a } 92 | basicThaw (Vec v) = MVec <$> thawByteArray v 0 (peanoToInt (proxy# @(Peano n))) 93 | unsafeIndex (Vec v) i = indexByteArray v i 94 | {-# INLINE basicUnsafeFreeze #-} 95 | {-# INLINE basicThaw #-} 96 | {-# INLINE unsafeIndex #-} 97 | 98 | instance (Arity n, Prim a) => Vector (Vec n) a where 99 | construct = constructVec 100 | inspect = inspectVec 101 | basicIndex = index 102 | {-# INLINE construct #-} 103 | {-# INLINE inspect #-} 104 | {-# INLINE basicIndex #-} 105 | 106 | instance (Typeable n, Arity n, Prim a, Data a) => Data (Vec n a) where 107 | gfoldl = C.gfoldl 108 | gunfold = C.gunfold 109 | toConstr _ = con_Vec 110 | dataTypeOf _ = ty_Vec 111 | 112 | ty_Vec :: DataType 113 | ty_Vec = mkDataType "Data.Vector.Fixed.Primitive.Vec" [con_Vec] 114 | 115 | con_Vec :: Constr 116 | con_Vec = mkConstr ty_Vec "Vec" [] Prefix 117 | -------------------------------------------------------------------------------- /fixed-vector/Data/Vector/Fixed/Strict.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MagicHash #-} 2 | {-# LANGUAGE UndecidableInstances #-} 3 | -- | 4 | -- Strict boxed vector which could hold any value. For lazy variant see 5 | -- "Data.Vector.Fixed.Boxed". 6 | module Data.Vector.Fixed.Strict where 7 | 8 | import Control.Applicative (Applicative(..)) 9 | import Control.DeepSeq (NFData(..)) 10 | import Data.Primitive.SmallArray 11 | import Data.Monoid (Monoid(..)) 12 | import Data.Semigroup (Semigroup(..)) 13 | import Data.Data 14 | import qualified Data.Foldable as F 15 | import qualified Data.Traversable as T 16 | import Foreign.Storable (Storable(..)) 17 | import GHC.TypeLits 18 | import GHC.Exts (proxy#) 19 | import Prelude ( Show(..),Eq(..),Ord(..),Functor(..),Monad(..) 20 | , ($!),error,(<$>)) 21 | 22 | import Data.Vector.Fixed hiding (index) 23 | import Data.Vector.Fixed.Mutable (Mutable, MVector(..), IVector(..), DimM, constructVec, inspectVec, index) 24 | import qualified Data.Vector.Fixed.Cont as C 25 | import Data.Vector.Fixed.Cont (ArityPeano(..)) 26 | 27 | 28 | ---------------------------------------------------------------- 29 | -- Data type 30 | ---------------------------------------------------------------- 31 | 32 | -- | Vector with fixed length which can hold any value. It's strict 33 | -- and ensures that elements are evaluated to WHNF. 34 | newtype Vec (n :: Nat) a = Vec (SmallArray a) 35 | 36 | -- | Mutable unboxed vector with fixed length 37 | newtype MVec (n :: Nat) s a = MVec (SmallMutableArray s a) 38 | 39 | type Vec1 = Vec 1 40 | type Vec2 = Vec 2 41 | type Vec3 = Vec 3 42 | type Vec4 = Vec 4 43 | type Vec5 = Vec 5 44 | 45 | type instance Mutable (Vec n) = MVec n 46 | type instance Dim (Vec n) = Peano n 47 | type instance DimM (MVec n) = Peano n 48 | 49 | 50 | ---------------------------------------------------------------- 51 | -- Instances 52 | ---------------------------------------------------------------- 53 | 54 | deriving via ViaFixed (Vec n) instance Arity n => Functor (Vec n) 55 | deriving via ViaFixed (Vec n) instance Arity n => Applicative (Vec n) 56 | deriving via ViaFixed (Vec n) instance Arity n => F.Foldable (Vec n) 57 | 58 | instance Arity n => T.Traversable (Vec n) where 59 | sequence = sequence 60 | sequenceA = sequence 61 | traverse = mapM 62 | mapM = mapM 63 | {-# INLINE sequence #-} 64 | {-# INLINE sequenceA #-} 65 | {-# INLINE mapM #-} 66 | {-# INLINE traverse #-} 67 | 68 | deriving via ViaFixed (Vec n) a instance (Arity n, Show a) => Show (Vec n a) 69 | deriving via ViaFixed (Vec n) a instance (Arity n, Eq a) => Eq (Vec n a) 70 | deriving via ViaFixed (Vec n) a instance (Arity n, Ord a) => Ord (Vec n a) 71 | deriving via ViaFixed (Vec n) a instance (Arity n, NFData a) => NFData (Vec n a) 72 | deriving via ViaFixed (Vec n) a instance (Arity n, Semigroup a) => Semigroup (Vec n a) 73 | deriving via ViaFixed (Vec n) a instance (Arity n, Monoid a) => Monoid (Vec n a) 74 | deriving via ViaFixed (Vec n) a instance (Arity n, Storable a) => Storable (Vec n a) 75 | 76 | instance (Arity n) => MVector (MVec n) a where 77 | basicNew = 78 | MVec <$> newSmallArray (peanoToInt (proxy# @(Peano n))) uninitialised 79 | basicReplicate a = 80 | MVec <$> newSmallArray (peanoToInt (proxy# @(Peano n))) a 81 | basicCopy (MVec dst) (MVec src) = 82 | copySmallMutableArray dst 0 src 0 (peanoToInt (proxy# @(Peano n))) 83 | basicClone (MVec src) = 84 | MVec <$> cloneSmallMutableArray src 0 (peanoToInt (proxy# @(Peano n))) 85 | basicUnsafeRead (MVec v) i = readSmallArray v i 86 | basicUnsafeWrite (MVec v) i !x = writeSmallArray v i x 87 | {-# INLINE basicNew #-} 88 | {-# INLINE basicReplicate #-} 89 | {-# INLINE basicCopy #-} 90 | {-# INLINE basicClone #-} 91 | {-# INLINE basicUnsafeRead #-} 92 | {-# INLINE basicUnsafeWrite #-} 93 | 94 | instance (Arity n) => IVector (Vec n) a where 95 | basicUnsafeFreeze (MVec v) = do { a <- unsafeFreezeSmallArray v; return $! Vec a } 96 | basicThaw (Vec v) = 97 | MVec <$> thawSmallArray v 0 (peanoToInt (proxy# @(Peano n))) 98 | unsafeIndex (Vec v) i = indexSmallArray v i 99 | {-# INLINE basicUnsafeFreeze #-} 100 | {-# INLINE basicThaw #-} 101 | {-# INLINE unsafeIndex #-} 102 | 103 | instance (Arity n) => Vector (Vec n) a where 104 | construct = constructVec 105 | inspect = inspectVec 106 | basicIndex = index 107 | {-# INLINE construct #-} 108 | {-# INLINE inspect #-} 109 | {-# INLINE basicIndex #-} 110 | 111 | instance (Typeable n, Arity n, Data a) => Data (Vec n a) where 112 | gfoldl = C.gfoldl 113 | gunfold = C.gunfold 114 | toConstr _ = con_Vec 115 | dataTypeOf _ = ty_Vec 116 | 117 | ty_Vec :: DataType 118 | ty_Vec = mkDataType "Data.Vector.Fixed.Strict.Vec" [con_Vec] 119 | 120 | con_Vec :: Constr 121 | con_Vec = mkConstr ty_Vec "Vec" [] Prefix 122 | 123 | uninitialised :: a 124 | uninitialised = error "Data.Vector.Fixed.Strict: uninitialised element" 125 | -------------------------------------------------------------------------------- /fixed-vector/fixed-vector.cabal: -------------------------------------------------------------------------------- 1 | Cabal-Version: 3.0 2 | Build-Type: Simple 3 | 4 | Name: fixed-vector 5 | Version: 2.0.0.0 6 | Synopsis: Generic vectors with statically known size. 7 | Description: 8 | Generic library for vectors with statically known 9 | size. Implementation is based on 10 | 11 | Same functions could be used to work with both ADT based vector like 12 | . 13 | > data Vec3 a = a a a 14 | . 15 | Tuples are vectors too: 16 | . 17 | >>> sum (1,2,3) 18 | 6 19 | . 20 | Vectors which are represented internally by arrays are provided by 21 | library. Both boxed and unboxed arrays are supported. 22 | . 23 | Library is structured as follows: 24 | . 25 | * Data.Vector.Fixed 26 | Generic API. It's suitable for both ADT-based vector like Complex 27 | and array-based ones. 28 | . 29 | * Data.Vector.Fixed.Cont 30 | Continuation based vectors. Internally all functions use them. 31 | . 32 | * Data.Vector.Fixed.Mutable 33 | Type classes for array-based implementation and API for working with 34 | mutable state. 35 | . 36 | * Data.Vector.Fixed.Unboxed 37 | Unboxed vectors. 38 | . 39 | * Data.Vector.Fixed.Boxed 40 | Boxed vector which can hold elements of any type. 41 | . 42 | * Data.Vector.Fixed.Storable 43 | Unboxed vectors of Storable types. 44 | . 45 | * Data.Vector.Fixed.Primitive 46 | Unboxed vectors based on pritimive package. 47 | 48 | License: BSD-3-Clause 49 | License-File: LICENSE 50 | Author: Aleksey Khudyakov 51 | Maintainer: Aleksey Khudyakov 52 | Bug-reports: https://github.com/Shimuuar/fixed-vector/issues 53 | Category: Data 54 | extra-doc-files: 55 | ChangeLog.md 56 | 57 | tested-with: 58 | GHC ==8.10.7 59 | || ==9.0.1 60 | || ==9.2.8 61 | || ==9.4.7 62 | || ==9.6.6 63 | || ==9.8.2 64 | || ==9.10.1 65 | 66 | source-repository head 67 | type: git 68 | location: http://github.com/Shimuuar/fixed-vector 69 | 70 | common language 71 | Ghc-options: -Wall -Wno-incomplete-uni-patterns 72 | Default-Language: Haskell2010 73 | Default-Extensions: 74 | -- GHC2021 sans PolyKinds 75 | BangPatterns 76 | ConstraintKinds 77 | DataKinds 78 | DeriveDataTypeable 79 | DeriveFoldable 80 | DeriveFunctor 81 | DeriveGeneric 82 | DeriveLift 83 | DeriveTraversable 84 | DerivingStrategies 85 | DisambiguateRecordFields 86 | DoAndIfThenElse 87 | EmptyCase 88 | EmptyDataDecls 89 | EmptyDataDeriving 90 | ExistentialQuantification 91 | ExplicitNamespaces 92 | FlexibleContexts 93 | FlexibleInstances 94 | ForeignFunctionInterface 95 | GADTs 96 | GADTSyntax 97 | GeneralisedNewtypeDeriving 98 | ImplicitPrelude 99 | ImportQualifiedPost 100 | InstanceSigs 101 | KindSignatures 102 | LambdaCase 103 | MonoLocalBinds 104 | MonomorphismRestriction 105 | MultiParamTypeClasses 106 | NamedFieldPuns 107 | NamedWildCards 108 | NumericUnderscores 109 | PatternGuards 110 | PostfixOperators 111 | RankNTypes 112 | RelaxedPolyRec 113 | RoleAnnotations 114 | ScopedTypeVariables 115 | StandaloneDeriving 116 | StandaloneKindSignatures 117 | TupleSections 118 | TypeApplications 119 | TypeOperators 120 | TypeSynonymInstances 121 | -- 122 | DerivingVia 123 | PatternSynonyms 124 | ViewPatterns 125 | TypeFamilies 126 | 127 | 128 | Library 129 | import: language 130 | Build-Depends: base >=4.14 && <5 131 | , primitive >=0.6.2 132 | , deepseq 133 | Exposed-modules: 134 | -- API 135 | Data.Vector.Fixed.Cont 136 | Data.Vector.Fixed 137 | Data.Vector.Fixed.Generic 138 | -- Arrays 139 | Data.Vector.Fixed.Mutable 140 | Data.Vector.Fixed.Boxed 141 | Data.Vector.Fixed.Strict 142 | Data.Vector.Fixed.Primitive 143 | Data.Vector.Fixed.Unboxed 144 | Data.Vector.Fixed.Storable 145 | Other-modules: 146 | Data.Vector.Fixed.Internal 147 | 148 | Test-Suite fixed-vector-doctests 149 | Default-Language: Haskell2010 150 | if impl(ghc < 9.2) 151 | buildable: False 152 | Type: exitcode-stdio-1.0 153 | Hs-source-dirs: test 154 | Main-is: Doctests.hs 155 | Build-Depends: base >=4.14 && <5 156 | , primitive >=0.6.2 157 | -- Additional test dependencies. 158 | , doctest >= 0.18 159 | , filemanip == 0.3.6.* 160 | 161 | Test-Suite fixed-vector-inspect 162 | import: language 163 | Type: exitcode-stdio-1.0 164 | Hs-source-dirs: test 165 | Main-is: inspect.hs 166 | Other-modules: Inspect.Obligations 167 | Build-Depends: base >=4.8 && <5 168 | , template-haskell 169 | , fixed-vector 170 | , tasty >= 1.2 171 | , tasty-inspection-testing >= 0.1 172 | -------------------------------------------------------------------------------- /fixed-vector/Data/Vector/Fixed/Boxed.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MagicHash #-} 2 | {-# LANGUAGE UndecidableInstances #-} 3 | -- | 4 | -- Lazy vector which could hold any value. For strict variant see 5 | -- "Data.Vector.Fixed.Strict". 6 | module Data.Vector.Fixed.Boxed ( 7 | -- * Immutable 8 | Vec 9 | , Vec1 10 | , Vec2 11 | , Vec3 12 | , Vec4 13 | , Vec5 14 | -- * Mutable 15 | , MVec 16 | ) where 17 | 18 | import Control.Applicative (Applicative(..)) 19 | import Control.DeepSeq (NFData(..)) 20 | import Data.Primitive.SmallArray 21 | import Data.Monoid (Monoid(..)) 22 | import Data.Semigroup (Semigroup(..)) 23 | import Data.Data 24 | import qualified Data.Foldable as F 25 | import qualified Data.Traversable as T 26 | import Foreign.Storable (Storable(..)) 27 | import GHC.TypeLits 28 | import GHC.Exts (proxy#) 29 | import Prelude ( Show(..),Eq(..),Ord(..),Functor(..),Monad(..) 30 | , ($!),error,(<$>)) 31 | 32 | import Data.Vector.Fixed hiding (index) 33 | import Data.Vector.Fixed.Mutable (Mutable, MVector(..), IVector(..), DimM, constructVec, inspectVec, index) 34 | import qualified Data.Vector.Fixed.Cont as C 35 | import Data.Vector.Fixed.Cont (ArityPeano(..)) 36 | 37 | 38 | ---------------------------------------------------------------- 39 | -- Data type 40 | ---------------------------------------------------------------- 41 | 42 | -- | Vector with fixed length which can hold any value. It's lazy and 43 | -- doesn't evaluate elements. 44 | newtype Vec (n :: Nat) a = Vec (SmallArray a) 45 | 46 | -- | Mutable unboxed vector with fixed length 47 | newtype MVec (n :: Nat) s a = MVec (SmallMutableArray s a) 48 | 49 | type Vec1 = Vec 1 50 | type Vec2 = Vec 2 51 | type Vec3 = Vec 3 52 | type Vec4 = Vec 4 53 | type Vec5 = Vec 5 54 | 55 | type instance Mutable (Vec n) = MVec n 56 | type instance Dim (Vec n) = Peano n 57 | type instance DimM (MVec n) = Peano n 58 | 59 | 60 | ---------------------------------------------------------------- 61 | -- Instances 62 | ---------------------------------------------------------------- 63 | 64 | deriving via ViaFixed (Vec n) instance Arity n => Functor (Vec n) 65 | deriving via ViaFixed (Vec n) instance Arity n => Applicative (Vec n) 66 | deriving via ViaFixed (Vec n) instance Arity n => F.Foldable (Vec n) 67 | 68 | instance Arity n => T.Traversable (Vec n) where 69 | sequence = sequence 70 | sequenceA = sequence 71 | traverse = mapM 72 | mapM = mapM 73 | {-# INLINE sequence #-} 74 | {-# INLINE sequenceA #-} 75 | {-# INLINE mapM #-} 76 | {-# INLINE traverse #-} 77 | 78 | deriving via ViaFixed (Vec n) a instance (Arity n, Show a) => Show (Vec n a) 79 | deriving via ViaFixed (Vec n) a instance (Arity n, Eq a) => Eq (Vec n a) 80 | deriving via ViaFixed (Vec n) a instance (Arity n, Ord a) => Ord (Vec n a) 81 | deriving via ViaFixed (Vec n) a instance (Arity n, NFData a) => NFData (Vec n a) 82 | deriving via ViaFixed (Vec n) a instance (Arity n, Semigroup a) => Semigroup (Vec n a) 83 | deriving via ViaFixed (Vec n) a instance (Arity n, Monoid a) => Monoid (Vec n a) 84 | deriving via ViaFixed (Vec n) a instance (Arity n, Storable a) => Storable (Vec n a) 85 | 86 | instance (Arity n) => MVector (MVec n) a where 87 | basicNew = 88 | MVec <$> newSmallArray (peanoToInt (proxy# @(Peano n))) uninitialised 89 | basicReplicate a = 90 | MVec <$> newSmallArray (peanoToInt (proxy# @(Peano n))) a 91 | basicCopy (MVec dst) (MVec src) = 92 | copySmallMutableArray dst 0 src 0 (peanoToInt (proxy# @(Peano n))) 93 | basicClone (MVec src) = 94 | MVec <$> cloneSmallMutableArray src 0 (peanoToInt (proxy# @(Peano n))) 95 | basicUnsafeRead (MVec v) i = readSmallArray v i 96 | basicUnsafeWrite (MVec v) i x = writeSmallArray v i x 97 | {-# INLINE basicNew #-} 98 | {-# INLINE basicReplicate #-} 99 | {-# INLINE basicCopy #-} 100 | {-# INLINE basicClone #-} 101 | {-# INLINE basicUnsafeRead #-} 102 | {-# INLINE basicUnsafeWrite #-} 103 | 104 | instance (Arity n) => IVector (Vec n) a where 105 | basicUnsafeFreeze (MVec v) = do { a <- unsafeFreezeSmallArray v; return $! Vec a } 106 | basicThaw (Vec v) = 107 | MVec <$> thawSmallArray v 0 (peanoToInt (proxy# @(Peano n))) 108 | unsafeIndex (Vec v) i = indexSmallArray v i 109 | {-# INLINE basicUnsafeFreeze #-} 110 | {-# INLINE basicThaw #-} 111 | {-# INLINE unsafeIndex #-} 112 | 113 | instance (Arity n) => Vector (Vec n) a where 114 | construct = constructVec 115 | inspect = inspectVec 116 | basicIndex = index 117 | {-# INLINE construct #-} 118 | {-# INLINE inspect #-} 119 | {-# INLINE basicIndex #-} 120 | 121 | instance (Typeable n, Arity n, Data a) => Data (Vec n a) where 122 | gfoldl = C.gfoldl 123 | gunfold = C.gunfold 124 | toConstr _ = con_Vec 125 | dataTypeOf _ = ty_Vec 126 | 127 | ty_Vec :: DataType 128 | ty_Vec = mkDataType "Data.Vector.Fixed.Boxed.Vec" [con_Vec] 129 | 130 | con_Vec :: Constr 131 | con_Vec = mkConstr ty_Vec "Vec" [] Prefix 132 | 133 | uninitialised :: a 134 | uninitialised = error "Data.Vector.Fixed.Boxed: uninitialised element" 135 | -------------------------------------------------------------------------------- /fixed-vector-aeson/Data/Vector/Fixed/Instances/Aeson.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DerivingVia #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | {-# LANGUAGE StandaloneDeriving #-} 5 | {-# LANGUAGE TypeFamilies #-} 6 | {-# LANGUAGE UndecidableInstances #-} 7 | {-# OPTIONS_GHC -fno-warn-orphans #-} 8 | -- | Module with @aeson@ instances for data types defined in fixed 9 | -- vector 10 | module Data.Vector.Fixed.Instances.Aeson 11 | ( fixedVectorParseJSON 12 | , fixedVectorToJSON 13 | , fixedVectorToEncoding 14 | ) where 15 | 16 | import Control.Monad 17 | import Control.Monad.ST 18 | import Data.Vector.Fixed (Arity,ArityPeano,ViaFixed(..),Vector) 19 | import qualified Data.Vector.Fixed as F 20 | import qualified Data.Vector.Fixed.Boxed as FB 21 | import qualified Data.Vector.Fixed.Strict as FF 22 | import qualified Data.Vector.Fixed.Unboxed as FU 23 | import qualified Data.Vector.Fixed.Primitive as FP 24 | import qualified Data.Vector.Fixed.Storable as FS 25 | import Data.Aeson 26 | import Data.Aeson.Types 27 | 28 | import qualified Data.Vector as V 29 | import qualified Data.Vector.Mutable as MV 30 | 31 | 32 | ---------------------------------------------------------------- 33 | -- Generic implementations 34 | ---------------------------------------------------------------- 35 | 36 | -- | Generic implementation of 'parseJSON' for data types which are 37 | -- instances of 'Vector'. 38 | fixedVectorParseJSON :: forall v a. (Vector v a, FromJSON a) => Value -> Parser (v a) 39 | {-# INLINE fixedVectorParseJSON #-} 40 | fixedVectorParseJSON = withArray "fixed-vector" $ \arr -> do 41 | let expected = F.length (undefined :: v a) 42 | when (V.length arr /= expected) $ 43 | fail $ "Expecting array of length " ++ show expected 44 | F.generateM $ \i -> parseJSON (arr V.! i) 45 | 46 | -- | Generic implementation of 'toJSON' for data types which are 47 | -- instances of 'Vector'. 48 | fixedVectorToJSON :: forall v a. (Vector v a, ToJSON a) => v a -> Value 49 | {-# INLINE fixedVectorToJSON #-} 50 | fixedVectorToJSON v = Array $ runST $ do 51 | -- NOTE: (!) from fixed vector could have O(n) complexity so let 52 | -- fold over fixed vector. Access to vector _is_ O(1) 53 | vec <- MV.unsafeNew n 54 | flip F.imapM_ v $ \i a -> MV.unsafeWrite vec i (toJSON a) 55 | V.unsafeFreeze vec 56 | where 57 | n = F.length v 58 | 59 | -- | Generic implementation of 'toEncoding' for data types which are 60 | -- instances of 'Vector'. 61 | fixedVectorToEncoding :: forall v a. (Vector v a, ToJSON a) => v a -> Encoding 62 | {-# INLINE fixedVectorToEncoding #-} 63 | fixedVectorToEncoding = foldable . F.cvec 64 | 65 | 66 | ---------------------------------------------------------------- 67 | -- Instances 68 | ---------------------------------------------------------------- 69 | 70 | instance (Vector v a, FromJSON a) => FromJSON (ViaFixed v a) where 71 | {-# INLINE parseJSON #-} 72 | parseJSON = fixedVectorParseJSON 73 | 74 | instance (Vector v a, ToJSON a) => ToJSON (ViaFixed v a) where 75 | toJSON = fixedVectorToJSON 76 | toEncoding = fixedVectorToEncoding 77 | {-# INLINE toJSON #-} 78 | {-# INLINE toEncoding #-} 79 | 80 | 81 | 82 | deriving via ViaFixed (FB.Vec n) a instance (Arity n, FromJSON a) => FromJSON (FB.Vec n a) 83 | deriving via ViaFixed (FB.Vec n) a instance (Arity n, ToJSON a) => ToJSON (FB.Vec n a) 84 | deriving via ViaFixed (FF.Vec n) a instance (Arity n, FromJSON a) => FromJSON (FF.Vec n a) 85 | deriving via ViaFixed (FF.Vec n) a instance (Arity n, ToJSON a) => ToJSON (FF.Vec n a) 86 | deriving via ViaFixed (FP.Vec n) a instance (Arity n, FromJSON a, FP.Prim a) => FromJSON (FP.Vec n a) 87 | deriving via ViaFixed (FP.Vec n) a instance (Arity n, ToJSON a, FP.Prim a) => ToJSON (FP.Vec n a) 88 | deriving via ViaFixed (FS.Vec n) a instance (Arity n, FromJSON a, FS.Storable a) => FromJSON (FS.Vec n a) 89 | deriving via ViaFixed (FS.Vec n) a instance (Arity n, ToJSON a, FS.Storable a) => ToJSON (FS.Vec n a) 90 | deriving via ViaFixed (FU.Vec n) a instance (Arity n, FromJSON a, FU.Unbox n a) => FromJSON (FU.Vec n a) 91 | deriving via ViaFixed (FU.Vec n) a instance (Arity n, ToJSON a, FU.Unbox n a) => ToJSON (FU.Vec n a) 92 | 93 | deriving via ViaFixed (F.VecList n) a instance (Arity n, FromJSON a) => FromJSON (F.VecList n a) 94 | deriving via ViaFixed (F.VecList n) a instance (Arity n, ToJSON a) => ToJSON (F.VecList n a) 95 | deriving via ViaFixed (F.VecPeano n) a instance (ArityPeano n, FromJSON a) => FromJSON (F.VecPeano n a) 96 | deriving via ViaFixed (F.VecPeano n) a instance (ArityPeano n, ToJSON a) => ToJSON (F.VecPeano n a) 97 | 98 | deriving via ViaFixed F.Only a instance (FromJSON a) => FromJSON (F.Only a) 99 | deriving via ViaFixed F.Only a instance (ToJSON a) => ToJSON (F.Only a) 100 | 101 | instance FromJSON (F.Empty a) where 102 | parseJSON = withArray "fixed-vector: Empty" $ \arr -> do 103 | unless (V.null arr) $ fail "Nonempty array" 104 | pure F.Empty 105 | instance ToJSON (F.Empty a) where 106 | toJSON _ = Array V.empty 107 | toEncoding _ = toEncoding ([]::[Value]) 108 | -------------------------------------------------------------------------------- /fixed-vector/Data/Vector/Fixed/Storable.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE MagicHash #-} 3 | {-# LANGUAGE UndecidableInstances #-} 4 | -- | 5 | -- Storable-based unboxed vectors. 6 | module Data.Vector.Fixed.Storable ( 7 | -- * Immutable 8 | Vec 9 | , Vec1 10 | , Vec2 11 | , Vec3 12 | , Vec4 13 | , Vec5 14 | -- * Raw pointers 15 | , unsafeFromForeignPtr 16 | , unsafeToForeignPtr 17 | , unsafeWith 18 | -- * Mutable 19 | , MVec(..) 20 | -- * Type classes 21 | , Storable 22 | ) where 23 | 24 | import Control.Monad.Primitive 25 | import Control.DeepSeq (NFData(..)) 26 | import Data.Monoid (Monoid(..)) 27 | import Data.Semigroup (Semigroup(..)) 28 | import Data.Data 29 | import Foreign.Ptr (castPtr) 30 | import Foreign.Storable 31 | import Foreign.Marshal.Array ( copyArray, moveArray ) 32 | import GHC.ForeignPtr ( mallocPlainForeignPtrBytes ) 33 | import GHC.Ptr ( Ptr(..) ) 34 | import GHC.Exts ( proxy# ) 35 | import GHC.TypeLits 36 | #if MIN_VERSION_base(4,15,0) 37 | import GHC.ForeignPtr ( unsafeWithForeignPtr ) 38 | #endif 39 | import Foreign.ForeignPtr ( ForeignPtr, withForeignPtr ) 40 | import Prelude ( Show(..),Eq(..),Ord(..),Num(..),Monad(..),IO,Int 41 | , ($),undefined,seq,pure) 42 | 43 | import Data.Vector.Fixed hiding (index) 44 | import Data.Vector.Fixed.Mutable (Mutable, MVector(..), IVector(..), DimM, constructVec, inspectVec, index, new,unsafeFreeze) 45 | import qualified Data.Vector.Fixed.Cont as C 46 | import Data.Vector.Fixed.Cont (ArityPeano(..)) 47 | 48 | 49 | 50 | ---------------------------------------------------------------- 51 | -- Data types 52 | ---------------------------------------------------------------- 53 | 54 | -- | Storable-based vector with fixed length 55 | newtype Vec (n :: Nat) a = Vec (ForeignPtr a) 56 | 57 | -- | Storable-based mutable vector with fixed length 58 | newtype MVec (n :: Nat) s a = MVec (ForeignPtr a) 59 | 60 | type Vec1 = Vec 1 61 | type Vec2 = Vec 2 62 | type Vec3 = Vec 3 63 | type Vec4 = Vec 4 64 | type Vec5 = Vec 5 65 | 66 | type instance Mutable (Vec n) = MVec n 67 | type instance Dim (Vec n) = Peano n 68 | type instance DimM (MVec n) = Peano n 69 | 70 | 71 | ---------------------------------------------------------------- 72 | -- Raw Ptrs 73 | ---------------------------------------------------------------- 74 | 75 | -- | Get underlying pointer. Data may not be modified through pointer. 76 | unsafeToForeignPtr :: Vec n a -> ForeignPtr a 77 | {-# INLINE unsafeToForeignPtr #-} 78 | unsafeToForeignPtr (Vec fp) = fp 79 | 80 | -- | Construct vector from foreign pointer. 81 | unsafeFromForeignPtr :: ForeignPtr a -> Vec n a 82 | {-# INLINE unsafeFromForeignPtr #-} 83 | unsafeFromForeignPtr = Vec 84 | 85 | -- | Pass pointer to the vector's data to the IO action. The data may 86 | -- not be modified through the 'Ptr. 87 | unsafeWith :: (Ptr a -> IO b) -> Vec n a -> IO b 88 | {-# INLINE unsafeWith #-} 89 | unsafeWith f (Vec fp) = withForeignPtr fp f 90 | 91 | 92 | 93 | ---------------------------------------------------------------- 94 | -- Instances 95 | ---------------------------------------------------------------- 96 | 97 | instance (Arity n, Storable a, NFData a) => NFData (Vec n a) where 98 | rnf x = seq x () 99 | 100 | deriving via ViaFixed (Vec n) a instance (Arity n, Storable a, Show a) => Show (Vec n a) 101 | deriving via ViaFixed (Vec n) a instance (Arity n, Storable a, Eq a) => Eq (Vec n a) 102 | deriving via ViaFixed (Vec n) a instance (Arity n, Storable a, Ord a) => Ord (Vec n a) 103 | deriving via ViaFixed (Vec n) a instance (Arity n, Storable a, Semigroup a) => Semigroup (Vec n a) 104 | deriving via ViaFixed (Vec n) a instance (Arity n, Storable a, Monoid a) => Monoid (Vec n a) 105 | 106 | instance (Arity n, Storable a) => MVector (MVec n) a where 107 | basicNew = unsafePrimToPrim $ do 108 | fp <- mallocVector (peanoToInt (proxy# @(Peano n))) 109 | return $ MVec fp 110 | {-# INLINE basicNew #-} 111 | basicCopy (MVec fp) (MVec fq) 112 | = unsafePrimToPrim 113 | $ unsafeWithForeignPtr fp $ \p -> 114 | unsafeWithForeignPtr fq $ \q -> 115 | copyArray p q (peanoToInt (proxy# @(Peano n))) 116 | {-# INLINE basicCopy #-} 117 | basicUnsafeRead (MVec fp) i 118 | = unsafePrimToPrim 119 | $ unsafeWithForeignPtr fp (`peekElemOff` i) 120 | {-# INLINE basicUnsafeRead #-} 121 | basicUnsafeWrite (MVec fp) i x 122 | = unsafePrimToPrim 123 | $ unsafeWithForeignPtr fp $ \p -> pokeElemOff p i x 124 | {-# INLINE basicUnsafeWrite #-} 125 | 126 | instance (Arity n, Storable a) => IVector (Vec n) a where 127 | basicUnsafeFreeze (MVec fp) = return $ Vec fp 128 | basicThaw (Vec fp) = do 129 | mv <- basicNew 130 | basicCopy mv (MVec fp) 131 | pure mv 132 | unsafeIndex (Vec fp) i 133 | = unsafeInlineIO 134 | $ unsafeWithForeignPtr fp (`peekElemOff` i) 135 | {-# INLINE basicUnsafeFreeze #-} 136 | {-# INLINE basicThaw #-} 137 | {-# INLINE unsafeIndex #-} 138 | 139 | instance (Arity n, Storable a) => Vector (Vec n) a where 140 | construct = constructVec 141 | inspect = inspectVec 142 | basicIndex = index 143 | {-# INLINE construct #-} 144 | {-# INLINE inspect #-} 145 | {-# INLINE basicIndex #-} 146 | 147 | instance (Arity n, Storable a) => Storable (Vec n a) where 148 | sizeOf = defaultSizeOf 149 | alignment = defaultAlignemnt 150 | peek ptr = do 151 | arr@(MVec fp) <- new 152 | unsafeWithForeignPtr fp $ \p -> 153 | moveArray p (castPtr ptr) (peanoToInt (proxy# @(Peano n))) 154 | unsafeFreeze arr 155 | poke ptr (Vec fp) 156 | = unsafeWithForeignPtr fp $ \p -> 157 | moveArray (castPtr ptr) p (peanoToInt (proxy# @(Peano n))) 158 | 159 | instance (Typeable n, Arity n, Storable a, Data a) => Data (Vec n a) where 160 | gfoldl = C.gfoldl 161 | gunfold = C.gunfold 162 | toConstr _ = con_Vec 163 | dataTypeOf _ = ty_Vec 164 | 165 | ty_Vec :: DataType 166 | ty_Vec = mkDataType "Data.Vector.Fixed.Primitive.Vec" [con_Vec] 167 | 168 | con_Vec :: Constr 169 | con_Vec = mkConstr ty_Vec "Vec" [] Prefix 170 | 171 | 172 | 173 | 174 | ---------------------------------------------------------------- 175 | -- Helpers 176 | ---------------------------------------------------------------- 177 | 178 | -- Code copied verbatim from vector package 179 | 180 | mallocVector :: forall a. Storable a => Int -> IO (ForeignPtr a) 181 | {-# INLINE mallocVector #-} 182 | mallocVector size 183 | = mallocPlainForeignPtrBytes (size * sizeOf (undefined :: a)) 184 | 185 | #if !MIN_VERSION_base(4,15,0) 186 | -- | A compatibility wrapper for 'GHC.ForeignPtr.unsafeWithForeignPtr' provided 187 | -- by GHC 9.0.1 and later. 188 | -- 189 | -- Only to be used when the continuation is known not to 190 | -- unconditionally diverge lest unsoundness can result. 191 | unsafeWithForeignPtr :: ForeignPtr a -> (Ptr a -> IO b) -> IO b 192 | unsafeWithForeignPtr = withForeignPtr 193 | #endif 194 | -------------------------------------------------------------------------------- /fixed-vector/ChangeLog.md: -------------------------------------------------------------------------------- 1 | 2.0.0.0 [2025.07.10] 2 | ------------------ 3 | * Type family `Dim` returns Peano numbers instead of standard type level 4 | naturals. 5 | 6 | - `Index` type class restored and all indexing operation are performed in 7 | - `Arity` simplified 8 | - `CVecPeano` dropped and `ContVec` is parameterized using Peano numbers. 9 | 10 | * In `ArityPeano` type class methods `reverseF` and `gunfoldF` are replaced 11 | with more general `accumPeano` and `reducePeano`. 12 | 13 | * `Unbox` vector are fully reworked. All uses of data types with `Unbox` 14 | instances which are defined in the library except `Bool` should work without 15 | changes. 16 | 17 | * `Data.Vector.Fixed.Cont.arity` dropped. 18 | 19 | * Type of `D.V.F.Cont.withFun` generalized. 20 | 21 | * Type class `VectorN` dropped. Use `QuantifiedConstraints` instead. 22 | 23 | * Show instance now has form `[...]` instead of `fromList [...]`. 24 | 25 | * `ViaFixed` newtype wrapper for deriving instances is 26 | added. `StorableViaFixed` is removed. 27 | 28 | * `Data.Vector.Fixed.Storable.unsafeWith` ensures that pointer won't 29 | get GC'd while function runs. 30 | 31 | * `Data.Vector.Fixed.sequenceA` is deprecated in favor of `sequence`. 32 | 33 | * `foldl'` and `ifoldl'` functions added. 34 | 35 | * Implement `sum` as in terms of `foldl'`. 36 | 37 | 38 | 1.2.3.0 [2023-10-31] 39 | -------------------- 40 | * Pattern `V1` added 41 | * `COMPLETE` pragmas added for patterns `V1`,`V2`,`V3`,`V4` 42 | 43 | 44 | 1.2.2.1 [2022-12-29] 45 | -------------------- 46 | * Newtype `StorableViaFixed` for deriving `Storable` instances added. 47 | 48 | 49 | 1.2.1.1 [2022-12-26] 50 | -------------------- 51 | * Fixed bug in `any` (#18) 52 | 53 | 54 | 1.2.1.0 [2021-11-13] 55 | -------------------- 56 | * Support for GHC7.10 dropped. 57 | * Pattern synonyms `V2`,`V3`,`V4` added. 58 | * `replicate{,M}` and `generate{,M}` added. 59 | * Functions `mk6`, `mk7`, `mk8` added. 60 | 61 | 62 | 1.2.0.0 [2018-09-02] 63 | -------------------- 64 | * `Show` instance for data type now respect precedence. 65 | 66 | 67 | 1.1.0.0 [2018-03-11] 68 | -------------------- 69 | * GHC8.4 compatibility release. Semigroup instances added and 70 | semigroup dependency added for GHC7.10 71 | 72 | 73 | 1.0.0.0 [2017-11-06] 74 | -------------------- 75 | * Vector length now expressed as GHC's type level literals. Underlying 76 | implementation still uses Peano numbers to perform induction. This doesn't 77 | change user facing API much. Notably `FlexibleInstances` and 78 | `GADTs`/`TypeFamiles` are now required to write `Arity` constraint. 79 | * `Monad` constraint is relaxed to `Applicative` where applicable. Duplicate 80 | functions are removed (`sequence` & `sequenceA` → `sequence`, etc) 81 | * Module `Data.Vector.Fixed.Monomorphic` is dropped. 82 | * Construction of N-ary vectors reworked. `Make` type class is gone. 83 | * Boxed arrays now use SmallArrays internally. 84 | * `overlaps` is removed from API for mutable vectors. 85 | * `Data.Vector.Fixed.defaultRnf` is added. 86 | * `Data.Vector.Fixed.Mutable.lengthI` is dropped. 87 | 88 | 89 | 0.9.0.0 [2016-09-14] 90 | -------------------- 91 | * Simplification of `Arity` type class. This change shouldn't affect client 92 | code. 93 | * Support for GHC < 7.8 is droppped. 94 | * Fixed bug in `any`. 95 | 96 | 97 | 0.8.1.0 [2015-08-27] 98 | -------------------- 99 | * `find` function added. 100 | 101 | 102 | 0.8.0.0 [2015-04-06] 103 | -------------------- 104 | * NFData instances for all data type. 105 | * Storable instances for all data types and default implementation of 106 | Storable's methods added. 107 | * {i,}zipWith3 and {i,}zipWithM_ added. 108 | 109 | 110 | 0.7.0.3 [2015-01-03] 111 | -------------------- 112 | * GHC 7.10 support 113 | 114 | 115 | 0.7.0.0 [2014-08-15] 116 | -------------------- 117 | * Type level addition for unary numbers added 118 | * `concat` function added 119 | * More consistent naming for functions for working with `Fun` 120 | 121 | 122 | 0.6.4.0 [2014-04-15] 123 | -------------------- 124 | * Isomorphism between Peano numbers and Nat added. (GHC >= 7.8) 125 | 126 | 127 | 0.6.3.1 [2014-03-12] 128 | -------------------- 129 | * Documentation fixes. 130 | 131 | 132 | 0.6.3.0 [2014-02-22] 133 | -------------------- 134 | * Left scans added. 135 | 136 | 137 | 0.6.2.0 [2014-02-07] 138 | -------------------- 139 | * `Vec1` type synonym for boxed/unboxed/etc. vectors added. 140 | * Vector instance for Data.Typeable.Proxy (GHC >= 7.8) 141 | 142 | 143 | 0.6.1.1 [2014-02-04] 144 | -------------------- 145 | * GHC 7.8 support 146 | 147 | 148 | 0.6.1.0 [2014-01-24] 149 | -------------------- 150 | * `distribute` `collect` and their monadic variants added. 151 | 152 | 153 | 0.6.0.0 [2013-11-17] 154 | -------------------- 155 | * Data instance for all array-based vectors added. 156 | * Storable instance added for `Storable.Vec`. 157 | * Monoid instances added for all vectors. 158 | 159 | 0.5.1.0 [2013-08-06] 160 | -------------------- 161 | * Zero-element vector `Empty'`is added. 162 | 163 | 164 | 0.5.0.0 [2013-08-02] 165 | -------------------- 166 | * `ContVec` now behaves like normal vector. `Arity` type class is 167 | reworked. `Id` data type is removed. 168 | * Construction of vector reworked. 169 | * `reverse`, `snoc`, `consV`, `fold` and `foldMap` are added. 170 | * Type changing maps and zips are added. 171 | * Vector indexing with type level numbers is added. 172 | * Twan van Laarhoven's lens added. (`element` and `elementTy`) 173 | * Ord instances added to vector data types defined in the library. 174 | 175 | 176 | 0.4.4.0 [2013-06-13] 177 | -------------------- 178 | * Functor and Applicative instances are added to Id. 179 | 180 | 181 | 0.4.3.0 [2013-05-18] 182 | -------------------- 183 | * Typeable instance for S and Z added. 184 | 185 | 186 | 0.4.2.0 [2013-05-01] 187 | -------------------- 188 | * 1-tuple `Only` added. 189 | * `fromList'` and fromListM added. 190 | * apply functions from Arity type class generalized. 191 | 192 | 193 | 0.4.1.0 [2013-04-29] 194 | -------------------- 195 | * `cons` function added. 196 | * Getter for `Fun` data type added. 197 | 198 | 199 | 0.4.0.0 [2013-04-04] 200 | -------------------- 201 | * Wrapper for monomorphics vectors is added. 202 | * `VecList` is reimplemented as GADT and constructors are exported. 203 | * Constructor of `ContVecT` is exported 204 | * Empty `ContVecT` is implemented as `empty`. 205 | * Typeable, Foldable and Traversable instances are added where 206 | appropriate 207 | 208 | 209 | 0.3.0.0 [2013-03-06] 210 | -------------------- 211 | * Vector type class definition is moved to the D.V.F.Cont module. 212 | * Indexing function restored. 213 | * `unfoldr` added. 214 | 215 | 216 | 0.2.0.0 [2013-02-10] 217 | -------------------- 218 | * Continuation-based vector added. 219 | * Right fold added. 220 | * tailWith, convertContinuation, and ! from 221 | Data.Vector.Fixed removed. 222 | * Vector instance for tuples added. 223 | 224 | 225 | 0.1.2 [2013-01-26] 226 | ------------------ 227 | * imap, imapM, ifoldl, ifoldM, zipWithM, izipWithM 228 | functions are added. 229 | * VectorN type class added. 230 | 231 | 232 | 0.1.1 [2012-11-29] 233 | ------------------ 234 | * foldM and tailWith added. Type synonyms for numbers up to 6 are 235 | added. Fun is reexported from Data.Vector.Fixed. 236 | -------------------------------------------------------------------------------- /fixed-vector/Data/Vector/Fixed/Mutable.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MagicHash #-} 2 | {-# LANGUAGE PolyKinds #-} 3 | -- | 4 | -- Type classes for vectors which are implemented on top of the arrays 5 | -- and support in-place mutation. API is similar to one used in the 6 | -- @vector@ package. 7 | module Data.Vector.Fixed.Mutable ( 8 | -- * Mutable vectors 9 | Arity 10 | , Mutable 11 | , DimM 12 | , MVector(..) 13 | , lengthM 14 | , new 15 | , clone 16 | , copy 17 | , read 18 | , write 19 | , unsafeRead 20 | , unsafeWrite 21 | -- * Creation 22 | , replicate 23 | , replicateM 24 | , generate 25 | , generateM 26 | -- * Loops 27 | , forI 28 | -- * Immutable vectors 29 | , IVector(..) 30 | , index 31 | , freeze 32 | , thaw 33 | , unsafeFreeze 34 | -- * Vector API 35 | , constructVec 36 | , inspectVec 37 | ) where 38 | 39 | import Control.Applicative (Const(..)) 40 | import Control.Monad.ST 41 | import Control.Monad.Primitive 42 | import Data.Kind (Type) 43 | import Prelude hiding (read,length,replicate) 44 | import GHC.Exts (proxy#) 45 | 46 | import Data.Vector.Fixed.Cont (Dim,PeanoNum(..),Arity,ArityPeano(..),Fun(..),Vector(..), 47 | ContVec,apply,accum,length) 48 | 49 | 50 | ---------------------------------------------------------------- 51 | -- Type classes 52 | ---------------------------------------------------------------- 53 | 54 | -- | Mutable counterpart of fixed-length vector. 55 | type family Mutable (v :: Type -> Type) :: Type -> Type -> Type 56 | 57 | -- | Dimension for mutable vector. 58 | type family DimM (v :: Type -> Type -> Type) :: PeanoNum 59 | 60 | -- | Type class for mutable vectors. 61 | class (ArityPeano (DimM v)) => MVector v a where 62 | -- | Copy vector. The two vectors may not overlap. Shouldn't be used 63 | -- directly, use 'copy' instead. 64 | basicCopy :: v s a -- ^ Target 65 | -> v s a -- ^ Source 66 | -> ST s () 67 | -- | Allocate new uninitialized vector. Shouldn't be used 68 | -- directly, use 'new' instead. 69 | basicNew :: ST s (v s a) 70 | -- | Allocate new vector initialized with given element. Shouldn't be used 71 | -- directly, use 'replicate' instead. 72 | basicReplicate :: a -> ST s (v s a) 73 | {-# INLINE basicReplicate #-} 74 | basicReplicate a = do 75 | v <- basicNew 76 | forI v $ \i -> basicUnsafeWrite v i a 77 | pure v 78 | -- | Create copy of existing vector. Shouldn't be used 79 | -- directly, use 'clone' instead. 80 | basicClone :: v s a -> ST s (v s a) 81 | {-# INLINE basicClone #-} 82 | basicClone src = do 83 | dst <- basicNew 84 | basicCopy dst src 85 | pure src 86 | -- | Read value at index without bound checks. Shouldn't be used 87 | -- directly, use 'unsafeRead' instead. 88 | basicUnsafeRead :: v s a -> Int -> ST s a 89 | -- | Write value at index without bound checks. Shouldn't be used 90 | -- directly, use 'unsafeWrite' instead. 91 | basicUnsafeWrite :: v s a -> Int -> a -> ST s () 92 | 93 | -- | Length of mutable vector. Function doesn't evaluate its argument. 94 | lengthM :: forall v s a. (ArityPeano (DimM v)) => v s a -> Int 95 | lengthM _ = peanoToInt (proxy# @(DimM v)) 96 | 97 | -- | Create new uninitialized mutable vector. 98 | new :: (MVector v a, PrimMonad m) => m (v (PrimState m) a) 99 | new = stToPrim basicNew 100 | {-# INLINE new #-} 101 | 102 | -- | Copy vector. The two vectors may not overlap. Since vectors' 103 | -- length is encoded in the type there is no need in runtime 104 | -- checks of length. 105 | copy :: (MVector v a, PrimMonad m) 106 | => v (PrimState m) a -- ^ Target 107 | -> v (PrimState m) a -- ^ Source 108 | -> m () 109 | {-# INLINE copy #-} 110 | copy tgt src = stToPrim $ basicCopy tgt src 111 | 112 | -- | Create copy of vector. 113 | -- 114 | -- Examples: 115 | -- 116 | -- >>> import Control.Monad.ST (runST) 117 | -- >>> import Data.Vector.Fixed (mk3) 118 | -- >>> import Data.Vector.Fixed.Boxed (Vec3) 119 | -- >>> import qualified Data.Vector.Fixed.Mutable as M 120 | -- >>> let x = runST (do { v <- M.replicate 100; v' <- clone v; M.write v' 0 2; M.unsafeFreeze v' }) :: Vec3 Int 121 | -- >>> x 122 | -- [2,100,100] 123 | clone :: (PrimMonad m, MVector v a) => v (PrimState m) a -> m (v (PrimState m) a) 124 | {-# INLINE clone #-} 125 | clone = stToPrim . basicClone 126 | 127 | -- | Read value at index without bound checks. 128 | unsafeRead :: (MVector v a, PrimMonad m) => v (PrimState m) a -> Int -> m a 129 | {-# INLINE unsafeRead #-} 130 | unsafeRead v i = stToPrim $ basicUnsafeRead v i 131 | 132 | -- | Write value at index without bound checks. 133 | unsafeWrite :: (MVector v a, PrimMonad m) => v (PrimState m) a -> Int -> a -> m () 134 | {-# INLINE unsafeWrite #-} 135 | unsafeWrite v i a = stToPrim $ basicUnsafeWrite v i a 136 | 137 | -- | Read value at index with bound checks. 138 | read :: (PrimMonad m, MVector v a) => v (PrimState m) a -> Int -> m a 139 | {-# INLINE read #-} 140 | read v i 141 | | i < 0 || i >= lengthM v = error "Data.Vector.Fixed.Mutable.read: index out of range" 142 | | otherwise = unsafeRead v i 143 | 144 | -- | Write value at index with bound checks. 145 | write :: (PrimMonad m, MVector v a) => v (PrimState m) a -> Int -> a -> m () 146 | {-# INLINE write #-} 147 | write v i x 148 | | i < 0 || i >= lengthM v = error "Data.Vector.Fixed.Mutable.write: index out of range" 149 | | otherwise = unsafeWrite v i x 150 | 151 | 152 | -- | Create new vector with all elements set to given value. 153 | replicate :: (PrimMonad m, MVector v a) => a -> m (v (PrimState m) a) 154 | {-# INLINE replicate #-} 155 | replicate = stToPrim . basicReplicate 156 | 157 | -- | Create new vector with all elements are generated by provided 158 | -- monadic action. 159 | replicateM :: (PrimMonad m, MVector v a) => m a -> m (v (PrimState m) a) 160 | {-# INLINE replicateM #-} 161 | replicateM m = do 162 | v <- new 163 | forI v $ \i -> unsafeWrite v i =<< m 164 | pure v 165 | 166 | -- | Create new vector with using function from index to value. 167 | generate :: (PrimMonad m, MVector v a) => (Int -> a) -> m (v (PrimState m) a) 168 | {-# INLINE generate #-} 169 | generate f = do 170 | v <- new 171 | forI v $ \i -> unsafeWrite v i $ f i 172 | pure v 173 | 174 | -- | Create new vector with using monadic function from index to value. 175 | generateM :: (PrimMonad m, MVector v a) => (Int -> m a) -> m (v (PrimState m) a) 176 | {-# INLINE generateM #-} 177 | generateM f = do 178 | v <- new 179 | forI v $ \i -> unsafeWrite v i =<< f i 180 | pure v 181 | 182 | -- | Loop which calls function for each index 183 | forI :: (PrimMonad m, MVector v a) => v (PrimState m) a -> (Int -> m ()) -> m () 184 | {-# INLINE forI #-} 185 | forI v f = go 0 186 | where 187 | go i | i >= n = pure () 188 | | otherwise = f i >> go (i+1) 189 | n = lengthM v 190 | 191 | 192 | ---------------------------------------------------------------- 193 | -- Immutable 194 | ---------------------------------------------------------------- 195 | 196 | -- | Type class for immutable vectors 197 | class (Dim v ~ DimM (Mutable v), MVector (Mutable v) a) => IVector v a where 198 | -- | Convert vector to immutable state. Mutable vector must not be 199 | -- modified afterwards. 200 | basicUnsafeFreeze :: Mutable v s a -> ST s (v a) 201 | -- | Convert immutable vector to mutable by copying it. 202 | basicThaw :: v a -> ST s (Mutable v s a) 203 | -- | Get element at specified index without bounds check. 204 | unsafeIndex :: v a -> Int -> a 205 | 206 | 207 | -- | Convert vector to immutable state. Mutable vector must not be 208 | -- modified afterwards. 209 | unsafeFreeze :: (IVector v a, PrimMonad m) => Mutable v (PrimState m) a -> m (v a) 210 | {-# INLINE unsafeFreeze #-} 211 | unsafeFreeze = stToPrim . basicUnsafeFreeze 212 | 213 | index :: IVector v a => v a -> Int -> a 214 | {-# INLINE index #-} 215 | index v i | i < 0 || i >= length v = error "Data.Vector.Fixed.Mutable.!: index out of bounds" 216 | | otherwise = unsafeIndex v i 217 | 218 | 219 | -- | Safely convert mutable vector to immutable. 220 | freeze :: (PrimMonad m, IVector v a) => Mutable v (PrimState m) a -> m (v a) 221 | {-# INLINE freeze #-} 222 | freeze v = unsafeFreeze =<< clone v 223 | 224 | -- | Safely convert immutable vector to mutable. 225 | thaw :: (PrimMonad m, IVector v a) => v a -> m (Mutable v (PrimState m) a) 226 | {-# INLINE thaw #-} 227 | thaw = stToPrim . basicThaw 228 | 229 | 230 | 231 | ---------------------------------------------------------------- 232 | -- Vector API 233 | ---------------------------------------------------------------- 234 | 235 | -- | Generic inspect implementation for array-based vectors. 236 | inspectVec :: forall v a b. (ArityPeano (Dim v), IVector v a) => v a -> Fun (Dim v) a b -> b 237 | {-# INLINE inspectVec #-} 238 | inspectVec v 239 | = inspect cv 240 | where 241 | cv :: ContVec (Dim v) a 242 | cv = apply (\(Const i) -> (unsafeIndex v i, Const (i+1))) 243 | (Const 0 :: Const Int (Dim v)) 244 | 245 | -- | Generic construct implementation for array-based vectors. 246 | constructVec :: forall v a. (ArityPeano (Dim v), IVector v a) => Fun (Dim v) a (v a) 247 | {-# INLINE constructVec #-} 248 | constructVec = 249 | accum step 250 | (\(T_new _ st) -> runST $ unsafeFreeze =<< st :: v a) 251 | (T_new 0 new :: T_new v a (Dim v)) 252 | 253 | data T_new v a n = T_new Int (forall s. ST s (Mutable v s a)) 254 | 255 | step :: (IVector v a) => T_new v a ('S n) -> a -> T_new v a n 256 | step (T_new i st) x = T_new (i+1) $ do 257 | mv <- st 258 | unsafeWrite mv i x 259 | return mv 260 | -------------------------------------------------------------------------------- /fixed-vector/Data/Vector/Fixed/Unboxed.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MagicHash #-} 2 | {-# LANGUAGE QuantifiedConstraints #-} 3 | {-# LANGUAGE UnboxedTuples #-} 4 | {-# LANGUAGE UndecidableInstances #-} 5 | -- | 6 | -- Adaptive array type which picks vector representation from type of 7 | -- element of array. For example arrays of @Double@ are backed by 8 | -- @ByteArray@, arrays of @Bool@ are represented as bit-vector, arrays 9 | -- of tuples are products of arrays. 'Unbox' type class is used to 10 | -- describe representation of an array. 11 | module Data.Vector.Fixed.Unboxed( 12 | -- * Data type 13 | Vec(..) 14 | , Vec1 15 | , Vec2 16 | , Vec3 17 | , Vec4 18 | , Vec5 19 | -- * Type classes & derivation 20 | , Unbox 21 | , UnboxViaPrim 22 | -- * Concrete representations 23 | , BitVec 24 | , T2(..) 25 | , T3(..) 26 | ) where 27 | 28 | import Control.Applicative (Const(..)) 29 | import Control.DeepSeq (NFData(..)) 30 | import Data.Bits 31 | import Data.Complex 32 | import Data.Coerce 33 | import Data.Data 34 | import Data.Kind 35 | import Data.Functor.Identity (Identity(..)) 36 | import Data.Int (Int8, Int16, Int32, Int64 ) 37 | import Data.Monoid (Monoid(..),Dual(..),Sum(..),Product(..),All(..),Any(..)) 38 | import Data.Semigroup (Semigroup(..)) 39 | import Data.Ord (Down(..)) 40 | import Data.Word (Word,Word8,Word16,Word32,Word64) 41 | import Foreign.Storable (Storable(..)) 42 | import GHC.TypeLits 43 | import GHC.Exts (Proxy#, proxy#) 44 | import Prelude ( Show(..),Eq(..),Ord(..),Num(..),Applicative(..) 45 | , Int,Double,Float,Char,Bool(..),($),id) 46 | 47 | import Data.Vector.Fixed (Dim,Vector(..),ViaFixed(..)) 48 | import Data.Vector.Fixed qualified as F 49 | import Data.Vector.Fixed.Cont qualified as C 50 | import Data.Vector.Fixed.Cont (Peano,Arity,ArityPeano,Fun(..),curryFirst) 51 | import Data.Vector.Fixed.Primitive qualified as P 52 | 53 | 54 | 55 | ---------------------------------------------------------------- 56 | -- Data type 57 | ---------------------------------------------------------------- 58 | 59 | -- | Adaptive array of dimension @n@ and containing elements of type 60 | -- @a@. 61 | newtype Vec (n :: Nat) a = Vec { getVecRepr :: VecRepr n a (EltRepr a) } 62 | 63 | type Vec1 = Vec 1 64 | type Vec2 = Vec 2 65 | type Vec3 = Vec 3 66 | type Vec4 = Vec 4 67 | type Vec5 = Vec 5 68 | 69 | -- | Type class which selects internal representation of unboxed vector. 70 | -- 71 | -- Crucial design constraint is this type class must be 72 | -- GND-derivable. And this rules out anything mentioning 'Fun', 73 | -- since all it's parameters has @nominal@ role. Thus 'Vector' is 74 | -- not GND-derivable and we have to take somewhat roundabout 75 | -- approach. 76 | class ( Dim (VecRepr n a) ~ Peano n 77 | , Vector (VecRepr n a) (EltRepr a) 78 | ) => Unbox n a where 79 | -- | Vector data type to use as a representation. 80 | type VecRepr n a :: Type -> Type 81 | -- | Element data type to use as a representation. 82 | type EltRepr a :: Type 83 | -- | Convert element to its representation 84 | toEltRepr :: Proxy# n -> a -> EltRepr a 85 | -- | Convert element from its representation 86 | fromEltRepr :: Proxy# n -> EltRepr a -> a 87 | 88 | type instance Dim (Vec n) = Peano n 89 | 90 | instance (Arity n, Unbox n a) => Vector (Vec n) a where 91 | inspect (Vec v) f 92 | = inspect v 93 | (C.dimapFun (fromEltRepr (proxy# @n)) id f) 94 | construct 95 | = C.dimapFun (toEltRepr (proxy# @n)) Vec 96 | (construct @(VecRepr n a) @(EltRepr a)) 97 | {-# INLINE inspect #-} 98 | {-# INLINE construct #-} 99 | 100 | 101 | 102 | ---------------------------------------------------------------- 103 | -- Generic instances 104 | ---------------------------------------------------------------- 105 | 106 | deriving via ViaFixed (Vec n) a instance (Unbox n a, Show a) => Show (Vec n a) 107 | deriving via ViaFixed (Vec n) a instance (Unbox n a, Eq a) => Eq (Vec n a) 108 | deriving via ViaFixed (Vec n) a instance (Unbox n a, Ord a) => Ord (Vec n a) 109 | deriving via ViaFixed (Vec n) a instance (Unbox n a, NFData a) => NFData (Vec n a) 110 | deriving via ViaFixed (Vec n) a instance (Unbox n a, Semigroup a) => Semigroup (Vec n a) 111 | deriving via ViaFixed (Vec n) a instance (Unbox n a, Monoid a) => Monoid (Vec n a) 112 | deriving via ViaFixed (Vec n) a instance (Unbox n a, Storable a) => Storable (Vec n a) 113 | 114 | instance (Typeable n, Unbox n a, Data a) => Data (Vec n a) where 115 | gfoldl = C.gfoldl 116 | gunfold = C.gunfold 117 | toConstr _ = con_Vec 118 | dataTypeOf _ = ty_Vec 119 | 120 | ty_Vec :: DataType 121 | ty_Vec = mkDataType "Data.Vector.Fixed.Unboxed.Vec" [con_Vec] 122 | 123 | con_Vec :: Constr 124 | con_Vec = mkConstr ty_Vec "Vec" [] Prefix 125 | 126 | 127 | ---------------------------------------------------------------- 128 | -- Data instances 129 | ---------------------------------------------------------------- 130 | 131 | instance F.Arity n => Unbox n () where 132 | type VecRepr n () = VecUnit n 133 | type EltRepr () = () 134 | toEltRepr _ = id 135 | fromEltRepr _ = id 136 | {-# INLINE toEltRepr #-} 137 | {-# INLINE fromEltRepr #-} 138 | 139 | data VecUnit (n :: Nat) a = VecUnit 140 | 141 | type instance Dim (VecUnit n) = Peano n 142 | 143 | instance F.Arity n => Vector (VecUnit n) () where 144 | inspect _ fun 145 | = C.runContVec fun 146 | $ C.apply (\Proxy -> ((),Proxy)) Proxy 147 | construct 148 | = pure VecUnit 149 | {-# INLINE inspect #-} 150 | {-# INLINE construct #-} 151 | 152 | 153 | 154 | ---------------------------------------------------------------- 155 | -- Boolean 156 | 157 | -- | Bit vector represented as 64-bit word. This puts upper limit on 158 | -- length of vector. It's not a big problem. 64-element will strain 159 | -- GHC quite a bit. 160 | data BitVec (n :: Nat) a = BitVec Word64 161 | 162 | type instance Dim (BitVec n) = Peano n 163 | 164 | instance (n <= 64, Arity n, a ~ Bool) => Vector (BitVec n) a where 165 | inspect (BitVec w) = inspect (C.generate (testBit w)) 166 | construct = C.accum 167 | (\(Const (i,w)) -> \case 168 | True -> Const (i+1, setBit w i) 169 | False -> Const (i+1, w)) 170 | (\(Const (_,w)) -> BitVec w) 171 | (Const (0,0)) 172 | 173 | instance (n <= 64, Arity n) => Unbox n Bool where 174 | type VecRepr n Bool = BitVec n 175 | type EltRepr Bool = Bool 176 | toEltRepr _ = id 177 | fromEltRepr _ = id 178 | {-# INLINE toEltRepr #-} 179 | {-# INLINE fromEltRepr #-} 180 | 181 | 182 | 183 | ---------------------------------------------------------------- 184 | -- Primitive wrappers 185 | ---------------------------------------------------------------- 186 | 187 | -- | Wrapper for deriving 'Unbox' for data types which are instances 188 | -- of 'P.Prim' type class: 189 | -- 190 | -- > deriving via UnboxViaPrim Word instance (C.Arity n) => Unbox n Word 191 | newtype UnboxViaPrim a = UnboxViaPrim a 192 | deriving newtype P.Prim 193 | 194 | instance (C.Arity n, P.Prim a) => Unbox n (UnboxViaPrim a) where 195 | type VecRepr n (UnboxViaPrim a) = P.Vec n 196 | type EltRepr (UnboxViaPrim a) = a 197 | toEltRepr _ = coerce 198 | fromEltRepr _ = coerce 199 | 200 | deriving via UnboxViaPrim Int instance (C.Arity n) => Unbox n Int 201 | deriving via UnboxViaPrim Int8 instance (C.Arity n) => Unbox n Int8 202 | deriving via UnboxViaPrim Int16 instance (C.Arity n) => Unbox n Int16 203 | deriving via UnboxViaPrim Int32 instance (C.Arity n) => Unbox n Int32 204 | deriving via UnboxViaPrim Int64 instance (C.Arity n) => Unbox n Int64 205 | deriving via UnboxViaPrim Word instance (C.Arity n) => Unbox n Word 206 | deriving via UnboxViaPrim Word8 instance (C.Arity n) => Unbox n Word8 207 | deriving via UnboxViaPrim Word16 instance (C.Arity n) => Unbox n Word16 208 | deriving via UnboxViaPrim Word32 instance (C.Arity n) => Unbox n Word32 209 | deriving via UnboxViaPrim Word64 instance (C.Arity n) => Unbox n Word64 210 | 211 | deriving via UnboxViaPrim Char instance (C.Arity n) => Unbox n Char 212 | deriving via UnboxViaPrim Float instance (C.Arity n) => Unbox n Float 213 | deriving via UnboxViaPrim Double instance (C.Arity n) => Unbox n Double 214 | 215 | 216 | ---------------------------------------------------------------- 217 | -- Newtypes 218 | ---------------------------------------------------------------- 219 | 220 | deriving newtype instance (Unbox n a) => Unbox n (Const a b) 221 | deriving newtype instance (Unbox n a) => Unbox n (Identity a) 222 | deriving newtype instance (Unbox n a) => Unbox n (Down a) 223 | deriving newtype instance (Unbox n a) => Unbox n (Dual a) 224 | deriving newtype instance (Unbox n a) => Unbox n (Sum a) 225 | deriving newtype instance (Unbox n a) => Unbox n (Product a) 226 | 227 | deriving newtype instance (n <= 64, Arity n) => Unbox n All 228 | deriving newtype instance (n <= 64, Arity n) => Unbox n Any 229 | 230 | 231 | ---------------------------------------------------------------- 232 | -- Tuples 233 | ---------------------------------------------------------------- 234 | 235 | -- | Representation for vector of 2-tuple as two vectors. 236 | data T2 n a b x = T2 !(Vec n a) !(Vec n b) 237 | 238 | type instance Dim (T2 n a b) = Peano n 239 | 240 | instance (Arity n, Unbox n a, Unbox n b) => Vector (T2 n a b) (a,b) where 241 | inspect (T2 vA vB) 242 | = inspect (C.zipWith (,) cvA cvB) 243 | where 244 | cvA = C.ContVec $ inspect vA 245 | cvB = C.ContVec $ inspect vB 246 | construct = pairF T2 construct construct 247 | {-# INLINE construct #-} 248 | {-# INLINE inspect #-} 249 | 250 | pairF 251 | :: ArityPeano n 252 | => (x -> y -> z) 253 | -> Fun n a x 254 | -> Fun n b y 255 | -> Fun n (a,b) z 256 | {-# INLINE pairF #-} 257 | pairF g funA funB = C.accum 258 | (\(T_pair fA fB) (a,b) -> T_pair (curryFirst fA a) (curryFirst fB b)) 259 | (\(T_pair (Fun x) (Fun y)) -> g x y) 260 | (T_pair funA funB) 261 | 262 | data T_pair a b x y n = T_pair (Fun n a x) (Fun n b y) 263 | 264 | 265 | -- | Representation for vector of 2-tuple as two vectors. 266 | data T3 n a b c x = T3 !(Vec n a) !(Vec n b) !(Vec n c) 267 | 268 | type instance Dim (T3 n a b c) = Peano n 269 | 270 | instance (Arity n, Unbox n a, Unbox n b, Unbox n c) => Vector (T3 n a b c) (a,b,c) where 271 | inspect (T3 vA vB vC) 272 | = inspect (C.zipWith3 (,,) cvA cvB cvC) 273 | where 274 | cvA = C.ContVec $ inspect vA 275 | cvB = C.ContVec $ inspect vB 276 | cvC = C.ContVec $ inspect vC 277 | construct = pair3F T3 construct construct construct 278 | {-# INLINE construct #-} 279 | {-# INLINE inspect #-} 280 | 281 | pair3F 282 | :: ArityPeano n 283 | => (x -> y -> z -> r) 284 | -> Fun n a x 285 | -> Fun n b y 286 | -> Fun n c z 287 | -> Fun n (a,b,c) r 288 | {-# INLINE pair3F #-} 289 | pair3F g funA funB funC = C.accum 290 | (\(T_pair3 fA fB fC) (a,b,c) -> T_pair3 (curryFirst fA a) 291 | (curryFirst fB b) 292 | (curryFirst fC c)) 293 | (\(T_pair3 (Fun x) (Fun y) (Fun z)) -> g x y z) 294 | (T_pair3 funA funB funC) 295 | 296 | data T_pair3 a b c x y z n = T_pair3 (Fun n a x) (Fun n b y) (Fun n c z) 297 | 298 | 299 | 300 | instance (Unbox n a, Unbox n b) => Unbox n (a,b) where 301 | type VecRepr n (a,b) = T2 n a b 302 | type EltRepr (a,b) = (a,b) 303 | toEltRepr _ = id 304 | fromEltRepr _ = id 305 | 306 | instance (Unbox n a) => Unbox n (Complex a) where 307 | -- NOTE: It would be nice to have ability to use single buffer say 308 | -- for `Complex Double`. But buffers seems to be opaque 309 | type VecRepr n (Complex a) = T2 n a a 310 | type EltRepr (Complex a) = (a,a) 311 | toEltRepr _ (r :+ i) = (r,i) 312 | fromEltRepr _ (r,i) = r :+ i 313 | {-# INLINE toEltRepr #-} 314 | {-# INLINE fromEltRepr #-} 315 | -------------------------------------------------------------------------------- /fixed-vector/Data/Vector/Fixed.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE PolyKinds #-} 3 | {-# LANGUAGE QuantifiedConstraints #-} 4 | {-# LANGUAGE UndecidableInstances #-} 5 | -- | 6 | -- @fixed-vector@ library provides general API for working with short 7 | -- N-element arrays. Functions in this module work on data types which 8 | -- are instances of 'Vector' type class. We provide instances for data 9 | -- types from @base@: tuples, 'Data.Complex.Complex', and few others. 10 | -- There are several length polymorphic arrays: 11 | -- 12 | -- * Lazy boxed arrays "Data.Vector.Fixed.Boxed". 13 | -- 14 | -- * Strict boxed arrays "Data.Vector.Fixed.Strict". 15 | -- 16 | -- * Arrays backed by single @ByteArray@: "Data.Vector.Fixed.Primitive". 17 | -- 18 | -- * Arrays backed by pinned memory: "Data.Vector.Fixed.Storable". 19 | -- 20 | -- * Arrays which infer array representation from element data type: 21 | -- "Data.Vector.Fixed.Unboxed" 22 | -- 23 | -- * Continuation based 'Data.Vector.Fixed.Cont.ContVec' which used 24 | -- by library internally. 25 | -- 26 | -- Type level naturals don't have support for induction so all type 27 | -- level computation with length and indices are done using Peano 28 | -- numerals ('PeanoNum'). Type level naturals are only used as type 29 | -- parameters for defining length of arrays. 30 | -- 31 | -- [@Instances for tuples@] 32 | -- 33 | -- Library provides instances for tuples. They however come with caveat. 34 | -- Let look at 'Vector' instance for 2-tuple: 35 | -- 36 | -- > instance b ~ a => Vector ((,) b) a 37 | -- 38 | -- Tuple could only be @Vector@ instance if all elements have same 39 | -- type. so first element fixes type of second one. Thus functions 40 | -- which change element type like 'map' won't work: 41 | -- 42 | -- > >>> map (== 1) ((1,2) :: (Int,Int)) 43 | -- > 44 | -- > :3:1: 45 | -- > Couldn't match type `Int' with `Bool' 46 | -- > In the expression: F.map (== 1) ((1, 2) :: (Int, Int)) 47 | -- > In an equation for `it': it = map (== 1) ((1, 2) :: (Int, Int)) 48 | -- 49 | -- This could be solved either by switching to @ContVec@ manually: 50 | -- 51 | -- >>> (vector . map (==1) . cvec) ((1, 2) :: Tuple2 Int) :: Tuple2 Bool 52 | -- (True,False) 53 | -- 54 | -- or by using functions genereic in vector type from module 55 | -- "Data.Vector.Fixed.Generic". 56 | module Data.Vector.Fixed ( 57 | -- * Vector type class 58 | Vector(..) 59 | , Dim 60 | , Arity 61 | , ArityPeano 62 | , Fun(..) 63 | , length 64 | -- ** Peano numbers 65 | , PeanoNum(..) 66 | , C.Peano 67 | , C.N1, C.N2, C.N3, C.N4, C.N5, C.N6, C.N7, C.N8 68 | -- * Construction and destructions 69 | -- $construction 70 | 71 | -- ** Constructors 72 | , mk0 73 | , mk1 74 | , mk2 75 | , mk3 76 | , mk4 77 | , mk5 78 | , mk6 79 | , mk7 80 | , mk8 81 | , mkN 82 | -- ** Pattern synonyms 83 | , pattern V1 84 | , pattern V2 85 | , pattern V3 86 | , pattern V4 87 | -- * Functions 88 | -- ** Creation 89 | , replicate 90 | , replicateM 91 | , generate 92 | , generateM 93 | , unfoldr 94 | , basis 95 | -- ** Transformations 96 | , head 97 | , tail 98 | , cons 99 | , snoc 100 | , concat 101 | , reverse 102 | -- ** Indexing & lenses 103 | , C.Index 104 | , (!) 105 | , index 106 | , set 107 | , element 108 | , elementTy 109 | -- ** Maps 110 | , map 111 | , mapM 112 | , mapM_ 113 | , imap 114 | , imapM 115 | , imapM_ 116 | , scanl 117 | , scanl1 118 | , sequence 119 | , sequence_ 120 | , traverse 121 | , distribute 122 | , collect 123 | -- ** Folds 124 | , foldl 125 | , foldl' 126 | , foldr 127 | , foldl1 128 | , fold 129 | , foldMap 130 | , ifoldl 131 | , ifoldr 132 | , foldM 133 | , ifoldM 134 | -- *** Special folds 135 | , sum 136 | , maximum 137 | , minimum 138 | , and 139 | , or 140 | , all 141 | , any 142 | , find 143 | -- ** Zips 144 | , zipWith 145 | , zipWith3 146 | , zipWithM 147 | , zipWithM_ 148 | , izipWith 149 | , izipWith3 150 | , izipWithM 151 | , izipWithM_ 152 | -- *** Special zips 153 | , eq 154 | , ord 155 | -- ** Conversion 156 | , convert 157 | , toList 158 | , fromList 159 | , fromList' 160 | , fromListM 161 | , fromFoldable 162 | -- * Data types 163 | , VecList(..) 164 | , VecPeano(..) 165 | , Only(..) 166 | , Empty(..) 167 | -- ** Tuple synonyms 168 | , Tuple2 169 | , Tuple3 170 | , Tuple4 171 | , Tuple5 172 | -- ** Continuation-based vectors 173 | , ContVec 174 | , empty 175 | , vector 176 | , cvec 177 | -- * Instance deriving 178 | , ViaFixed(..) 179 | -- ** Storable 180 | -- $storable 181 | , defaultAlignemnt 182 | , defaultSizeOf 183 | , defaultPeek 184 | , defaultPoke 185 | -- ** NFData 186 | , defaultRnf 187 | -- * Deprecated functions 188 | , sequenceA 189 | ) where 190 | 191 | import Control.Applicative (Applicative(..)) 192 | import Control.DeepSeq (NFData(..)) 193 | import Data.Coerce 194 | import Data.Data (Data) 195 | import Data.Monoid (Monoid(..)) 196 | import Data.Semigroup (Semigroup(..)) 197 | import Data.Foldable qualified as F 198 | import Data.Traversable qualified as T 199 | import Foreign.Storable (Storable(..)) 200 | import GHC.TypeLits 201 | 202 | import Data.Vector.Fixed.Cont (Vector(..),Dim,length,ContVec,PeanoNum(..), 203 | vector,cvec,empty,Arity,ArityPeano,Fun(..),accum,apply) 204 | import Data.Vector.Fixed.Cont qualified as C 205 | import Data.Vector.Fixed.Internal as I 206 | 207 | import Prelude (Show(..),Eq(..),Ord(..),Num(..),Functor(..),id,(.),($),(<$>)) 208 | 209 | 210 | -- $construction 211 | -- 212 | -- There are several ways to construct fixed vectors except using 213 | -- their constructor if it's available. For small ones it's possible 214 | -- to use functions 'mk1', 'mk2', etc. 215 | -- 216 | -- >>> mk3 'a' 'b' 'c' :: (Char,Char,Char) 217 | -- ('a','b','c') 218 | -- 219 | -- Another way is to use pattern synonyms for construction and 220 | -- inspection of vectors: 221 | -- 222 | -- >>> V2 'a' 'b' :: (Char,Char) 223 | -- ('a','b') 224 | -- 225 | -- >>> case ('a','b') of V2 a b -> [a,b] 226 | -- "ab" 227 | -- 228 | -- Last option is to use 'convert' to convert between different vector 229 | -- types of same length. For example 230 | -- 231 | -- > v = convert (x,y,z) 232 | -- 233 | -- This could be used in view patterns as well: 234 | -- 235 | -- > foo :: Vec3 Double -> Foo 236 | -- > foo (convert -> (x,y,z)) = ... 237 | -- 238 | -- Pattern synonyms use this trick internally. 239 | 240 | 241 | -- $storable 242 | -- 243 | -- Default implementation of methods for Storable type class assumes 244 | -- that individual elements of vector are stored as N-element array. 245 | 246 | 247 | -- | Type-based vector with statically known length parametrized by 248 | -- GHC's type naturals 249 | newtype VecList (n :: Nat) a = VecList (VecPeano (C.Peano n) a) 250 | 251 | -- | Standard GADT-based vector with statically known length 252 | -- parametrized by Peano numbers. 253 | data VecPeano (n :: PeanoNum) a where 254 | Nil :: VecPeano 'Z a 255 | Cons :: a -> VecPeano n a -> VecPeano ('S n) a 256 | 257 | type instance Dim (VecList n) = C.Peano n 258 | type instance Dim (VecPeano n) = n 259 | 260 | instance Arity n => Vector (VecList n) a where 261 | construct = VecList <$> construct @(VecPeano (C.Peano n)) @a 262 | inspect (VecList v) = inspect v 263 | {-# INLINE construct #-} 264 | {-# INLINE inspect #-} 265 | 266 | instance C.ArityPeano n => Vector (VecPeano n) a where 267 | construct = accum 268 | (\(T_List f) a -> T_List (f . Cons a)) 269 | (\(T_List f) -> f Nil) 270 | (T_List id :: T_List a n n) 271 | inspect v 272 | = inspect (apply step (Flip v) :: C.ContVec n a) 273 | where 274 | step :: Flip VecPeano a ('S k) -> (a, Flip VecPeano a k) 275 | step (Flip (Cons a xs)) = (a, Flip xs) 276 | {-# INLINE construct #-} 277 | {-# INLINE inspect #-} 278 | 279 | newtype Flip f a n = Flip (f n a) 280 | newtype T_List a n k = T_List (VecPeano k a -> VecPeano n a) 281 | 282 | 283 | 284 | deriving via ViaFixed (VecList n) instance (Arity n) => Functor (VecList n) 285 | deriving via ViaFixed (VecList n) instance (Arity n) => Applicative (VecList n) 286 | deriving via ViaFixed (VecList n) instance (Arity n) => F.Foldable (VecList n) 287 | 288 | instance Arity n => T.Traversable (VecList n) where 289 | sequence = sequence 290 | sequenceA = sequence 291 | traverse = mapM 292 | mapM = mapM 293 | {-# INLINE sequence #-} 294 | {-# INLINE sequenceA #-} 295 | {-# INLINE mapM #-} 296 | {-# INLINE traverse #-} 297 | 298 | deriving via ViaFixed (VecList n) a instance (Arity n, Show a) => Show (VecList n a) 299 | deriving via ViaFixed (VecList n) a instance (Arity n, Eq a) => Eq (VecList n a) 300 | deriving via ViaFixed (VecList n) a instance (Arity n, Ord a) => Ord (VecList n a) 301 | deriving via ViaFixed (VecList n) a instance (Arity n, NFData a) => NFData (VecList n a) 302 | deriving via ViaFixed (VecList n) a instance (Arity n, Semigroup a) => Semigroup (VecList n a) 303 | deriving via ViaFixed (VecList n) a instance (Arity n, Monoid a) => Monoid (VecList n a) 304 | deriving via ViaFixed (VecList n) a instance (Arity n, Storable a) => Storable (VecList n a) 305 | 306 | 307 | 308 | deriving via ViaFixed (VecPeano n) instance (ArityPeano n) => Functor (VecPeano n) 309 | deriving via ViaFixed (VecPeano n) instance (ArityPeano n) => Applicative (VecPeano n) 310 | deriving via ViaFixed (VecPeano n) instance (ArityPeano n) => F.Foldable (VecPeano n) 311 | 312 | instance ArityPeano n => T.Traversable (VecPeano n) where 313 | sequence = sequence 314 | sequenceA = sequence 315 | traverse = mapM 316 | mapM = mapM 317 | {-# INLINE sequence #-} 318 | {-# INLINE sequenceA #-} 319 | {-# INLINE mapM #-} 320 | {-# INLINE traverse #-} 321 | 322 | deriving via ViaFixed (VecPeano n) a instance (ArityPeano n, Show a) => Show (VecPeano n a) 323 | deriving via ViaFixed (VecPeano n) a instance (ArityPeano n, Eq a) => Eq (VecPeano n a) 324 | deriving via ViaFixed (VecPeano n) a instance (ArityPeano n, Ord a) => Ord (VecPeano n a) 325 | deriving via ViaFixed (VecPeano n) a instance (ArityPeano n, NFData a) => NFData (VecPeano n a) 326 | deriving via ViaFixed (VecPeano n) a instance (ArityPeano n, Semigroup a) => Semigroup (VecPeano n a) 327 | deriving via ViaFixed (VecPeano n) a instance (ArityPeano n, Monoid a) => Monoid (VecPeano n a) 328 | deriving via ViaFixed (VecPeano n) a instance (ArityPeano n, Storable a) => Storable (VecPeano n a) 329 | 330 | 331 | 332 | -- | Single-element tuple. 333 | newtype Only a = Only a 334 | deriving (Show,Eq,Ord,Data,Functor,F.Foldable,T.Traversable) 335 | 336 | instance Monoid a => Monoid (Only a) where 337 | mempty = Only mempty 338 | mappend = (<>) 339 | instance (Semigroup a) => Semigroup (Only a) where 340 | (<>) = coerce ((<>) @a) 341 | {-# INLINE (<>) #-} 342 | 343 | 344 | instance NFData a => NFData (Only a) where 345 | rnf (Only a) = rnf a 346 | 347 | type instance Dim Only = C.N1 348 | 349 | instance Vector Only a where 350 | construct = Fun Only 351 | inspect (Only a) (Fun f) = f a 352 | {-# INLINE construct #-} 353 | {-# INLINE inspect #-} 354 | 355 | instance (Storable a) => Storable (Only a) where 356 | alignment = coerce (alignment @a) 357 | sizeOf = coerce (sizeOf @a) 358 | peek = coerce (peek @a) 359 | poke = coerce (poke @a) 360 | 361 | 362 | -- | Empty tuple. 363 | data Empty a = Empty 364 | deriving (Show,Eq,Ord,Data,Functor,F.Foldable,T.Traversable) 365 | 366 | instance NFData (Empty a) where 367 | rnf Empty = () 368 | 369 | type instance Dim Empty = 'Z 370 | 371 | instance Vector Empty a where 372 | construct = Fun Empty 373 | inspect _ (Fun b) = b 374 | {-# INLINE construct #-} 375 | {-# INLINE inspect #-} 376 | 377 | type Tuple2 a = (a,a) 378 | type Tuple3 a = (a,a,a) 379 | type Tuple4 a = (a,a,a,a) 380 | type Tuple5 a = (a,a,a,a,a) 381 | 382 | 383 | ---------------------------------------------------------------- 384 | -- Deriving 385 | ---------------------------------------------------------------- 386 | 387 | -- | Newtype for deriving instance for data types which has instance 388 | -- of 'Vector'. It supports 'Eq', 'Ord', 'Semigroup', 'Monoid', 389 | -- 'Storable', 'NFData', 'Functor', 'Applicative', 'Foldable'. 390 | newtype ViaFixed v a = ViaFixed (v a) 391 | 392 | type instance Dim (ViaFixed v) = Dim v 393 | 394 | instance Vector v a => Vector (ViaFixed v) a where 395 | construct = ViaFixed <$> construct 396 | inspect (ViaFixed v) = inspect v 397 | {-# INLINE construct #-} 398 | {-# INLINE inspect #-} 399 | 400 | instance (Vector v a, Show a) => Show (ViaFixed v a) where 401 | showsPrec = coerce (I.showsPrec @v @a) 402 | 403 | instance (Vector v a, Eq a) => Eq (ViaFixed v a) where 404 | (==) = coerce (eq @v @a) 405 | {-# INLINE (==) #-} 406 | 407 | instance (Vector v a, Ord a) => Ord (ViaFixed v a) where 408 | compare = coerce (ord @v @a) 409 | {-# INLINE compare #-} 410 | 411 | instance (Vector v a, NFData a) => NFData (ViaFixed v a) where 412 | rnf = coerce (defaultRnf @a @v) 413 | {-# INLINE rnf #-} 414 | 415 | instance (Vector v a, Semigroup a) => Semigroup (ViaFixed v a) where 416 | (<>) = coerce (zipWith @v @a (<>)) 417 | {-# INLINE (<>) #-} 418 | 419 | instance (Vector v a, Monoid a) => Monoid (ViaFixed v a) where 420 | mempty = coerce (replicate @v @a mempty) 421 | {-# INLINE mempty #-} 422 | 423 | instance (Vector v a, Storable a) => Storable (ViaFixed v a) where 424 | alignment = coerce (defaultAlignemnt @a @v) 425 | sizeOf = coerce (defaultSizeOf @a @v) 426 | peek = coerce (defaultPeek @a @v) 427 | poke = coerce (defaultPoke @a @v) 428 | {-# INLINE alignment #-} 429 | {-# INLINE sizeOf #-} 430 | {-# INLINE peek #-} 431 | {-# INLINE poke #-} 432 | 433 | instance (forall a. Vector v a) => Functor (ViaFixed v) where 434 | fmap = map 435 | {-# INLINE fmap #-} 436 | 437 | instance (forall a. Vector v a) => Applicative (ViaFixed v) where 438 | pure = replicate 439 | (<*>) = zipWith ($) 440 | liftA2 = zipWith 441 | a <* _ = a 442 | _ *> b = b 443 | {-# INLINE pure #-} 444 | {-# INLINE (<*>) #-} 445 | {-# INLINE (<*) #-} 446 | {-# INLINE (*>) #-} 447 | {-# INLINE liftA2 #-} 448 | 449 | instance (forall a. Vector v a) => F.Foldable (ViaFixed v) where 450 | foldMap' f = foldl' (\ acc a -> acc <> f a) mempty 451 | foldr = foldr 452 | foldl = foldl 453 | foldl' = foldl' 454 | toList = toList 455 | sum = sum 456 | product = foldl' (*) 0 457 | {-# INLINE foldMap' #-} 458 | {-# INLINE foldr #-} 459 | {-# INLINE foldl #-} 460 | {-# INLINE foldl' #-} 461 | {-# INLINE toList #-} 462 | {-# INLINE sum #-} 463 | {-# INLINE product #-} 464 | -- GHC<9.2 fails to compile this 465 | #if MIN_VERSION_base(4,16,0) 466 | length = length 467 | {-# INLINE length #-} 468 | #endif 469 | 470 | 471 | ---------------------------------------------------------------- 472 | -- Patterns 473 | ---------------------------------------------------------------- 474 | 475 | pattern V1 :: (Vector v a, Dim v ~ C.N1) => a -> v a 476 | pattern V1 x <- (convert -> (Only x)) where 477 | V1 x = mk1 x 478 | #if MIN_VERSION_base(4,16,0) 479 | {-# INLINE V1 #-} 480 | {-# COMPLETE V1 #-} 481 | #endif 482 | 483 | pattern V2 :: (Vector v a, Dim v ~ C.N2) => a -> a -> v a 484 | pattern V2 x y <- (convert -> (x,y)) where 485 | V2 x y = mk2 x y 486 | #if MIN_VERSION_base(4,16,0) 487 | {-# INLINE V2 #-} 488 | {-# COMPLETE V2 #-} 489 | #endif 490 | 491 | pattern V3 :: (Vector v a, Dim v ~ C.N3) => a -> a -> a -> v a 492 | pattern V3 x y z <- (convert -> (x,y,z)) where 493 | V3 x y z = mk3 x y z 494 | #if MIN_VERSION_base(4,16,0) 495 | {-# INLINE V3 #-} 496 | {-# COMPLETE V3 #-} 497 | #endif 498 | 499 | pattern V4 :: (Vector v a, Dim v ~ C.N4) => a -> a -> a -> a -> v a 500 | pattern V4 t x y z <- (convert -> (t,x,y,z)) where 501 | V4 t x y z = mk4 t x y z 502 | #if MIN_VERSION_base(4,16,0) 503 | {-# INLINE V4 #-} 504 | {-# COMPLETE V4 #-} 505 | #endif 506 | 507 | -- $setup 508 | -- 509 | -- >>> import Data.Char 510 | -- >>> import Prelude (Int,Bool(..)) 511 | -------------------------------------------------------------------------------- /fixed-vector/Data/Vector/Fixed/Internal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MagicHash #-} 2 | {-# LANGUAGE PolyKinds #-} 3 | -- | 4 | -- Implementation of fixed-vectors 5 | module Data.Vector.Fixed.Internal where 6 | 7 | import Control.DeepSeq (NFData(..)) 8 | import qualified Data.Foldable as T 9 | import qualified Data.Traversable as T 10 | import Foreign.Storable (Storable(..)) 11 | import Foreign.Ptr (Ptr,castPtr) 12 | import GHC.Exts (proxy#) 13 | 14 | import Data.Vector.Fixed.Cont (Vector(..),Dim,vector,Add,PeanoNum(..), 15 | Peano,Index,ArityPeano) 16 | import qualified Data.Vector.Fixed.Cont as C 17 | 18 | import Prelude hiding ( replicate,map,zipWith,maximum,minimum,and,or,all,any 19 | , foldl,foldr,foldl1,length,sum,reverse,scanl,scanl1 20 | , head,tail,mapM,mapM_,sequence,sequence_,concat 21 | ) 22 | 23 | 24 | ---------------------------------------------------------------- 25 | -- Constructors 26 | ---------------------------------------------------------------- 27 | 28 | mk0 :: (Vector v a, Dim v ~ 'Z) => v a 29 | mk0 = vector C.empty 30 | {-# INLINE mk0 #-} 31 | 32 | mk1 :: (Vector v a, Dim v ~ C.N1) => a -> v a 33 | mk1 a1 = vector $ C.mk1 a1 34 | {-# INLINE mk1 #-} 35 | 36 | mk2 :: (Vector v a, Dim v ~ C.N2) => a -> a -> v a 37 | mk2 a1 a2 = vector $ C.mk2 a1 a2 38 | {-# INLINE mk2 #-} 39 | 40 | mk3 :: (Vector v a, Dim v ~ C.N3) => a -> a -> a -> v a 41 | mk3 a1 a2 a3 = vector $ C.mk3 a1 a2 a3 42 | {-# INLINE mk3 #-} 43 | 44 | mk4 :: (Vector v a, Dim v ~ C.N4) => a -> a -> a -> a -> v a 45 | mk4 a1 a2 a3 a4 = vector $ C.mk4 a1 a2 a3 a4 46 | {-# INLINE mk4 #-} 47 | 48 | mk5 :: (Vector v a, Dim v ~ C.N5) => a -> a -> a -> a -> a -> v a 49 | mk5 a1 a2 a3 a4 a5 = vector $ C.mk5 a1 a2 a3 a4 a5 50 | {-# INLINE mk5 #-} 51 | 52 | mk6 :: (Vector v a, Dim v ~ C.N6) => a -> a -> a -> a -> a -> a -> v a 53 | mk6 a1 a2 a3 a4 a5 a6 = vector $ C.mk6 a1 a2 a3 a4 a5 a6 54 | {-# INLINE mk6 #-} 55 | 56 | mk7 :: (Vector v a, Dim v ~ C.N7) => a -> a -> a -> a -> a -> a -> a -> v a 57 | mk7 a1 a2 a3 a4 a5 a6 a7 = vector $ C.mk7 a1 a2 a3 a4 a5 a6 a7 58 | {-# INLINE mk7 #-} 59 | 60 | mk8 :: (Vector v a, Dim v ~ C.N8) => a -> a -> a -> a -> a -> a -> a -> a -> v a 61 | mk8 a1 a2 a3 a4 a5 a6 a7 a8 = vector $ C.mk8 a1 a2 a3 a4 a5 a6 a7 a8 62 | {-# INLINE mk8 #-} 63 | 64 | -- | N-ary constructor. Despite scary signature it's just N-ary 65 | -- function with additional type parameter which is used to fix type 66 | -- of vector being constructed. It could be used as: 67 | -- 68 | -- > v = mkN (Proxy :: Proxy (Int,Int,Int)) 1 2 3 69 | -- 70 | -- or using @TypeApplications@ syntax: 71 | -- 72 | -- > v = mkN (Proxy @(Int,Int,Int)) 1 2 3 73 | -- 74 | -- or if type of @v@ is fixed elsewhere 75 | -- 76 | -- > v = mkN [v] 1 2 3 77 | mkN :: forall proxy v a. (Vector v a) 78 | => proxy (v a) -> C.Fn (Dim v) a (v a) 79 | mkN _ = C.unFun (construct :: C.Fun (Dim v) a (v a)) 80 | 81 | ---------------------------------------------------------------- 82 | -- Generic functions 83 | ---------------------------------------------------------------- 84 | 85 | -- | Replicate value /n/ times. 86 | -- 87 | -- Examples: 88 | -- 89 | -- >>> import Data.Vector.Fixed.Boxed (Vec2) 90 | -- >>> replicate 1 :: Vec2 Int 91 | -- [1,1] 92 | -- 93 | -- >>> replicate 2 :: (Double,Double,Double) 94 | -- (2.0,2.0,2.0) 95 | -- 96 | -- >>> import Data.Vector.Fixed.Boxed (Vec4) 97 | -- >>> replicate "foo" :: Vec4 String 98 | -- ["foo","foo","foo","foo"] 99 | replicate :: Vector v a => a -> v a 100 | {-# INLINE replicate #-} 101 | replicate 102 | = vector . C.replicate 103 | 104 | 105 | -- | Execute monadic action for every element of vector. 106 | -- 107 | -- Examples: 108 | -- 109 | -- >>> import Data.Vector.Fixed.Boxed (Vec2,Vec3) 110 | -- >>> replicateM (Just 3) :: Maybe (Vec3 Int) 111 | -- Just [3,3,3] 112 | -- >>> replicateM (putStrLn "Hi!") :: IO (Vec2 ()) 113 | -- Hi! 114 | -- Hi! 115 | -- [(),()] 116 | replicateM :: (Vector v a, Applicative f) => f a -> f (v a) 117 | {-# INLINE replicateM #-} 118 | replicateM 119 | = fmap vector . C.replicateM 120 | 121 | 122 | -- | Unit vector along Nth axis. If index is larger than vector 123 | -- dimensions returns zero vector. 124 | -- 125 | -- Examples: 126 | -- 127 | -- >>> import Data.Vector.Fixed.Boxed (Vec3) 128 | -- >>> basis 0 :: Vec3 Int 129 | -- [1,0,0] 130 | -- >>> basis 1 :: Vec3 Int 131 | -- [0,1,0] 132 | -- >>> basis 3 :: Vec3 Int 133 | -- [0,0,0] 134 | basis :: (Vector v a, Num a) => Int -> v a 135 | {-# INLINE basis #-} 136 | basis = vector . C.basis 137 | 138 | 139 | -- | Unfold vector. 140 | unfoldr :: (Vector v a) => (b -> (a,b)) -> b -> v a 141 | {-# INLINE unfoldr #-} 142 | unfoldr f = vector . C.unfoldr f 143 | 144 | 145 | -- | Generate vector from function which maps element's index to its 146 | -- value. 147 | -- 148 | -- Examples: 149 | -- 150 | -- >>> import Data.Vector.Fixed.Unboxed (Vec4) 151 | -- >>> generate (^2) :: Vec4 Int 152 | -- [0,1,4,9] 153 | generate :: (Vector v a) => (Int -> a) -> v a 154 | {-# INLINE generate #-} 155 | generate = vector . C.generate 156 | 157 | 158 | -- | Generate vector from monadic function which maps element's index 159 | -- to its value. 160 | generateM :: (Applicative f, Vector v a) => (Int -> f a) -> f (v a) 161 | {-# INLINE generateM #-} 162 | generateM = fmap vector . C.generateM 163 | 164 | 165 | 166 | ---------------------------------------------------------------- 167 | 168 | -- | First element of vector. 169 | -- 170 | -- Examples: 171 | -- 172 | -- >>> import Data.Vector.Fixed.Boxed (Vec3) 173 | -- >>> let x = mk3 1 2 3 :: Vec3 Int 174 | -- >>> head x 175 | -- 1 176 | head :: (Vector v a, Dim v ~ 'S k) => v a -> a 177 | {-# INLINE head #-} 178 | head = C.head . C.cvec 179 | 180 | 181 | -- | Tail of vector. 182 | -- 183 | -- Examples: 184 | -- 185 | -- >>> import Data.Complex 186 | -- >>> tail (1,2,3) :: Complex Double 187 | -- 2.0 :+ 3.0 188 | tail :: (Vector v a, Vector w a, Dim v ~ 'S (Dim w)) 189 | => v a -> w a 190 | {-# INLINE tail #-} 191 | tail = vector . C.tail . C.cvec 192 | 193 | -- | Cons element to the vector 194 | cons :: (Vector v a, Vector w a, Dim w ~ 'S (Dim v)) 195 | => a -> v a -> w a 196 | {-# INLINE cons #-} 197 | cons a = vector . C.cons a . C.cvec 198 | 199 | -- | Append element to the vector 200 | snoc :: (Vector v a, Vector w a, Dim w ~ 'S (Dim v)) 201 | => a -> v a -> w a 202 | {-# INLINE snoc #-} 203 | snoc a = vector . C.snoc a . C.cvec 204 | 205 | concat :: ( Vector v a, Vector u a, Vector w a 206 | , (Dim v `Add` Dim u) ~ Dim w 207 | ) 208 | => v a -> u a -> w a 209 | {-# INLINE concat #-} 210 | concat v u = vector $ C.concat (C.cvec v) (C.cvec u) 211 | 212 | -- | Reverse order of elements in the vector 213 | reverse :: Vector v a => v a -> v a 214 | reverse = vector . C.reverse . C.cvec 215 | {-# INLINE reverse #-} 216 | 217 | -- | Retrieve vector's element at index. Generic implementation is 218 | -- /O(n)/ but more efficient one is used when possible. 219 | (!) :: (Vector v a) => v a -> Int -> a 220 | {-# INLINE (!) #-} 221 | (!) v n = runIndex n (C.cvec v) 222 | 223 | -- Used in rewriting of index function. 224 | runIndex :: ArityPeano n => Int -> C.ContVec n r -> r 225 | runIndex = C.index 226 | {-# INLINE[0] runIndex #-} 227 | 228 | -- We are trying to be clever with indexing here. It's not possible to 229 | -- write generic indexing function. For example it's necessary O(n) 230 | -- for VecList. It's however possible to write O(1) indexing for some 231 | -- vectors and we trying to use such functions where possible. 232 | -- 233 | -- We try to use presumable more efficient basicIndex 234 | -- 235 | -- 1. It should not interfere with deforestation. So we should 236 | -- rewrite only when deforestation rule already fired. 237 | -- (starting from phase 1). 238 | -- 239 | -- 2. Creation of vector is costlier than generic indexing so we should 240 | -- apply rule only when vector is created anyway 241 | -- 242 | -- In order to avoid firing this rule on implementation of (!) it has 243 | -- been necessary to move definition of all functions to internal module. 244 | 245 | {-# RULES 246 | "fixed-vector:index/basicIndex"[1] forall vv i. 247 | runIndex i (C.cvec vv) = C.basicIndex vv i 248 | #-} 249 | 250 | 251 | -- | Get element from vector at statically known index 252 | index :: forall k v a proxy. (Vector v a, Index (Peano k) (Dim v)) 253 | => v a -> proxy k -> a 254 | {-# INLINE index #-} 255 | index v _ = inspect v (C.getF (proxy# @(Peano k))) 256 | 257 | -- | Set n'th element in the vector 258 | set :: forall k v a proxy. (Vector v a, Index (Peano k) (Dim v)) 259 | => proxy k -> a -> v a -> v a 260 | {-# INLINE set #-} 261 | set _ a v 262 | = inspect v 263 | $ C.putF (proxy# @(Peano k)) a construct 264 | 265 | -- | Twan van Laarhoven's lens for element of vector 266 | element :: (Vector v a, Functor f) => Int -> (a -> f a) -> (v a -> f (v a)) 267 | {-# INLINE element #-} 268 | element i f v = vector `fmap` C.element i f (C.cvec v) 269 | 270 | -- | Twan van Laarhoven's lens for element of vector with statically 271 | -- known index. 272 | elementTy :: forall k v a f proxy. (Vector v a, Index (Peano k) (Dim v), Functor f) 273 | => proxy k -> (a -> f a) -> (v a -> f (v a)) 274 | {-# INLINE elementTy #-} 275 | elementTy _ f v 276 | = fmap vector 277 | $ inspect (C.cvec v) 278 | (C.lensF (proxy# @(Peano k)) f construct) 279 | 280 | -- | Left fold over vector 281 | foldl :: Vector v a => (b -> a -> b) -> b -> v a -> b 282 | {-# INLINE foldl #-} 283 | foldl f x = C.foldl f x 284 | . C.cvec 285 | 286 | -- | Strict left fold over vector 287 | foldl' :: Vector v a => (b -> a -> b) -> b -> v a -> b 288 | {-# INLINE foldl' #-} 289 | foldl' f x = C.foldl' f x 290 | . C.cvec 291 | 292 | -- | Right fold over vector 293 | foldr :: Vector v a => (a -> b -> b) -> b -> v a -> b 294 | {-# INLINE foldr #-} 295 | foldr f x = C.foldr f x 296 | . C.cvec 297 | 298 | 299 | -- | Left fold over vector 300 | foldl1 :: (Vector v a, Dim v ~ 'S k) => (a -> a -> a) -> v a -> a 301 | {-# INLINE foldl1 #-} 302 | foldl1 f = C.foldl1 f 303 | . C.cvec 304 | 305 | -- | Combine the elements of a structure using a monoid. Similar to 306 | -- 'T.fold' 307 | fold :: (Vector v m, Monoid m) => v m -> m 308 | {-# INLINE fold #-} 309 | fold = T.fold 310 | . C.cvec 311 | 312 | -- | Map each element of the structure to a monoid, 313 | -- and combine the results. Similar to 'T.foldMap' 314 | foldMap :: (Vector v a, Monoid m) => (a -> m) -> v a -> m 315 | {-# INLINE foldMap #-} 316 | foldMap f = T.foldMap f 317 | . C.cvec 318 | 319 | -- | Right fold over vector 320 | ifoldr :: Vector v a => (Int -> a -> b -> b) -> b -> v a -> b 321 | {-# INLINE ifoldr #-} 322 | ifoldr f x = C.ifoldr f x 323 | . C.cvec 324 | 325 | -- | Left fold over vector. Function is applied to each element and 326 | -- its index. 327 | ifoldl :: Vector v a => (b -> Int -> a -> b) -> b -> v a -> b 328 | {-# INLINE ifoldl #-} 329 | ifoldl f z = C.ifoldl f z 330 | . C.cvec 331 | 332 | -- | Strict left fold over vector. Function is applied to each element 333 | -- and its index. 334 | ifoldl' :: Vector v a => (b -> Int -> a -> b) -> b -> v a -> b 335 | {-# INLINE ifoldl' #-} 336 | ifoldl' f z = C.ifoldl' f z 337 | . C.cvec 338 | 339 | -- | Monadic fold over vector. 340 | foldM :: (Vector v a, Monad m) => (b -> a -> m b) -> b -> v a -> m b 341 | {-# INLINE foldM #-} 342 | foldM f x = C.foldM f x . C.cvec 343 | 344 | -- | Left monadic fold over vector. Function is applied to each element and 345 | -- its index. 346 | ifoldM :: (Vector v a, Monad m) => (b -> Int -> a -> m b) -> b -> v a -> m b 347 | {-# INLINE ifoldM #-} 348 | ifoldM f x = C.ifoldM f x . C.cvec 349 | 350 | 351 | 352 | ---------------------------------------------------------------- 353 | 354 | -- | Sum all elements in the vector. 355 | sum :: (Vector v a, Num a) => v a -> a 356 | sum = C.sum . C.cvec 357 | {-# INLINE sum #-} 358 | 359 | -- | Maximal element of vector. 360 | -- 361 | -- Examples: 362 | -- 363 | -- >>> import Data.Vector.Fixed.Boxed (Vec3) 364 | -- >>> let x = mk3 1 2 3 :: Vec3 Int 365 | -- >>> maximum x 366 | -- 3 367 | maximum :: (Vector v a, Dim v ~ S k, Ord a) => v a -> a 368 | maximum = C.maximum . C.cvec 369 | {-# INLINE maximum #-} 370 | 371 | -- | Minimal element of vector. 372 | -- 373 | -- Examples: 374 | -- 375 | -- >>> import Data.Vector.Fixed.Boxed (Vec3) 376 | -- >>> let x = mk3 1 2 3 :: Vec3 Int 377 | -- >>> minimum x 378 | -- 1 379 | minimum :: (Vector v a, Dim v ~ S k, Ord a) => v a -> a 380 | minimum = C.minimum . C.cvec 381 | {-# INLINE minimum #-} 382 | 383 | -- | Conjunction of all elements of a vector. 384 | and :: (Vector v Bool) => v Bool -> Bool 385 | and = C.and . C.cvec 386 | {-# INLINE and #-} 387 | 388 | -- | Disjunction of all elements of a vector. 389 | or :: (Vector v Bool) => v Bool -> Bool 390 | or = C.or . C.cvec 391 | {-# INLINE or #-} 392 | 393 | -- | Determines whether all elements of vector satisfy predicate. 394 | all :: (Vector v a) => (a -> Bool) -> v a -> Bool 395 | all f = (C.all f) . C.cvec 396 | {-# INLINE all #-} 397 | 398 | -- | Determines whether any of element of vector satisfy predicate. 399 | any :: (Vector v a) => (a -> Bool) -> v a -> Bool 400 | any f = (C.any f) . C.cvec 401 | {-# INLINE any #-} 402 | 403 | -- | The 'find' function takes a predicate and a vector and returns 404 | -- the leftmost element of the vector matching the predicate, 405 | -- or 'Nothing' if there is no such element. 406 | find :: (Vector v a) => (a -> Bool) -> v a -> Maybe a 407 | find f = (C.find f) . C.cvec 408 | {-# INLINE find #-} 409 | 410 | ---------------------------------------------------------------- 411 | 412 | -- | Test two vectors for equality. 413 | -- 414 | -- Examples: 415 | -- 416 | -- >>> import Data.Vector.Fixed.Boxed (Vec2) 417 | -- >>> let v0 = basis 0 :: Vec2 Int 418 | -- >>> let v1 = basis 1 :: Vec2 Int 419 | -- >>> v0 `eq` v0 420 | -- True 421 | -- >>> v0 `eq` v1 422 | -- False 423 | eq :: (Vector v a, Eq a) => v a -> v a -> Bool 424 | {-# INLINE eq #-} 425 | eq v w = C.and 426 | $ C.zipWith (==) (C.cvec v) (C.cvec w) 427 | 428 | 429 | -- | Lexicographic ordering of two vectors. 430 | ord :: (Vector v a, Ord a) => v a -> v a -> Ordering 431 | {-# INLINE ord #-} 432 | ord v w = C.foldl mappend mempty 433 | $ C.zipWith compare (C.cvec v) (C.cvec w) 434 | 435 | 436 | 437 | ---------------------------------------------------------------- 438 | 439 | -- | Map over vector 440 | map :: (Vector v a, Vector v b) => (a -> b) -> v a -> v b 441 | {-# INLINE map #-} 442 | map f = vector 443 | . C.map f 444 | . C.cvec 445 | 446 | -- | Evaluate every action in the vector from left to right. 447 | sequence :: (Vector v a, Vector v (f a), Applicative f) => v (f a) -> f (v a) 448 | {-# INLINE sequence #-} 449 | sequence = mapM id 450 | 451 | -- | Evaluate every action in the vector from left to right and ignore result 452 | sequence_ :: (Vector v (f a), Applicative f) => v (f a) -> f () 453 | {-# INLINE sequence_ #-} 454 | sequence_ = mapM_ id 455 | 456 | 457 | -- | Effectful map over vector. 458 | mapM :: (Vector v a, Vector v b, Applicative f) => (a -> f b) -> v a -> f (v b) 459 | {-# INLINE mapM #-} 460 | mapM f = fmap vector 461 | . C.mapM f 462 | . C.cvec 463 | 464 | -- | Apply monadic action to each element of vector and ignore result. 465 | mapM_ :: (Vector v a, Applicative f) => (a -> f b) -> v a -> f () 466 | {-# INLINE mapM_ #-} 467 | mapM_ f = C.mapM_ f 468 | . C.cvec 469 | 470 | 471 | -- | Apply function to every element of the vector and its index. 472 | imap :: (Vector v a, Vector v b) => 473 | (Int -> a -> b) -> v a -> v b 474 | {-# INLINE imap #-} 475 | imap f = vector 476 | . C.imap f 477 | . C.cvec 478 | 479 | -- | Apply monadic function to every element of the vector and its index. 480 | imapM :: (Vector v a, Vector v b, Applicative f) 481 | => (Int -> a -> f b) -> v a -> f (v b) 482 | {-# INLINE imapM #-} 483 | imapM f = fmap vector 484 | . C.imapM f 485 | . C.cvec 486 | 487 | -- | Apply monadic function to every element of the vector and its 488 | -- index and discard result. 489 | imapM_ :: (Vector v a, Applicative f) => (Int -> a -> f b) -> v a -> f () 490 | {-# INLINE imapM_ #-} 491 | imapM_ f = C.imapM_ f 492 | . C.cvec 493 | 494 | -- | Left scan over vector 495 | scanl :: (Vector v a, Vector w b, Dim w ~ 'S (Dim v)) 496 | => (b -> a -> b) -> b -> v a -> w b 497 | {-# INLINE scanl #-} 498 | scanl f x0 = vector . C.scanl f x0 . C.cvec 499 | 500 | -- | Left scan over vector 501 | scanl1 :: (Vector v a) 502 | => (a -> a -> a) -> v a -> v a 503 | {-# INLINE scanl1 #-} 504 | scanl1 f = vector . C.scanl1 f . C.cvec 505 | 506 | -- | Analog of 'T.sequenceA' from 'T.Traversable'. 507 | sequenceA :: (Vector v a, Vector v (f a), Applicative f) 508 | => v (f a) -> f (v a) 509 | {-# INLINE sequenceA #-} 510 | sequenceA = sequence 511 | {-# DEPRECATED sequenceA "Use sequence instead" #-} 512 | 513 | -- | Analog of 'T.traverse' from 'T.Traversable'. 514 | traverse :: (Vector v a, Vector v b, Applicative f) 515 | => (a -> f b) -> v a -> f (v b) 516 | {-# INLINE traverse #-} 517 | traverse f = fmap vector . T.traverse f . C.cvec 518 | 519 | distribute :: (Vector v a, Vector v (f a), Functor f) 520 | => f (v a) -> v (f a) 521 | {-# INLINE distribute #-} 522 | distribute = vector . C.distribute . fmap C.cvec 523 | 524 | collect :: (Vector v a, Vector v b, Vector v (f b), Functor f) 525 | => (a -> v b) -> f a -> v (f b) 526 | {-# INLINE collect #-} 527 | collect f = vector . C.collect (C.cvec . f) 528 | 529 | 530 | 531 | ---------------------------------------------------------------- 532 | 533 | -- | Zip two vector together using function. 534 | -- 535 | -- Examples: 536 | -- 537 | -- >>> import Data.Vector.Fixed.Boxed (Vec3) 538 | -- >>> let b0 = basis 0 :: Vec3 Int 539 | -- >>> let b1 = basis 1 :: Vec3 Int 540 | -- >>> let b2 = basis 2 :: Vec3 Int 541 | -- >>> let vplus x y = zipWith (+) x y 542 | -- >>> vplus b0 b1 543 | -- [1,1,0] 544 | -- >>> vplus b0 b2 545 | -- [1,0,1] 546 | -- >>> vplus b1 b2 547 | -- [0,1,1] 548 | zipWith :: (Vector v a, Vector v b, Vector v c) 549 | => (a -> b -> c) -> v a -> v b -> v c 550 | {-# INLINE zipWith #-} 551 | zipWith f v u = vector 552 | $ C.zipWith f (C.cvec v) (C.cvec u) 553 | 554 | -- | Zip three vector together 555 | zipWith3 556 | :: (Vector v a, Vector v b, Vector v c, Vector v d) 557 | => (a -> b -> c -> d) 558 | -> v a -> v b -> v c 559 | -> v d 560 | {-# INLINE zipWith3 #-} 561 | zipWith3 f v1 v2 v3 562 | = vector 563 | $ C.zipWith3 f (C.cvec v1) (C.cvec v2) (C.cvec v3) 564 | 565 | -- | Zip two vector together using monadic function. 566 | zipWithM :: (Vector v a, Vector v b, Vector v c, Applicative f) 567 | => (a -> b -> f c) -> v a -> v b -> f (v c) 568 | {-# INLINE zipWithM #-} 569 | zipWithM f v u = fmap vector 570 | $ C.zipWithM f (C.cvec v) (C.cvec u) 571 | 572 | -- | Zip two vector elementwise using monadic function and discard 573 | -- result 574 | zipWithM_ 575 | :: (Vector v a, Vector v b, Applicative f) 576 | => (a -> b -> f c) -> v a -> v b -> f () 577 | {-# INLINE zipWithM_ #-} 578 | zipWithM_ f xs ys = C.zipWithM_ f (C.cvec xs) (C.cvec ys) 579 | 580 | -- | Zip two vector together using function which takes element index 581 | -- as well. 582 | izipWith :: (Vector v a, Vector v b, Vector v c) 583 | => (Int -> a -> b -> c) -> v a -> v b -> v c 584 | {-# INLINE izipWith #-} 585 | izipWith f v u = vector 586 | $ C.izipWith f (C.cvec v) (C.cvec u) 587 | 588 | -- | Zip three vector together 589 | izipWith3 590 | :: (Vector v a, Vector v b, Vector v c, Vector v d) 591 | => (Int -> a -> b -> c -> d) 592 | -> v a -> v b -> v c 593 | -> v d 594 | {-# INLINE izipWith3 #-} 595 | izipWith3 f v1 v2 v3 596 | = vector 597 | $ C.izipWith3 f (C.cvec v1) (C.cvec v2) (C.cvec v3) 598 | 599 | -- | Zip two vector together using monadic function which takes element 600 | -- index as well.. 601 | izipWithM :: (Vector v a, Vector v b, Vector v c, Applicative f) 602 | => (Int -> a -> b -> f c) -> v a -> v b -> f (v c) 603 | {-# INLINE izipWithM #-} 604 | izipWithM f v u = fmap vector 605 | $ C.izipWithM f (C.cvec v) (C.cvec u) 606 | 607 | -- | Zip two vector elementwise using monadic function and discard 608 | -- result 609 | izipWithM_ 610 | :: (Vector v a, Vector v b, Vector v c, Applicative f, Vector v (f c)) 611 | => (Int -> a -> b -> f c) -> v a -> v b -> f () 612 | {-# INLINE izipWithM_ #-} 613 | izipWithM_ f xs ys = C.izipWithM_ f (C.cvec xs) (C.cvec ys) 614 | 615 | 616 | ---------------------------------------------------------------- 617 | 618 | -- | Default implementation of 'alignment' for 'Storable' type class 619 | -- for fixed vectors. 620 | defaultAlignemnt :: forall a v. Storable a => v a -> Int 621 | defaultAlignemnt _ = alignment (undefined :: a) 622 | {-# INLINE defaultAlignemnt #-} 623 | 624 | 625 | -- | Default implementation of 'sizeOf` for 'Storable' type class for 626 | -- fixed vectors 627 | defaultSizeOf 628 | :: forall a v. (Storable a, Vector v a) 629 | => v a -> Int 630 | defaultSizeOf _ = sizeOf (undefined :: a) * C.peanoToInt (proxy# @(Dim v)) 631 | {-# INLINE defaultSizeOf #-} 632 | 633 | -- | Default implementation of 'peek' for 'Storable' type class for 634 | -- fixed vector 635 | defaultPeek :: (Storable a, Vector v a) => Ptr (v a) -> IO (v a) 636 | {-# INLINE defaultPeek #-} 637 | defaultPeek ptr 638 | = generateM (peekElemOff (castPtr ptr)) 639 | 640 | -- | Default implementation of 'poke' for 'Storable' type class for 641 | -- fixed vector 642 | defaultPoke :: (Storable a, Vector v a) => Ptr (v a) -> v a -> IO () 643 | {-# INLINE defaultPoke #-} 644 | defaultPoke ptr 645 | = imapM_ (pokeElemOff (castPtr ptr)) 646 | 647 | -- | Default implementation of 'rnf' from `NFData' type class 648 | defaultRnf :: (NFData a, Vector v a) => v a -> () 649 | defaultRnf = foldl (\() a -> rnf a) () 650 | 651 | ---------------------------------------------------------------- 652 | 653 | -- | Convert between different vector types 654 | convert :: (Vector v a, Vector w a, Dim v ~ Dim w) => v a -> w a 655 | {-# INLINE convert #-} 656 | convert = vector . C.cvec 657 | 658 | -- | Convert vector to the list 659 | toList :: (Vector v a) => v a -> [a] 660 | toList = foldr (:) [] 661 | {-# INLINE toList #-} 662 | 663 | -- | Create vector form list. Will throw error if list is shorter than 664 | -- resulting vector. 665 | fromList :: (Vector v a) => [a] -> v a 666 | {-# INLINE fromList #-} 667 | fromList = vector . C.fromList 668 | 669 | -- | Create vector form list. Will throw error if list has different 670 | -- length from resulting vector. 671 | fromList' :: (Vector v a) => [a] -> v a 672 | {-# INLINE fromList' #-} 673 | fromList' = vector . C.fromList' 674 | 675 | -- | Create vector form list. Will return @Nothing@ if list has different 676 | -- length from resulting vector. 677 | fromListM :: (Vector v a) => [a] -> Maybe (v a) 678 | {-# INLINE fromListM #-} 679 | fromListM = fmap vector . C.fromListM 680 | 681 | -- | Create vector from 'Foldable' data type. Will return @Nothing@ if 682 | -- data type different number of elements that resulting vector. 683 | fromFoldable :: (Vector v a, T.Foldable f) => f a -> Maybe (v a) 684 | {-# INLINE fromFoldable #-} 685 | fromFoldable = fromListM . T.toList 686 | 687 | -- | Generic definition of 'Prelude.showsPrec' 688 | showsPrec :: (Vector v a, Show a) => Int -> v a -> ShowS 689 | showsPrec _ = shows . toList 690 | {-# INLINE showsPrec #-} 691 | -------------------------------------------------------------------------------- /fixed-vector/Data/Vector/Fixed/Cont.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE MagicHash #-} 3 | {-# LANGUAGE PolyKinds #-} 4 | {-# LANGUAGE UndecidableInstances #-} 5 | -- | 6 | -- API for Church-encoded vectors. Implementation of function from 7 | -- "Data.Vector.Fixed" module uses these function internally in order 8 | -- to provide shortcut fusion. 9 | module Data.Vector.Fixed.Cont ( 10 | -- * Type-level numbers 11 | PeanoNum(..) 12 | , N1,N2,N3,N4,N5,N6,N7,N8 13 | , Peano 14 | , Add 15 | -- * N-ary functions 16 | , Fn 17 | , Fun(..) 18 | , Arity 19 | , ArityPeano(..) 20 | , apply 21 | , applyM 22 | , Index(..) 23 | -- ** Combinators 24 | , constFun 25 | , curryFirst 26 | , uncurryFirst 27 | , curryLast 28 | , curryMany 29 | , apLast 30 | , shuffleFun 31 | , withFun 32 | , dimapFun 33 | -- * Vector type class 34 | , Dim 35 | , Vector(..) 36 | , length 37 | -- * Vector as continuation 38 | , ContVec(..) 39 | , consPeano 40 | , runContVec 41 | -- * Construction of ContVec 42 | , cvec 43 | , fromList 44 | , fromList' 45 | , fromListM 46 | , toList 47 | , replicate 48 | , replicateM 49 | , generate 50 | , generateM 51 | , unfoldr 52 | , basis 53 | -- ** Constructors 54 | , empty 55 | , cons 56 | , consV 57 | , snoc 58 | , concat 59 | , mk1 60 | , mk2 61 | , mk3 62 | , mk4 63 | , mk5 64 | , mk6 65 | , mk7 66 | , mk8 67 | -- * Transformations 68 | , map 69 | , imap 70 | , mapM 71 | , imapM 72 | , mapM_ 73 | , imapM_ 74 | , scanl 75 | , scanl1 76 | , sequence 77 | , sequence_ 78 | , distribute 79 | , collect 80 | , tail 81 | , reverse 82 | -- ** Zips 83 | , zipWith 84 | , zipWith3 85 | , izipWith 86 | , izipWith3 87 | , zipWithM 88 | , zipWithM_ 89 | , izipWithM 90 | , izipWithM_ 91 | -- ** Getters 92 | , head 93 | , index 94 | , element 95 | -- ** Vector construction 96 | , vector 97 | -- ** Folds 98 | , foldl 99 | , foldl' 100 | , foldl1 101 | , foldl1' 102 | , foldr 103 | , ifoldl 104 | , ifoldl' 105 | , ifoldr 106 | , foldM 107 | , ifoldM 108 | -- *** Special folds 109 | , sum 110 | , minimum 111 | , maximum 112 | , and 113 | , or 114 | , all 115 | , any 116 | , find 117 | -- ** Data.Data.Data 118 | , gfoldl 119 | , gunfold 120 | ) where 121 | 122 | import Control.Applicative ((<|>), Const(..)) 123 | import Data.Coerce 124 | import Data.Complex (Complex(..)) 125 | import Data.Data (Data) 126 | import Data.Kind (Type) 127 | import Data.Functor.Identity (Identity(..)) 128 | import Data.Typeable (Proxy(..)) 129 | import qualified Data.Foldable as F 130 | import qualified Data.Traversable as T 131 | import Unsafe.Coerce (unsafeCoerce) 132 | import GHC.TypeLits 133 | import GHC.Exts (Proxy#, proxy#) 134 | import Prelude ( Bool(..), Int, Maybe(..), Either(..) 135 | , Eq(..), Ord(..), Num(..), Functor(..), Applicative(..), Monad(..) 136 | , Semigroup(..), Monoid(..) 137 | , (.), ($), (&&), (||), (<$>), id, error, otherwise, fst 138 | ) 139 | 140 | 141 | ---------------------------------------------------------------- 142 | -- Naturals 143 | ---------------------------------------------------------------- 144 | 145 | -- | Peano numbers. Since type level naturals don't support induction 146 | -- we have to convert type nats to Peano representation first and 147 | -- work with it, 148 | data PeanoNum = Z 149 | | S PeanoNum 150 | 151 | type N1 = S Z 152 | type N2 = S N1 153 | type N3 = S N2 154 | type N4 = S N3 155 | type N5 = S N4 156 | type N6 = S N5 157 | type N7 = S N6 158 | type N8 = S N7 159 | 160 | 161 | -- | Convert type level natural to Peano representation 162 | type family Peano (n :: Nat) :: PeanoNum where 163 | Peano 0 = 'Z 164 | Peano n = 'S (Peano (n - 1)) 165 | 166 | -- | Type family for sum of unary natural numbers. 167 | type family Add (n :: PeanoNum) (m :: PeanoNum) :: PeanoNum where 168 | Add 'Z n = n 169 | Add ('S n) k = 'S (Add n k) 170 | 171 | 172 | ---------------------------------------------------------------- 173 | -- N-ary functions 174 | ---------------------------------------------------------------- 175 | 176 | -- | Type family for n-ary functions. @n@ is number of parameters of 177 | -- type @a@ and @b@ is result type. 178 | type family Fn (n :: PeanoNum) (a :: Type) (b :: Type) where 179 | Fn 'Z a b = b 180 | Fn ('S n) a b = a -> Fn n a b 181 | 182 | -- | Newtype wrapper which is used to make 'Fn' injective. It's a 183 | -- function which takes @n@ parameters of type @a@ and returns value 184 | -- of type @b@. 185 | newtype Fun n a b = Fun { unFun :: Fn n a b } 186 | 187 | 188 | instance ArityPeano n => Functor (Fun n a) where 189 | fmap f fun 190 | = accum (\(T_Flip g) a -> T_Flip (curryFirst g a)) 191 | (\(T_Flip x) -> f (unFun x)) 192 | (T_Flip fun) 193 | {-# INLINE fmap #-} 194 | 195 | instance ArityPeano n => Applicative (Fun n a) where 196 | pure x = accum (\Proxy _ -> Proxy) 197 | (\Proxy -> x) 198 | Proxy 199 | (Fun f0 :: Fun n a (p -> q)) <*> (Fun g0 :: Fun n a p) 200 | = accum (\(T_ap f g) a -> T_ap (f a) (g a)) 201 | (\(T_ap f g) -> f g) 202 | (T_ap f0 g0 :: T_ap a (p -> q) p n) 203 | {-# INLINE pure #-} 204 | {-# INLINE (<*>) #-} 205 | 206 | -- | Reader 207 | instance ArityPeano n => Monad (Fun n a) where 208 | return = pure 209 | f >>= g = shuffleFun g <*> f 210 | {-# INLINE return #-} 211 | {-# INLINE (>>=) #-} 212 | 213 | newtype T_Flip a b n = T_Flip (Fun n a b) 214 | data T_ap a b c n = T_ap (Fn n a b) (Fn n a c) 215 | 216 | 217 | 218 | ---------------------------------------------------------------- 219 | -- Generic operations of N-ary functions 220 | ---------------------------------------------------------------- 221 | 222 | -- | Synonym for writing constrains using type level naturals. 223 | type Arity n = ArityPeano (Peano n) 224 | 225 | -- | Type class for defining and applying /n/-ary functions. 226 | class ArityPeano n where 227 | -- | Left fold over /n/ elements exposed as n-ary function. These 228 | -- elements are supplied as arguments to the function. 229 | accum :: (forall k. t ('S k) -> a -> t k) -- ^ Fold function 230 | -> (t 'Z -> b) -- ^ Extract result of fold 231 | -> t n -- ^ Initial value 232 | -> Fun n a b -- ^ Reduction function 233 | 234 | -- | Same as @accum@ but allow use @ArityPeano@ at each step Note 235 | -- that in general case this will lead to /O(n²)/ compilation time. 236 | accumPeano 237 | :: (forall k. ArityPeano k => t ('S k) -> a -> t k) -- ^ Fold function 238 | -> (t 'Z -> b) -- ^ Extract result of fold 239 | -> t n -- ^ Initial value 240 | -> Fun n a b -- ^ Reduction function 241 | 242 | -- | Apply all parameters to the function. 243 | applyFun :: (forall k. t ('S k) -> (a, t k)) 244 | -- ^ Get value to apply to function 245 | -> t n 246 | -- ^ Initial value 247 | -> (ContVec n a, t 'Z) 248 | 249 | -- | Apply all parameters to the function using monadic 250 | -- actions. Note that for identity monad it's same as 251 | -- applyFun. Ignoring newtypes: 252 | -- 253 | -- > forall b. Fn n a b -> b ~ ContVec n a 254 | applyFunM :: Applicative f 255 | => (forall k. t ('S k) -> (f a, t k)) -- ^ Get value to apply to function 256 | -> t n -- ^ Initial value 257 | -> (f (ContVec n a), t 'Z) 258 | 259 | 260 | -- | Perform N reduction steps. This function doesn't involve N-ary 261 | -- function directly. 262 | reducePeano :: (forall k. t ('S k) -> t k) -- ^ Reduction step 263 | -> t n 264 | -> t 'Z 265 | 266 | -- | Conver peano number to int 267 | peanoToInt :: Proxy# n -> Int 268 | 269 | -- | Provide @ArityPeano@ dictionary for previous Peano number. GHC 270 | -- cannot infer that when @ArityPeano n@ and @n ~ S k@ we have 271 | -- instance for @k@ as well. So we have to provide such dictionary 272 | -- manually. 273 | -- 274 | -- It's not possible to have non-⊥ implementation for @Z@ but 275 | -- neither it's possible to call it. 276 | dictionaryPred :: (n ~ S k) => Proxy# n -> (ArityPeano k => r) -> r 277 | 278 | newtype T_gunfold c r a n = T_gunfold (c (Fn n a r)) 279 | 280 | 281 | -- | Apply all parameters to the function. 282 | apply :: ArityPeano n 283 | => (forall k. t ('S k) -> (a, t k)) -- ^ Get value to apply to function 284 | -> t n -- ^ Initial value 285 | -> ContVec n a -- ^ N-ary function 286 | {-# INLINE apply #-} 287 | apply step z = fst (applyFun step z) 288 | 289 | -- | Apply all parameters to the function using applicative actions. 290 | applyM :: (Applicative f, ArityPeano n) 291 | => (forall k. t ('S k) -> (f a, t k)) -- ^ Get value to apply to function 292 | -> t n -- ^ Initial value 293 | -> f (ContVec n a) 294 | {-# INLINE applyM #-} 295 | applyM f t = fst $ applyFunM f t 296 | 297 | 298 | -- | Type class for indexing of vector of length @n@ with statically 299 | -- known index @k@ 300 | class Index (k :: PeanoNum) (n :: PeanoNum) where 301 | getF :: Proxy# k -> Fun n a a 302 | putF :: Proxy# k -> a -> Fun n a r -> Fun n a r 303 | lensF :: Functor f => Proxy# k -> (a -> f a) -> Fun n a r -> Fun n a (f r) 304 | 305 | 306 | 307 | instance ArityPeano 'Z where 308 | accum _ g t = Fun $ g t 309 | accumPeano _ g t = Fun $ g t 310 | applyFun _ t = (ContVec unFun, t) 311 | applyFunM _ t = (pure (ContVec unFun), t) 312 | reducePeano _ = id 313 | peanoToInt _ = 0 314 | {-# INLINE accum #-} 315 | {-# INLINE accumPeano #-} 316 | {-# INLINE applyFun #-} 317 | {-# INLINE applyFunM #-} 318 | {-# INLINE reducePeano #-} 319 | {-# INLINE peanoToInt #-} 320 | dictionaryPred _ _ = error "dictionaryPred: IMPOSSIBLE" 321 | 322 | instance ArityPeano n => ArityPeano ('S n) where 323 | accum f g t = Fun $ \a -> unFun $ accum f g (f t a) 324 | accumPeano f g t = Fun $ \a -> unFun $ accumPeano f g (f t a) 325 | applyFun f t = let (a,t') = f t 326 | (v,tZ) = applyFun f t' 327 | in (consPeano a v, tZ) 328 | applyFunM f t = let (a,t') = f t 329 | (vec,t0) = applyFunM f t' 330 | in (consPeano <$> a <*> vec, t0) 331 | reducePeano f t = reducePeano f (f t) 332 | peanoToInt _ = 1 + peanoToInt (proxy# @n) 333 | {-# INLINE accum #-} 334 | {-# INLINE applyFun #-} 335 | {-# INLINE applyFunM #-} 336 | {-# INLINE peanoToInt #-} 337 | {-# INLINE reducePeano #-} 338 | dictionaryPred _ r = r 339 | {-# INLINE dictionaryPred #-} 340 | 341 | 342 | instance ArityPeano n => Index 'Z ('S n) where 343 | getF _ = uncurryFirst pure 344 | putF _ a f = Fun $ \_ -> unFun f a 345 | lensF _ f fun = Fun $ \a -> unFun $ 346 | (\g -> g <$> f a) <$> shuffleFun (curryFirst fun) 347 | {-# INLINE getF #-} 348 | {-# INLINE putF #-} 349 | {-# INLINE lensF #-} 350 | 351 | instance Index k n => Index (S k) (S n) where 352 | getF _ = uncurryFirst $ \_ -> getF (proxy# @k) 353 | putF _ a = withFun (putF (proxy# @k) a) 354 | lensF _ f fun = withFun (lensF (proxy# @k) f) fun 355 | {-# INLINE getF #-} 356 | {-# INLINE putF #-} 357 | {-# INLINE lensF #-} 358 | 359 | 360 | 361 | ---------------------------------------------------------------- 362 | -- Combinators 363 | ---------------------------------------------------------------- 364 | 365 | -- | Prepend ignored parameter to function 366 | constFun :: Fun n a b -> Fun ('S n) a b 367 | constFun (Fun f) = Fun $ \_ -> f 368 | {-# INLINE constFun #-} 369 | 370 | -- | Curry first parameter of n-ary function 371 | curryFirst :: Fun ('S n) a b -> a -> Fun n a b 372 | curryFirst = coerce 373 | {-# INLINE curryFirst #-} 374 | 375 | -- | Uncurry first parameter of n-ary function 376 | uncurryFirst :: (a -> Fun n a b) -> Fun ('S n) a b 377 | uncurryFirst = coerce 378 | {-# INLINE uncurryFirst #-} 379 | 380 | -- | Curry last parameter of n-ary function 381 | curryLast :: ArityPeano n => Fun ('S n) a b -> Fun n a (a -> b) 382 | {-# INLINE curryLast #-} 383 | -- NOTE: This function is essentially rearrangement of newtypes. Since 384 | -- Fn is closed type family it couldn't be extended and it's 385 | -- quite straightforward to show that both types have same 386 | -- representation. Unfortunately GHC cannot infer it so we have 387 | -- to unsafe-coerce it. 388 | curryLast = unsafeCoerce 389 | 390 | 391 | -- | Curry /n/ first parameters of n-ary function 392 | curryMany :: forall n k a b. ArityPeano n 393 | => Fun (Add n k) a b -> Fun n a (Fun k a b) 394 | {-# INLINE curryMany #-} 395 | -- NOTE: It's same as curryLast 396 | curryMany = unsafeCoerce 397 | 398 | 399 | -- | Apply last parameter to function. Unlike 'apFun' we need to 400 | -- traverse all parameters but last hence 'Arity' constraint. 401 | apLast :: ArityPeano n => Fun ('S n) a b -> a -> Fun n a b 402 | apLast f x = fmap ($ x) $ curryLast f 403 | {-# INLINE apLast #-} 404 | 405 | -- | Recursive step for the function 406 | withFun :: (Fun n a b -> Fun n a c) -> Fun ('S n) a b -> Fun ('S n) a c 407 | withFun f fun = Fun $ \a -> unFun $ f $ curryFirst fun a 408 | {-# INLINE withFun #-} 409 | 410 | -- | Move function parameter to the result of N-ary function. 411 | shuffleFun :: ArityPeano n 412 | => (b -> Fun n a r) -> Fun n a (b -> r) 413 | {-# INLINE shuffleFun #-} 414 | shuffleFun f0 415 | = accum (\(T_shuffle f) a -> T_shuffle $ \x -> f x a) 416 | (\(T_shuffle f) -> f) 417 | (T_shuffle (fmap unFun f0)) 418 | 419 | newtype T_shuffle x a r n = T_shuffle (x -> Fn n a r) 420 | 421 | -- | Apply function to parameters and result of @Fun@ simultaneously. 422 | dimapFun :: ArityPeano n => (a -> b) -> (c -> d) -> Fun n b c -> Fun n a d 423 | {-# INLINE dimapFun #-} 424 | dimapFun fA fR fun 425 | = accum (\(T_Flip g) a -> T_Flip (curryFirst g (fA a))) 426 | (\(T_Flip x) -> fR (unFun x)) 427 | (T_Flip fun) 428 | 429 | 430 | 431 | 432 | ---------------------------------------------------------------- 433 | -- Type class for fixed vectors 434 | ---------------------------------------------------------------- 435 | 436 | -- | Size of vector expressed as Peano natural. 437 | type family Dim (v :: Type -> Type) :: PeanoNum 438 | 439 | -- | Type class for vectors with fixed length. Instance should provide 440 | -- two functions: one to create vector from @N@ elements and another 441 | -- for vector deconstruction. They must obey following law: 442 | -- 443 | -- > inspect v construct = v 444 | -- 445 | -- For example instance for 2D vectors could be written as: 446 | -- 447 | -- > data V2 a = V2 a a 448 | -- > 449 | -- > type instance V2 = 2 450 | -- > instance Vector V2 a where 451 | -- > construct = Fun V2 452 | -- > inspect (V2 a b) (Fun f) = f a b 453 | class ArityPeano (Dim v) => Vector v a where 454 | -- | N-ary function for creation of vectors. It takes @N@ elements 455 | -- of array as parameters and return vector. 456 | construct :: Fun (Dim v) a (v a) 457 | -- | Deconstruction of vector. It takes N-ary function as parameters 458 | -- and applies vector's elements to it. 459 | inspect :: v a -> Fun (Dim v) a b -> b 460 | -- | Optional more efficient implementation of indexing. Shouldn't 461 | -- be used directly, use 'Data.Vector.Fixed.!' instead. 462 | basicIndex :: v a -> Int -> a 463 | basicIndex v i = index i (cvec v) 464 | {-# INLINE basicIndex #-} 465 | 466 | -- | Length of vector. Function doesn't evaluate its argument. 467 | length :: forall v a. ArityPeano (Dim v) => v a -> Int 468 | {-# INLINE length #-} 469 | length _ = peanoToInt (proxy# @(Dim v)) 470 | 471 | 472 | ---------------------------------------------------------------- 473 | -- Cont. vectors and their instances 474 | ---------------------------------------------------------------- 475 | 476 | -- | Vector represented as continuation. Alternative wording: it's 477 | -- Church encoded N-element vector. 478 | newtype ContVec n a = ContVec (forall r. Fun n a r -> r) 479 | 480 | type instance Dim (ContVec n) = n 481 | 482 | -- | Cons values to the @ContVec@. 483 | consPeano :: a -> ContVec n a -> ContVec ('S n) a 484 | consPeano a (ContVec cont) = ContVec $ \f -> cont $ curryFirst f a 485 | {-# INLINE consPeano #-} 486 | 487 | instance ArityPeano n => Vector (ContVec n) a where 488 | construct = accum 489 | (\(T_mkN f) a -> T_mkN (f . consPeano a)) 490 | (\(T_mkN f) -> f (ContVec unFun)) 491 | (T_mkN id) 492 | inspect (ContVec c) f = c f 493 | {-# INLINE construct #-} 494 | {-# INLINE inspect #-} 495 | 496 | newtype T_mkN n_tot a n = T_mkN (ContVec n a -> ContVec n_tot a) 497 | 498 | 499 | 500 | instance (Eq a, ArityPeano n) => Eq (ContVec n a) where 501 | a == b = and $ zipWith (==) a b 502 | {-# INLINE (==) #-} 503 | 504 | instance (Ord a, ArityPeano n) => Ord (ContVec n a) where 505 | compare a b = foldl mappend mempty $ zipWith compare a b 506 | {-# INLINE compare #-} 507 | 508 | instance (ArityPeano n, Monoid a) => Monoid (ContVec n a) where 509 | mempty = replicate mempty 510 | {-# INLINE mempty #-} 511 | 512 | instance (ArityPeano n, Semigroup a) => Semigroup (ContVec n a) where 513 | (<>) = zipWith (<>) 514 | {-# INLINE (<>) #-} 515 | 516 | 517 | instance (ArityPeano n) => Functor (ContVec n) where 518 | fmap = map 519 | {-# INLINE fmap #-} 520 | 521 | instance (ArityPeano n) => Applicative (ContVec n) where 522 | pure = replicate 523 | (<*>) = zipWith ($) 524 | {-# INLINE pure #-} 525 | {-# INLINE (<*>) #-} 526 | 527 | instance (ArityPeano n) => F.Foldable (ContVec n) where 528 | foldMap' f = foldl' (\ acc a -> acc <> f a) mempty 529 | foldr = foldr 530 | foldl = foldl 531 | foldl' = foldl' 532 | toList = toList 533 | sum = sum 534 | product = foldl' (*) 0 535 | {-# INLINE foldMap' #-} 536 | {-# INLINE foldr #-} 537 | {-# INLINE foldl #-} 538 | {-# INLINE foldl' #-} 539 | {-# INLINE toList #-} 540 | {-# INLINE sum #-} 541 | {-# INLINE product #-} 542 | -- GHC<9.2 fails to compile this 543 | #if MIN_VERSION_base(4,16,0) 544 | length = length 545 | {-# INLINE length #-} 546 | #endif 547 | 548 | instance (ArityPeano n) => T.Traversable (ContVec n) where 549 | sequence = sequence 550 | sequenceA = sequence 551 | traverse = mapM 552 | mapM = mapM 553 | {-# INLINE sequence #-} 554 | {-# INLINE sequenceA #-} 555 | {-# INLINE mapM #-} 556 | {-# INLINE traverse #-} 557 | 558 | 559 | 560 | ---------------------------------------------------------------- 561 | -- Construction 562 | ---------------------------------------------------------------- 563 | 564 | -- | Convert regular vector to continuation based one. 565 | cvec :: (Vector v a) => v a -> ContVec (Dim v) a 566 | cvec v = ContVec (inspect v) 567 | {-# INLINE[0] cvec #-} 568 | 569 | -- | Create empty vector. 570 | empty :: ContVec 'Z a 571 | {-# INLINE empty #-} 572 | empty = ContVec (\(Fun r) -> r) 573 | 574 | 575 | -- | Convert list to continuation-based vector. Will throw error if 576 | -- list is shorter than resulting vector. 577 | fromList :: ArityPeano n => [a] -> ContVec n a 578 | {-# INLINE fromList #-} 579 | fromList xs = 580 | apply step (Const xs) 581 | where 582 | step (Const [] ) = error "Data.Vector.Fixed.Cont.fromList: too few elements" 583 | step (Const (a:as)) = (a, Const as) 584 | 585 | -- | Same as 'fromList' bu throws error is list doesn't have same 586 | -- length as vector. 587 | fromList' :: forall n a. ArityPeano n => [a] -> ContVec n a 588 | {-# INLINE fromList' #-} 589 | fromList' xs = 590 | let step (Const [] ) = error "Data.Vector.Fixed.Cont.fromList': too few elements" 591 | step (Const (a:as)) = (a, Const as) 592 | in case applyFun step (Const xs :: Const [a] n) of 593 | (v,Const []) -> v 594 | _ -> error "Data.Vector.Fixed.Cont.fromList': too many elements" 595 | 596 | 597 | -- | Convert list to continuation-based vector. Will fail with 598 | -- 'Nothing' if list doesn't have right length. 599 | fromListM :: forall n a. ArityPeano n => [a] -> Maybe (ContVec n a) 600 | {-# INLINE fromListM #-} 601 | fromListM xs = case applyFunM step (Const xs :: Const [a] n) of 602 | (Just v, Const []) -> Just v 603 | _ -> Nothing 604 | where 605 | step (Const [] ) = (Nothing, Const []) 606 | step (Const (a:as)) = (Just a , Const as) 607 | 608 | 609 | -- | Convert vector to the list 610 | toList :: (ArityPeano n) => ContVec n a -> [a] 611 | toList = foldr (:) [] 612 | {-# INLINE toList #-} 613 | 614 | 615 | -- | Execute monadic action for every element of vector. Synonym for 'pure'. 616 | replicate :: (ArityPeano n) => a -> ContVec n a 617 | {-# INLINE replicate #-} 618 | replicate a = apply (\Proxy -> (a, Proxy)) Proxy 619 | 620 | -- | Execute monadic action for every element of vector. 621 | replicateM :: (ArityPeano n, Applicative f) => f a -> f (ContVec n a) 622 | {-# INLINE replicateM #-} 623 | replicateM act 624 | = applyM (\Proxy -> (act, Proxy)) Proxy 625 | 626 | 627 | -- | Generate vector from function which maps element's index to its value. 628 | generate :: (ArityPeano n) => (Int -> a) -> ContVec n a 629 | {-# INLINE generate #-} 630 | generate f = 631 | apply (\(Const n) -> (f n, Const (n + 1))) (Const 0) 632 | 633 | -- | Generate vector from monadic function which maps element's index 634 | -- to its value. 635 | generateM :: (Applicative f, ArityPeano n) => (Int -> f a) -> f (ContVec n a) 636 | {-# INLINE generateM #-} 637 | generateM f = 638 | applyM (\(Const n) -> (f n, Const (n + 1))) (Const 0) 639 | 640 | 641 | -- | Unfold vector. 642 | unfoldr :: ArityPeano n => (b -> (a,b)) -> b -> ContVec n a 643 | {-# INLINE unfoldr #-} 644 | unfoldr f b0 = 645 | apply (\(Const b) -> let (a,b') = f b in (a, Const b')) 646 | (Const b0) 647 | 648 | -- | Unit vector along Nth axis. 649 | basis :: (Num a, ArityPeano n) => Int -> ContVec n a 650 | {-# INLINE basis #-} 651 | basis n0 = 652 | apply (\(Const n) -> (if n == 0 then 1 else 0, Const (n - 1))) 653 | (Const n0) 654 | 655 | 656 | 657 | mk1 :: a -> ContVec N1 a 658 | mk1 a1 = ContVec $ \(Fun f) -> f a1 659 | {-# INLINE mk1 #-} 660 | 661 | mk2 :: a -> a -> ContVec N2 a 662 | mk2 a1 a2 = ContVec $ \(Fun f) -> f a1 a2 663 | {-# INLINE mk2 #-} 664 | 665 | mk3 :: a -> a -> a -> ContVec N3 a 666 | mk3 a1 a2 a3 = ContVec $ \(Fun f) -> f a1 a2 a3 667 | {-# INLINE mk3 #-} 668 | 669 | mk4 :: a -> a -> a -> a -> ContVec N4 a 670 | mk4 a1 a2 a3 a4 = ContVec $ \(Fun f) -> f a1 a2 a3 a4 671 | {-# INLINE mk4 #-} 672 | 673 | mk5 :: a -> a -> a -> a -> a -> ContVec N5 a 674 | mk5 a1 a2 a3 a4 a5 = ContVec $ \(Fun f) -> f a1 a2 a3 a4 a5 675 | {-# INLINE mk5 #-} 676 | 677 | mk6 :: a -> a -> a -> a -> a -> a -> ContVec N6 a 678 | mk6 a1 a2 a3 a4 a5 a6 = ContVec $ \(Fun f) -> f a1 a2 a3 a4 a5 a6 679 | {-# INLINE mk6 #-} 680 | 681 | mk7 :: a -> a -> a -> a -> a -> a -> a -> ContVec N7 a 682 | mk7 a1 a2 a3 a4 a5 a6 a7 = ContVec $ \(Fun f) -> f a1 a2 a3 a4 a5 a6 a7 683 | {-# INLINE mk7 #-} 684 | 685 | mk8 :: a -> a -> a -> a -> a -> a -> a -> a -> ContVec N8 a 686 | mk8 a1 a2 a3 a4 a5 a6 a7 a8 = ContVec $ \(Fun f) -> f a1 a2 a3 a4 a5 a6 a7 a8 687 | {-# INLINE mk8 #-} 688 | 689 | 690 | ---------------------------------------------------------------- 691 | -- Transforming vectors 692 | ---------------------------------------------------------------- 693 | 694 | -- | Map over vector. Synonym for 'fmap' 695 | map :: (ArityPeano n) => (a -> b) -> ContVec n a -> ContVec n b 696 | {-# INLINE map #-} 697 | map f (ContVec contA) = ContVec $ 698 | contA . mapF f 699 | 700 | -- | Apply function to every element of the vector and its index. 701 | imap :: (ArityPeano n) => (Int -> a -> b) -> ContVec n a -> ContVec n b 702 | {-# INLINE imap #-} 703 | imap f (ContVec contA) = ContVec $ 704 | contA . imapF f 705 | 706 | -- | Effectful map over vector. 707 | mapM :: (ArityPeano n, Applicative f) => (a -> f b) -> ContVec n a -> f (ContVec n b) 708 | {-# INLINE mapM #-} 709 | mapM f v 710 | = inspect v 711 | $ mapMF f construct 712 | 713 | -- | Apply monadic function to every element of the vector and its index. 714 | imapM :: (ArityPeano n, Applicative f) 715 | => (Int -> a -> f b) -> ContVec n a -> f (ContVec n b) 716 | {-# INLINE imapM #-} 717 | imapM f v 718 | = inspect v 719 | $ imapMF f construct 720 | 721 | -- | Apply monadic action to each element of vector and ignore result. 722 | mapM_ :: (ArityPeano n, Applicative f) => (a -> f b) -> ContVec n a -> f () 723 | {-# INLINE mapM_ #-} 724 | mapM_ f = foldl (\m a -> m *> f a *> pure ()) (pure ()) 725 | 726 | -- | Apply monadic action to each element of vector and its index and 727 | -- ignore result. 728 | imapM_ :: (ArityPeano n, Applicative f) => (Int -> a -> f b) -> ContVec n a -> f () 729 | {-# INLINE imapM_ #-} 730 | imapM_ f = ifoldl (\m i a -> m *> f i a *> pure ()) (pure ()) 731 | 732 | 733 | 734 | mapMF :: (ArityPeano n, Applicative f) 735 | => (a -> f b) -> Fun n b r -> Fun n a (f r) 736 | {-# INLINE mapMF #-} 737 | mapMF f (Fun funB) = 738 | accum (\(T_mapM m) a -> T_mapM (($) <$> m <*> f a)) 739 | (\(T_mapM m) -> m) 740 | (T_mapM (pure funB)) 741 | 742 | imapMF :: (ArityPeano n, Applicative f) 743 | => (Int -> a -> f b) -> Fun n b r -> Fun n a (f r) 744 | {-# INLINE imapMF #-} 745 | imapMF f (Fun funB) = 746 | accum (\(T_imapM i m) a -> T_imapM (i+1) $ ($) <$> m <*> f i a) 747 | (\(T_imapM _ m) -> m) 748 | (T_imapM 0 (pure funB)) 749 | 750 | newtype T_mapM a m r n = T_mapM (m (Fn n a r)) 751 | data T_imapM a m r n = T_imapM Int (m (Fn n a r)) 752 | 753 | 754 | mapF :: ArityPeano n 755 | => (a -> b) -> Fun n b r -> Fun n a r 756 | {-# INLINE mapF #-} 757 | mapF f (Fun funB) = 758 | accum (\(T_map g) b -> T_map (g (f b))) 759 | (\(T_map r) -> r) 760 | ( T_map funB) 761 | 762 | imapF :: ArityPeano n 763 | => (Int -> a -> b) -> Fun n b r -> Fun n a r 764 | {-# INLINE imapF #-} 765 | imapF f (Fun funB) = 766 | accum (\(T_imap i g) b -> T_imap (i+1) (g (f i b))) 767 | (\(T_imap _ r) -> r) 768 | ( T_imap 0 funB) 769 | 770 | newtype T_map a r n = T_map (Fn n a r) 771 | data T_imap a r n = T_imap Int (Fn n a r) 772 | 773 | -- | Left scan over vector 774 | scanl :: (ArityPeano n) => (b -> a -> b) -> b -> ContVec n a -> ContVec ('S n) b 775 | {-# INLINE scanl #-} 776 | scanl f b0 (ContVec cont) = ContVec $ 777 | cont . scanlF f b0 778 | 779 | -- | Left scan over vector 780 | scanl1 :: (ArityPeano n) => (a -> a -> a) -> ContVec n a -> ContVec n a 781 | {-# INLINE scanl1 #-} 782 | scanl1 f (ContVec cont) = ContVec $ 783 | cont . scanl1F f 784 | 785 | scanlF :: forall n a b r. (ArityPeano n) => (b -> a -> b) -> b -> Fun ('S n) b r -> Fun n a r 786 | scanlF f b0 (Fun fun0) 787 | = accum step fini start 788 | where 789 | step :: forall k. T_scanl r b ('S k) -> a -> T_scanl r b k 790 | step (T_scanl b fn) a = let b' = f b a in T_scanl b' (fn b') 791 | fini (T_scanl _ r) = r 792 | start = T_scanl b0 (fun0 b0) :: T_scanl r b n 793 | 794 | scanl1F :: forall n a r. (ArityPeano n) => (a -> a -> a) -> Fun n a r -> Fun n a r 795 | scanl1F f (Fun fun0) = accum step fini start 796 | where 797 | step :: forall k. T_scanl1 r a ('S k) -> a -> T_scanl1 r a k 798 | step (T_scanl1 Nothing fn) a = T_scanl1 (Just a) (fn a) 799 | step (T_scanl1 (Just x) fn) a = let a' = f x a in T_scanl1 (Just a') (fn a') 800 | fini (T_scanl1 _ r) = r 801 | start = T_scanl1 Nothing fun0 :: T_scanl1 r a n 802 | 803 | data T_scanl r a n = T_scanl a (Fn n a r) 804 | data T_scanl1 r a n = T_scanl1 (Maybe a) (Fn n a r) 805 | 806 | 807 | -- | Evaluate every action in the vector from left to right. 808 | sequence :: (ArityPeano n, Applicative f) => ContVec n (f a) -> f (ContVec n a) 809 | sequence = mapM id 810 | {-# INLINE sequence #-} 811 | 812 | -- | Evaluate every action in the vector from left to right and ignore result. 813 | sequence_ :: (ArityPeano n, Applicative f) => ContVec n (f a) -> f () 814 | sequence_ = mapM_ id 815 | {-# INLINE sequence_ #-} 816 | 817 | -- | The dual of sequenceA 818 | distribute :: (Functor f, ArityPeano n) => f (ContVec n a) -> ContVec n (f a) 819 | {-# INLINE distribute #-} 820 | distribute f0 821 | = apply step start 822 | where 823 | -- It's not possible to use ContVec as accumulator type since `head' 824 | -- require Arity constraint on `k'. So we use plain lists 825 | step (Const f) = ( fmap (\(x:_) -> x) f 826 | , Const $ fmap (\(_:x) -> x) f) 827 | start = Const (fmap toList f0) 828 | 829 | collect :: (Functor f, ArityPeano n) => (a -> ContVec n b) -> f a -> ContVec n (f b) 830 | collect f = distribute . fmap f 831 | {-# INLINE collect #-} 832 | 833 | -- | /O(1)/ Tail of vector. 834 | tail :: ContVec (S n) a -> ContVec n a 835 | tail (ContVec cont) = ContVec $ \f -> cont $ constFun f 836 | {-# INLINE tail #-} 837 | 838 | -- | /O(1)/ Prepend element to vector 839 | cons :: a -> ContVec n a -> ContVec ('S n) a 840 | cons a (ContVec cont) = ContVec $ \f -> cont $ curryFirst f a 841 | {-# INLINE cons #-} 842 | 843 | -- | Prepend single element vector to another vector. 844 | consV :: ArityPeano n => ContVec N1 a -> ContVec n a -> ContVec ('S n) a 845 | {-# INLINE consV #-} 846 | consV (ContVec cont1) (ContVec cont) 847 | = ContVec $ \f -> cont $ curryFirst f $ cont1 $ Fun id 848 | 849 | -- | /O(1)/ Append element to vector 850 | snoc :: ArityPeano n => a -> ContVec n a -> ContVec ('S n) a 851 | snoc a (ContVec cont) = ContVec $ \f -> cont $ apLast f a 852 | {-# INLINE snoc #-} 853 | 854 | 855 | -- | Concatenate vector 856 | concat :: ( ArityPeano n 857 | , ArityPeano k 858 | , ArityPeano (n `Add` k) 859 | ) 860 | => ContVec n a -> ContVec k a -> ContVec (Add n k) a 861 | {-# INLINE concat #-} 862 | concat v u = inspect u 863 | $ inspect v 864 | $ curryMany construct 865 | 866 | -- | Reverse order of elements in the vector 867 | reverse :: ArityPeano n => ContVec n a -> ContVec n a 868 | reverse (ContVec cont) = ContVec $ cont . reverseF 869 | {-# INLINE reverse #-} 870 | 871 | reverseF :: forall n a b. ArityPeano n => Fun n a b -> Fun n a b 872 | reverseF (Fun fun0) = accumPeano 873 | step 874 | (\(T_map b) -> b) 875 | (T_map fun0 :: T_map a b n) 876 | where 877 | step :: forall k. ArityPeano k => T_map a b (S k) -> a -> T_map a b k 878 | step (T_map f) a = T_map $ unFun $ apLast (Fun f :: Fun (S k) a b) a 879 | 880 | 881 | -- | Zip two vector together using function. 882 | zipWith :: (ArityPeano n) => (a -> b -> c) 883 | -> ContVec n a -> ContVec n b -> ContVec n c 884 | {-# INLINE zipWith #-} 885 | zipWith f vecA vecB = ContVec $ \funC -> 886 | inspect vecB 887 | $ inspect vecA 888 | $ zipWithF f funC 889 | 890 | -- | Zip three vectors together 891 | zipWith3 :: (ArityPeano n) => (a -> b -> c -> d) 892 | -> ContVec n a -> ContVec n b -> ContVec n c -> ContVec n d 893 | {-# INLINE zipWith3 #-} 894 | zipWith3 f v1 v2 v3 895 | = zipWith ($) (zipWith f v1 v2) v3 896 | 897 | -- | Zip two vector together using function which takes element index 898 | -- as well. 899 | izipWith :: (ArityPeano n) => (Int -> a -> b -> c) 900 | -> ContVec n a -> ContVec n b -> ContVec n c 901 | {-# INLINE izipWith #-} 902 | izipWith f vecA vecB = ContVec $ \funC -> 903 | inspect vecB 904 | $ inspect vecA 905 | $ izipWithF f funC 906 | 907 | -- | Zip three vectors together 908 | izipWith3 :: (ArityPeano n) => (Int -> a -> b -> c -> d) 909 | -> ContVec n a -> ContVec n b -> ContVec n c -> ContVec n d 910 | {-# INLINE izipWith3 #-} 911 | izipWith3 f v1 v2 v3 = izipWith (\i a (b, c) -> f i a b c) v1 (zipWith (,) v2 v3) 912 | 913 | -- | Zip two vector together using monadic function. 914 | zipWithM :: (ArityPeano n, Applicative f) => (a -> b -> f c) 915 | -> ContVec n a -> ContVec n b -> f (ContVec n c) 916 | {-# INLINE zipWithM #-} 917 | zipWithM f v w = sequence $ zipWith f v w 918 | 919 | zipWithM_ :: (ArityPeano n, Applicative f) 920 | => (a -> b -> f c) -> ContVec n a -> ContVec n b -> f () 921 | {-# INLINE zipWithM_ #-} 922 | zipWithM_ f xs ys = sequence_ (zipWith f xs ys) 923 | 924 | -- | Zip two vector together using monadic function which takes element 925 | -- index as well.. 926 | izipWithM :: (ArityPeano n, Applicative f) => (Int -> a -> b -> f c) 927 | -> ContVec n a -> ContVec n b -> f (ContVec n c) 928 | {-# INLINE izipWithM #-} 929 | izipWithM f v w = sequence $ izipWith f v w 930 | 931 | izipWithM_ :: (ArityPeano n, Applicative f) 932 | => (Int -> a -> b -> f c) -> ContVec n a -> ContVec n b -> f () 933 | {-# INLINE izipWithM_ #-} 934 | izipWithM_ f xs ys = sequence_ (izipWith f xs ys) 935 | 936 | -- NOTE: [zipWith] 937 | -- ~~~~~~~~~~~~~~~ 938 | -- 939 | -- It turns out it's very difficult to implement zipWith using 940 | -- accum/apply. Key problem is we need to implement: 941 | -- 942 | -- > zipF :: Fun n (a,b) r → Fun n a (Fun b r) 943 | -- 944 | -- Induction step would be implementing 945 | -- 946 | -- > ((a,b) → Fun n (a,b) r) → (a → Fun n a (b → Fun b r)) 947 | -- 948 | -- in terms of zipF above. It will give us `Fun n a (Fun b r)` but 949 | -- we'll need to move parameter `b` _inside_ `Fun n a`. This requires 950 | -- `ArityPeano` constraint while accum's parameter has note. Even 951 | -- worse this implementation has quadratic complexity. 952 | -- 953 | -- It's possible to make zipF method of ArityPeano but quadratic 954 | -- complexity won't go away and starts cause slowdown even for modest 955 | -- values of `n`: 5-6. For n above 10 compilation starts to fail with 956 | -- "simplifier ticks exhausted error". 957 | -- 958 | -- It turns out easiest way is materialize list and then deconstruct. 959 | -- GHC is able to eliminate it and it's very hard to beat this approach 960 | 961 | zipWithF :: (ArityPeano n) 962 | => (a -> b -> c) -> Fun n c r -> Fun n a (Fun n b r) 963 | {-# INLINE zipWithF #-} 964 | zipWithF f (Fun g0) 965 | = makeList 966 | $ \v -> accum (\(T_zip (a:as) g) b -> T_zip as (g $ f a b)) 967 | (\(T_zip _ x) -> x) 968 | (T_zip v g0) 969 | 970 | izipWithF :: (ArityPeano n) 971 | => (Int -> a -> b -> c) -> Fun n c r -> Fun n a (Fun n b r) 972 | {-# INLINE izipWithF #-} 973 | izipWithF f (Fun g0) 974 | = makeList 975 | $ \v -> accum (\(T_izip i (a:as) g) b -> T_izip (i+1) as (g $ f i a b)) 976 | (\(T_izip _ _ x) -> x) 977 | (T_izip 0 v g0) 978 | 979 | makeList :: ArityPeano n => ([a] -> b) -> Fun n a b 980 | {-# INLINE makeList #-} 981 | makeList cont = accum 982 | (\(Const xs) x -> Const (xs . (x:))) 983 | (\(Const xs) -> cont (xs [])) 984 | (Const id) 985 | 986 | data T_izip a c r n = T_izip Int [a] (Fn n c r) 987 | data T_zip a c r n = T_zip [a] (Fn n c r) 988 | 989 | 990 | 991 | ---------------------------------------------------------------- 992 | -- Running vector 993 | ---------------------------------------------------------------- 994 | 995 | -- | Run continuation vector. It's same as 'inspect' but with 996 | -- arguments flipped. 997 | runContVec :: Fun n a r 998 | -> ContVec n a 999 | -> r 1000 | runContVec f (ContVec c) = c f 1001 | {-# INLINE runContVec #-} 1002 | 1003 | -- | Convert continuation to the vector. 1004 | vector :: (Vector v a) => ContVec (Dim v) a -> v a 1005 | vector = runContVec construct 1006 | {-# INLINE[1] vector #-} 1007 | 1008 | -- | Finalizer function for getting head of the vector. 1009 | head :: forall n k a. (ArityPeano n, n ~ 'S k) => ContVec n a -> a 1010 | {-# INLINE head #-} 1011 | head 1012 | = dictionaryPred (proxy# @n) 1013 | $ runContVec 1014 | $ uncurryFirst pure 1015 | 1016 | 1017 | -- | /O(n)/ Get value at specified index. 1018 | index :: ArityPeano n => Int -> ContVec n a -> a 1019 | {-# INLINE index #-} 1020 | index n 1021 | | n < 0 = error "Data.Vector.Fixed.Cont.index: index out of range" 1022 | | otherwise = runContVec $ accum 1023 | (\(Const x) a -> Const $ case x of 1024 | Left 0 -> Right a 1025 | Left i -> Left (i - 1) 1026 | r -> r 1027 | ) 1028 | (\(Const x) -> case x of 1029 | Left _ -> error "Data.Vector.Fixed.index: index out of range" 1030 | Right a -> a 1031 | ) 1032 | (Const (Left n)) 1033 | 1034 | 1035 | -- | Twan van Laarhoven lens for continuation based vector 1036 | element :: (ArityPeano n, Functor f) 1037 | => Int -> (a -> f a) -> ContVec n a -> f (ContVec n a) 1038 | {-# INLINE element #-} 1039 | element i f v = inspect v 1040 | $ elementF i f construct 1041 | 1042 | -- | Helper for implementation of Twan van Laarhoven lens. 1043 | elementF :: forall a n f r. (ArityPeano n, Functor f) 1044 | => Int -> (a -> f a) -> Fun n a r -> Fun n a (f r) 1045 | {-# INLINE elementF #-} 1046 | elementF n f (Fun fun0) = accum step fini start 1047 | where 1048 | step :: forall k. T_lens f a r ('S k) -> a -> T_lens f a r k 1049 | step (T_lens (Left (0,fun))) a = T_lens $ Right $ fmap fun $ f a 1050 | step (T_lens (Left (i,fun))) a = T_lens $ Left (i-1, fun a) 1051 | step (T_lens (Right fun)) a = T_lens $ Right $ fmap ($ a) fun 1052 | -- 1053 | fini :: T_lens f a r 'Z -> f r 1054 | fini (T_lens (Left _)) = error "Data.Vector.Fixed.lensF: Index out of range" 1055 | fini (T_lens (Right r)) = r 1056 | -- 1057 | start :: T_lens f a r n 1058 | start = T_lens $ Left (n,fun0) 1059 | 1060 | data T_lens f a r n = T_lens (Either (Int,(Fn n a r)) (f (Fn n a r))) 1061 | 1062 | 1063 | 1064 | -- | Left fold over continuation vector. 1065 | foldl :: ArityPeano n => (b -> a -> b) -> b -> ContVec n a -> b 1066 | {-# INLINE foldl #-} 1067 | foldl f b0 = runContVec (foldlF f b0) 1068 | 1069 | -- | Strict left fold over continuation vector. 1070 | foldl' :: ArityPeano n => (b -> a -> b) -> b -> ContVec n a -> b 1071 | {-# INLINE foldl' #-} 1072 | foldl' f b0 = runContVec (foldlF' f b0) 1073 | 1074 | -- | Left fold over continuation vector. 1075 | ifoldl :: ArityPeano n => (b -> Int -> a -> b) -> b -> ContVec n a -> b 1076 | {-# INLINE ifoldl #-} 1077 | ifoldl f b v 1078 | = inspect v 1079 | $ accum (\(T_ifoldl i r) a -> T_ifoldl (i+1) (f r i a)) 1080 | (\(T_ifoldl _ r) -> r) 1081 | (T_ifoldl 0 b) 1082 | 1083 | -- | Strict left fold over continuation vector. 1084 | ifoldl' :: ArityPeano n => (b -> Int -> a -> b) -> b -> ContVec n a -> b 1085 | {-# INLINE ifoldl' #-} 1086 | ifoldl' f b v 1087 | = inspect v 1088 | $ accum (\(T_ifoldl i !r) a -> T_ifoldl (i+1) (f r i a)) 1089 | (\(T_ifoldl _ r) -> r) 1090 | (T_ifoldl 0 b) 1091 | 1092 | -- | Monadic left fold over continuation vector. 1093 | foldM :: (ArityPeano n, Monad m) 1094 | => (b -> a -> m b) -> b -> ContVec n a -> m b 1095 | {-# INLINE foldM #-} 1096 | foldM f x 1097 | = foldl (\m a -> do{ b <- m; f b a}) (return x) 1098 | 1099 | -- | Monadic left fold over continuation vector. 1100 | ifoldM :: (ArityPeano n, Monad m) 1101 | => (b -> Int -> a -> m b) -> b -> ContVec n a -> m b 1102 | {-# INLINE ifoldM #-} 1103 | ifoldM f x 1104 | = ifoldl (\m i a -> do{ b <- m; f b i a}) (return x) 1105 | 1106 | 1107 | -- | Left fold without base case. It's total because it requires vector to be nonempty 1108 | foldl1 :: forall n k a. (ArityPeano n, n ~ 'S k) 1109 | => (a -> a -> a) -> ContVec n a -> a 1110 | {-# INLINE foldl1 #-} 1111 | foldl1 f 1112 | = dictionaryPred (proxy# @n) 1113 | $ runContVec 1114 | $ uncurryFirst (foldlF f) 1115 | 1116 | -- | Left fold without base case. It's total because it requires vector to be nonempty 1117 | foldl1' :: forall n k a. (ArityPeano n, n ~ 'S k) 1118 | => (a -> a -> a) -> ContVec n a -> a 1119 | {-# INLINE foldl1' #-} 1120 | foldl1' f 1121 | = dictionaryPred (proxy# @n) 1122 | $ runContVec 1123 | $ uncurryFirst (foldlF' f) 1124 | 1125 | 1126 | foldlF :: ArityPeano n => (b -> a -> b) -> b -> Fun n a b 1127 | {-# INLINE foldlF #-} 1128 | foldlF f b0 1129 | = accum (\(T_foldl b) a -> T_foldl (f b a)) 1130 | (\(T_foldl b) -> b) 1131 | (T_foldl b0) 1132 | 1133 | foldlF' :: ArityPeano n => (b -> a -> b) -> b -> Fun n a b 1134 | {-# INLINE foldlF' #-} 1135 | foldlF' f b0 1136 | = accum (\(T_foldl !b) a -> T_foldl (f b a)) 1137 | (\(T_foldl b) -> b) 1138 | (T_foldl b0) 1139 | 1140 | newtype T_foldl b n = T_foldl b 1141 | data T_ifoldl b n = T_ifoldl !Int b 1142 | 1143 | 1144 | -- | Right fold over continuation vector 1145 | foldr :: ArityPeano n => (a -> b -> b) -> b -> ContVec n a -> b 1146 | {-# INLINE foldr #-} 1147 | foldr f b0 = runContVec $ foldrF f b0 1148 | 1149 | -- | Right fold over continuation vector 1150 | ifoldr :: ArityPeano n => (Int -> a -> b -> b) -> b -> ContVec n a -> b 1151 | {-# INLINE ifoldr #-} 1152 | ifoldr f b0 = runContVec $ ifoldrF f b0 1153 | 1154 | 1155 | foldrF :: ArityPeano n => (a -> b -> b) -> b -> Fun n a b 1156 | {-# INLINE foldrF #-} 1157 | foldrF f b0 = accum 1158 | (\(T_foldr g) a -> T_foldr (g . f a)) 1159 | (\(T_foldr g) -> g b0) 1160 | (T_foldr id) 1161 | 1162 | ifoldrF :: ArityPeano n => (Int -> a -> b -> b) -> b -> Fun n a b 1163 | {-# INLINE ifoldrF #-} 1164 | ifoldrF f b0 = accum 1165 | (\(T_ifoldr i g) a -> T_ifoldr (i+1) (g . f i a)) 1166 | (\(T_ifoldr _ g) -> g b0) 1167 | (T_ifoldr 0 id) 1168 | 1169 | data T_foldr b n = T_foldr (b -> b) 1170 | data T_ifoldr b n = T_ifoldr Int (b -> b) 1171 | 1172 | 1173 | -- | Sum all elements in the vector. 1174 | sum :: (Num a, ArityPeano n) => ContVec n a -> a 1175 | sum = foldl' (+) 0 1176 | {-# INLINE sum #-} 1177 | 1178 | -- | Minimal element of vector. 1179 | minimum :: (Ord a, ArityPeano n, n ~ 'S k) => ContVec n a -> a 1180 | minimum = foldl1 min 1181 | {-# INLINE minimum #-} 1182 | 1183 | -- | Maximal element of vector. 1184 | maximum :: (Ord a, ArityPeano n, n ~ 'S k) => ContVec n a -> a 1185 | maximum = foldl1 max 1186 | {-# INLINE maximum #-} 1187 | 1188 | -- | Conjunction of elements of a vector. 1189 | and :: ArityPeano n => ContVec n Bool -> Bool 1190 | and = foldr (&&) True 1191 | {-# INLINE and #-} 1192 | 1193 | -- | Disjunction of all elements of a vector. 1194 | or :: ArityPeano n => ContVec n Bool -> Bool 1195 | or = foldr (||) False 1196 | {-# INLINE or #-} 1197 | 1198 | -- | Determines whether all elements of vector satisfy predicate. 1199 | all :: ArityPeano n => (a -> Bool) -> ContVec n a -> Bool 1200 | all f = foldr (\x b -> f x && b) True 1201 | {-# INLINE all #-} 1202 | 1203 | -- | Determines whether any of element of vector satisfy predicate. 1204 | any :: ArityPeano n => (a -> Bool) -> ContVec n a -> Bool 1205 | any f = foldr (\x b -> f x || b) False 1206 | {-# INLINE any #-} 1207 | 1208 | -- | The 'find' function takes a predicate and a vector and returns 1209 | -- the leftmost element of the vector matching the predicate, 1210 | -- or 'Nothing' if there is no such element. 1211 | find :: ArityPeano n => (a -> Bool) -> ContVec n a -> Maybe a 1212 | find f = foldl (\r x -> r <|> if f x then Just x else Nothing) Nothing 1213 | {-# INLINE find #-} 1214 | 1215 | -- | Generic 'Data.Data.gfoldl' which could work with any vector. 1216 | gfoldl :: forall c v a. (Vector v a, Data a) 1217 | => (forall x y. Data x => c (x -> y) -> x -> c y) 1218 | -> (forall x . x -> c x) 1219 | -> v a -> c (v a) 1220 | gfoldl f inj v 1221 | = inspect v 1222 | $ gfoldlF f (inj $ unFun (construct :: Fun (Dim v) a (v a))) 1223 | 1224 | -- | Generic 'Data.Data.gunfoldl' which could work with any 1225 | -- vector. Since vector can only have one constructor argument for 1226 | -- constructor is ignored. 1227 | gunfold :: forall con c v a. (Vector v a, Data a) 1228 | => (forall b r. Data b => c (b -> r) -> c r) 1229 | -> (forall r. r -> c r) 1230 | -> con -> c (v a) 1231 | gunfold f inj _ = 1232 | case reducePeano step gun of 1233 | T_gunfold c -> c 1234 | where 1235 | con = construct @v @a 1236 | gun = T_gunfold (inj $ unFun con) :: T_gunfold c (v a) a (Dim v) 1237 | -- 1238 | step :: forall k r. T_gunfold c r a ('S k) -> T_gunfold c r a k 1239 | step (T_gunfold c) = T_gunfold (f c) 1240 | 1241 | gfoldlF :: (ArityPeano n, Data a) 1242 | => (forall x y. Data x => c (x -> y) -> x -> c y) 1243 | -> c (Fn n a r) -> Fun n a (c r) 1244 | gfoldlF f c0 = accum 1245 | (\(T_mapM c) x -> T_mapM (f c x)) 1246 | (\(T_mapM c) -> c) 1247 | (T_mapM c0) 1248 | 1249 | 1250 | 1251 | ---------------------------------------------------------------- 1252 | -- Deforestation 1253 | ---------------------------------------------------------------- 1254 | 1255 | -- Deforestation uses following assertion: if we convert continuation 1256 | -- to vector and immediately back to the continuation we can eliminate 1257 | -- intermediate vector. This optimization can however turn 1258 | -- nonterminating programs into terminating. 1259 | -- 1260 | -- > runContVec head $ cvec $ vector $ mk2 () ⊥ 1261 | -- 1262 | -- If intermediate vector is strict in its elements expression above 1263 | -- evaluates to ⊥ too. But if we apply rewrite rule resuling expression: 1264 | -- 1265 | -- > runContVec head $ mk2 () ⊥ 1266 | -- 1267 | -- will evaluate to () since ContVec is not strict in its elements. 1268 | -- It has been considered acceptable. 1269 | -- 1270 | -- 1271 | -- In order to get rule fire reliably (it still doesn't). `vector' in 1272 | -- inlined starting from phase 1. `cvec' is inlined even later (only 1273 | -- during phase 0) because it need to participate in rewriting of 1274 | -- indexing functions. 1275 | 1276 | 1277 | {-# RULES 1278 | "cvec/vector" forall v. 1279 | cvec (vector v) = v 1280 | #-} 1281 | 1282 | 1283 | ---------------------------------------------------------------- 1284 | -- Instances 1285 | ---------------------------------------------------------------- 1286 | 1287 | type instance Dim Complex = N2 1288 | 1289 | instance Vector Complex a where 1290 | construct = Fun (:+) 1291 | inspect (x :+ y) (Fun f) = f x y 1292 | {-# INLINE construct #-} 1293 | {-# INLINE inspect #-} 1294 | 1295 | 1296 | type instance Dim Identity = N1 1297 | 1298 | instance Vector Identity a where 1299 | construct = Fun Identity 1300 | inspect (Identity x) (Fun f) = f x 1301 | {-# INLINE construct #-} 1302 | {-# INLINE inspect #-} 1303 | 1304 | 1305 | type instance Dim ((,) a) = N2 1306 | 1307 | -- | Note this instance (and other instances for tuples) is 1308 | -- essentially monomorphic in element type. Vector type /v/ of 2 1309 | -- element tuple @(Int,Int)@ is @(,) Int@ so it will only work 1310 | -- with elements of type @Int@. 1311 | instance (b~a) => Vector ((,) b) a where 1312 | construct = Fun (,) 1313 | inspect (a,b) (Fun f) = f a b 1314 | {-# INLINE construct #-} 1315 | {-# INLINE inspect #-} 1316 | 1317 | 1318 | type instance Dim ((,,) a b) = N3 1319 | 1320 | instance (b~a, c~a) => Vector ((,,) b c) a where 1321 | construct = Fun (,,) 1322 | inspect (a,b,c) (Fun f) = f a b c 1323 | {-# INLINE construct #-} 1324 | {-# INLINE inspect #-} 1325 | 1326 | 1327 | type instance Dim ((,,,) a b c) = N4 1328 | 1329 | instance (b~a, c~a, d~a) => Vector ((,,,) b c d) a where 1330 | construct = Fun (,,,) 1331 | inspect (a,b,c,d) (Fun f) = f a b c d 1332 | {-# INLINE construct #-} 1333 | {-# INLINE inspect #-} 1334 | 1335 | 1336 | type instance Dim ((,,,,) a b c d) = N5 1337 | 1338 | instance (b~a, c~a, d~a, e~a) => Vector ((,,,,) b c d e) a where 1339 | construct = Fun (,,,,) 1340 | inspect (a,b,c,d,e) (Fun f) = f a b c d e 1341 | {-# INLINE construct #-} 1342 | {-# INLINE inspect #-} 1343 | 1344 | 1345 | type instance Dim ((,,,,,) a b c d e) = N6 1346 | 1347 | instance (b~a, c~a, d~a, e~a, f~a) => Vector ((,,,,,) b c d e f) a where 1348 | construct = Fun (,,,,,) 1349 | inspect (a,b,c,d,e,f) (Fun fun) = fun a b c d e f 1350 | {-# INLINE construct #-} 1351 | {-# INLINE inspect #-} 1352 | 1353 | 1354 | type instance Dim ((,,,,,,) a b c d e f) = N7 1355 | 1356 | instance (b~a, c~a, d~a, e~a, f~a, g~a) => Vector ((,,,,,,) b c d e f g) a where 1357 | construct = Fun (,,,,,,) 1358 | inspect (a,b,c,d,e,f,g) (Fun fun) = fun a b c d e f g 1359 | {-# INLINE construct #-} 1360 | {-# INLINE inspect #-} 1361 | 1362 | type instance Dim Proxy = Z 1363 | 1364 | instance Vector Proxy a where 1365 | construct = Fun Proxy 1366 | inspect _ = unFun 1367 | --------------------------------------------------------------------------------