diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,3 @@ +# 0 + +* Split off from `codex` diff --git a/LICENSE.md b/LICENSE.md new file mode 100644 --- /dev/null +++ b/LICENSE.md @@ -0,0 +1,230 @@ +# License + +Licensed under either of + * Apache License, Version 2.0 (http://www.apache.org/licenses/LICENSE-2.0) + * BSD 2-Clause license (https://opensource.org/licenses/BSD-2-Clause) +at your option. + +## BSD 2-Clause License + +- Copyright 2019 Edward Kmett and Sean Chalmers + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: + +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + +THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR +IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR +ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS +OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, +STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN +ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +POSSIBILITY OF SUCH DAMAGE. + +## Apache License + +_Version 2.0, January 2004_ +_<>_ + +### Terms and Conditions for use, reproduction, and distribution + +#### 1. Definitions + +“License” shall mean the terms and conditions for use, reproduction, and +distribution as defined by Sections 1 through 9 of this document. + +“Licensor” shall mean the copyright owner or entity authorized by the copyright +owner that is granting the License. + +“Legal Entity” shall mean the union of the acting entity and all other entities +that control, are controlled by, or are under common control with that entity. +For the purposes of this definition, “control” means **(i)** the power, direct or +indirect, to cause the direction or management of such entity, whether by +contract or otherwise, or **(ii)** ownership of fifty percent (50%) or more of the +outstanding shares, or **(iii)** beneficial ownership of such entity. + +“You” (or “Your”) shall mean an individual or Legal Entity exercising +permissions granted by this License. + +“Source” form shall mean the preferred form for making modifications, including +but not limited to software source code, documentation source, and configuration +files. + +“Object” form shall mean any form resulting from mechanical transformation or +translation of a Source form, including but not limited to compiled object code, +generated documentation, and conversions to other media types. + +“Work” shall mean the work of authorship, whether in Source or Object form, made +available under the License, as indicated by a copyright notice that is included +in or attached to the work (an example is provided in the Appendix below). + +“Derivative Works” shall mean any work, whether in Source or Object form, that +is based on (or derived from) the Work and for which the editorial revisions, +annotations, elaborations, or other modifications represent, as a whole, an +original work of authorship. For the purposes of this License, Derivative Works +shall not include works that remain separable from, or merely link (or bind by +name) to the interfaces of, the Work and Derivative Works thereof. + +“Contribution” shall mean any work of authorship, including the original version +of the Work and any modifications or additions to that Work or Derivative Works +thereof, that is intentionally submitted to Licensor for inclusion in the Work +by the copyright owner or by an individual or Legal Entity authorized to submit +on behalf of the copyright owner. For the purposes of this definition, +“submitted” means any form of electronic, verbal, or written communication sent +to the Licensor or its representatives, including but not limited to +communication on electronic mailing lists, source code control systems, and +issue tracking systems that are managed by, or on behalf of, the Licensor for +the purpose of discussing and improving the Work, but excluding communication +that is conspicuously marked or otherwise designated in writing by the copyright +owner as “Not a Contribution.” + +“Contributor” shall mean Licensor and any individual or Legal Entity on behalf +of whom a Contribution has been received by Licensor and subsequently +incorporated within the Work. + +#### 2. Grant of Copyright License + +Subject to the terms and conditions of this License, each Contributor hereby +grants to You a perpetual, worldwide, non-exclusive, no-charge, royalty-free, +irrevocable copyright license to reproduce, prepare Derivative Works of, +publicly display, publicly perform, sublicense, and distribute the Work and such +Derivative Works in Source or Object form. + +#### 3. Grant of Patent License + +Subject to the terms and conditions of this License, each Contributor hereby +grants to You a perpetual, worldwide, non-exclusive, no-charge, royalty-free, +irrevocable (except as stated in this section) patent license to make, have +made, use, offer to sell, sell, import, and otherwise transfer the Work, where +such license applies only to those patent claims licensable by such Contributor +that are necessarily infringed by their Contribution(s) alone or by combination +of their Contribution(s) with the Work to which such Contribution(s) was +submitted. If You institute patent litigation against any entity (including a +cross-claim or counterclaim in a lawsuit) alleging that the Work or a +Contribution incorporated within the Work constitutes direct or contributory +patent infringement, then any patent licenses granted to You under this License +for that Work shall terminate as of the date such litigation is filed. + +#### 4. Redistribution + +You may reproduce and distribute copies of the Work or Derivative Works thereof +in any medium, with or without modifications, and in Source or Object form, +provided that You meet the following conditions: + +* **(a)** You must give any other recipients of the Work or Derivative Works a copy of +this License; and +* **(b)** You must cause any modified files to carry prominent notices stating that You +changed the files; and +* **(c)** You must retain, in the Source form of any Derivative Works that You distribute, +all copyright, patent, trademark, and attribution notices from the Source form +of the Work, excluding those notices that do not pertain to any part of the +Derivative Works; and +* **(d)** If the Work includes a “NOTICE” text file as part of its distribution, then any +Derivative Works that You distribute must include a readable copy of the +attribution notices contained within such NOTICE file, excluding those notices +that do not pertain to any part of the Derivative Works, in at least one of the +following places: within a NOTICE text file distributed as part of the +Derivative Works; within the Source form or documentation, if provided along +with the Derivative Works; or, within a display generated by the Derivative +Works, if and wherever such third-party notices normally appear. The contents of +the NOTICE file are for informational purposes only and do not modify the +License. You may add Your own attribution notices within Derivative Works that +You distribute, alongside or as an addendum to the NOTICE text from the Work, +provided that such additional attribution notices cannot be construed as +modifying the License. + +You may add Your own copyright statement to Your modifications and may provide +additional or different license terms and conditions for use, reproduction, or +distribution of Your modifications, or for any such Derivative Works as a whole, +provided Your use, reproduction, and distribution of the Work otherwise complies +with the conditions stated in this License. + +#### 5. Submission of Contributions + +Unless You explicitly state otherwise, any Contribution intentionally submitted +for inclusion in the Work by You to the Licensor shall be under the terms and +conditions of this License, without any additional terms or conditions. +Notwithstanding the above, nothing herein shall supersede or modify the terms of +any separate license agreement you may have executed with Licensor regarding +such Contributions. + +#### 6. Trademarks + +This License does not grant permission to use the trade names, trademarks, +service marks, or product names of the Licensor, except as required for +reasonable and customary use in describing the origin of the Work and +reproducing the content of the NOTICE file. + +#### 7. Disclaimer of Warranty + +Unless required by applicable law or agreed to in writing, Licensor provides the +Work (and each Contributor provides its Contributions) on an “AS IS” BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied, +including, without limitation, any warranties or conditions of TITLE, +NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A PARTICULAR PURPOSE. You are +solely responsible for determining the appropriateness of using or +redistributing the Work and assume any risks associated with Your exercise of +permissions under this License. + +#### 8. Limitation of Liability + +In no event and under no legal theory, whether in tort (including negligence), +contract, or otherwise, unless required by applicable law (such as deliberate +and grossly negligent acts) or agreed to in writing, shall any Contributor be +liable to You for damages, including any direct, indirect, special, incidental, +or consequential damages of any character arising as a result of this License or +out of the use or inability to use the Work (including but not limited to +damages for loss of goodwill, work stoppage, computer failure or malfunction, or +any and all other commercial damages or losses), even if such Contributor has +been advised of the possibility of such damages. + +#### 9. Accepting Warranty or Additional Liability + +While redistributing the Work or Derivative Works thereof, You may choose to +offer, and charge a fee for, acceptance of support, warranty, indemnity, or +other liability obligations and/or rights consistent with this License. However, +in accepting such obligations, You may act only on Your own behalf and on Your +sole responsibility, not on behalf of any other Contributor, and only if You +agree to indemnify, defend, and hold each Contributor harmless for any liability +incurred by, or claims asserted against, such Contributor by reason of your +accepting any such warranty or additional liability. + +_END OF TERMS AND CONDITIONS_ + +### APPENDIX: How to apply the Apache License to your work + +To apply the Apache License to your work, attach the following boilerplate +notice, with the fields enclosed by brackets `[]` replaced with your own +identifying information. (Don't include the brackets!) The text should be +enclosed in the appropriate comment syntax for the file format. We also +recommend that a file or class name and description of purpose be included on +the same “printed page” as the copyright notice for easier identification within +third-party archives. + + Copyright [yyyy] [name of copyright owner] + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. + diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,20 @@ +const +===== + +[![Hackage](https://img.shields.io/hackage/v/const.svg)](https://hackage.haskell.org/package/const) + +This package provides a small shim around the data types and operations in `Foreign` and `Data.Primitive` +for emulating const-correctness from a C perspective. + +In the future it'd be nice to have a proper const-cast that can handle nested ConstPtr's, etc. but this suffices +for my current usecases. Patches welcome! + +Contact Information +------------------- + +Contributions and bug reports are welcome! + +Please feel free to contact me through github or on the #haskell IRC channel on irc.freenode.net. + +-Edward Kmett + diff --git a/const.cabal b/const.cabal new file mode 100644 --- /dev/null +++ b/const.cabal @@ -0,0 +1,56 @@ +cabal-version: 2.2 +name: const +version: 0 +synopsis: Read-only mutable primitives +homepage: https://github.com/ekmett/codex/tree/master/const#readme +license: BSD-2-Clause OR Apache-2.0 +license-file: LICENSE.md +author: Edward Kmett +maintainer: Edward Kmett +copyright: Copyright (c) 2019-2021 Edward Kmett +stability: experimental +category: FFI +build-type: Simple +description: + Read-only mutable primitives. + . + This can be used for more accurate FFI bindings + or simply to indicate more cleanly in your code + what you are and aren't allowed to modify. +extra-doc-files: + README.md, + CHANGELOG.md + +source-repository head + type: git + location: https://github.com/ekmett/codex + subdir: const + +library + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: + -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates + -Wredundant-constraints -Widentities -Wmissing-export-lists + build-depends: + , base >= 4.12 && < 5 + , bytestring >= 0.10.8 && < 0.12 + , primitive ^>= 0.7 + , ptrdiff ^>= 0 + exposed-modules: + Data.Const + Data.Const.ByteString + Data.Const.IORef + Data.Const.STRef + Data.Const.Unsafe + Data.Const.Primitive.Array + Data.Const.Primitive.ByteArray + Data.Const.Primitive.PrimArray + Data.Const.Primitive.MutVar + Data.Const.Primitive.SmallArray + Foreign.Const.C.String + Foreign.Const.Concurrent + Foreign.Const.ForeignPtr + Foreign.Const.Ptr + Foreign.Const.Marshal.Array + Foreign.Const.Marshal.Utils diff --git a/src/Data/Const.hs b/src/Data/Const.hs new file mode 100644 --- /dev/null +++ b/src/Data/Const.hs @@ -0,0 +1,14 @@ +{-# language Trustworthy #-} +-- | +-- Copyright : (c) 2019 Edward Kmett +-- License : BSD-2-Clause OR Apache-2.0 +-- Maintainer: Edward Kmett +-- Stability : experimental +-- Portability: non-portable +-- +module Data.Const +( Constable +, constant +) where + +import Data.Const.Unsafe diff --git a/src/Data/Const/ByteString.hs b/src/Data/Const/ByteString.hs new file mode 100644 --- /dev/null +++ b/src/Data/Const/ByteString.hs @@ -0,0 +1,42 @@ +{-# language RankNTypes #-} +{-# language ConstraintKinds #-} +{-# language FlexibleContexts #-} +{-# language TypeApplications #-} +{-# language ScopedTypeVariables #-} +{-# language TypeFamilies #-} +{-# language Trustworthy #-} +-- | +-- Copyright : (c) 2019 Edward Kmett +-- License : BSD-2-Clause OR Apache-2.0 +-- Maintainer: Edward Kmett +-- Stability : experimental +-- Portability: non-portable +-- +module Data.Const.ByteString +( packACString +, packACStringLen +, useAsConstCString +, useAsConstCStringLen +) where + +import Data.ByteString as Strict +import Data.Coerce +import Data.Type.Coercion + +import Data.Const.Unsafe + +useAsConstCString :: forall a. Strict.ByteString -> (ConstCString -> IO a) -> IO a +useAsConstCString = coerce (Strict.useAsCString @a) +{-# inline useAsConstCString #-} + +useAsConstCStringLen:: forall a. Strict.ByteString -> (ConstCStringLen -> IO a) -> IO a +useAsConstCStringLen = coerce (Strict.useAsCStringLen @a) +{-# inline useAsConstCStringLen #-} + +packACString :: forall s. ACString s => s -> IO ByteString +packACString = gcoerceWith (unsafeCStringCoercion @s) $ coerce $ Strict.packCString +{-# inline packACString #-} + +packACStringLen :: forall s. ACString s => (s,Int) -> IO ByteString +packACStringLen = gcoerceWith (unsafeCStringCoercion @s) $ coerce $ Strict.packCStringLen +{-# inline packACStringLen #-} diff --git a/src/Data/Const/IORef.hs b/src/Data/Const/IORef.hs new file mode 100644 --- /dev/null +++ b/src/Data/Const/IORef.hs @@ -0,0 +1,34 @@ +{-# language ScopedTypeVariables #-} +{-# language TypeApplications #-} +{-# language FlexibleContexts #-} +{-# language ConstraintKinds #-} +{-# language TypeFamilies #-} +{-# language Trustworthy #-} +-- | +-- Copyright : (c) 2019 Edward Kmett +-- License : BSD-2-Clause OR Apache-2.0 +-- Maintainer: Edward Kmett +-- Stability : experimental +-- Portability: non-portable +-- +module Data.Const.IORef +( ConstIORef +, constIORef +, AnIORef + +, readAnIORef +) where + +import Data.Coerce +import Data.IORef +import Data.Type.Coercion + +import Data.Const.Unsafe + +constIORef :: AnIORef p => p a -> ConstIORef a +constIORef = constant +{-# inline constIORef #-} + +readAnIORef :: forall p a. AnIORef p => p a -> IO a +readAnIORef = gcoerceWith (unsafeIORefCoercion @p @a) $ coerce $ readIORef @a +{-# inline readAnIORef #-} diff --git a/src/Data/Const/Primitive/Array.hs b/src/Data/Const/Primitive/Array.hs new file mode 100644 --- /dev/null +++ b/src/Data/Const/Primitive/Array.hs @@ -0,0 +1,57 @@ +{-# language ScopedTypeVariables #-} +{-# language TypeApplications #-} +{-# language FlexibleContexts #-} +{-# language ConstraintKinds #-} +{-# language TypeFamilies #-} +{-# language Trustworthy #-} +-- | +-- Copyright : (c) 2019 Edward Kmett +-- License : BSD-2-Clause OR Apache-2.0 +-- Maintainer: Edward Kmett +-- Stability : experimental +-- Portability: non-portable +-- +module Data.Const.Primitive.Array +( ConstArray +, constArray +, AnArray +, readAnArray +, sameArray +, copyAnArray +, cloneAnArray +, sizeofAnArray +) where + +import Control.Monad.Primitive +import Data.Coerce +import Data.Type.Coercion +import Data.Primitive.Array + +import Data.Const.Unsafe + +constArray :: AnArray s p => p a -> ConstArray s a +constArray = constant +{-# inline constArray #-} + +readAnArray :: forall m p a. (PrimMonad m, AnArray (PrimState m) p) => p a -> Int -> m a +readAnArray = gcoerceWith (unsafeArrayCoercion @(PrimState m) @p @a) $ coerce $ readArray @m @a +{-# inline readAnArray #-} + +sameArray :: forall s p q a. (AnArray s p, AnArray s q) => p a -> q a -> Bool +sameArray + = gcoerceWith (unsafeArrayCoercion @s @p @a) + $ gcoerceWith (unsafeArrayCoercion @s @q @a) + $ coerce $ sameMutableArray @s @a +{-# inline sameArray #-} + +copyAnArray :: forall m p a. (PrimMonad m, AnArray (PrimState m) p) => MutableArray (PrimState m) a -> Int -> p a -> Int -> Int -> m () +copyAnArray = gcoerceWith (unsafeArrayCoercion @(PrimState m) @p @a) $ coerce $ copyMutableArray @m @a +{-# inline copyAnArray #-} + +cloneAnArray :: forall m p a. (PrimMonad m, AnArray (PrimState m) p) => p a -> Int -> Int -> m (MutableArray (PrimState m) a) +cloneAnArray = gcoerceWith (unsafeArrayCoercion @(PrimState m) @p @a) $ coerce $ cloneMutableArray @m @a +{-# inline cloneAnArray #-} + +sizeofAnArray :: forall s p a. AnArray s p => p a -> Int +sizeofAnArray = gcoerceWith (unsafeArrayCoercion @s @p @a) $ coerce $ sizeofMutableArray @s @a +{-# inline sizeofAnArray #-} diff --git a/src/Data/Const/Primitive/ByteArray.hs b/src/Data/Const/Primitive/ByteArray.hs new file mode 100644 --- /dev/null +++ b/src/Data/Const/Primitive/ByteArray.hs @@ -0,0 +1,91 @@ +{-# language ScopedTypeVariables #-} +{-# language TypeApplications #-} +{-# language FlexibleContexts #-} +{-# language ConstraintKinds #-} +{-# language TypeFamilies #-} +{-# language Trustworthy #-} +{-# language CPP #-} +-- | +-- Copyright : (c) 2019 Edward Kmett +-- License : BSD-2-Clause OR Apache-2.0 +-- Maintainer: Edward Kmett +-- Stability : experimental +-- Portability: non-portable +-- +module Data.Const.Primitive.ByteArray +( ConstByteArray +, constByteArray +, AByteArray + +, readAByteArray +, sameByteArray +, copyAByteArray +, copyAByteArrayToAddr +, moveAByteArray +, sizeofAByteArray +, getSizeofAByteArray +, isAByteArrayPinned +, constByteArrayContents +) where + +import Control.Monad.Primitive +import Data.Coerce +import Data.Type.Coercion +import Data.Primitive.ByteArray +import Data.Primitive.Ptr (Ptr (..)) +import Data.Primitive.Types +import Data.Word + +import Data.Const.Unsafe + +#if MIN_VERSION_primitive(0,7,0) +type Addr = Ptr () +#endif + +constByteArray :: AByteArray p => p s -> ConstByteArray s +constByteArray = constant +{-# inline constByteArray #-} + +readAByteArray :: forall a m p. (Prim a, PrimMonad m, AByteArray p) => p (PrimState m) -> Int -> m a +readAByteArray = gcoerceWith (unsafeByteArrayCoercion @p @(PrimState m)) $ coerce $ readByteArray @a @m +{-# inline readAByteArray #-} + +sameByteArray :: forall s p q. (AByteArray p, AByteArray q) => p s -> q s -> Bool +sameByteArray + = gcoerceWith (unsafeByteArrayCoercion @p @s) + $ gcoerceWith (unsafeByteArrayCoercion @q @s) + $ coerce $ sameMutableByteArray @s +{-# inline sameByteArray #-} + +copyAByteArray :: forall m p. (AByteArray p, PrimMonad m) => MutableByteArray (PrimState m) -> Int -> p (PrimState m) -> Int -> Int -> m () +copyAByteArray = gcoerceWith (unsafeByteArrayCoercion @p @(PrimState m)) $ coerce $ copyMutableByteArray @m +{-# inline copyAByteArray #-} + +copyAByteArrayToAddr :: forall m p. (AByteArray p, PrimMonad m) => Addr -> p (PrimState m) -> Int -> Int -> m () +copyAByteArrayToAddr = gcoerceWith (unsafeByteArrayCoercion @p @(PrimState m)) $ coerce $ copyMutableByteArrayToAddr @m +{-# inline copyAByteArrayToAddr #-} + +moveAByteArray :: forall m p. (AByteArray p, PrimMonad m) => MutableByteArray (PrimState m) -> Int -> p (PrimState m) -> Int -> Int -> m () +moveAByteArray = gcoerceWith (unsafeByteArrayCoercion @p @(PrimState m)) $ coerce $ moveByteArray @m +{-# inline moveAByteArray #-} + +sizeofAByteArray :: forall s p. AByteArray p => p s -> Int +sizeofAByteArray = gcoerceWith (unsafeByteArrayCoercion @p @s) $ coerce $ sizeofMutableByteArray @s +{-# inline sizeofAByteArray #-} + +getSizeofAByteArray :: forall m p. (PrimMonad m, AByteArray p) => p (PrimState m) -> m Int +getSizeofAByteArray = gcoerceWith (unsafeByteArrayCoercion @p @(PrimState m)) $ coerce $ getSizeofMutableByteArray @m +{-# inline getSizeofAByteArray #-} + +isAByteArrayPinned :: forall s p. AByteArray p => p s -> Bool +isAByteArrayPinned = gcoerceWith (unsafeByteArrayCoercion @p @s) $ coerce $ isMutableByteArrayPinned @s +{-# inline isAByteArrayPinned #-} + +-- | Only safe on a pinned ByteArray or pinned ConstByteArray +constByteArrayContents :: forall s p. AByteArray p => p s -> ConstPtr Word8 +#if MIN_VERSION_primitive(0,7,0) +constByteArrayContents = gcoerceWith (unsafeByteArrayCoercion @p @s) $ coerce $ mutableByteArrayContents @s +#else +constByteArrayContents = gcoerceWith (unsafeByteArrayCoercion @p @s) $ coerce $ (\(Addr a) -> Ptr a) . mutableByteArrayContents @s +#endif +{-# inline constByteArrayContents #-} diff --git a/src/Data/Const/Primitive/MutVar.hs b/src/Data/Const/Primitive/MutVar.hs new file mode 100644 --- /dev/null +++ b/src/Data/Const/Primitive/MutVar.hs @@ -0,0 +1,35 @@ +{-# language ScopedTypeVariables #-} +{-# language TypeApplications #-} +{-# language FlexibleContexts #-} +{-# language ConstraintKinds #-} +{-# language TypeFamilies #-} +{-# language Trustworthy #-} +-- | +-- Copyright : (c) 2019 Edward Kmett +-- License : BSD-2-Clause OR Apache-2.0 +-- Maintainer: Edward Kmett +-- Stability : experimental +-- Portability: non-portable +-- +module Data.Const.Primitive.MutVar + ( ConstMutVar + , constMutVar + , AMutVar + + , readAMutVar + ) where + +import Control.Monad.Primitive +import Data.Coerce +import Data.Type.Coercion +import Data.Primitive.MutVar + +import Data.Const.Unsafe + +constMutVar :: AMutVar s p => p a -> ConstMutVar s a +constMutVar = constant +{-# inline constMutVar #-} + +readAMutVar :: forall m p a. (PrimMonad m, AMutVar (PrimState m) p) => p a -> m a +readAMutVar = gcoerceWith (unsafeMutVarCoercion @(PrimState m) @p @a) $ coerce $ readMutVar @m @a +{-# inline readAMutVar #-} diff --git a/src/Data/Const/Primitive/PrimArray.hs b/src/Data/Const/Primitive/PrimArray.hs new file mode 100644 --- /dev/null +++ b/src/Data/Const/Primitive/PrimArray.hs @@ -0,0 +1,65 @@ +{-# language ScopedTypeVariables #-} +{-# language TypeApplications #-} +{-# language FlexibleContexts #-} +{-# language ConstraintKinds #-} +{-# language TypeFamilies #-} +{-# language Trustworthy #-} +-- | +-- Copyright : (c) 2019 Edward Kmett +-- License : BSD-2-Clause OR Apache-2.0 +-- Maintainer: Edward Kmett +-- Stability : experimental +-- Portability: non-portable +-- +module Data.Const.Primitive.PrimArray +( ConstPrimArray +, constPrimArray +, APrimArray + +, readAPrimArray +, samePrimArray +, copyAPrimArray +, copyAPrimArrayToPtr +, sizeofAPrimArray +, getSizeofAPrimArray +) where + +import Control.Monad.Primitive +import Data.Coerce +import Data.Type.Coercion +import Data.Primitive.PrimArray +import Data.Primitive.Types +import Data.Primitive.Ptr (Ptr (..)) + +import Data.Const.Unsafe + +constPrimArray :: APrimArray s p => p a -> ConstPrimArray s a +constPrimArray = constant +{-# inline constPrimArray #-} + +readAPrimArray :: forall a m p. (Prim a, PrimMonad m, APrimArray (PrimState m) p) => p a -> Int -> m a +readAPrimArray = gcoerceWith (unsafePrimArrayCoercion @(PrimState m) @p @a) $ coerce $ readPrimArray @a @m +{-# inline readAPrimArray #-} + +samePrimArray :: forall s a p q. (APrimArray s p, APrimArray s q) => p a -> q a -> Bool +samePrimArray + = gcoerceWith (unsafePrimArrayCoercion @s @p @a) + $ gcoerceWith (unsafePrimArrayCoercion @s @q @a) + $ coerce $ sameMutablePrimArray @s @a +{-# inline samePrimArray #-} + +copyAPrimArray :: forall m a p. (Prim a, PrimMonad m, APrimArray (PrimState m) p) => MutablePrimArray (PrimState m) a -> Int -> p a -> Int -> Int -> m () +copyAPrimArray = gcoerceWith (unsafePrimArrayCoercion @(PrimState m) @p @a) $ coerce $ copyMutablePrimArray @m @a +{-# inline copyAPrimArray #-} + +copyAPrimArrayToPtr :: forall m a p. (Prim a, PrimMonad m, APrimArray (PrimState m) p) => Ptr a -> p a -> Int -> Int -> m () +copyAPrimArrayToPtr = gcoerceWith (unsafePrimArrayCoercion @(PrimState m) @p @a) $ coerce $ copyMutablePrimArrayToPtr @m @a +{-# inline copyAPrimArrayToPtr #-} + +sizeofAPrimArray :: forall s a p. (Prim a, APrimArray s p) => p a -> Int +sizeofAPrimArray = gcoerceWith (unsafePrimArrayCoercion @s @p @a) $ coerce $ sizeofMutablePrimArray @s @a +{-# inline sizeofAPrimArray #-} + +getSizeofAPrimArray :: forall m a p. (Prim a, PrimMonad m, APrimArray (PrimState m) p) => p a -> m Int +getSizeofAPrimArray = gcoerceWith (unsafePrimArrayCoercion @(PrimState m) @p @a) $ coerce $ getSizeofMutablePrimArray @m @a +{-# inline getSizeofAPrimArray #-} diff --git a/src/Data/Const/Primitive/SmallArray.hs b/src/Data/Const/Primitive/SmallArray.hs new file mode 100644 --- /dev/null +++ b/src/Data/Const/Primitive/SmallArray.hs @@ -0,0 +1,57 @@ +{-# language ScopedTypeVariables #-} +{-# language TypeApplications #-} +{-# language FlexibleContexts #-} +{-# language ConstraintKinds #-} +{-# language TypeFamilies #-} +{-# language Trustworthy #-} +-- | +-- Copyright : (c) 2019 Edward Kmett +-- License : BSD-2-Clause OR Apache-2.0 +-- Maintainer: Edward Kmett +-- Stability : experimental +-- Portability: non-portable +-- +module Data.Const.Primitive.SmallArray +( SmallConstArray +, smallConstArray +, ASmallArray +, readASmallArray +, sameSmallArray +, copyASmallArray +, cloneASmallArray +, sizeofASmallArray +) where + +import Control.Monad.Primitive +import Data.Coerce +import Data.Type.Coercion +import Data.Primitive.SmallArray + +import Data.Const.Unsafe + +smallConstArray :: ASmallArray s p => p a -> SmallConstArray s a +smallConstArray = constant +{-# inline smallConstArray #-} + +readASmallArray :: forall m p a. (PrimMonad m, ASmallArray (PrimState m) p) => p a -> Int -> m a +readASmallArray = gcoerceWith (unsafeSmallArrayCoercion @(PrimState m) @p @a) $ coerce $ readSmallArray @m @a +{-# inline readASmallArray #-} + +sameSmallArray :: forall s p q a. (ASmallArray s p, ASmallArray s q) => p a -> q a -> Bool +sameSmallArray + = gcoerceWith (unsafeSmallArrayCoercion @s @p @a) + $ gcoerceWith (unsafeSmallArrayCoercion @s @q @a) + $ coerce $ (==) @(SmallMutableArray s a) +{-# inline sameSmallArray #-} + +copyASmallArray :: forall m p a. (PrimMonad m, ASmallArray (PrimState m) p) => SmallMutableArray (PrimState m) a -> Int -> p a -> Int -> Int -> m () +copyASmallArray = gcoerceWith (unsafeSmallArrayCoercion @(PrimState m) @p @a) $ coerce $ copySmallMutableArray @m @a +{-# inline copyASmallArray #-} + +cloneASmallArray :: forall m p a. (PrimMonad m, ASmallArray (PrimState m) p) => p a -> Int -> Int -> m (SmallMutableArray (PrimState m) a) +cloneASmallArray = gcoerceWith (unsafeSmallArrayCoercion @(PrimState m) @p @a) $ coerce $ cloneSmallMutableArray @m @a +{-# inline cloneASmallArray #-} + +sizeofASmallArray :: forall s p a. ASmallArray s p => p a -> Int +sizeofASmallArray = gcoerceWith (unsafeSmallArrayCoercion @s @p @a) $ coerce $ sizeofSmallMutableArray @s @a +{-# inline sizeofASmallArray #-} diff --git a/src/Data/Const/STRef.hs b/src/Data/Const/STRef.hs new file mode 100644 --- /dev/null +++ b/src/Data/Const/STRef.hs @@ -0,0 +1,35 @@ +{-# language ScopedTypeVariables #-} +{-# language TypeApplications #-} +{-# language FlexibleContexts #-} +{-# language ConstraintKinds #-} +{-# language TypeFamilies #-} +{-# language Trustworthy #-} +-- | +-- Copyright : (c) 2019 Edward Kmett +-- License : BSD-2-Clause OR Apache-2.0 +-- Maintainer: Edward Kmett +-- Stability : experimental +-- Portability: non-portable +-- +module Data.Const.STRef +( ConstSTRef +, constSTRef +, AnSTRef + +, readAnSTRef +) where + +import Control.Monad.ST +import Data.Coerce +import Data.STRef +import Data.Type.Coercion + +import Data.Const.Unsafe + +constSTRef :: AnSTRef s p => p a -> ConstSTRef s a +constSTRef = constant +{-# inline constSTRef #-} + +readAnSTRef :: forall s p a. AnSTRef s p => p a -> ST s a +readAnSTRef = gcoerceWith (unsafeSTRefCoercion @s @p @a) $ coerce $ readSTRef @s @a +{-# inline readAnSTRef #-} diff --git a/src/Data/Const/Unsafe.hs b/src/Data/Const/Unsafe.hs new file mode 100644 --- /dev/null +++ b/src/Data/Const/Unsafe.hs @@ -0,0 +1,255 @@ +{-# language CPP #-} +{-# language GeneralizedNewtypeDeriving #-} +{-# language UndecidableSuperClasses #-} +#ifndef HLINT +{-# language FunctionalDependencies #-} +#endif +{-# language QuantifiedConstraints #-} +{-# language MultiParamTypeClasses #-} +{-# language AllowAmbiguousTypes #-} +{-# language ScopedTypeVariables #-} +{-# language DeriveDataTypeable #-} +{-# language FlexibleContexts #-} +{-# language TypeApplications #-} +{-# language ConstraintKinds #-} +{-# language TypeOperators #-} +{-# language TypeFamilies #-} +{-# language RankNTypes #-} +{-# language PolyKinds #-} +-- | +-- Copyright : (c) 2019 Edward Kmett +-- License : BSD-2-Clause OR Apache-2.0 +-- Maintainer: Edward Kmett +-- Stability : experimental +-- Portability: non-portable +-- +module Data.Const.Unsafe +( Constable +, ConstPtr(..) +, ConstForeignPtr(..) +, ConstArray(..) +, ConstByteArray(..) +, ConstPrimArray(..) +, ConstMutVar(..) +, ConstIORef(..) +, ConstSTRef(..) +, SmallConstArray(..) -- to mirror SmallMutableArray's naming +, ConstCString +, ConstCStringLen +, ConstCWString +, ConstCWStringLen +, constant, unsafeConstantCoercion -- note, using the symmetry of this coercion is dangerous +, APtr, unsafePtr, unsafePtrCoercion +, AForeignPtr, unsafeForeignPtr, unsafeForeignPtrCoercion +, AnArray, unsafeArray, unsafeArrayCoercion +, AByteArray, unsafeByteArray, unsafeByteArrayCoercion +, APrimArray, unsafePrimArray, unsafePrimArrayCoercion +, ASmallArray, unsafeSmallArray, unsafeSmallArrayCoercion +, AMutVar, unsafeMutVar, unsafeMutVarCoercion +, AnIORef, unsafeIORef, unsafeIORefCoercion +, AnSTRef, unsafeSTRef, unsafeSTRefCoercion +, ACString, unsafeCStringCoercion +, ACWString, unsafeCWStringCoercion +) where + +import Data.Coerce +import Data.Data +import Data.IORef +import Data.Primitive.Array +import Data.Primitive.ByteArray +import Data.Primitive.PrimArray +import Data.Primitive.SmallArray +import Data.Primitive.MutVar +import Data.STRef +import Data.Type.Coercion +import Foreign.C.String +import Foreign.C.Types +import Foreign.Ptr +import Foreign.Ptr.Diff +import Foreign.ForeignPtr +import Foreign.Storable +import Control.Category +import Prelude hiding (id,(.)) + +#ifndef HLINT +class (Constable q q, forall a. Coercible (q a) (p a)) => Constable q p | p -> q +#endif + +-- this is the safe direction +constant :: forall p a q. Constable q p => p a -> q a +constant = coerceWith (sym unsafeConstantCoercion) +{-# inline constant #-} + +unsafeConstantCoercion :: forall p a q. Constable q p => Coercion (q a) (p a) +unsafeConstantCoercion = Coercion +{-# inline unsafeConstantCoercion #-} + +uncoerceWith :: Coercion a b -> b -> a +uncoerceWith = coerceWith . sym +{-# inline uncoerceWith #-} + +-- * pointers + +newtype ConstPtr a = ConstPtr { unsafeConstPtrPtr :: Ptr a } deriving (Eq,Ord,Show,Data,Storable,DiffTorsor) +instance Constable ConstPtr Ptr +instance Constable ConstPtr ConstPtr +type APtr = Constable ConstPtr + +-- note backwards +unsafePtrCoercion :: forall p a. APtr p => Coercion (Ptr a) (p a) +unsafePtrCoercion = unsafeConstantCoercion @p @a . Coercion +{-# inline unsafePtrCoercion #-} + +unsafePtr :: forall p a. APtr p => p a -> Ptr a +unsafePtr = uncoerceWith (unsafePtrCoercion @p) +{-# inline unsafePtr #-} + +-- * foreign pointers +-- +newtype ConstForeignPtr a = ConstForeignPtr { unsafeConstForeignPtrForeignPtr :: ForeignPtr a } deriving (Eq,Ord,Show,Data,DiffTorsor) +instance Constable ConstForeignPtr ForeignPtr +instance Constable ConstForeignPtr ConstForeignPtr +type AForeignPtr = Constable ConstForeignPtr + +unsafeForeignPtrCoercion :: forall p a. AForeignPtr p => Coercion (ForeignPtr a) (p a) +unsafeForeignPtrCoercion = unsafeConstantCoercion @p @a . Coercion +{-# inline unsafeForeignPtrCoercion #-} + +unsafeForeignPtr :: forall p a. AForeignPtr p => p a -> ForeignPtr a +unsafeForeignPtr = coerceWith (sym (unsafeForeignPtrCoercion @p)) +{-# inline unsafeForeignPtr #-} + +-- Data.Primitive.IORef + +newtype ConstIORef a = ConstIORef { unsafeConstIORefIORef :: IORef a } deriving Eq +instance Constable ConstIORef IORef +instance Constable ConstIORef ConstIORef +type AnIORef = Constable ConstIORef + +unsafeIORefCoercion :: forall p a. AnIORef p => Coercion (IORef a) (p a) +unsafeIORefCoercion = unsafeConstantCoercion @p @a . Coercion +{-# inline unsafeIORefCoercion #-} + +unsafeIORef :: forall p a. AnIORef p => p a -> IORef a +unsafeIORef = uncoerceWith (unsafeIORefCoercion @p) +{-# inline unsafeIORef #-} + +-- Data.Primitive.Array + +newtype ConstArray s a = ConstArray { unsafeConstArrayMutableArray :: MutableArray s a } deriving Eq +instance Constable (ConstArray s) (MutableArray s) +instance Constable (ConstArray s) (ConstArray s) +type AnArray s = Constable (ConstArray s) + +unsafeArrayCoercion :: forall s p a. AnArray s p => Coercion (MutableArray s a) (p a) +unsafeArrayCoercion = unsafeConstantCoercion @p @a . Coercion +{-# inline unsafeArrayCoercion #-} + +unsafeArray :: forall s p a. AnArray s p => p a -> MutableArray s a +unsafeArray = uncoerceWith (unsafeArrayCoercion @s @p) +{-# inline unsafeArray #-} + +-- Data.Primitive.ByteArray + +-- this one trickily uses 's' as the 'a' parameter above. Blech, but it works +newtype ConstByteArray s = ConstByteArray { unsafeConstByteArrayMutableByteArray :: MutableByteArray s } + +instance Eq (ConstByteArray s) where + (==) = coerce (sameMutableByteArray @s) + +instance Constable ConstByteArray MutableByteArray +instance Constable ConstByteArray ConstByteArray +type AByteArray = Constable ConstByteArray + +unsafeByteArrayCoercion :: forall p s. AByteArray p => Coercion (MutableByteArray s) (p s) +unsafeByteArrayCoercion = unsafeConstantCoercion @p @s. Coercion +{-# inline unsafeByteArrayCoercion #-} + +unsafeByteArray :: forall s p. AByteArray p => p s -> MutableByteArray s +unsafeByteArray = uncoerceWith (unsafeByteArrayCoercion @p @s) +{-# inline unsafeByteArray #-} + +-- Data.Primitive.PrimArray + +newtype ConstPrimArray s a = ConstPrimArray { unsafeConstPrimArrayMutablePrimArray :: MutablePrimArray s a } + +instance Eq (ConstPrimArray s a) where + (==) = coerce (sameMutablePrimArray @s) + +instance Constable (ConstPrimArray s) (MutablePrimArray s) +instance Constable (ConstPrimArray s) (ConstPrimArray s) +type APrimArray s = Constable (ConstPrimArray s) + +unsafePrimArrayCoercion :: forall s p a. APrimArray s p => Coercion (MutablePrimArray s a) (p a) +unsafePrimArrayCoercion = unsafeConstantCoercion @p @a . Coercion +{-# inline unsafePrimArrayCoercion #-} + +unsafePrimArray :: forall s p a. APrimArray s p => p a -> MutablePrimArray s a +unsafePrimArray = uncoerceWith (unsafePrimArrayCoercion @s @p) +{-# inline unsafePrimArray #-} + +-- Data.Primitive.SmallArray + +newtype SmallConstArray s a = SmallConstArray { unsafeSmallConstArraySmallMutableArray :: SmallMutableArray s a } deriving Eq +instance Constable (SmallConstArray s) (SmallMutableArray s) +instance Constable (SmallConstArray s) (SmallConstArray s) +type ASmallArray s = Constable (SmallConstArray s) + +unsafeSmallArrayCoercion :: forall s p a. ASmallArray s p => Coercion (SmallMutableArray s a) (p a) +unsafeSmallArrayCoercion = unsafeConstantCoercion @p @a . Coercion +{-# inline unsafeSmallArrayCoercion #-} + +unsafeSmallArray :: forall s p a. ASmallArray s p => p a -> SmallMutableArray s a +unsafeSmallArray = uncoerceWith (unsafeSmallArrayCoercion @s @p) +{-# inline unsafeSmallArray #-} + +-- Data.Primitive.MutVar + +newtype ConstMutVar s a = ConstMutVar { unsafeConstMutVarMutVar :: MutVar s a } deriving Eq +instance Constable (ConstMutVar s) (MutVar s) +instance Constable (ConstMutVar s) (ConstMutVar s) +type AMutVar s = Constable (ConstMutVar s) + +unsafeMutVarCoercion :: forall s p a. AMutVar s p => Coercion (MutVar s a) (p a) +unsafeMutVarCoercion = unsafeConstantCoercion @p @a . Coercion +{-# inline unsafeMutVarCoercion #-} + +unsafeMutVar :: forall s p a. AMutVar s p => p a -> MutVar s a +unsafeMutVar = uncoerceWith (unsafeMutVarCoercion @s @p) +{-# inline unsafeMutVar #-} + +-- Data.STRef + +newtype ConstSTRef s a = ConstSTRef { unsafeConstSTRefSTRef :: STRef s a } deriving Eq +instance Constable (ConstSTRef s) (STRef s) +instance Constable (ConstSTRef s) (ConstSTRef s) +type AnSTRef s = Constable (ConstSTRef s) + +unsafeSTRefCoercion :: forall s p a. AnSTRef s p => Coercion (STRef s a) (p a) +unsafeSTRefCoercion = unsafeConstantCoercion @p @a . Coercion +{-# inline unsafeSTRefCoercion #-} + +unsafeSTRef :: forall s p a. AnSTRef s p => p a -> STRef s a +unsafeSTRef = uncoerceWith (unsafeSTRefCoercion @s @p) +{-# inline unsafeSTRef #-} + +-- * Cstrings +-- +type family Unapply s :: * -> * where + Unapply (p CChar) = p + +type ConstCString = ConstPtr CChar +type ConstCStringLen = (ConstCString, Int) +type ConstCWString = ConstPtr CWchar +type ConstCWStringLen = (ConstCWString, Int) + +type ACWString s = (s ~ Unapply s CWchar, APtr (Unapply s)) +type ACString s = (s ~ Unapply s CChar, APtr (Unapply s)) + +unsafeCStringCoercion :: forall s. ACString s => Coercion CString s +unsafeCStringCoercion = unsafePtrCoercion @(Unapply s) @CChar +{-# inline unsafeCStringCoercion #-} + +unsafeCWStringCoercion :: forall s. ACWString s => Coercion CWString s +unsafeCWStringCoercion = unsafePtrCoercion @(Unapply s) @CWchar +{-# inline unsafeCWStringCoercion #-} diff --git a/src/Foreign/Const/C/String.hs b/src/Foreign/Const/C/String.hs new file mode 100644 --- /dev/null +++ b/src/Foreign/Const/C/String.hs @@ -0,0 +1,100 @@ +{-# language RankNTypes #-} +{-# language ConstraintKinds #-} +{-# language FlexibleContexts #-} +{-# language TypeApplications #-} +{-# language ScopedTypeVariables #-} +{-# language TypeFamilies #-} +{-# language Trustworthy #-} +-- | +-- Copyright : (c) 2019 Edward Kmett +-- License : BSD-2-Clause OR Apache-2.0 +-- Maintainer: Edward Kmett +-- Stability : experimental +-- Portability: non-portable +-- +module Foreign.Const.C.String +( ConstCString +, ConstCStringLen +, ConstCWString +, ConstCWStringLen +, constCString +, constCWString + +, ACString +, ACWString + +, peekACAString +, peekACAStringLen +, peekACString +, peekACStringLen +, peekACWString +, peekACWStringLen +, withConstCAString +, withConstCAStringLen +, withConstCString +, withConstCStringLen +, withConstCWString +, withConstCWStringLen +) where + +import Data.Coerce +import Data.Type.Coercion +import Foreign.C.String + +import Data.Const.Unsafe + +constCString :: ACString s => s -> ConstCString +constCString = constant +{-# inline constCString #-} + +constCWString :: ACWString s => s -> ConstCWString +constCWString = constant +{-# inline constCWString #-} + +peekACAString :: forall s. ACString s => s -> IO String +peekACAString = gcoerceWith (unsafeCStringCoercion @s) $ coerce peekCAString +{-# inline peekACAString #-} + +peekACAStringLen :: forall s. ACString s => (s,Int) -> IO String +peekACAStringLen = gcoerceWith (unsafeCStringCoercion @s) $ coerce peekCAStringLen +{-# inline peekACAStringLen #-} + +peekACString :: forall s. ACString s => s -> IO String +peekACString = gcoerceWith (unsafeCStringCoercion @s) $ coerce peekCString +{-# inline peekACString #-} + +peekACStringLen :: forall s. ACString s => (s,Int) -> IO String +peekACStringLen = gcoerceWith (unsafeCStringCoercion @s) $ coerce peekCStringLen +{-# inline peekACStringLen #-} + +peekACWString :: forall s. ACWString s => s -> IO String +peekACWString = gcoerceWith (unsafeCWStringCoercion @s) $ coerce peekCWString +{-# inline peekACWString #-} + +peekACWStringLen :: forall s. ACWString s => (s,Int) -> IO String +peekACWStringLen = gcoerceWith (unsafeCWStringCoercion @s) $ coerce peekCWStringLen +{-# inline peekACWStringLen #-} + +withConstCAString :: forall a. String -> (ConstCString -> IO a) -> IO a +withConstCAString = coerce (withCAString @a) +{-# inline withConstCAString #-} + +withConstCAStringLen :: forall a. String -> (ConstCStringLen -> IO a) -> IO a +withConstCAStringLen = coerce (withCAStringLen @a) +{-# inline withConstCAStringLen #-} + +withConstCString :: forall a. String -> (ConstCString -> IO a) -> IO a +withConstCString = coerce (withCString @a) +{-# inline withConstCString #-} + +withConstCStringLen :: forall a. String -> (ConstCStringLen -> IO a) -> IO a +withConstCStringLen = coerce (withCStringLen @a) +{-# inline withConstCStringLen #-} + +withConstCWString :: forall a. String -> (ConstCWString -> IO a) -> IO a +withConstCWString = coerce (withCWString @a) +{-# inline withConstCWString #-} + +withConstCWStringLen :: forall a. String -> (ConstCWStringLen -> IO a) -> IO a +withConstCWStringLen = coerce (withCWStringLen @a) +{-# inline withConstCWStringLen #-} diff --git a/src/Foreign/Const/Concurrent.hs b/src/Foreign/Const/Concurrent.hs new file mode 100644 --- /dev/null +++ b/src/Foreign/Const/Concurrent.hs @@ -0,0 +1,34 @@ +{-# language UndecidableSuperClasses #-} +{-# language ScopedTypeVariables #-} +{-# language FlexibleContexts #-} +{-# language TypeApplications #-} +{-# language ConstraintKinds #-} +{-# language TypeFamilies #-} +{-# language Trustworthy #-} +-- | +-- Copyright : (c) 2019 Edward Kmett +-- License : BSD-2-Clause OR Apache-2.0 +-- Maintainer: Edward Kmett +-- Stability : experimental +-- Portability: non-portable +-- +module Foreign.Const.Concurrent +( newConstForeignPtr +, addAForeignPtrFinalizer +) where + +import Data.Coerce +import Data.Type.Coercion +import Foreign.Concurrent + +import Data.Const.Unsafe + +-- | Analogous to 'Concurrent.newForeignPtr' +newConstForeignPtr :: forall p a. APtr p => p a -> IO () -> IO (ConstForeignPtr a) +newConstForeignPtr = gcoerceWith (unsafePtrCoercion @p @a) $ coerce $ newForeignPtr @a +{-# inline newConstForeignPtr #-} + +-- | Analogous to 'Concurrent.addForeignPtrFinalizer' +addAForeignPtrFinalizer :: forall fp a. AForeignPtr fp => fp a -> IO () -> IO () +addAForeignPtrFinalizer = gcoerceWith (unsafeForeignPtrCoercion @fp @a) $ coerce $ addForeignPtrFinalizer @a +{-# inline addAForeignPtrFinalizer #-} diff --git a/src/Foreign/Const/ForeignPtr.hs b/src/Foreign/Const/ForeignPtr.hs new file mode 100644 --- /dev/null +++ b/src/Foreign/Const/ForeignPtr.hs @@ -0,0 +1,109 @@ +{-# language UndecidableSuperClasses #-} +{-# language ScopedTypeVariables #-} +{-# language FlexibleContexts #-} +{-# language TypeApplications #-} +{-# language NoStarIsType #-} +{-# language ConstraintKinds #-} +{-# language TypeFamilies #-} +{-# language Trustworthy #-} +-- | +-- Copyright : (c) 2019 Edward Kmett +-- License : BSD-2-Clause OR Apache-2.0 +-- Maintainer: Edward Kmett +-- Stability : experimental +-- Portability: non-portable +-- +module Foreign.Const.ForeignPtr +( ConstForeignPtr +, constForeignPtr + +, AForeignPtr + +-- * const foreign pointer operations + +, newConstForeignPtr +, newConstForeignPtr_ +, castConstForeignPtr +, plusConstForeignPtr +, newConstForeignPtrEnv +, withConstForeignPtr + +-- * const-preserving foreign pointer operations + +, Unforeign +, plusAForeignPtr +, withAForeignPtr + +-- * const agnostic foreign pointer operations + +, addAForeignPtrFinalizer +, addAForeignPtrFinalizerEnv +, finalizeAForeignPtr +, touchAForeignPtr +) where + +import Data.Coerce +import Data.Kind +import Data.Type.Coercion +import Foreign.Const.Ptr +import Foreign.ForeignPtr +import Foreign.Ptr + +import Data.Const.Unsafe + +type family Unforeign (fp :: Type -> Type) :: Type -> Type + +type instance Unforeign ForeignPtr = Ptr +type instance Unforeign ConstForeignPtr = ConstPtr + +constForeignPtr :: AForeignPtr fp => fp a -> ConstForeignPtr a +constForeignPtr = constant +{-# inline constForeignPtr #-} + +newConstForeignPtr :: forall p a. APtr p => FinalizerPtr a -> p a -> IO (ConstForeignPtr a) +newConstForeignPtr = gcoerceWith (unsafePtrCoercion @p @a) $ coerce $ newForeignPtr @a +{-# inline newConstForeignPtr #-} + +newConstForeignPtr_ :: forall p a. APtr p => p a -> IO (ConstForeignPtr a) +newConstForeignPtr_ = gcoerceWith (unsafePtrCoercion @p @a) $ coerce $ newForeignPtr_ @a +{-# inline newConstForeignPtr_ #-} + +addAForeignPtrFinalizer :: forall fp a. AForeignPtr fp => FinalizerPtr a -> fp a -> IO () +addAForeignPtrFinalizer = gcoerceWith (unsafeForeignPtrCoercion @fp @a) $ coerce $ addForeignPtrFinalizer @a +{-# inline addAForeignPtrFinalizer #-} + +newConstForeignPtrEnv :: forall p env a. APtr p => FinalizerEnvPtr env a -> Ptr env -> p a -> IO (ConstForeignPtr a) +newConstForeignPtrEnv = gcoerceWith (unsafePtrCoercion @p @a) $ coerce $ newForeignPtrEnv @env @a +{-# inline newConstForeignPtrEnv #-} + +addAForeignPtrFinalizerEnv :: forall fp env a. AForeignPtr fp => FinalizerEnvPtr env a -> Ptr env -> fp a -> IO () +addAForeignPtrFinalizerEnv = gcoerceWith (unsafeForeignPtrCoercion @fp @a) $ coerce $ addForeignPtrFinalizerEnv @env @a +{-# inline addAForeignPtrFinalizerEnv #-} + +withConstForeignPtr :: forall fp a r. AForeignPtr fp => fp a -> (ConstPtr a -> IO r) -> IO r +withConstForeignPtr = gcoerceWith (unsafeForeignPtrCoercion @fp @a) $ coerce $ withForeignPtr @a @r +{-# inline withConstForeignPtr #-} + +finalizeAForeignPtr :: forall fp a. AForeignPtr fp => fp a -> IO () +finalizeAForeignPtr = gcoerceWith (unsafeForeignPtrCoercion @fp @a) $ coerce $ finalizeForeignPtr @a +{-# inline finalizeAForeignPtr #-} + +touchAForeignPtr :: forall fp a. AForeignPtr fp => fp a -> IO () +touchAForeignPtr = gcoerceWith (unsafeForeignPtrCoercion @fp @a) $ coerce $ touchForeignPtr @a +{-# inline touchAForeignPtr #-} + +castConstForeignPtr :: forall fp a b. AForeignPtr fp => fp a -> ConstForeignPtr b +castConstForeignPtr = gcoerceWith (unsafeForeignPtrCoercion @fp @a) $ coerce $ castForeignPtr @a @b +{-# inline castConstForeignPtr #-} + +plusAForeignPtr :: forall fp a b. AForeignPtr fp => fp a -> Int -> fp b +plusAForeignPtr = gcoerceWith (unsafeForeignPtrCoercion @fp @a) $ gcoerceWith (unsafeForeignPtrCoercion @fp @b) $ coerce $ plusForeignPtr @a @b +{-# inline plusAForeignPtr #-} + +plusConstForeignPtr :: forall fp a b. AForeignPtr fp => fp a -> Int -> ConstForeignPtr b +plusConstForeignPtr = gcoerceWith (unsafeForeignPtrCoercion @fp @a) $ coerce $ plusForeignPtr @a @b +{-# inline plusConstForeignPtr #-} + +withAForeignPtr :: forall fp a r. (AForeignPtr fp, APtr (Unforeign fp)) => fp a -> (Unforeign fp a -> IO r) -> IO r +withAForeignPtr = gcoerceWith (unsafeForeignPtrCoercion @fp @a) $ gcoerceWith (unsafePtrCoercion @(Unforeign fp) @a) $ coerce $ withForeignPtr @a @r +{-# inline withAForeignPtr #-} diff --git a/src/Foreign/Const/Marshal/Array.hs b/src/Foreign/Const/Marshal/Array.hs new file mode 100644 --- /dev/null +++ b/src/Foreign/Const/Marshal/Array.hs @@ -0,0 +1,77 @@ +{-# language ScopedTypeVariables #-} +{-# language FlexibleContexts #-} +{-# language TypeApplications #-} +{-# language Trustworthy #-} +-- | +-- Copyright : (c) 2019 Edward Kmett +-- License : BSD-2-Clause OR Apache-2.0 +-- Maintainer: Edward Kmett +-- Stability : experimental +-- Portability: non-portable +-- + +module Foreign.Const.Marshal.Array +( peekAnArray +, peekAnArray0 +, withConstArray +, withConstArray0 +, withConstArrayLen +, withConstArrayLen0 +, copyAnArray +, moveAnArray +, lengthAnArray0 +, advanceConstPtr +, advanceAPtr +) where + +import Data.Coerce +import Data.Type.Coercion +import Foreign.Marshal.Array +import Foreign.Ptr +import Foreign.Storable + +import Data.Const.Unsafe + +peekAnArray :: forall a p. (APtr p, Storable a) => Int -> p a -> IO [a] +peekAnArray = gcoerceWith (unsafePtrCoercion @p @a) (coerce (peekArray @a)) +{-# inline peekAnArray #-} + +peekAnArray0 :: forall a p. (APtr p, Storable a, Eq a) => a -> p a -> IO [a] +peekAnArray0 = gcoerceWith (unsafePtrCoercion @p @a) (coerce (peekArray0 @a)) +{-# inline peekAnArray0 #-} + +withConstArray :: forall a b. Storable a => [a] -> (ConstPtr a -> IO b) -> IO b +withConstArray = coerce (withConstArray @a @b) +{-# inline withConstArray #-} + +withConstArray0 :: forall a b. Storable a => a -> [a] -> (ConstPtr a -> IO b) -> IO b +withConstArray0 = coerce (withConstArray0 @a @b) +{-# inline withConstArray0 #-} + +withConstArrayLen :: forall a b. Storable a => [a] -> (Int -> ConstPtr a -> IO b) -> IO b +withConstArrayLen = coerce (withConstArrayLen @a @b) +{-# inline withConstArrayLen #-} + +withConstArrayLen0 :: forall a b. Storable a => a -> [a] -> (Int -> ConstPtr a -> IO b) -> IO b +withConstArrayLen0 = coerce (withConstArrayLen0 @a @b) +{-# inline withConstArrayLen0 #-} + +copyAnArray :: forall a p. (APtr p, Storable a) => Ptr a -> p a -> Int -> IO () +copyAnArray = gcoerceWith (unsafePtrCoercion @p @a) (coerce (copyArray @a)) +{-# inline copyAnArray #-} + +moveAnArray :: forall a p. (APtr p, Storable a) => Ptr a -> p a -> Int -> IO () +moveAnArray = gcoerceWith (unsafePtrCoercion @p @a) (coerce (moveArray @a)) +{-# inline moveAnArray #-} + +lengthAnArray0 :: forall a p. (APtr p, Storable a, Eq a) => a -> p a -> IO Int +lengthAnArray0 = gcoerceWith (unsafePtrCoercion @p @a) (coerce (lengthArray0 @a)) +{-# inline lengthAnArray0 #-} + +advanceConstPtr :: forall a p. (APtr p, Storable a) => p a -> Int -> ConstPtr a +advanceConstPtr = gcoerceWith (unsafePtrCoercion @p @a) (coerce (advancePtr @a)) +{-# inline advanceConstPtr #-} + +advanceAPtr :: forall a p. (APtr p, Storable a) => p a -> Int -> p a +advanceAPtr = gcoerceWith (unsafePtrCoercion @p @a) (coerce (advancePtr @a)) +{-# inline advanceAPtr #-} diff --git a/src/Foreign/Const/Marshal/Utils.hs b/src/Foreign/Const/Marshal/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Foreign/Const/Marshal/Utils.hs @@ -0,0 +1,49 @@ +{-# language ScopedTypeVariables #-} +{-# language FlexibleContexts #-} +{-# language TypeApplications #-} +{-# language Trustworthy #-} +-- | +-- Copyright : (c) 2019 Edward Kmett +-- License : BSD-2-Clause OR Apache-2.0 +-- Maintainer: Edward Kmett +-- Stability : experimental +-- Portability: non-portable +-- +module Foreign.Const.Marshal.Utils +( withConst +, newConst +, copyBytesAt +, moveBytesAt +, maybeNewA +, maybePeekA +, maybeWithA +) where + +import Data.Coerce +import Data.Type.Coercion +import Foreign.Ptr +import Foreign.Marshal.Utils +import Foreign.Storable + +import Data.Const.Unsafe + +withConst :: forall a b. Storable a => a -> (ConstPtr a -> IO b) -> IO b +withConst = coerce $ withConst @a @b + +newConst :: forall a. Storable a => a -> IO (ConstPtr a) +newConst = coerce $ new @a + +copyBytesAt :: forall a p. APtr p => Ptr a -> p a -> Int -> IO () +copyBytesAt = gcoerceWith (unsafePtrCoercion @p @a) $ coerce $ copyBytes @a + +moveBytesAt :: forall a p. APtr p => Ptr a -> p a -> Int -> IO () +moveBytesAt = gcoerceWith (unsafePtrCoercion @p @a) $ coerce $ moveBytes @a + +maybeNewA :: forall a b p. APtr p => (a -> IO (p b)) -> Maybe a -> IO (p b) +maybeNewA = gcoerceWith (unsafePtrCoercion @p @b) $ coerce $ maybeNew @a @b + +maybePeekA :: forall a b p. APtr p => (p a -> IO b) -> p a -> IO (Maybe b) +maybePeekA = gcoerceWith (unsafePtrCoercion @p @a) $ coerce $ maybePeek @a @b + +maybeWithA :: forall a b c p. APtr p => (a -> (p b -> IO c) -> IO c) -> Maybe a -> (p b -> IO c) -> IO c +maybeWithA = gcoerceWith (unsafePtrCoercion @p @b) $ coerce $ maybeWith @a @b @c diff --git a/src/Foreign/Const/Ptr.hs b/src/Foreign/Const/Ptr.hs new file mode 100644 --- /dev/null +++ b/src/Foreign/Const/Ptr.hs @@ -0,0 +1,90 @@ +{-# language ScopedTypeVariables #-} +{-# language TypeApplications #-} +{-# language FlexibleContexts #-} +{-# language ConstraintKinds #-} +{-# language TypeFamilies #-} +{-# language Trustworthy #-} +-- | +-- Copyright : (c) 2019 Edward Kmett +-- License : BSD-2-Clause OR Apache-2.0 +-- Maintainer: Edward Kmett +-- Stability : experimental +-- Portability: non-portable +-- +module Foreign.Const.Ptr +( ConstPtr +, constPtr +, APtr + +-- * const-agnostic operations +, peekAt +, peekAtElemOff +, peekAtByteOff + +-- * const preserving operations +, minusAPtr +, castAPtr +, plusAPtr +, alignAPtr + +-- * operations returning const pointers +, nullConstPtr +, castConstPtr +, plusConstPtr +, alignConstPtr + ) where + +import Data.Coerce +import Data.Type.Coercion +import Foreign.Ptr +import Foreign.Storable + +import Data.Const.Unsafe + +constPtr :: APtr p => p a -> ConstPtr a +constPtr = constant +{-# inline constPtr #-} + +peekAt :: forall p a. (Storable a, APtr p) => p a -> IO a +peekAt = gcoerceWith (unsafePtrCoercion @p @a) (coerce (peek @a)) +{-# inline peekAt #-} + +peekAtElemOff :: forall p a. (Storable a, APtr p) => p a -> Int -> IO a +peekAtElemOff = gcoerceWith (unsafePtrCoercion @p @a) $ coerce (peekElemOff @a) +{-# inline peekAtElemOff #-} + +peekAtByteOff :: forall p a b. (Storable a, APtr p) => p b -> Int -> IO a +peekAtByteOff = gcoerceWith (unsafePtrCoercion @p @b) $ coerce (peekByteOff @a @b) +{-# inline peekAtByteOff #-} + +nullConstPtr :: ConstPtr a +nullConstPtr = ConstPtr nullPtr +{-# inline nullConstPtr #-} + +castAPtr :: forall p a b. APtr p => p a -> p b +castAPtr = gcoerceWith (unsafePtrCoercion @p @a) $ gcoerceWith (unsafePtrCoercion @p @b) $ coerce (castPtr @a @b) +{-# inline castAPtr #-} + +castConstPtr :: forall p a b. APtr p => p a -> ConstPtr b +castConstPtr = gcoerceWith (unsafePtrCoercion @p @a) $ coerce (castPtr @a @b) +{-# inline castConstPtr #-} + +plusAPtr :: forall p a b. APtr p => p a -> Int -> p b +plusAPtr = gcoerceWith (unsafePtrCoercion @p @a) $ gcoerceWith (unsafePtrCoercion @p @b) $ coerce (plusPtr @a @b) +{-# inline plusAPtr #-} + +plusConstPtr :: forall p a b. APtr p => p a -> Int -> ConstPtr b +plusConstPtr = gcoerceWith (unsafePtrCoercion @p @a) $ coerce (plusPtr @a @b) +{-# inline plusConstPtr #-} + +alignAPtr :: forall p a. APtr p => p a -> Int -> p a +alignAPtr = gcoerceWith (unsafePtrCoercion @p @a) $ coerce (alignPtr @a) +{-# inline alignAPtr #-} + +alignConstPtr :: forall p a. APtr p => p a -> Int -> ConstPtr a +alignConstPtr = gcoerceWith (unsafePtrCoercion @p @a) $ coerce (alignPtr @a) +{-# inline alignConstPtr #-} + +minusAPtr :: forall p q a b. (APtr p, APtr q) => p a -> q b -> Int +minusAPtr = gcoerceWith (unsafePtrCoercion @p @a) $ gcoerceWith (unsafePtrCoercion @q @b) $ coerce (minusPtr @a @b) +{-# inline minusAPtr #-}