├── .ghci ├── .github └── workflows │ └── main.yml ├── .gitignore ├── .haskell-ci ├── .hlint.yaml ├── .weeder.yaml ├── CHANGELOG.md ├── Collection.md ├── LICENSE ├── README.md ├── Setup.hs ├── TODO.md ├── basement ├── Basement │ ├── Alg │ │ ├── Class.hs │ │ ├── Mutable.hs │ │ ├── PrimArray.hs │ │ ├── String.hs │ │ ├── UTF8.hs │ │ └── XorShift.hs │ ├── Base16.hs │ ├── Bindings │ │ └── Memory.hs │ ├── Bits.hs │ ├── Block.hs │ ├── Block │ │ ├── Base.hs │ │ ├── Builder.hs │ │ └── Mutable.hs │ ├── BlockN.hs │ ├── Bounded.hs │ ├── BoxedArray.hs │ ├── Cast.hs │ ├── Compat │ │ ├── AMP.hs │ │ ├── Base.hs │ │ ├── Bifunctor.hs │ │ ├── C │ │ │ └── Types.hs │ │ ├── CallStack.hs │ │ ├── ExtList.hs │ │ ├── Identity.hs │ │ ├── IsList.hs │ │ ├── MonadTrans.hs │ │ ├── Natural.hs │ │ ├── NumLiteral.hs │ │ ├── PrimTypes.hs │ │ ├── Primitive.hs │ │ ├── Semigroup.hs │ │ └── Typeable.hs │ ├── Endianness.hs │ ├── Environment.hs │ ├── Error.hs │ ├── Exception.hs │ ├── FinalPtr.hs │ ├── Floating.hs │ ├── From.hs │ ├── Imports.hs │ ├── IntegralConv.hs │ ├── Monad.hs │ ├── MutableBuilder.hs │ ├── Nat.hs │ ├── NonEmpty.hs │ ├── NormalForm.hs │ ├── Numerical │ │ ├── Additive.hs │ │ ├── Conversion.hs │ │ ├── Multiplicative.hs │ │ ├── Number.hs │ │ └── Subtractive.hs │ ├── PrimType.hs │ ├── Runtime.hs │ ├── Show.hs │ ├── Sized │ │ ├── Block.hs │ │ ├── List.hs │ │ ├── UVect.hs │ │ └── Vect.hs │ ├── String.hs │ ├── String │ │ ├── Builder.hs │ │ ├── CaseMapping.hs │ │ └── Encoding │ │ │ ├── ASCII7.hs │ │ │ ├── Encoding.hs │ │ │ ├── ISO_8859_1.hs │ │ │ ├── UTF16.hs │ │ │ └── UTF32.hs │ ├── Terminal.hs │ ├── Terminal │ │ ├── ANSI.hs │ │ └── Size.hsc │ ├── These.hs │ ├── Types │ │ ├── AsciiString.hs │ │ ├── Char7.hs │ │ ├── CharUTF8.hs │ │ ├── OffsetSize.hs │ │ ├── Ptr.hs │ │ ├── Word128.hs │ │ └── Word256.hs │ ├── UArray.hs │ ├── UArray │ │ ├── Base.hs │ │ └── Mutable.hs │ └── UTF8 │ │ ├── Base.hs │ │ ├── Helper.hs │ │ ├── Table.hs │ │ └── Types.hs ├── LICENSE ├── Setup.hs ├── basement.cabal └── cbits │ ├── foundation_mem.c │ ├── foundation_prim.h │ └── foundation_system.h ├── cabal.project ├── docs ├── CHANGELOG.md ├── advanced-runtime.md ├── contributing.md ├── core-collection.md ├── core-numerical.md ├── home.md ├── improvements.md ├── index.md └── porting.md ├── edge ├── .gitignore ├── Foundation │ └── Compat │ │ ├── ByteString.hs │ │ └── Text.hs ├── LICENSE ├── README.md ├── Setup.hs └── foundation-edge.cabal ├── foundation ├── Foundation.hs ├── Foundation │ ├── Array.hs │ ├── Array │ │ ├── Bitmap.hs │ │ ├── Chunked │ │ │ └── Unboxed.hs │ │ └── Internal.hs │ ├── Bits.hs │ ├── Check.hs │ ├── Check │ │ ├── Arbitrary.hs │ │ ├── Config.hs │ │ ├── Gen.hs │ │ ├── Main.hs │ │ ├── Print.hs │ │ ├── Property.hs │ │ └── Types.hs │ ├── Class │ │ ├── Bifunctor.hs │ │ └── Storable.hs │ ├── Collection.hs │ ├── Collection │ │ ├── Buildable.hs │ │ ├── Collection.hs │ │ ├── Copy.hs │ │ ├── Element.hs │ │ ├── Foldable.hs │ │ ├── Indexed.hs │ │ ├── InnerFunctor.hs │ │ ├── Keyed.hs │ │ ├── List.hs │ │ ├── Mappable.hs │ │ ├── Mutable.hs │ │ ├── Sequential.hs │ │ └── Zippable.hs │ ├── Conduit.hs │ ├── Conduit │ │ ├── Internal.hs │ │ └── Textual.hs │ ├── Exception.hs │ ├── Foreign.hs │ ├── Foreign │ │ ├── Alloc.hs │ │ ├── MemoryMap.hs │ │ └── MemoryMap │ │ │ ├── Posix.hsc │ │ │ ├── Types.hs │ │ │ └── Windows.hs │ ├── Format │ │ ├── CSV.hs │ │ └── CSV │ │ │ ├── Builder.hs │ │ │ ├── Parser.hs │ │ │ └── Types.hs │ ├── Hashing.hs │ ├── Hashing │ │ ├── FNV.hs │ │ ├── Hashable.hs │ │ ├── Hasher.hs │ │ └── SipHash.hs │ ├── IO.hs │ ├── IO │ │ ├── File.hs │ │ ├── FileMap.hs │ │ └── Terminal.hs │ ├── Idea.hs │ ├── List │ │ ├── DList.hs │ │ └── ListN.hs │ ├── Math │ │ └── Trigonometry.hs │ ├── Monad.hs │ ├── Monad │ │ ├── Base.hs │ │ ├── Except.hs │ │ ├── Exception.hs │ │ ├── Identity.hs │ │ ├── MonadIO.hs │ │ ├── Reader.hs │ │ ├── State.hs │ │ └── Transformer.hs │ ├── Network │ │ ├── HostName.hsc │ │ ├── IPv4.hs │ │ └── IPv6.hs │ ├── Numerical.hs │ ├── Numerical │ │ └── Floating.hs │ ├── Parser.hs │ ├── Partial.hs │ ├── Primitive.hs │ ├── Random.hs │ ├── Random │ │ ├── ChaChaDRG.hs │ │ ├── Class.hs │ │ ├── DRG.hs │ │ └── XorShift.hs │ ├── Strict.hs │ ├── String.hs │ ├── String │ │ ├── Builder.hs │ │ └── Read.hs │ ├── System │ │ ├── Bindings.hs │ │ ├── Bindings │ │ │ ├── Hs.hs │ │ │ ├── Linux.hsc │ │ │ ├── Macos.hsc │ │ │ ├── Network.hsc │ │ │ ├── Posix.hsc │ │ │ ├── PosixDef.hsc │ │ │ ├── Time.hsc │ │ │ └── Windows.hs │ │ ├── Entropy.hs │ │ ├── Entropy │ │ │ ├── Common.hs │ │ │ ├── Unix.hs │ │ │ └── Windows.hs │ │ └── Info.hs │ ├── Time │ │ ├── Bindings.hs │ │ ├── StopWatch.hs │ │ └── Types.hs │ ├── Timing.hs │ ├── Timing │ │ └── Main.hs │ ├── Tuple.hs │ ├── Tuple │ │ └── Nth.hs │ ├── UUID.hs │ ├── VFS.hs │ └── VFS │ │ ├── FilePath.hs │ │ ├── Path.hs │ │ └── URI.hs ├── LICENSE ├── benchs │ ├── Array.hs │ ├── BenchUtil │ │ ├── Common.hs │ │ └── RefData.hs │ ├── Break.hs │ ├── Buildable.hs │ ├── Fake │ │ ├── ByteString.hs │ │ ├── Text.hs │ │ └── Vector.hs │ ├── LargeWords.hs │ ├── Main.hs │ ├── SplitAt.hs │ ├── Sys.hs │ ├── ToForeign.hs │ └── compare-libs │ │ ├── ByteString.hs │ │ ├── Parser.hs │ │ ├── Text.hs │ │ ├── Vector32.hs │ │ └── Vector8.hs ├── cbits │ ├── foundation_bits.h │ ├── foundation_network.c │ ├── foundation_prim.h │ ├── foundation_random.c │ ├── foundation_system.h │ ├── foundation_time.c │ └── foundation_utf8.c ├── foundation.cabal └── tests │ ├── Checks.hs │ ├── DocTest.hs │ ├── Imports.hs │ ├── Profiling │ └── ProfBreak.hs │ ├── Scripts │ └── Link.hs │ ├── Test │ ├── Basement.hs │ ├── Basement │ │ └── UTF8.hs │ ├── Checks │ │ └── Property │ │ │ └── Collection.hs │ ├── Data │ │ ├── List.hs │ │ └── Network.hs │ ├── Foundation │ │ ├── Array.hs │ │ ├── Bits.hs │ │ ├── ChunkedUArray.hs │ │ ├── Collection.hs │ │ ├── Conduit.hs │ │ ├── Encoding.hs │ │ ├── Format.hs │ │ ├── Format │ │ │ └── CSV.hs │ │ ├── Misc.hs │ │ ├── Network │ │ │ ├── IPv4.hs │ │ │ └── IPv6.hs │ │ ├── Number.hs │ │ ├── Parser.hs │ │ ├── Primitive │ │ │ └── BlockN.hs │ │ ├── Random.hs │ │ ├── Storable.hs │ │ ├── String.hs │ │ └── String │ │ │ └── Base64.hs │ └── Utils │ │ └── Foreign.hs │ └── Tests.hs ├── mkdocs.yml ├── programs ├── CSV.hs ├── InputOutputLines.hs ├── SumDouble.hs ├── Time.hs ├── foundation-programs.cabal └── stack.yaml ├── scripts ├── algorithms.sh └── caseMapping │ ├── CaseFolding.hs │ ├── CaseMapping.hs │ ├── SpecialCasing.hs │ ├── UnicodeParsers.hs │ └── generateCaseMapping.sh ├── stack.yaml └── with-edge.yaml /.ghci: -------------------------------------------------------------------------------- 1 | :set -fobject-code 2 | -------------------------------------------------------------------------------- /.github/workflows/main.yml: -------------------------------------------------------------------------------- 1 | on: [push, pull_request] 2 | 3 | name: Continuous integration 4 | 5 | jobs: 6 | test: 7 | name: Test Suite 8 | strategy: 9 | matrix: 10 | config: 11 | # main lts 12 | - { os: ubuntu-latest, resolver: lts-15.0 } 13 | - { os: windows-latest, resolver: lts-15.0 } 14 | - { os: macos-latest, resolver: lts-15.0 } 15 | # other resolvers 16 | - { os: ubuntu-latest, resolver: nightly } 17 | - { os: ubuntu-latest, resolver: lts-14.27 } 18 | - { os: ubuntu-latest, resolver: lts-12.26 } 19 | runs-on: ${{ matrix.config.os }} 20 | steps: 21 | - uses: actions/checkout@v1 22 | - name: Install Stack 23 | if: matrix.config.os != 'ubuntu-latest' 24 | run: curl -sSL https://get.haskellstack.org/ | sh 25 | 26 | - name: cache programs 27 | id: cache-programs 28 | uses: actions/cache@v1 29 | with: 30 | path: ~/.stack/programs 31 | key: programs-${{ matrix.config.os }}-${{ matrix.config.resolver }} 32 | 33 | - name: Setup 34 | if: steps.cache-programs.outputs.cache-hit != 'true' 35 | run: stack setup --resolver ${{ matrix.config.resolver }} 36 | 37 | - name: Build 38 | run: stack build --resolver ${{ matrix.config.resolver }} --test --no-run-tests 39 | - name: run tests 40 | run: stack test --resolver ${{ matrix.config.resolver }} 41 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *.o 2 | *.hi 3 | *.tix 4 | *.mix 5 | *.prof 6 | *.swp 7 | .stack-work 8 | exts 9 | dist 10 | _site 11 | report.html 12 | cabal.config 13 | .idea 14 | *.iml 15 | stack.yaml.lock 16 | 17 | # ignore file generated by the tests 18 | temp-file 19 | 20 | dist-newstyle/ 21 | -------------------------------------------------------------------------------- /.haskell-ci: -------------------------------------------------------------------------------- 1 | # compiler supported and their equivalent LTS 2 | compiler: ghc-8.6 lts-14.4 3 | compiler: ghc-8.8 lts-16.8 4 | compiler: ghc-8.10 nightly-2020-08-08 5 | 6 | # options 7 | option: gaugedep extradep=gauge-0.2.1 8 | option: checkbounds flag=foundation:bounds-check flag=foundation:linktest 9 | option: experimental flag=foundation:experimental 10 | 11 | # builds 12 | build: ghc-8.6 os=osx,linux,windows 13 | build: ghc-8.6 os=win32 14 | build: ghc-8.8 checkbounds os=osx,linux,windows 15 | build: ghc-8.8 os=osx,linux,windows 16 | build: ghc-8.10 os=osx,linux,windows 17 | 18 | # packages 19 | package: foundation/ 20 | package: basement/ 21 | 22 | # extra builds 23 | hlint: allowed-failure 24 | weeder: allowed-failure 25 | coverall: false 26 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2015-2017 Vincent Hanquez 2 | Copyright (c) 2017-2018 Foundation Maintainers 3 | 4 | All rights reserved. 5 | 6 | Redistribution and use in source and binary forms, with or without 7 | modification, are permitted provided that the following conditions 8 | are met: 9 | 1. Redistributions of source code must retain the above copyright 10 | notice, this list of conditions and the following disclaimer. 11 | 2. Redistributions in binary form must reproduce the above copyright 12 | notice, this list of conditions and the following disclaimer in the 13 | documentation and/or other materials provided with the distribution. 14 | 3. Neither the name of the author nor the names of his contributors 15 | may be used to endorse or promote products derived from this software 16 | without specific prior written permission. 17 | 18 | THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS AS IS'' AND 19 | ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 20 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 21 | ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE 22 | FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 23 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 24 | OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 25 | HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 26 | LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY 27 | OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF 28 | SUCH DAMAGE. 29 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /TODO.md: -------------------------------------------------------------------------------- 1 | TODO - To make Foundation complete (might not be exhaustive :) ) 2 | ================================================================ 3 | 4 | General Purpose: 5 | ---------------- 6 | 7 | * Process 8 | * Time 9 | * Benchmarks 10 | * Tests 11 | 12 | Data Structure: 13 | --------------- 14 | 15 | * (Balanced) Binary Trees 16 | * Hashtables 17 | * Dictionary 18 | 19 | Data Format: 20 | ------------ 21 | 22 | * CSV 23 | * JSON 24 | * YAML 25 | * XML 26 | 27 | Network: 28 | -------- 29 | 30 | * Socket 31 | * HTTP 32 | * HTTPs : nice but complicated need lots of crypto, ASN1, x509, tls. 33 | -------------------------------------------------------------------------------- /basement/Basement/Alg/Class.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiParamTypeClasses #-} 2 | 3 | module Basement.Alg.Class 4 | ( Indexable, index 5 | , RandomAccess, read, write 6 | ) where 7 | 8 | import Basement.Types.OffsetSize 9 | 10 | class Indexable container ty where 11 | index :: container -> (Offset ty) -> ty 12 | 13 | class RandomAccess container prim ty where 14 | read :: container -> (Offset ty) -> prim ty 15 | write :: container -> (Offset ty) -> ty -> prim () 16 | -------------------------------------------------------------------------------- /basement/Basement/Alg/XorShift.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Foundation.Random.XorShift 3 | -- License : BSD-style 4 | -- 5 | -- XorShift variant: Xoroshiro128+ 6 | -- 7 | -- 8 | -- Xoroshiro128+ is a PRNG that uses a shift/rotate-based linear transformation. 9 | -- This is lar 10 | -- 11 | -- C implementation at: 12 | -- 13 | -- 14 | module Basement.Alg.XorShift 15 | ( State(..) 16 | , next 17 | , nextDouble 18 | , jump 19 | ) where 20 | 21 | import Data.Word 22 | import Data.Bits 23 | import Basement.Compat.Base 24 | import Basement.Floating (wordToDouble) 25 | import Basement.Numerical.Additive 26 | import Basement.Numerical.Subtractive 27 | 28 | -- | State of Xoroshiro128 plus 29 | data State = State {-# UNPACK #-} !Word64 {-# UNPACK #-} !Word64 30 | 31 | -- | Given a state, call the function 'f' with the generated Word64 and the next State 32 | next :: State -> (Word64 -> State -> a) -> a 33 | next (State s0 s1prev) f = f ran stNext 34 | where 35 | !stNext = State s0' s1' 36 | !ran = s0 + s1prev 37 | !s1 = s0 `xor` s1prev 38 | s0' = (s0 `rotateL` 55) `xor` s1 `xor` (s1 `unsafeShiftL` 14) 39 | s1' = (s1 `rotateL` 36) 40 | 41 | -- | Same as 'next' but give a random value of type Double in the range of [0.0 .. 1.0] 42 | nextDouble :: State -> (Double -> State -> a) -> a 43 | nextDouble st f = next st $ \w -> f (toDouble w) 44 | where 45 | -- generate a number in the interval [1..2[ by bit manipulation. 46 | -- this generate double with a ~2^52 47 | toDouble w = wordToDouble (upperMask .|. (w .&. lowerMask)) - 1.0 48 | where 49 | upperMask = 0x3FF0000000000000 50 | lowerMask = 0x000FFFFFFFFFFFFF 51 | 52 | -- | Jump the state by 2^64 calls of next 53 | jump :: State -> State 54 | jump (State s0 s1) = withK 0xd86b048b86aa9922 55 | $ withK 0xbeac0467eba5facb 56 | $ (State 0 0) 57 | where 58 | withK :: Word64 -> State -> State 59 | withK !k = loop 0 60 | where 61 | loop !i st@(State c0 c1) 62 | | i == 64 = st 63 | | testBit k i = loop (i+1) (State (c0 `xor` s0) (c1 `xor` s1)) 64 | | otherwise = st 65 | -------------------------------------------------------------------------------- /basement/Basement/Bindings/Memory.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_HADDOCK hide #-} 2 | {-# LANGUAGE MagicHash #-} 3 | {-# LANGUAGE UnliftedFFITypes #-} 4 | module Basement.Bindings.Memory 5 | where 6 | 7 | import GHC.IO 8 | import GHC.Prim 9 | import GHC.Word 10 | import Basement.Compat.C.Types 11 | import Foreign.Ptr 12 | import Basement.Types.OffsetSize 13 | 14 | foreign import ccall unsafe "_foundation_memcmp" sysHsMemcmpBaBa :: 15 | ByteArray# -> Offset Word8 -> ByteArray# -> Offset Word8 -> CountOf Word8 -> IO CInt 16 | 17 | foreign import ccall unsafe "_foundation_memcmp" sysHsMemcmpBaPtr :: 18 | ByteArray# -> Offset Word8 -> Ptr a -> Offset Word8 -> CountOf Word8 -> IO CInt 19 | 20 | foreign import ccall unsafe "_foundation_memcmp" sysHsMemcmpPtrBa :: 21 | Ptr a -> Offset Word8 -> ByteArray# -> Offset Word8 -> CountOf Word8 -> IO CInt 22 | 23 | foreign import ccall unsafe "_foundation_memcmp" sysHsMemcmpPtrPtr :: 24 | Ptr a -> Offset Word8 -> Ptr b -> Offset Word8 -> CountOf Word8 -> IO CInt 25 | 26 | foreign import ccall unsafe "_foundation_mem_findbyte" sysHsMemFindByteBa :: 27 | ByteArray# -> Offset Word8 -> Offset Word8 -> Word8 -> Offset Word8 28 | 29 | foreign import ccall unsafe "_foundation_mem_findbyte" sysHsMemFindByteAddr :: 30 | Addr# -> Offset Word8 -> Offset Word8 -> Word8 -> Offset Word8 31 | -------------------------------------------------------------------------------- /basement/Basement/BlockN.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Basement.Block 3 | -- License : BSD-style 4 | -- Maintainer : Haskell Foundation 5 | -- 6 | -- A Nat-sized version of Block 7 | 8 | module Basement.BlockN (module X) where 9 | 10 | import Basement.Sized.Block as X 11 | -------------------------------------------------------------------------------- /basement/Basement/Compat/AMP.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE ConstraintKinds #-} 3 | -- a compat module for ghc < 7.10 to handle the AMP change smoothly 4 | module Basement.Compat.AMP 5 | ( AMPMonad 6 | ) where 7 | 8 | import Basement.Compat.Base 9 | 10 | {-# DEPRECATED AMPMonad "use Monad" #-} 11 | type AMPMonad m = Monad m 12 | -------------------------------------------------------------------------------- /basement/Basement/Compat/C/Types.hs: -------------------------------------------------------------------------------- 1 | {-# Language CPP #-} 2 | -- | 3 | -- Module : Basement.Compat.C.Types 4 | -- License : BSD-style 5 | -- Maintainer : Foundation 6 | -- 7 | -- Literal support for Integral and Fractional 8 | -- {-# LANGUAGE TypeSynonymInstances #-} 9 | -- {-# LANGUAGE FlexibleInstances #-} 10 | module Basement.Compat.C.Types 11 | ( CChar(..), CSChar(..), CUChar(..) 12 | , CShort(..), CUShort(..), CInt(..), CUInt(..), CLong(..), CULong(..) 13 | , CPtrdiff(..), CSize(..), CWchar(..), CSigAtomic(..), CLLong(..), CULLong(..) 14 | #if MIN_VERSION_base(4,10,0) 15 | , CBool(..) 16 | #endif 17 | , CIntPtr(..), CUIntPtr(..), CIntMax(..), CUIntMax(..) 18 | , CClock(..), CTime(..), CUSeconds(..), CSUSeconds(..), CFloat(..), CDouble 19 | , COff(..), CMode(..) 20 | ) where 21 | 22 | import Foreign.C.Types 23 | import System.Posix.Types 24 | -------------------------------------------------------------------------------- /basement/Basement/Compat/CallStack.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE ImplicitParams #-} 3 | {-# LANGUAGE ConstraintKinds #-} 4 | module Basement.Compat.CallStack 5 | ( HasCallStack 6 | ) where 7 | 8 | #if MIN_VERSION_base(4,9,0) 9 | 10 | import GHC.Stack (HasCallStack) 11 | 12 | #elif MIN_VERSION_base(4,8,1) 13 | 14 | import qualified GHC.Stack 15 | 16 | type HasCallStack = (?callStack :: GHC.Stack.CallStack) 17 | 18 | #else 19 | 20 | import GHC.Exts (Constraint) 21 | 22 | type HasCallStack = (() :: Constraint) 23 | 24 | #endif 25 | -------------------------------------------------------------------------------- /basement/Basement/Compat/ExtList.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | module Basement.Compat.ExtList 3 | ( length 4 | , null 5 | , sum 6 | , reverse 7 | , (!!) 8 | ) where 9 | 10 | import Basement.Compat.Base 11 | import Basement.Numerical.Additive 12 | import Basement.Types.OffsetSize 13 | import qualified GHC.List as List 14 | 15 | -- | Compute the size of the list 16 | length :: [a] -> CountOf a 17 | #if MIN_VERSION_base(4,8,0) 18 | length = CountOf . List.foldl' (\c _ -> c+1) 0 19 | #else 20 | length = CountOf . loop 0 21 | where loop !acc [] = acc 22 | loop !acc (_:xs) = loop (1+acc) xs 23 | #endif 24 | 25 | null :: [a] -> Bool 26 | null [] = True 27 | null (_:_) = False 28 | 29 | -- | Sum the element in a list 30 | sum :: Additive n => [n] -> n 31 | sum [] = azero 32 | sum (i:is) = loop i is 33 | where 34 | loop !acc [] = acc 35 | loop !acc (x:xs) = loop (acc+x) xs 36 | {-# INLINE loop #-} 37 | 38 | reverse :: [a] -> [a] 39 | reverse l = go l [] 40 | where 41 | go [] acc = acc 42 | go (x:xs) acc = go xs (x:acc) 43 | 44 | (!!) :: [a] -> Offset a -> a 45 | [] !! _ = error "invalid offset for !!" 46 | (x:_) !! 0 = x 47 | (_:xs) !! i = xs !! pred i 48 | -------------------------------------------------------------------------------- /basement/Basement/Compat/Identity.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Basement.Compat.Identity 3 | -- License : BSD-style 4 | -- Maintainer : Vincent Hanquez 5 | -- Stability : experimental 6 | -- Portability : portable 7 | -- 8 | -- Identity re-export, with a compat wrapper for older version of base that 9 | -- do not have Data.Functor.Identity 10 | {-# LANGUAGE CPP #-} 11 | module Basement.Compat.Identity 12 | ( Identity(..) 13 | ) where 14 | 15 | #if MIN_VERSION_base(4,8,0) 16 | 17 | import Data.Functor.Identity 18 | 19 | #else 20 | 21 | import Basement.Compat.Base 22 | 23 | newtype Identity a = Identity { runIdentity :: a } 24 | deriving (Eq, Ord) 25 | 26 | instance Functor Identity where 27 | fmap f (Identity a) = Identity (f a) 28 | 29 | instance Applicative Identity where 30 | pure a = Identity a 31 | (<*>) fab fa = Identity $ runIdentity fab (runIdentity fa) 32 | 33 | instance Monad Identity where 34 | return = pure 35 | ma >>= mb = mb (runIdentity ma) 36 | 37 | #endif 38 | -------------------------------------------------------------------------------- /basement/Basement/Compat/IsList.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Basement.Compat.IsList 3 | -- License : BSD-style 4 | -- Maintainer : Vincent Hanquez 5 | -- Stability : experimental 6 | -- Portability : portable 7 | -- 8 | -- compat friendly version of IsList 9 | {-# LANGUAGE TypeFamilies #-} 10 | {-# LANGUAGE CPP #-} 11 | module Basement.Compat.IsList 12 | ( IsList(..) 13 | ) where 14 | 15 | #if MIN_VERSION_base(4,7,0) 16 | 17 | import GHC.Exts 18 | 19 | #else 20 | 21 | import qualified Prelude 22 | 23 | class IsList l where 24 | type Item l 25 | fromList :: [Item l] -> l 26 | toList :: l -> [Item l] 27 | 28 | fromListN :: Prelude.Int -> [Item l] -> l 29 | fromListN _ = fromList 30 | 31 | instance IsList [a] where 32 | type Item [a] = a 33 | fromList = Prelude.id 34 | toList = Prelude.id 35 | 36 | #endif 37 | -------------------------------------------------------------------------------- /basement/Basement/Compat/MonadTrans.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Basement.Compat.MonadTrans 3 | -- License : BSD-style 4 | -- Maintainer : Psychohistorians 5 | -- Stability : experimental 6 | -- Portability : portable 7 | -- 8 | -- An internal and really simple monad transformers, 9 | -- without any bells and whistse. 10 | module Basement.Compat.MonadTrans 11 | ( State(..) 12 | , Reader(..) 13 | ) where 14 | 15 | import Basement.Compat.Base 16 | import Control.Monad ((>=>)) 17 | 18 | -- | Simple State monad 19 | newtype State s m a = State { runState :: s -> m (a, s) } 20 | 21 | instance Monad m => Functor (State s m) where 22 | fmap f fa = State $ runState fa >=> (\(a, s2) -> return (f a, s2)) 23 | instance Monad m => Applicative (State s m) where 24 | pure a = State $ \st -> return (a,st) 25 | fab <*> fa = State $ \s1 -> do 26 | (ab,s2) <- runState fab s1 27 | (a,s3) <- runState fa s2 28 | return (ab a, s3) 29 | instance Monad m => Monad (State r m) where 30 | return = pure 31 | ma >>= mb = State $ \s1 -> do 32 | (a,s2) <- runState ma s1 33 | runState (mb a) s2 34 | 35 | -- | Simple Reader monad 36 | newtype Reader r m a = Reader { runReader :: r -> m a } 37 | 38 | instance Monad m => Functor (Reader r m) where 39 | fmap f fa = Reader $ runReader fa >=> (\a -> return (f a)) 40 | instance Monad m => Applicative (Reader r m) where 41 | pure a = Reader $ \_ -> return a 42 | fab <*> fa = Reader $ \r -> do 43 | a <- runReader fa r 44 | ab <- runReader fab r 45 | return $ ab a 46 | instance Monad m => Monad (Reader r m) where 47 | return = pure 48 | ma >>= mb = Reader $ \r -> do 49 | a <- runReader ma r 50 | runReader (mb a) r 51 | -------------------------------------------------------------------------------- /basement/Basement/Compat/Natural.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 3 | module Basement.Compat.Natural 4 | ( Natural 5 | , integerToNatural 6 | , naturalToInteger 7 | ) where 8 | 9 | #if MIN_VERSION_base(4,8,0) 10 | 11 | import Numeric.Natural 12 | import Prelude (Integer, abs, fromInteger, toInteger) 13 | 14 | #else 15 | 16 | import Prelude (Show(..),Eq,Ord,Enum,Num(..),Real(..),Integral(..),Integer,error,(<), (>), otherwise, toInteger) 17 | import Data.Bits 18 | import Data.Typeable 19 | 20 | newtype Natural = Natural Integer 21 | deriving (Eq,Ord,Enum,Typeable,Bits) 22 | 23 | instance Show Natural where 24 | show (Natural i) = show i 25 | 26 | -- re-create the buggy Num instance for Natural 27 | instance Num Natural where 28 | fromInteger n 29 | | n < 0 = error "natural should be positive: " 30 | | otherwise = Natural n 31 | (+) (Natural a) (Natural b) = Natural (a + b) 32 | (-) (Natural a) (Natural b) 33 | | r < 0 = error "natural should be positve" 34 | | otherwise = Natural (a - b) 35 | where r = (a - b) 36 | (*) (Natural a) (Natural b) = Natural (a * b) 37 | abs n = n 38 | negate n = n 39 | signum (Natural n) 40 | | n > 0 = 1 41 | | otherwise = 0 42 | 43 | instance Real Natural where 44 | toRational (Natural n) = toRational n 45 | 46 | instance Integral Natural where 47 | toInteger (Natural n) = n 48 | divMod (Natural n) (Natural e) = let (a,b) = n `quotRem` e in (Natural a, Natural b) 49 | quotRem (Natural n) (Natural e) = let (a,b) = n `quotRem` e in (Natural a, Natural b) 50 | quot (Natural n) (Natural e) = Natural (n `quot` e) 51 | rem (Natural n) (Natural e) = Natural (n `rem` e) 52 | div = quot 53 | mod = rem 54 | 55 | #endif 56 | 57 | integerToNatural :: Integer -> Natural 58 | integerToNatural i = fromInteger (abs i) 59 | 60 | naturalToInteger :: Natural -> Integer 61 | naturalToInteger n = toInteger n 62 | -------------------------------------------------------------------------------- /basement/Basement/Compat/PrimTypes.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Basement.Compat.PrimTypes 3 | -- License : BSD-style 4 | -- Maintainer : Vincent Hanquez 5 | -- Stability : experimental 6 | -- Portability : portable 7 | -- 8 | {-# LANGUAGE MagicHash #-} 9 | module Basement.Compat.PrimTypes 10 | ( FileSize# 11 | , Offset# 12 | , CountOf# 13 | , Bool# 14 | , Pinned# 15 | ) where 16 | 17 | import GHC.Prim 18 | 19 | -- | File size in bytes 20 | type FileSize# = Word64# 21 | 22 | -- | Offset in a bytearray, string, type alias 23 | -- 24 | -- for code documentation purpose only, just a simple type alias on Int# 25 | type Offset# = Int# 26 | 27 | -- | CountOf in bytes type alias 28 | -- 29 | -- for code documentation purpose only, just a simple type alias on Int# 30 | type CountOf# = Int# 31 | 32 | -- | Lowlevel Boolean 33 | type Bool# = Int# 34 | 35 | -- | Pinning status 36 | type Pinned# = Bool# 37 | -------------------------------------------------------------------------------- /basement/Basement/Compat/Typeable.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Basement.Compat.Typeable 3 | -- License : BSD-style 4 | -- Maintainer : Nicolas Di Prima 5 | -- Stability : statble 6 | -- Portability : portable 7 | -- 8 | -- conveniently provide support for legacy and modern base 9 | -- 10 | 11 | {-# LANGUAGE CPP #-} 12 | 13 | module Basement.Compat.Typeable 14 | ( 15 | #if MIN_VERSION_base(4,7,0) 16 | Typeable 17 | #else 18 | Typeable(..) 19 | , typeRep 20 | #endif 21 | ) where 22 | 23 | #if !MIN_VERSION_base(4,7,0) 24 | import Data.Proxy (Proxy(..)) 25 | import qualified Prelude (undefined) 26 | #endif 27 | import Data.Typeable 28 | 29 | #if !MIN_VERSION_base(4,7,0) 30 | -- this function does not exist prior base 4.7 31 | typeRep :: Typeable a => Proxy a -> TypeRep 32 | typeRep = typeRep' Prelude.undefined 33 | where 34 | typeRep' :: Typeable a => a -> Proxy a -> TypeRep 35 | typeRep' a _ = typeOf a 36 | {-# INLINE typeRep' #-} 37 | #endif 38 | -------------------------------------------------------------------------------- /basement/Basement/Environment.hs: -------------------------------------------------------------------------------- 1 | module Basement.Environment 2 | ( getArgs 3 | , lookupEnv 4 | ) where 5 | 6 | import Basement.Compat.Base 7 | import Basement.UTF8.Base (String) 8 | import qualified System.Environment as Sys (getArgs, lookupEnv) 9 | 10 | -- | Returns a list of the program's command line arguments (not including the program name). 11 | getArgs :: IO [String] 12 | getArgs = fmap fromList <$> Sys.getArgs 13 | 14 | -- | Lookup variable in the environment 15 | lookupEnv :: String -> IO (Maybe String) 16 | lookupEnv s = fmap fromList <$> Sys.lookupEnv (toList s) 17 | -------------------------------------------------------------------------------- /basement/Basement/Error.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MagicHash #-} 2 | {-# LANGUAGE PolyKinds #-} 3 | {-# LANGUAGE ImplicitParams #-} 4 | {-# LANGUAGE ExistentialQuantification #-} 5 | {-# LANGUAGE CPP #-} 6 | #if __GLASGOW_HASKELL__ >= 800 7 | {-# LANGUAGE TypeInType #-} 8 | #endif 9 | module Basement.Error 10 | ( error 11 | ) where 12 | 13 | import GHC.Prim 14 | import Basement.UTF8.Base 15 | import Basement.Compat.CallStack 16 | 17 | #if MIN_VERSION_base(4,9,0) 18 | 19 | import GHC.Types (RuntimeRep) 20 | import GHC.Exception (errorCallWithCallStackException) 21 | 22 | -- | stop execution and displays an error message 23 | error :: forall (r :: RuntimeRep) . forall (a :: TYPE r) . HasCallStack => String -> a 24 | error s = raise# (errorCallWithCallStackException (sToList s) ?callstack) 25 | 26 | #elif MIN_VERSION_base(4,7,0) 27 | 28 | import GHC.Exception (errorCallException) 29 | 30 | error :: String -> a 31 | error s = raise# (errorCallException (sToList s)) 32 | 33 | #else 34 | 35 | import GHC.Types 36 | import GHC.Exception 37 | 38 | error :: String -> a 39 | error s = throw (ErrorCall (sToList s)) 40 | 41 | #endif 42 | -------------------------------------------------------------------------------- /basement/Basement/Exception.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Basement.Exception 3 | -- License : BSD-style 4 | -- Maintainer : Vincent Hanquez 5 | -- Stability : experimental 6 | -- Portability : portable 7 | -- 8 | -- Common part for vectors 9 | -- 10 | {-# LANGUAGE DeriveDataTypeable #-} 11 | module Basement.Exception 12 | ( OutOfBound(..) 13 | , OutOfBoundOperation(..) 14 | , isOutOfBound 15 | , outOfBound 16 | , primOutOfBound 17 | , InvalidRecast(..) 18 | , RecastSourceSize(..) 19 | , RecastDestinationSize(..) 20 | , NonEmptyCollectionIsEmpty(..) 21 | ) where 22 | 23 | import Basement.Compat.Base 24 | import Basement.Types.OffsetSize 25 | import Basement.Monad 26 | 27 | -- | The type of operation that triggers an OutOfBound exception. 28 | -- 29 | -- * OOB_Index: reading an immutable vector 30 | -- * OOB_Read: reading a mutable vector 31 | -- * OOB_Write: write a mutable vector 32 | -- * OOB_MemCopy: copying a vector 33 | -- * OOB_MemSet: initializing a mutable vector 34 | data OutOfBoundOperation = OOB_Read | OOB_Write | OOB_MemSet | OOB_MemCopy | OOB_Index 35 | deriving (Show,Eq,Typeable) 36 | 37 | -- | Exception during an operation accessing the vector out of bound 38 | -- 39 | -- Represent the type of operation, the index accessed, and the total length of the vector. 40 | data OutOfBound = OutOfBound OutOfBoundOperation Int Int 41 | deriving (Show,Typeable) 42 | 43 | instance Exception OutOfBound 44 | 45 | outOfBound :: OutOfBoundOperation -> Offset ty -> CountOf ty -> a 46 | outOfBound oobop (Offset ofs) (CountOf sz) = throw (OutOfBound oobop ofs sz) 47 | {-# INLINE outOfBound #-} 48 | 49 | primOutOfBound :: PrimMonad prim => OutOfBoundOperation -> Offset ty -> CountOf ty -> prim a 50 | primOutOfBound oobop (Offset ofs) (CountOf sz) = primThrow (OutOfBound oobop ofs sz) 51 | {-# INLINE primOutOfBound #-} 52 | 53 | isOutOfBound :: Offset ty -> CountOf ty -> Bool 54 | isOutOfBound (Offset ty) (CountOf sz) = ty < 0 || ty >= sz 55 | {-# INLINE isOutOfBound #-} 56 | 57 | newtype RecastSourceSize = RecastSourceSize Int 58 | deriving (Show,Eq,Typeable) 59 | newtype RecastDestinationSize = RecastDestinationSize Int 60 | deriving (Show,Eq,Typeable) 61 | 62 | data InvalidRecast = InvalidRecast RecastSourceSize RecastDestinationSize 63 | deriving (Show,Typeable) 64 | 65 | instance Exception InvalidRecast 66 | 67 | -- | Exception for using NonEmpty assertion with an empty collection 68 | data NonEmptyCollectionIsEmpty = NonEmptyCollectionIsEmpty 69 | deriving (Show,Typeable) 70 | 71 | instance Exception NonEmptyCollectionIsEmpty 72 | -------------------------------------------------------------------------------- /basement/Basement/Floating.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE MagicHash #-} 3 | {-# LANGUAGE UnboxedTuples #-} 4 | {-# LANGUAGE BangPatterns #-} 5 | module Basement.Floating 6 | ( integerToDouble 7 | , naturalToDouble 8 | , doubleExponant 9 | , integerToFloat 10 | , naturalToFloat 11 | , wordToFloat 12 | , floatToWord 13 | , wordToDouble 14 | , doubleToWord 15 | ) where 16 | 17 | import GHC.Types 18 | import GHC.Prim 19 | import GHC.Float 20 | import GHC.Word 21 | import GHC.ST 22 | import Basement.Compat.Base 23 | import Basement.Compat.Natural 24 | import qualified Prelude (fromInteger, toInteger, (^^)) 25 | 26 | integerToDouble :: Integer -> Double 27 | integerToDouble = Prelude.fromInteger 28 | -- this depends on integer-gmp 29 | --integerToDouble i = D# (doubleFromInteger i) 30 | 31 | naturalToDouble :: Natural -> Double 32 | naturalToDouble = integerToDouble . Prelude.toInteger 33 | 34 | doubleExponant :: Double -> Int -> Double 35 | doubleExponant = (Prelude.^^) 36 | 37 | integerToFloat :: Integer -> Float 38 | integerToFloat = Prelude.fromInteger 39 | 40 | naturalToFloat :: Natural -> Float 41 | naturalToFloat = integerToFloat . Prelude.toInteger 42 | 43 | wordToFloat :: Word32 -> Float 44 | wordToFloat (W32# x) = runST $ ST $ \s1 -> 45 | case newByteArray# 4# s1 of { (# s2, mbarr #) -> 46 | case writeWord32Array# mbarr 0# x s2 of { s3 -> 47 | case readFloatArray# mbarr 0# s3 of { (# s4, f #) -> 48 | (# s4, F# f #) }}} 49 | {-# INLINE wordToFloat #-} 50 | 51 | floatToWord :: Float -> Word32 52 | floatToWord (F# x) = runST $ ST $ \s1 -> 53 | case newByteArray# 4# s1 of { (# s2, mbarr #) -> 54 | case writeFloatArray# mbarr 0# x s2 of { s3 -> 55 | case readWord32Array# mbarr 0# s3 of { (# s4, w #) -> 56 | (# s4, W32# w #) }}} 57 | {-# INLINE floatToWord #-} 58 | 59 | wordToDouble :: Word64 -> Double 60 | wordToDouble (W64# x) = runST $ ST $ \s1 -> 61 | case newByteArray# 8# s1 of { (# s2, mbarr #) -> 62 | case writeWord64Array# mbarr 0# x s2 of { s3 -> 63 | case readDoubleArray# mbarr 0# s3 of { (# s4, f #) -> 64 | (# s4, D# f #) }}} 65 | {-# INLINE wordToDouble #-} 66 | 67 | doubleToWord :: Double -> Word64 68 | doubleToWord (D# x) = runST $ ST $ \s1 -> 69 | case newByteArray# 8# s1 of { (# s2, mbarr #) -> 70 | case writeDoubleArray# mbarr 0# x s2 of { s3 -> 71 | case readWord64Array# mbarr 0# s3 of { (# s4, w #) -> 72 | (# s4, W64# w #) }}} 73 | {-# INLINE doubleToWord #-} 74 | -------------------------------------------------------------------------------- /basement/Basement/MutableBuilder.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 2 | module Basement.MutableBuilder 3 | ( Builder(..) 4 | , BuildingState(..) 5 | ) where 6 | 7 | import Basement.Compat.Base 8 | import Basement.Compat.MonadTrans 9 | import Basement.Types.OffsetSize 10 | import Basement.Monad 11 | 12 | newtype Builder collection mutCollection step state err a = Builder 13 | { runBuilder :: State (Offset step, BuildingState collection mutCollection step (PrimState state), Maybe err) state a } 14 | deriving (Functor, Applicative, Monad) 15 | 16 | -- | The in-progress state of a building operation. 17 | -- 18 | -- The previous buffers are in reverse order, and 19 | -- this contains the current buffer and the state of 20 | -- progress packing the elements inside. 21 | data BuildingState collection mutCollection step state = BuildingState 22 | { prevChunks :: [collection] 23 | , prevChunksSize :: !(CountOf step) 24 | , curChunk :: mutCollection state 25 | , chunkSize :: !(CountOf step) 26 | } 27 | 28 | instance Monad state => MonadFailure (Builder collection mutCollection step state err) where 29 | type Failure (Builder collection mutCollection step state err) = err 30 | mFail builderError = Builder $ State $ \(offset, bs, _) -> 31 | return ((), (offset, bs, Just builderError)) 32 | -------------------------------------------------------------------------------- /basement/Basement/NonEmpty.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Basement.NonEmpty 3 | -- License : BSD-style 4 | -- Maintainer : Foundation 5 | -- Stability : experimental 6 | -- Portability : portable 7 | -- 8 | -- A newtype wrapper around a non-empty Collection. 9 | 10 | module Basement.NonEmpty 11 | ( NonEmpty(..) 12 | ) where 13 | 14 | import Basement.Exception 15 | import Basement.Compat.Base 16 | 17 | -- | NonEmpty property for any Collection 18 | newtype NonEmpty a = NonEmpty { getNonEmpty :: a } 19 | deriving (Show,Eq) 20 | 21 | instance IsList c => IsList (NonEmpty c) where 22 | type Item (NonEmpty c) = Item c 23 | toList = toList . getNonEmpty 24 | fromList [] = throw NonEmptyCollectionIsEmpty 25 | fromList l = NonEmpty . fromList $ l 26 | -------------------------------------------------------------------------------- /basement/Basement/Runtime.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Basement.Runtime 3 | -- License : BSD-style 4 | -- Maintainer : foundation 5 | -- 6 | -- Global configuration environment 7 | module Basement.Runtime 8 | where 9 | 10 | import Basement.Compat.Base 11 | import Basement.Types.OffsetSize 12 | import System.Environment 13 | import System.IO.Unsafe (unsafePerformIO) 14 | import Text.Read (readMaybe) 15 | 16 | -- | Defines the maximum size in bytes of unpinned arrays. 17 | -- 18 | -- You can change this value by setting the environment variable 19 | -- @HS_FOUNDATION_UARRAY_UNPINNED_MAX@ to an unsigned integer number. 20 | -- 21 | -- Note: We use 'unsafePerformIO' here. If the environment variable 22 | -- changes during runtime and the runtime system decides to recompute 23 | -- this value, referential transparency is violated (like the First 24 | -- Order violated the Galactic Concordance!). 25 | -- 26 | -- TODO The default value of 1024 bytes is arbitrarily chosen for now. 27 | unsafeUArrayUnpinnedMaxSize :: CountOf Word8 28 | unsafeUArrayUnpinnedMaxSize = unsafePerformIO $ do 29 | maxSize <- (>>= readMaybe) <$> lookupEnv "HS_FOUNDATION_UARRAY_UNPINNED_MAX" 30 | pure $ maybe (CountOf 1024) CountOf maxSize 31 | {-# NOINLINE unsafeUArrayUnpinnedMaxSize #-} 32 | -------------------------------------------------------------------------------- /basement/Basement/Show.hs: -------------------------------------------------------------------------------- 1 | module Basement.Show 2 | where 3 | 4 | import qualified Prelude 5 | import Basement.Compat.Base 6 | import Basement.UTF8.Base (String) 7 | 8 | -- | Use the Show class to create a String. 9 | -- 10 | -- Note that this is not efficient, since 11 | -- an intermediate [Char] is going to be 12 | -- created before turning into a real String. 13 | show :: Prelude.Show a => a -> String 14 | show = fromList . Prelude.show 15 | -------------------------------------------------------------------------------- /basement/Basement/String/Builder.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Basement.String.Builder 3 | -- License : BSD-style 4 | -- Maintainer : Foundation 5 | -- 6 | -- String builder 7 | 8 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 9 | 10 | module Basement.String.Builder 11 | ( Builder 12 | , run 13 | , runUnsafe 14 | 15 | -- * Emit functions 16 | , emit 17 | , emitChar 18 | 19 | -- * unsafe 20 | , unsafeStringBuilder 21 | ) where 22 | 23 | 24 | import qualified Basement.Block.Base as Block (length) 25 | import qualified Basement.Block.Builder as Block 26 | import Basement.Compat.Base 27 | import Basement.Compat.Semigroup 28 | import Basement.Monad 29 | import Basement.String (String, ValidationFailure, Encoding (UTF8), fromBytes) 30 | import Basement.UArray.Base (UArray) 31 | import qualified Basement.UArray.Base as A 32 | 33 | newtype Builder = Builder Block.Builder 34 | deriving (Semigroup, Monoid) 35 | 36 | unsafeStringBuilder :: Block.Builder -> Builder 37 | unsafeStringBuilder = Builder 38 | {-# INLINE unsafeStringBuilder #-} 39 | 40 | run :: PrimMonad prim => Builder -> prim (String, Maybe ValidationFailure, UArray Word8) 41 | run (Builder builder) = do 42 | block <- Block.run builder 43 | let array = A.UArray 0 (Block.length block) (A.UArrayBA block) 44 | pure $ fromBytes UTF8 array 45 | 46 | -- | run the given builder and return the generated String 47 | -- 48 | -- prefer `run` 49 | runUnsafe :: PrimMonad prim => Builder -> prim String 50 | runUnsafe (Builder builder) = Block.unsafeRunString builder 51 | 52 | -- | add a string in the builder 53 | emit :: String -> Builder 54 | emit = Builder . Block.emitString 55 | 56 | -- | emit a UTF8 char in the builder 57 | emitChar :: Char -> Builder 58 | emitChar = Builder . Block.emitUTF8Char 59 | -------------------------------------------------------------------------------- /basement/Basement/String/Encoding/ASCII7.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Basement.String.Encoding.ASCII7 3 | -- License : BSD-style 4 | -- Maintainer : Foundation 5 | -- Stability : experimental 6 | -- Portability : portable 7 | -- 8 | 9 | {-# LANGUAGE MagicHash #-} 10 | 11 | module Basement.String.Encoding.ASCII7 12 | ( ASCII7(..) 13 | , ASCII7_Invalid(..) 14 | ) where 15 | 16 | import Basement.Compat.Base 17 | import Basement.Compat.Primitive 18 | import Basement.Types.OffsetSize 19 | import Basement.Numerical.Additive 20 | import Basement.Monad 21 | import Basement.Bits 22 | 23 | import GHC.Prim (int2Word#, ord#) 24 | import GHC.Word 25 | import GHC.Types 26 | import Basement.UArray 27 | import Basement.UArray.Mutable (MUArray) 28 | import Basement.MutableBuilder 29 | 30 | import Basement.String.Encoding.Encoding 31 | 32 | -- | validate a given byte is within ASCII characters encoring size 33 | -- 34 | -- This function check the 8th bit is set to 0 35 | -- 36 | isAscii :: Word8 -> Bool 37 | isAscii w = (w .&. 0x80) == 0 38 | {-# INLINE isAscii #-} 39 | 40 | data ASCII7_Invalid 41 | = ByteOutOfBound Word8 42 | | CharNotAscii Char 43 | deriving (Typeable, Show, Eq) 44 | instance Exception ASCII7_Invalid 45 | 46 | data ASCII7 = ASCII7 47 | 48 | instance Encoding ASCII7 where 49 | type Unit ASCII7 = Word8 50 | type Error ASCII7 = ASCII7_Invalid 51 | encodingNext _ = next 52 | encodingWrite _ = write 53 | 54 | -- | consume an Ascii7 char and return the Unicode point and the position 55 | -- of the next possible Ascii7 char 56 | -- 57 | next :: (Offset Word8 -> Word8) 58 | -- ^ method to access a given byte 59 | -> Offset Word8 60 | -- ^ index of the byte 61 | -> Either ASCII7_Invalid (Char, Offset Word8) 62 | -- ^ either successfully validated the ASCII char and returned the 63 | -- next index or fail with an error 64 | next getter off 65 | | isAscii w8 = Right (toChar w, off + 1) 66 | | otherwise = Left $ ByteOutOfBound w8 67 | where 68 | !w8@(W8# w) = getter off 69 | toChar :: Word8# -> Char 70 | toChar a = C# (word8ToChar# w) 71 | 72 | -- Write ascii char 73 | -- 74 | -- > build 64 $ sequence_ write "this is a simple list of char..." 75 | -- 76 | write :: (PrimMonad st, Monad st) 77 | => Char 78 | -- ^ expecting it to be a valid Ascii character. 79 | -- otherwise this function will throw an exception 80 | -> Builder (UArray Word8) (MUArray Word8) Word8 st err () 81 | write c 82 | | c < toEnum 0x80 = builderAppend $ w8 c 83 | | otherwise = throw $ CharNotAscii c 84 | where 85 | w8 :: Char -> Word8 86 | w8 (C# ch) = W8# (wordToWord8# (int2Word# (ord# ch))) 87 | -------------------------------------------------------------------------------- /basement/Basement/String/Encoding/ISO_8859_1.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Basement.String.Encoding.ISO_8859_1 3 | -- License : BSD-style 4 | -- Maintainer : Foundation 5 | -- Stability : experimental 6 | -- Portability : portable 7 | -- 8 | 9 | {-# LANGUAGE MagicHash #-} 10 | 11 | module Basement.String.Encoding.ISO_8859_1 12 | ( ISO_8859_1(..) 13 | , ISO_8859_1_Invalid(..) 14 | ) where 15 | 16 | import Basement.Compat.Base 17 | import Basement.Compat.Primitive 18 | import Basement.Types.OffsetSize 19 | import Basement.Numerical.Additive 20 | import Basement.Monad 21 | 22 | import GHC.Prim (int2Word#, ord#) 23 | import GHC.Word 24 | import GHC.Types 25 | import Basement.UArray 26 | import Basement.UArray.Mutable (MUArray) 27 | import Basement.MutableBuilder 28 | 29 | import Basement.String.Encoding.Encoding 30 | 31 | -- offset of size one 32 | aone :: Offset Word8 33 | aone = Offset 1 34 | 35 | data ISO_8859_1_Invalid 36 | = NotISO_8859_1 Char 37 | deriving (Typeable, Show, Eq) 38 | instance Exception ISO_8859_1_Invalid 39 | 40 | data ISO_8859_1 = ISO_8859_1 41 | 42 | instance Encoding ISO_8859_1 where 43 | type Unit ISO_8859_1 = Word8 44 | type Error ISO_8859_1 = ISO_8859_1_Invalid 45 | encodingNext _ = next 46 | encodingWrite _ = write 47 | 48 | next :: (Offset Word8 -> Word8) 49 | -> Offset Word8 50 | -> Either ISO_8859_1_Invalid (Char, Offset Word8) 51 | next getter off = Right (toChar w, off + aone) 52 | where 53 | !(W8# w) = getter off 54 | toChar :: Word8# -> Char 55 | toChar a = C# (word8ToChar# w) 56 | 57 | write :: (PrimMonad st, Monad st) 58 | => Char 59 | -> Builder (UArray Word8) (MUArray Word8) Word8 st err () 60 | write c@(C# ch) 61 | | c <= toEnum 0xFF = builderAppend (W8# x) 62 | | otherwise = throw $ NotISO_8859_1 c 63 | where 64 | x :: Word8# 65 | !x = wordToWord8# (int2Word# (ord# ch)) 66 | -------------------------------------------------------------------------------- /basement/Basement/String/Encoding/UTF32.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Basement.String.Encoding.UTF32 3 | -- License : BSD-style 4 | -- Maintainer : Foundation 5 | -- Stability : experimental 6 | -- Portability : portable 7 | -- 8 | {-# LANGUAGE MagicHash #-} 9 | module Basement.String.Encoding.UTF32 10 | ( UTF32(..) 11 | , UTF32_Invalid 12 | ) where 13 | 14 | import GHC.Prim 15 | import GHC.Word 16 | import GHC.Types 17 | import Basement.Compat.Base 18 | import Basement.Compat.Primitive 19 | import Basement.Types.OffsetSize 20 | import Basement.Monad 21 | import Basement.Numerical.Additive 22 | import Basement.UArray 23 | import Basement.UArray.Mutable (MUArray) 24 | import Basement.MutableBuilder 25 | 26 | import Basement.String.Encoding.Encoding 27 | 28 | data UTF32 = UTF32 29 | 30 | data UTF32_Invalid = UTF32_Invalid 31 | deriving (Typeable, Show, Eq, Ord, Enum, Bounded) 32 | instance Exception UTF32_Invalid 33 | 34 | instance Encoding UTF32 where 35 | type Unit UTF32 = Word32 36 | type Error UTF32 = UTF32_Invalid 37 | encodingNext _ = next 38 | encodingWrite _ = write 39 | 40 | next :: (Offset Word32 -> Word32) 41 | -> Offset Word32 42 | -> Either UTF32_Invalid (Char, Offset Word32) 43 | next getter off = Right (char, off + Offset 1) 44 | where 45 | !(W32# hh) = getter off 46 | char :: Char 47 | char = C# (word32ToChar# hh) 48 | 49 | write :: (PrimMonad st, Monad st) 50 | => Char 51 | -> Builder (UArray Word32) (MUArray Word32) Word32 st err () 52 | write c = builderAppend w32 53 | where 54 | !(C# ch) = c 55 | w32 :: Word32 56 | w32 = W32# (charToWord32# ch) 57 | -------------------------------------------------------------------------------- /basement/Basement/Terminal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | module Basement.Terminal 3 | ( initialize 4 | , getDimensions 5 | ) where 6 | 7 | import Basement.Compat.Base 8 | import Basement.Terminal.Size (getDimensions) 9 | #ifdef mingw32_HOST_OS 10 | import System.IO (hSetEncoding, utf8, hPutStrLn, stderr, stdin, stdout) 11 | import System.Win32.Console (setConsoleCP, setConsoleOutputCP, getConsoleCP, getConsoleOutputCP) 12 | #endif 13 | 14 | initialize :: IO () 15 | initialize = do 16 | #ifdef mingw32_HOST_OS 17 | query getConsoleOutputCP (\e -> setConsoleOutputCP e >> hSetEncoding stdout utf8 >> hSetEncoding stderr utf8) utf8Code 18 | query getConsoleCP (\e -> setConsoleCP e >> hSetEncoding stdin utf8) utf8Code 19 | where 20 | utf8Code = 65001 21 | query get set expected = do 22 | v <- get 23 | if v == expected then pure () else set expected 24 | #else 25 | pure () 26 | #endif 27 | -------------------------------------------------------------------------------- /basement/Basement/These.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Basement.These 3 | -- License : BSD-style 4 | -- Maintainer : Nicolas Di Prima 5 | -- Stability : stable 6 | -- Portability : portable 7 | -- 8 | -- @These a b@, sum type to represent either @a@ or @b@ or both. 9 | -- 10 | module Basement.These 11 | ( These(..) 12 | ) where 13 | 14 | import Basement.Compat.Base 15 | import Basement.NormalForm 16 | 17 | -- | Either a or b or both. 18 | data These a b 19 | = This a 20 | | That b 21 | | These a b 22 | deriving (Eq, Ord, Show, Typeable) 23 | 24 | instance (NormalForm a, NormalForm b) => NormalForm (These a b) where 25 | toNormalForm (This a) = toNormalForm a 26 | toNormalForm (That b) = toNormalForm b 27 | toNormalForm (These a b) = toNormalForm a `seq` toNormalForm b 28 | -------------------------------------------------------------------------------- /basement/Basement/Types/AsciiString.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Foundation.Primitives.Types.AsciiString 3 | -- License : BSD-style 4 | -- Maintainer : Haskell Foundation 5 | -- Stability : experimental 6 | -- Portability : portable 7 | -- 8 | -- A AsciiString type backed by a `ASCII` encoded byte array and all the necessary 9 | -- functions to manipulate the string. 10 | -- 11 | {-# LANGUAGE BangPatterns #-} 12 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 13 | {-# LANGUAGE MagicHash #-} 14 | {-# LANGUAGE TypeFamilies #-} 15 | {-# LANGUAGE FlexibleContexts #-} 16 | module Basement.Types.AsciiString 17 | ( AsciiString(..) 18 | , MutableAsciiString(..) 19 | -- * Binary conversion 20 | , fromBytesUnsafe 21 | , fromBytes 22 | ) where 23 | 24 | import Basement.Compat.Base 25 | import Basement.Compat.Semigroup 26 | import Basement.Types.Char7 27 | import Basement.UArray.Base 28 | import qualified Basement.Types.Char7 as Char7 29 | import qualified Basement.UArray as A (all, unsafeRecast) 30 | 31 | -- | Opaque packed array of characters in the ASCII encoding 32 | newtype AsciiString = AsciiString { toBytes :: UArray Char7 } 33 | deriving (Typeable, Semigroup, Monoid, Eq, Ord) 34 | 35 | newtype MutableAsciiString st = MutableAsciiString (MUArray Char7 st) 36 | deriving (Typeable) 37 | 38 | instance Show AsciiString where 39 | show = fmap Char7.toChar . toList 40 | instance IsString AsciiString where 41 | fromString = fromList . fmap Char7.fromCharMask 42 | instance IsList AsciiString where 43 | type Item AsciiString = Char7 44 | fromList = AsciiString . fromList 45 | toList (AsciiString chars) = toList chars 46 | 47 | -- | Convert a Byte Array representing ASCII data directly to an AsciiString without checking for ASCII validity 48 | -- 49 | -- If the input contains invalid Char7 value (anything above 0x7f), 50 | -- it will trigger runtime async errors when processing data. 51 | -- 52 | -- In doubt, use 'fromBytes' 53 | fromBytesUnsafe :: UArray Word8 -> AsciiString 54 | fromBytesUnsafe = AsciiString . A.unsafeRecast 55 | 56 | -- | Convert a Byte Array representing ASCII checking validity. 57 | -- 58 | -- If the byte array is not valid, then Nothing is returned 59 | fromBytes :: UArray Word8 -> Maybe AsciiString 60 | fromBytes arr 61 | | A.all (\x -> x < 0x80) arr = Just $ AsciiString $ A.unsafeRecast arr 62 | | otherwise = Nothing 63 | -------------------------------------------------------------------------------- /basement/Basement/Types/CharUTF8.hs: -------------------------------------------------------------------------------- 1 | module Basement.Types.CharUTF8 2 | ( CharUTF8(..) 3 | , encodeCharUTF8 4 | , decodeCharUTF8 5 | ) where 6 | 7 | import Basement.UTF8.Types 8 | import Basement.UTF8.Helper 9 | -------------------------------------------------------------------------------- /basement/Basement/Types/Ptr.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MagicHash #-} 2 | module Basement.Types.Ptr 3 | ( Addr(..) 4 | , addrPlus 5 | , addrPlusSz 6 | , addrPlusCSz 7 | , Ptr(..) 8 | , ptrPlus 9 | , ptrPlusSz 10 | , ptrPlusCSz 11 | , castPtr 12 | ) where 13 | 14 | import Basement.Compat.Base 15 | import Basement.Compat.C.Types 16 | import Basement.Types.OffsetSize 17 | import GHC.Ptr 18 | import GHC.Prim 19 | import GHC.Types 20 | 21 | data Addr = Addr Addr# 22 | deriving (Eq,Ord) 23 | 24 | addrPlus :: Addr -> Offset Word8 -> Addr 25 | addrPlus (Addr addr) (Offset (I# i)) = Addr (plusAddr# addr i) 26 | 27 | addrPlusSz :: Addr -> CountOf Word8 -> Addr 28 | addrPlusSz (Addr addr) (CountOf (I# i)) = Addr (plusAddr# addr i) 29 | 30 | addrPlusCSz :: Addr -> CSize -> Addr 31 | addrPlusCSz addr = addrPlusSz addr . sizeOfCSize 32 | 33 | ptrPlus :: Ptr a -> Offset Word8 -> Ptr a 34 | ptrPlus (Ptr addr) (Offset (I# i)) = Ptr (plusAddr# addr i) 35 | 36 | ptrPlusSz :: Ptr a -> CountOf Word8 -> Ptr a 37 | ptrPlusSz (Ptr addr) (CountOf (I# i)) = Ptr (plusAddr# addr i) 38 | 39 | ptrPlusCSz :: Ptr a -> CSize -> Ptr a 40 | ptrPlusCSz ptr = ptrPlusSz ptr . sizeOfCSize 41 | -------------------------------------------------------------------------------- /basement/Basement/UTF8/Types.hs: -------------------------------------------------------------------------------- 1 | module Basement.UTF8.Types 2 | ( 3 | -- * Stepper 4 | Step(..) 5 | , StepBack(..) 6 | , StepASCII(..) 7 | , StepDigit(..) 8 | , isValidStepASCII 9 | , isValidStepDigit 10 | -- * Unicode Errors 11 | , ValidationFailure(..) 12 | -- * UTF8 Encoded 'Char' 13 | , CharUTF8(..) 14 | -- * Case Conversion 15 | , CM (..) 16 | ) where 17 | 18 | import Basement.Compat.Base 19 | import Basement.Types.OffsetSize 20 | 21 | -- | Step when walking a String 22 | -- 23 | -- this is a return value composed of : 24 | -- * the unicode code point read (Char) which need to be 25 | -- between 0 and 0x10ffff (inclusive) 26 | -- * The next offset to start reading the next unicode code point (or end) 27 | data Step = Step {-# UNPACK #-} !Char {-# UNPACK #-} !(Offset Word8) 28 | 29 | -- | Similar to Step but used when processing the string from the end. 30 | -- 31 | -- The stepper is thus the previous character, and the offset of 32 | -- the beginning of the previous character 33 | data StepBack = StepBack {-# UNPACK #-} !Char {-# UNPACK #-} !(Offset Word8) 34 | 35 | -- | Step when processing digits. the value is between 0 and 9 to be valid 36 | newtype StepDigit = StepDigit Word8 37 | 38 | -- | Step when processing ASCII character 39 | newtype StepASCII = StepASCII { stepAsciiRawValue :: Word8 } 40 | 41 | -- | Specialized tuple used for case mapping. 42 | data CM = CM {-# UNPACK #-} !Char {-# UNPACK #-} !Char {-# UNPACK #-} !Char deriving (Eq) 43 | 44 | -- | Represent an already encoded UTF8 Char where the the lowest 8 bits is the start of the 45 | -- sequence. If this contains a multi bytes sequence then each higher 8 bits are filled with 46 | -- the remaining sequence 8 bits per 8 bits. 47 | -- 48 | -- For example: 49 | -- 'A' => U+0041 => 41 => 0x00000041 50 | -- '€ => U+20AC => E2 82 AC => 0x00AC82E2 51 | -- '𐍈' => U+10348 => F0 90 8D 88 => 0x888D90F0 52 | -- 53 | newtype CharUTF8 = CharUTF8 Word32 54 | 55 | isValidStepASCII :: StepASCII -> Bool 56 | isValidStepASCII (StepASCII w) = w < 0x80 57 | 58 | isValidStepDigit :: StepDigit -> Bool 59 | isValidStepDigit (StepDigit w) = w < 0xa 60 | 61 | -- | Possible failure related to validating bytes of UTF8 sequences. 62 | data ValidationFailure = InvalidHeader 63 | | InvalidContinuation 64 | | MissingByte 65 | | BuildingFailure 66 | deriving (Show,Eq,Typeable) 67 | 68 | instance Exception ValidationFailure 69 | -------------------------------------------------------------------------------- /basement/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2015-2017 Vincent Hanquez 2 | Copyright (c) 2017-2019 Foundation Maintainers 3 | 4 | All rights reserved. 5 | 6 | Redistribution and use in source and binary forms, with or without 7 | modification, are permitted provided that the following conditions 8 | are met: 9 | 1. Redistributions of source code must retain the above copyright 10 | notice, this list of conditions and the following disclaimer. 11 | 2. Redistributions in binary form must reproduce the above copyright 12 | notice, this list of conditions and the following disclaimer in the 13 | documentation and/or other materials provided with the distribution. 14 | 3. Neither the name of the author nor the names of his contributors 15 | may be used to endorse or promote products derived from this software 16 | without specific prior written permission. 17 | 18 | THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS AS IS'' AND 19 | ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 20 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 21 | ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE 22 | FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 23 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 24 | OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 25 | HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 26 | LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY 27 | OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF 28 | SUCH DAMAGE. 29 | -------------------------------------------------------------------------------- /basement/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /basement/cbits/foundation_mem.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include "foundation_prim.h" 4 | 5 | int _foundation_memcmp(const void *s1, FsOffset off1, const void *s2, FsOffset off2, FsCountOf n) 6 | { 7 | return memcmp(s1 + off1, s2 + off2, n); 8 | } 9 | 10 | FsOffset _foundation_mem_findbyte(uint8_t * const arr, FsOffset startofs, FsOffset endofs, uint8_t ty) 11 | { 12 | uint8_t *r = memchr(arr + startofs, ty, endofs - startofs); 13 | return ((r == NULL) ? endofs : r - arr); 14 | } 15 | -------------------------------------------------------------------------------- /basement/cbits/foundation_prim.h: -------------------------------------------------------------------------------- 1 | #ifndef FOUNDATION_PRIM_H 2 | #define FOUNDATION_PRIM_H 3 | #include "Rts.h" 4 | 5 | typedef StgInt FsOffset; 6 | typedef StgInt FsCountOf; 7 | 8 | #endif 9 | -------------------------------------------------------------------------------- /basement/cbits/foundation_system.h: -------------------------------------------------------------------------------- 1 | #ifndef FOUNDATION_SYSTEM_H 2 | # define FOUNDATION_SYSTEM_H 3 | 4 | #ifdef _WIN32 5 | #define FOUNDATION_SYSTEM_WINDOWS 6 | #define FOUNDATION_SYSTEM_API_NO_CLOCK 7 | 8 | //define something for Windows (32-bit and 64-bit, this part is common) 9 | #ifdef _WIN64 10 | #define FOUNDATION_SYSTEM_WINDOWS_64 11 | //define something for Windows (64-bit only) 12 | #else 13 | #define FOUNDATION_SYSTEM_WINDOWS_32 14 | //define something for Windows (32-bit only) 15 | #endif 16 | #elif __APPLE__ 17 | #include "TargetConditionals.h" 18 | #include "Availability.h" 19 | 20 | #if TARGET_OS_MAC 21 | #define FOUNDATION_SYSTEM_UNIX 22 | #define FOUNDATION_SYSTEM_MACOS 23 | 24 | #if !defined(__MAC_10_12) || __MAC_OS_X_VERSION_MIN_REQUIRED < __MAC_10_12 25 | #define FOUNDATION_SYSTEM_API_NO_CLOCK 26 | #endif 27 | // Other kinds of Mac OS 28 | #else 29 | # error "foundation: system: Unknown Apple platform" 30 | #endif 31 | #elif __linux__ 32 | #define FOUNDATION_SYSTEM_UNIX 33 | #define FOUNDATION_SYSTEM_LINUX 34 | // linux 35 | #elif defined(__FreeBSD__) 36 | #define FOUNDATION_SYSTEM_UNIX 37 | #define FOUNDATION_SYSTEM_BSD 38 | #define FOUNDATION_SYSTEM_FREEBSD 39 | // freeBSD 40 | #elif defined(__NetBSD__) 41 | #define FOUNDATION_SYSTEM_UNIX 42 | #define FOUNDATION_SYSTEM_BSD 43 | #define FOUNDATION_SYSTEM_NETBSD 44 | // NetBSD 45 | #elif defined(__OpenBSD__) 46 | #define FOUNDATION_SYSTEM_UNIX 47 | #define FOUNDATION_SYSTEM_BSD 48 | #define FOUNDATION_SYSTEM_OPENBSD 49 | // OpenBSD 50 | #elif __unix__ // all unices not caught above 51 | #define FOUNDATION_SYSTEM_UNIX 52 | // Unix 53 | #elif defined(_POSIX_VERSION) 54 | #define FOUNDATION_SYSTEM_UNIX 55 | // POSIX 56 | #else 57 | # error "foundation: system: Unknown compiler" 58 | #endif 59 | 60 | #endif 61 | -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | packages: 2 | basement 3 | foundation 4 | -------------------------------------------------------------------------------- /docs/CHANGELOG.md: -------------------------------------------------------------------------------- 1 | ../CHANGELOG.md -------------------------------------------------------------------------------- /docs/advanced-runtime.md: -------------------------------------------------------------------------------- 1 | # Advanced Usage Options 2 | 3 | ## Environment Variables 4 | 5 | You can override some of the constants used by *Foundation* using environment 6 | variables: 7 | 8 | ### Maximum size of unpinned arrays (in bytes) 9 | 10 | - Environment Variable: `HS_FOUNDATION_UARRAY_UNPINNED_MAX` 11 | - Default: `1024` 12 | 13 | When memory for a new array is allocated, we decide if that memory region should 14 | be **pinned** (will not be copied around by GC) or **unpinned** (can be moved 15 | around by GC) depending on the size of the memory region. This value specifies 16 | up to which size **unpinned** memory will be used. 17 | -------------------------------------------------------------------------------- /docs/contributing.md: -------------------------------------------------------------------------------- 1 | How to contribute 2 | ================= 3 | 4 | Any contributions is welcome, but a short list includes: 5 | 6 | * Improve the code base 7 | * Report an issue 8 | * Fix an issue 9 | * Improve the documentation 10 | * Make tutorial on how to use foundation 11 | * Make your project use foundation instead of base, report the missing coverage (IO, types, etc.), or what functionality is missing to make a succesful transition 12 | 13 | HLint 14 | ----- 15 | 16 | [HLint]() 17 | is a tool for suggesting possible improvements to Haskell code. 18 | Foundation uses HLint to maintain a high level standard of code. 19 | 20 | It is recommended that the latest possible HLint version is used. 21 | To install the latest version, find out what the 22 | [latest version of HLint in hackage](https://hackage.haskell.org/package/hlint) 23 | is, and install it via: 24 | 25 | ``` 26 | $ stack install hlint- 27 | ``` 28 | 29 | To succesfully run HLint locally, you need to pass in the directory on which to run. 30 | Foundation provides a default HLint configuration file with certain assumed exclusions, so HLint should be run from the Foundation repository root directory for the correct report to be generated. 31 | Also, it might be necessary to pass in specific CPP flags: 32 | 33 | ``` 34 | $ hlint \ 35 | --cpp-define=__GLASGOW_HASKELL__=800 \ 36 | --cpp-define=x86_64_HOST_ARCH=1 \ 37 | --cpp-define=mingw32_HOST_OS=1 \ 38 | --report \ 39 | . 40 | ``` 41 | -------------------------------------------------------------------------------- /docs/core-collection.md: -------------------------------------------------------------------------------- 1 | ## IsList 2 | 3 | Type class that allow convertions to and from a list of homogenous types. 4 | This is a re-export of a class available in base. 5 | 6 | ## Element type family 7 | 8 | The Element define a family for thing inside other things. 9 | 10 | ## Collection 11 | 12 | Collection type class represent types containing 1-to-many values of a specific 13 | homogenous type. Allow to efficently support 14 | 15 | ## Sequential 16 | 17 | Represent collection that contains elements in a sequence, this loosely abstract 18 | things like `[a]`. 19 | -------------------------------------------------------------------------------- /docs/core-numerical.md: -------------------------------------------------------------------------------- 1 | # Core Numerical 2 | 3 | While the Num is practical, it's also not very well defined or generic enough. 4 | For example, it's heavily skewed towards types forming a Field, which are also 5 | typically signed. 6 | 7 | The design used here is to try to break single piece of functionality into 8 | their own classe, so that you can overloaded addition operation on your types 9 | which doesn't requires an implementation for subtraction or negation that is 10 | fundamentally impossible to write. 11 | 12 | We also strive to provide something that is enjoyable to use for computer programs 13 | purpose instead of exposing an extremely precise mathematical abstraction that 14 | is only useful for corner cases. 15 | 16 | ### Integral 17 | ### HasNegation 18 | ### IsIntegral 19 | ### IsNatural 20 | 21 | ### Additive 22 | 23 | This is a simple type class to wrap the + operation. 24 | 25 | It has the following member 'azero', '+' and 'scale' where: 26 | 27 | * azero is the identity element of the group over '+' 28 | * '+' is the group addition 29 | * 'scale' is the repeated addition of n times. 30 | 31 | It has the following properties: 32 | 33 | ```haskell 34 | azero + azero == azero 35 | azero + x == x 36 | x + azero == x 37 | scale 0 x == azero 38 | scale 1 x == x 39 | ``` 40 | 41 | This can be effectively be seen as a Monoid where mempty is azero, and (+) is mappend. 42 | 43 | ### Subtractive 44 | 45 | This is a class to wrap the `-` operation. 46 | 47 | However the key difference with the `-` available in base, is that while the 48 | operand need to be of same type, the result is not constraint to be of the same 49 | type as the operands. 50 | 51 | The result is an associated type called `Difference` which is determined by the 52 | operand. 53 | 54 | ```haskell 55 | (-) :: a -> a -> Difference a 56 | ``` 57 | 58 | This doesn't cover all the possible scenario available, but the added flexibility 59 | allow new interesting use cases. 60 | 61 | ### Multiplicative 62 | 63 | This is a class to wrap the multiplication `*` operation. 64 | 65 | It has the following properties: 66 | 67 | ```haskell 68 | midentity * midentity == midentity 69 | midentity * x == x 70 | x * midentity == x 71 | x ^ 0 == midentity 72 | x ^ 1 == x 73 | ``` 74 | 75 | 76 | -------------------------------------------------------------------------------- /docs/home.md: -------------------------------------------------------------------------------- 1 | Welcome to foundation 2 | ===================== 3 | 4 | 5 | -------------------------------------------------------------------------------- /docs/improvements.md: -------------------------------------------------------------------------------- 1 | Block 2 | ----- 3 | 4 | This represent a simple block of memory that is natively handled by the GC; 5 | this is very similar to a Short ByteString, or an unboxed vector without 6 | slicing capabilities. 7 | 8 | Boxed & Unboxed Arrays 9 | ---------------------- 10 | 11 | From a simplistic point of view we provide the same functionalities as the 12 | vector package, but we unify the foreign ptr arrays and the native arrays behind 13 | one type. 14 | 15 | Strings 16 | ------- 17 | 18 | We don't define String to a be list of Char. Just like in many other languages 19 | our strings are packed array of byte using the [UTF8](https://en.wikipedia.org/wiki/UTF-8) encoding. 20 | 21 | It does re-use all the array code, and it's literally an array of bytes with 22 | the property of containing validated UTF8-encoded unicode characters. 23 | -------------------------------------------------------------------------------- /docs/index.md: -------------------------------------------------------------------------------- 1 | Introduction 2 | ============ 3 | 4 | Foundation is a Haskell project to implement a modern & performant standard 5 | library with various centrally maintained functionalities. 6 | 7 | Haskell's base has been designed a while ago and shows its age. For better or 8 | worse, it's also really hard to change base, leading to many interesting but 9 | ultimately fruitless discussions, lots of wasted efforts, and/or 10 | duplicated pieces and libraries. 11 | 12 | Also many core libraries, which brings lots of welcome modern additions to 13 | the language (text, bytestring, vector, & many others), are maintained on the 14 | side, without coordination. For example bytestring and vector doesn't share 15 | any code. 16 | 17 | Foundation is trying to provide a solution to those technical and maintainance 18 | limitations. The core ideas are: 19 | 20 | * Provide all the interesting modern core primitives (packed UTF8 strings, arrays, others) 21 | and have them works well together. 22 | * Improve types where possible; we don't want to be stuck on broken concepts because of compatibility 23 | * Improve classes where possible, for the same reasons. 24 | * Provide core types (e.g. uuid) by default with all the right instances 25 | and convertion functions, integrating well with the rest 26 | * Improve & modernize management using modern services by default, thus we 27 | use all the good services of: 28 | * github: for code, issues and discussions 29 | * cloud services for testing: travis, appveyor 30 | * documentation services: mkdocs 31 | -------------------------------------------------------------------------------- /docs/porting.md: -------------------------------------------------------------------------------- 1 | 2 | ## Core packages 3 | 4 | | Haskell package | Foundation module | Status | 5 | | ------------ | ------------- | ------------ | 6 | | vector | Foundation.Array.Unboxed Foundation.Array.Boxed | Good | 7 | | bytestring | Basement.Block Foundation.Array.Unboxed Foundation.Array.Boxed | Good | 8 | | utf8-string | Foundation.String | Good | 9 | | text | Foundation.String | Good | 10 | | conduit | Foundation.Conduit | Usable | 11 | 12 | ## Various types 13 | 14 | | Haskell package | Foundation module | Status | 15 | | ------------ | ------------- | ------------ | 16 | | uuid-type | Foundation.UUID | Usable | 17 | | uuid | Foundation.UUID | Usable | 18 | | dlist | Foundation.List.DList | Complete | 19 | 20 | ## Network 21 | 22 | | Haskell package | Foundation module | Status | 23 | | ------------ | ------------- | ------------ | 24 | | network | Foundation.Network | Started | 25 | 26 | ## Formats 27 | 28 | | Name | Haskell package | Foundation module | Status | 29 | | ------------ | ------------- | ------------ | ------------ | 30 | | JSON | aeson, json | | Not-Started | 31 | | YAML | yaml | | Not-Started | 32 | | CSV | cassava, csv | | Not-Started | 33 | | XML | xml, xml-conduit | | Not-Started | 34 | 35 | 36 | ## Time 37 | 38 | | Haskell package | Foundation module | Status | 39 | | ------------ | ------------- | ------------ | 40 | | time | Foundation.Time | Started | 41 | 42 | ## Testing 43 | 44 | | Haskell package | Foundation module | Status | 45 | | ------------ | ------------- | ------------ | 46 | | QuickCheck | Foundation.Check | Started | 47 | | tasty | Foundation.Check.Main | Started | 48 | 49 | ## Benchmarks 50 | 51 | | Haskell package | Foundation module | Status | 52 | | ------------ | ------------- | ------------ | 53 | | Criterion | Foundation.Timing | Started | 54 | -------------------------------------------------------------------------------- /edge/.gitignore: -------------------------------------------------------------------------------- 1 | *.o 2 | *.hi 3 | *.tix 4 | *.mix 5 | .stack-work 6 | exts 7 | dist 8 | -------------------------------------------------------------------------------- /edge/Foundation/Compat/ByteString.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Foundation.Compat.ByteString 3 | -- License : BSD-style 4 | -- Maintainer : Foundation 5 | -- Stability : experimental 6 | -- Portability : portable 7 | -- 8 | -- Module to convert bytestring's ByteString type 9 | {-# LANGUAGE ViewPatterns #-} 10 | module Foundation.Compat.ByteString 11 | ( fromByteString 12 | , toByteString 13 | ) where 14 | 15 | import Data.ByteString (ByteString) 16 | import Data.ByteString.Internal (toForeignPtr, unsafeCreate, memcpy) 17 | import Foundation 18 | import Foundation.Array 19 | import Foundation.Array.Internal (withPtr, fromForeignPtr) 20 | 21 | -- | Convert a ByteString to a UArray Word8, 22 | -- without re-allocating or copying anything 23 | fromByteString :: ByteString -> UArray Word8 24 | fromByteString = fromForeignPtr . toForeignPtr 25 | 26 | -- | Convert a UArray Word8 to ByteString 27 | -- 28 | -- all the bytes are copied to a brand new memory chunk 29 | toByteString :: UArray Word8 -> ByteString 30 | toByteString v = unsafeCreate len $ \dst -> withPtr v $ \src -> memcpy dst src len 31 | where 32 | !(CountOf len) = length v 33 | -------------------------------------------------------------------------------- /edge/Foundation/Compat/Text.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Foundation.Compat.Text 3 | -- License : BSD-style 4 | -- Maintainer : Foundation 5 | -- Stability : experimental 6 | -- Portability : portable 7 | -- 8 | -- Module to convert text's Text type 9 | module Foundation.Compat.Text 10 | ( toText 11 | , fromText 12 | ) where 13 | 14 | import Data.Text (Text) 15 | import qualified Data.Text as T 16 | import Foundation 17 | 18 | -- | Convert a String to a Text. 19 | -- This currently allocates a new Text and copies the String content. 20 | toText :: String -> Text 21 | toText = T.pack . toList 22 | 23 | -- | Convert a Text to String 24 | -- This currently allocates a new String and copies the Text content. 25 | fromText :: Text -> String 26 | fromText = fromList . T.unpack 27 | -------------------------------------------------------------------------------- /edge/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2015-2017 Vincent Hanquez 2 | Copyright (c) 2017 Foundation Maintainers 3 | 4 | All rights reserved. 5 | 6 | Redistribution and use in source and binary forms, with or without 7 | modification, are permitted provided that the following conditions 8 | are met: 9 | 1. Redistributions of source code must retain the above copyright 10 | notice, this list of conditions and the following disclaimer. 11 | 2. Redistributions in binary form must reproduce the above copyright 12 | notice, this list of conditions and the following disclaimer in the 13 | documentation and/or other materials provided with the distribution. 14 | 3. Neither the name of the author nor the names of his contributors 15 | may be used to endorse or promote products derived from this software 16 | without specific prior written permission. 17 | 18 | THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS AS IS'' AND 19 | ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 20 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 21 | ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE 22 | FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 23 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 24 | OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 25 | HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 26 | LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY 27 | OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF 28 | SUCH DAMAGE. 29 | -------------------------------------------------------------------------------- /edge/README.md: -------------------------------------------------------------------------------- 1 | Foundation-edge 2 | =============== 3 | 4 | This package is useful to convert to and from, types and data structure commonly found in 5 | the haskell ecosystem. 6 | 7 | For now, edge support the following packages: 8 | 9 | * bytestring (initial) 10 | * text (initial) 11 | 12 | And planning to add support to: 13 | 14 | * vector 15 | 16 | If you think edge would benefits from other packages, open an issue (or even better a PR) with 17 | suggestion of what to add. 18 | -------------------------------------------------------------------------------- /edge/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /edge/foundation-edge.cabal: -------------------------------------------------------------------------------- 1 | Name: foundation-edge 2 | Version: 0.0.3 3 | Synopsis: foundation's edge with the conventional set of packages 4 | Description: 5 | A set of functions to allow interaction with more conventional 6 | and well established packages like bytestring, text, vector 7 | . 8 | Current support: 9 | . 10 | * bytestring 11 | . 12 | * text 13 | License: BSD3 14 | License-file: LICENSE 15 | copyright: 2015-2017 Vincent Hanquez , 2017- Foundation Maintainers 16 | Author: Vincent Hanquez 17 | Maintainer: vincent@snarc.org 18 | Category: foundation 19 | Stability: experimental 20 | Build-Type: Simple 21 | Homepage: https://github.com/haskell-foundation/foundation 22 | Bug-Reports: https://github.com/haskell-foundation/foundation/issues 23 | Cabal-Version: >=1.10 24 | tested-with: GHC == 7.10.3, GHC == 8.0.2, GHC == 8.2.1 25 | extra-source-files: README.md 26 | 27 | source-repository head 28 | type: git 29 | location: https://github.com/haskell-foundation/foundation 30 | subdir: edge 31 | 32 | Library 33 | Exposed-modules: Foundation.Compat.ByteString 34 | , Foundation.Compat.Text 35 | Default-Extensions: NoImplicitPrelude 36 | TypeFamilies 37 | BangPatterns 38 | DeriveDataTypeable 39 | Build-depends: foundation >= 0.0.10 40 | , bytestring 41 | , text 42 | ghc-options: -Wall 43 | default-language: Haskell2010 44 | -------------------------------------------------------------------------------- /foundation/Foundation/Array.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Foundation.Array 3 | -- License : BSD-style 4 | -- Maintainer : Vincent Hanquez 5 | -- Stability : experimental 6 | -- Portability : portable 7 | -- 8 | -- Simple Array and Almost-Array-like data structure 9 | -- 10 | -- Generally accessible in o(1) 11 | -- 12 | {-# LANGUAGE MagicHash #-} 13 | module Foundation.Array 14 | ( Array 15 | , MArray 16 | , UArray 17 | , MUArray 18 | , ChunkedUArray 19 | , Bitmap 20 | , MutableBitmap 21 | , PrimType 22 | -- exceptions 23 | , OutOfBound 24 | ) where 25 | 26 | import Basement.Exception 27 | import Basement.BoxedArray 28 | import Basement.UArray 29 | import Basement.UArray.Mutable 30 | import Foundation.Array.Bitmap 31 | import Foundation.Array.Chunked.Unboxed 32 | -------------------------------------------------------------------------------- /foundation/Foundation/Array/Internal.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Foundation.Array.Internal 3 | -- License : BSD-style 4 | -- Maintainer : Vincent Hanquez 5 | -- Stability : experimental 6 | -- Portability : portable 7 | -- 8 | -- Give access to Array non public functions which 9 | -- can be used to make certains optimisations. 10 | -- 11 | -- Most of what is available here has no guarantees of stability. 12 | -- Anything can be removed and changed. 13 | -- 14 | module Foundation.Array.Internal 15 | ( UArray(..) 16 | , fromForeignPtr 17 | , withPtr 18 | , copyToPtr 19 | , recast 20 | , toHexadecimal 21 | -- * Mutable facilities 22 | , new 23 | , newPinned 24 | , withMutablePtr 25 | ) where 26 | 27 | import Basement.UArray 28 | import Basement.UArray.Mutable hiding (copyToPtr) 29 | -------------------------------------------------------------------------------- /foundation/Foundation/Bits.hs: -------------------------------------------------------------------------------- 1 | -- Extra bits stuff 2 | module Foundation.Bits 3 | ( (.<<.) 4 | , (.>>.) 5 | , Bits(..) 6 | , alignRoundUp 7 | , alignRoundDown 8 | ) where 9 | 10 | import Basement.Compat.Base 11 | import Foundation.Numerical 12 | import Data.Bits hiding ((.<<.), (.>>.)) 13 | 14 | -- | Unsafe Shift Left Operator 15 | (.<<.) :: Bits a => a -> Int -> a 16 | (.<<.) = unsafeShiftL 17 | 18 | -- | Unsafe Shift Right Operator 19 | (.>>.) :: Bits a => a -> Int -> a 20 | (.>>.) = unsafeShiftR 21 | 22 | -- | Round up (if needed) to a multiple of @alignment@ closst to @m@ 23 | -- 24 | -- @alignment@ needs to be a power of two 25 | -- 26 | -- alignRoundUp 16 8 = 16 27 | -- alignRoundUp 15 8 = 16 28 | alignRoundUp :: Int -- ^ Number to Align 29 | -> Int -- ^ Alignment (power of 2) 30 | -> Int 31 | alignRoundUp m alignment = (m + (alignment-1)) .&. complement (alignment-1) 32 | 33 | -- | Round down (if needed) to a multiple of @alignment@ closest to @m@ 34 | -- 35 | -- @alignment@ needs to be a power of two 36 | -- 37 | -- > alignRoundDown 15 8 = 8 38 | -- > alignRoundDown 8 8 = 8 39 | alignRoundDown :: Int -- ^ Number to Align 40 | -> Int -- ^ Alignment (power of 2) 41 | -> Int 42 | alignRoundDown m alignment = m .&. complement (alignment-1) 43 | -------------------------------------------------------------------------------- /foundation/Foundation/Check/Gen.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ExistentialQuantification #-} 2 | {-# LANGUAGE Rank2Types #-} 3 | {-# LANGUAGE GADTs #-} 4 | {-# LANGUAGE OverloadedStrings #-} 5 | module Foundation.Check.Gen 6 | ( Gen 7 | , runGen 8 | , GenParams(..) 9 | , GenRng 10 | , genRng 11 | , genWithRng 12 | , genWithParams 13 | ) where 14 | 15 | import Basement.Imports 16 | import Foundation.Collection 17 | import Foundation.Random 18 | import qualified Foundation.Random.XorShift as XorShift 19 | import Foundation.String 20 | import Foundation.Numerical 21 | import Foundation.Hashing.SipHash 22 | import Foundation.Hashing.Hasher 23 | 24 | data GenParams = GenParams 25 | { genMaxSizeIntegral :: Word -- maximum number of bytes 26 | , genMaxSizeArray :: Word -- number of elements, as placeholder 27 | , genMaxSizeString :: Word -- maximum number of chars 28 | } 29 | 30 | newtype GenRng = GenRng XorShift.State 31 | 32 | type GenSeed = Word64 33 | 34 | genRng :: GenSeed -> [String] -> (Word64 -> GenRng) 35 | genRng seed groups = \iteration -> GenRng $ XorShift.initialize rngSeed (rngSeed * iteration) 36 | where 37 | (SipHash rngSeed) = hashEnd $ hashMixBytes hashData iHashState 38 | hashData = toBytes UTF8 $ intercalate "::" groups 39 | iHashState :: Sip1_3 40 | iHashState = hashNewParam (SipKey seed 0x12345678) 41 | 42 | genGenerator :: GenRng -> (GenRng, GenRng) 43 | genGenerator (GenRng rng) = 44 | let (newSeed1, rngNext) = randomGenerateWord64 rng 45 | (newSeed2, rngNext') = randomGenerateWord64 rngNext 46 | in (GenRng $ XorShift.initialize newSeed1 newSeed2, GenRng rngNext') 47 | 48 | -- | Generator monad 49 | newtype Gen a = Gen { runGen :: GenRng -> GenParams -> a } 50 | 51 | instance Functor Gen where 52 | fmap f g = Gen (\rng params -> f (runGen g rng params)) 53 | 54 | instance Applicative Gen where 55 | pure a = Gen (\_ _ -> a) 56 | fab <*> fa = Gen $ \rng params -> 57 | let (r1,r2) = genGenerator rng 58 | ab = runGen fab r1 params 59 | a = runGen fa r2 params 60 | in ab a 61 | 62 | instance Monad Gen where 63 | return = pure 64 | ma >>= mb = Gen $ \rng params -> 65 | let (r1,r2) = genGenerator rng 66 | a = runGen ma r1 params 67 | in runGen (mb a) r2 params 68 | 69 | genWithRng :: forall a . (forall randomly . MonadRandom randomly => randomly a) -> Gen a 70 | genWithRng f = Gen $ \(GenRng rng) _ -> 71 | let (a, _) = withRandomGenerator rng f in a 72 | 73 | genWithParams :: (GenParams -> Gen a) -> Gen a 74 | genWithParams f = Gen $ \rng params -> runGen (f params) rng params 75 | -------------------------------------------------------------------------------- /foundation/Foundation/Check/Types.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Foundation.Check.Types 3 | -- License : BSD-style 4 | -- Maintainer : Foundation maintainers 5 | -- 6 | -- A implementation of a test framework 7 | -- and property expression & testing 8 | -- 9 | {-# LANGUAGE ScopedTypeVariables #-} 10 | {-# LANGUAGE ExistentialQuantification #-} 11 | {-# LANGUAGE Rank2Types #-} 12 | {-# LANGUAGE GADTs #-} 13 | {-# LANGUAGE OverloadedStrings #-} 14 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 15 | module Foundation.Check.Types 16 | ( Test(..) 17 | , testName 18 | , fqTestName 19 | , groupHasSubGroup 20 | , Check(..) 21 | , PlanState(..) 22 | , PropertyResult(..) 23 | , TestResult(..) 24 | , HasFailures 25 | ) where 26 | 27 | import Basement.Imports 28 | import Foundation.Collection 29 | import Foundation.Monad.State 30 | import Foundation.Check.Property 31 | import Foundation.Check.Gen 32 | 33 | -- | Result of a property run 34 | data PropertyResult = 35 | PropertySuccess 36 | | PropertyFailed String 37 | deriving (Show,Eq) 38 | 39 | -- | Name of a test Followed 40 | data TestResult = 41 | PropertyResult String HasTests PropertyResult 42 | | GroupResult String HasFailures HasTests [TestResult] 43 | deriving (Show) 44 | 45 | -- | number of tests and failures 46 | type HasTests = CountOf TestResult 47 | type HasFailures = CountOf TestResult 48 | 49 | data PlanState = PlanState 50 | { planRng :: Word64 -> GenRng 51 | , planValidations :: CountOf TestResult 52 | , planParams :: GenParams 53 | , planFailures :: [TestResult] 54 | } 55 | 56 | newtype Check a = Check { runCheck :: StateT PlanState IO a } 57 | deriving (Functor, Applicative, Monad) 58 | instance MonadState Check where 59 | type State Check = PlanState 60 | withState f = Check (withState f) 61 | 62 | -- | different type of tests supported 63 | data Test where 64 | -- Unit test 65 | Unit :: String -> IO () -> Test 66 | -- Property test 67 | Property :: IsProperty prop => String -> prop -> Test 68 | -- Multiples tests grouped together 69 | Group :: String -> [Test] -> Test 70 | -- Check plan 71 | CheckPlan :: String -> Check () -> Test 72 | 73 | -- | Name of a test 74 | testName :: Test -> String 75 | testName (Unit s _) = s 76 | testName (Property s _) = s 77 | testName (Group s _) = s 78 | testName (CheckPlan s _) = s 79 | 80 | fqTestName :: [String] -> String 81 | fqTestName = intercalate "/" . reverse 82 | 83 | groupHasSubGroup :: [Test] -> Bool 84 | groupHasSubGroup [] = False 85 | groupHasSubGroup (Group{}:_) = True 86 | groupHasSubGroup (_:xs) = groupHasSubGroup xs 87 | -------------------------------------------------------------------------------- /foundation/Foundation/Class/Bifunctor.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Foundation.Class.Bifunctor 3 | -- License : BSD-style 4 | -- Maintainer : Vincent Hanquez 5 | -- Stability : experimental 6 | -- Portability : portable 7 | -- 8 | -- Formally, the class 'Bifunctor' represents a bifunctor 9 | -- from @Hask@ -> @Hask@. 10 | -- 11 | -- Intuitively it is a bifunctor where both the first and second 12 | -- arguments are covariant. 13 | -- 14 | -- You can define a 'Bifunctor' by either defining 'bimap' or by 15 | -- defining both 'first' and 'second'. 16 | -- 17 | {-# LANGUAGE CPP #-} 18 | module Foundation.Class.Bifunctor 19 | ( module Basement.Compat.Bifunctor 20 | ) where 21 | 22 | import Basement.Compat.Bifunctor 23 | -------------------------------------------------------------------------------- /foundation/Foundation/Collection.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Foundation.Collection 3 | -- License : BSD-style 4 | -- Maintainer : Vincent Hanquez 5 | -- Stability : experimental 6 | -- Portability : portable 7 | -- 8 | -- Different collections (list, vector, string, ..) unified under 1 API. 9 | -- an API to rules them all, and in the darkness bind them. 10 | -- 11 | {-# LANGUAGE FlexibleInstances #-} 12 | module Foundation.Collection 13 | ( BoxedZippable(..) 14 | , Element 15 | , InnerFunctor(..) 16 | , Foldable(..) 17 | , Fold1able(..) 18 | , Mappable(..) 19 | , traverse_ 20 | , mapM_ 21 | , forM 22 | , forM_ 23 | , Collection(..) 24 | , and 25 | , or 26 | , NonEmpty 27 | , getNonEmpty 28 | , nonEmpty 29 | , nonEmpty_ 30 | , nonEmptyFmap 31 | , Sequential(..) 32 | , MutableCollection(..) 33 | , IndexedCollection(..) 34 | , KeyedCollection(..) 35 | , Zippable(..) 36 | , Buildable(..) 37 | , build_ 38 | , Builder(..) 39 | , BuildingState(..) 40 | , Copy(..) 41 | ) where 42 | 43 | import Foundation.Collection.Buildable 44 | import Foundation.Collection.Element 45 | import Foundation.Collection.Foldable 46 | import Foundation.Collection.Indexed 47 | import Foundation.Collection.InnerFunctor 48 | import Foundation.Collection.Keyed 49 | import Foundation.Collection.Mutable 50 | import Foundation.Collection.Collection 51 | import Foundation.Collection.Sequential 52 | import Foundation.Collection.Mappable 53 | import Foundation.Collection.Zippable 54 | import Foundation.Collection.Copy 55 | -------------------------------------------------------------------------------- /foundation/Foundation/Collection/Copy.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE UndecidableInstances #-} 2 | {-# LANGUAGE CPP #-} 3 | 4 | module Foundation.Collection.Copy 5 | ( Copy(..) 6 | ) where 7 | 8 | import GHC.ST (runST) 9 | import Basement.Compat.Base ((>>=)) 10 | import Basement.Nat 11 | import Basement.Types.OffsetSize 12 | import qualified Basement.Block as BLK 13 | import qualified Basement.UArray as UA 14 | import qualified Basement.BoxedArray as BA 15 | import qualified Basement.String as S 16 | 17 | #if MIN_VERSION_base(4,9,0) 18 | import qualified Basement.Sized.Block as BLKN 19 | import qualified Basement.Sized.List as LN 20 | #endif 21 | 22 | class Copy a where 23 | copy :: a -> a 24 | instance Copy [ty] where 25 | copy a = a 26 | instance UA.PrimType ty => Copy (BLK.Block ty) where 27 | copy blk = runST (BLK.thaw blk >>= BLK.unsafeFreeze) 28 | instance UA.PrimType ty => Copy (UA.UArray ty) where 29 | copy = UA.copy 30 | instance Copy (BA.Array ty) where 31 | copy = BA.copy 32 | instance Copy S.String where 33 | copy = S.copy 34 | 35 | #if MIN_VERSION_base(4,9,0) 36 | instance Copy (LN.ListN n ty) where 37 | copy a = a 38 | instance (Countable ty n, UA.PrimType ty, KnownNat n) => Copy (BLKN.BlockN n ty) where 39 | copy blk = runST (BLKN.thaw blk >>= BLKN.freeze) 40 | #endif 41 | -------------------------------------------------------------------------------- /foundation/Foundation/Collection/Element.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Foundation.Array.Element 3 | -- License : BSD-style 4 | -- Maintainer : Vincent Hanquez 5 | -- Stability : experimental 6 | -- Portability : portable 7 | -- 8 | 9 | {-# LANGUAGE CPP #-} 10 | 11 | module Foundation.Collection.Element 12 | ( Element 13 | ) where 14 | 15 | import Basement.Compat.Base 16 | import Basement.Block (Block) 17 | import Basement.UArray (UArray) 18 | import Basement.BoxedArray (Array) 19 | import Basement.String (String) 20 | import Basement.Types.AsciiString (AsciiString) 21 | import Basement.Types.Char7 (Char7) 22 | import Basement.NonEmpty 23 | 24 | #if MIN_VERSION_base(4,9,0) 25 | import Basement.Sized.Block (BlockN) 26 | import Basement.Sized.List (ListN) 27 | #endif 28 | 29 | -- | Element type of a collection 30 | type family Element container 31 | type instance Element [a] = a 32 | type instance Element (Block ty) = ty 33 | type instance Element (UArray ty) = ty 34 | type instance Element (Array ty) = ty 35 | type instance Element String = Char 36 | type instance Element AsciiString = Char7 37 | type instance Element (NonEmpty a) = Element a 38 | 39 | #if MIN_VERSION_base(4,9,0) 40 | type instance Element (BlockN n ty) = ty 41 | type instance Element (ListN n a) = a 42 | #endif 43 | -------------------------------------------------------------------------------- /foundation/Foundation/Collection/InnerFunctor.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DefaultSignatures #-} 2 | {-# LANGUAGE TypeOperators #-} 3 | module Foundation.Collection.InnerFunctor 4 | ( InnerFunctor(..) 5 | ) where 6 | 7 | import Basement.Compat.Base 8 | import Foundation.Collection.Element 9 | import qualified Basement.String as S 10 | import qualified Basement.UArray as UV 11 | import Basement.BoxedArray (Array) 12 | 13 | -- | A monomorphic functor that maps the inner values to values of the same type 14 | class InnerFunctor c where 15 | imap :: (Element c -> Element c) -> c -> c 16 | default imap :: (Functor f, Element (f a) ~ a, f a ~ c) => (Element c -> Element c) -> c -> c 17 | imap = fmap 18 | 19 | instance InnerFunctor [a] 20 | 21 | instance UV.PrimType ty => InnerFunctor (UV.UArray ty) where 22 | imap = UV.map 23 | 24 | instance InnerFunctor (Array ty) 25 | 26 | instance InnerFunctor S.String where 27 | imap = S.charMap 28 | -------------------------------------------------------------------------------- /foundation/Foundation/Collection/Keyed.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Foundation.Array.Keyed 3 | -- License : BSD-style 4 | -- Maintainer : Vincent Hanquez 5 | -- Stability : experimental 6 | -- Portability : portable 7 | -- 8 | {-# LANGUAGE FlexibleInstances #-} 9 | module Foundation.Collection.Keyed 10 | ( KeyedCollection(..) 11 | ) where 12 | 13 | import Basement.Compat.Base 14 | import qualified Data.List 15 | 16 | -- | Collection of things that can be looked up by Key 17 | class KeyedCollection c where 18 | type Key c 19 | type Value c 20 | lookup :: Key c -> c -> Maybe (Value c) 21 | 22 | instance Eq k => KeyedCollection [(k, v)] where 23 | type Key [(k,v)] = k 24 | type Value [(k,v)] = v 25 | lookup = Data.List.lookup 26 | -------------------------------------------------------------------------------- /foundation/Foundation/Collection/List.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Foundation.Collection.List 3 | -- License : BSD-style 4 | -- Maintainer : Vincent Hanquez 5 | -- Stability : experimental 6 | -- Portability : portable 7 | -- 8 | module Foundation.Collection.List 9 | ( wordsWhen 10 | , revTake 11 | , revDrop 12 | , revSplitAt 13 | , breakEnd 14 | , uncons 15 | , unsnoc 16 | ) where 17 | 18 | import qualified Data.List 19 | import Data.Tuple (swap) 20 | import Basement.Compat.Base 21 | import Foundation.Numerical 22 | 23 | -- | Simple helper to split a list repeatly when the predicate match 24 | wordsWhen :: (x -> Bool) -> [x] -> [[x]] 25 | wordsWhen _ [] = [[]] 26 | wordsWhen p is = loop is 27 | where 28 | loop s = 29 | let (w, s') = Data.List.break p s 30 | in case s' of 31 | [] -> [w] 32 | _:xs -> w : loop xs 33 | 34 | revTake :: Int -> [a] -> [a] 35 | revTake n l = Data.List.drop (len - n) l 36 | where 37 | len = Data.List.length l 38 | 39 | revDrop :: Int -> [a] -> [a] 40 | revDrop n l = Data.List.take (len - n) l 41 | where 42 | len = Data.List.length l 43 | 44 | revSplitAt :: Int -> [a] -> ([a],[a]) 45 | revSplitAt n l = swap $ Data.List.splitAt (len - n) l 46 | where 47 | len = Data.List.length l 48 | 49 | breakEnd :: (a -> Bool) -> [a] -> ([a], [a]) 50 | breakEnd predicate l = 51 | let (l1,l2) = Data.List.break predicate (Data.List.reverse l) 52 | in if Data.List.null l2 then (l, []) else (Data.List.reverse l2, Data.List.reverse l1) 53 | 54 | uncons :: [a] -> Maybe (a, [a]) 55 | uncons [] = Nothing 56 | uncons (x:xs) = Just (x,xs) 57 | 58 | unsnoc :: [a] -> Maybe ([a], a) 59 | unsnoc [] = Nothing 60 | unsnoc [x] = Just ([], x) 61 | unsnoc [x,y] = Just ([x], y) 62 | unsnoc (x:xs@(_:_)) = Just $ loop [x] xs 63 | where 64 | loop acc [y] = (Data.List.reverse acc, y) 65 | loop acc (y:ys) = loop (y:acc) ys 66 | loop _ _ = error "impossible" 67 | -------------------------------------------------------------------------------- /foundation/Foundation/Conduit.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeOperators #-} 2 | module Foundation.Conduit 3 | ( Conduit 4 | , ResourceT 5 | , ZipSink (..) 6 | , await 7 | , awaitForever 8 | , yield 9 | , yields 10 | , yieldOr 11 | , leftover 12 | , runConduit 13 | , runConduitPure 14 | , runConduitRes 15 | , fuse 16 | , (.|) 17 | , sourceFile 18 | , sourceHandle 19 | , sinkFile 20 | , sinkHandle 21 | , sinkList 22 | , bracketConduit 23 | ) where 24 | 25 | import Foundation.Conduit.Internal 26 | import Foundation.Collection 27 | import Foundation.IO 28 | import Foundation.IO.File 29 | import Basement.Compat.Base 30 | import Foundation.Monad.Base 31 | import Foundation.Array 32 | import Foundation 33 | import System.IO (Handle) 34 | 35 | 36 | infixr 2 .| 37 | -- | Operator version of 'fuse'. 38 | (.|) :: Monad m => Conduit a b m () -> Conduit b c m r -> Conduit a c m r 39 | (.|) = fuse 40 | {-# INLINE (.|) #-} 41 | 42 | sourceFile :: MonadResource m => FilePath -> Conduit i (UArray Word8) m () 43 | sourceFile fp = bracketConduit 44 | (openFile fp ReadMode) 45 | closeFile 46 | sourceHandle 47 | 48 | sourceHandle :: MonadIO m 49 | => Handle 50 | -> Conduit i (UArray Word8) m () 51 | sourceHandle h = 52 | loop 53 | where 54 | defaultChunkSize :: Int 55 | defaultChunkSize = (32 :: Int) * 1000 - 16 56 | loop = do 57 | arr <- liftIO (hGet h defaultChunkSize) 58 | if null arr 59 | then return () 60 | else yield arr >> loop 61 | 62 | -- | Send values downstream. 63 | yields :: (Monad m, Foldable os, Element os ~ o) => os -> Conduit i o m () 64 | -- FIXME: Should be using mapM_ once that is in Foldable, see #334 65 | yields = foldr ((>>) . yield) (return ()) 66 | 67 | 68 | sinkFile :: MonadResource m => FilePath -> Conduit (UArray Word8) i m () 69 | sinkFile fp = bracketConduit 70 | (openFile fp WriteMode) 71 | closeFile 72 | sinkHandle 73 | 74 | sinkHandle :: MonadIO m 75 | => Handle 76 | -> Conduit (UArray Word8) o m () 77 | sinkHandle h = 78 | loop 79 | where 80 | loop = await >>= maybe 81 | (return ()) 82 | (\arr -> liftIO (hPut h arr) >> loop) 83 | 84 | sinkList :: Monad m => Conduit i o m [i] 85 | sinkList = 86 | loop id 87 | where 88 | loop front = await >>= maybe 89 | (return (front [])) 90 | (\x -> loop (front . (x:))) 91 | -------------------------------------------------------------------------------- /foundation/Foundation/Exception.hs: -------------------------------------------------------------------------------- 1 | module Foundation.Exception 2 | ( finally 3 | , try 4 | , SomeException 5 | ) where 6 | 7 | import Basement.Imports 8 | import Control.Exception (SomeException) 9 | import Foundation.Monad.Exception 10 | 11 | finally :: MonadBracket m => m a -> m b -> m a 12 | finally f g = generalBracket (return ()) (\() a -> g >> return a) (\() _ -> g) (const f) 13 | 14 | try :: (MonadCatch m, Exception e) => m a -> m (Either e a) 15 | try a = catch (a >>= \ v -> return (Right v)) (\e -> return (Left e)) 16 | -------------------------------------------------------------------------------- /foundation/Foundation/Foreign.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Foundation.Foreign 3 | -- License : BSD-style 4 | -- Maintainer : Vincent Hanquez 5 | -- Stability : experimental 6 | -- Portability : portable 7 | -- 8 | module Foundation.Foreign 9 | ( module Basement.FinalPtr 10 | , V.foreignMem 11 | , V.mutableForeignMem 12 | , module Basement.Compat.C.Types 13 | ) where 14 | 15 | import Basement.FinalPtr 16 | import qualified Basement.UArray as V 17 | import qualified Basement.UArray.Mutable as V 18 | 19 | import Basement.Compat.C.Types 20 | -------------------------------------------------------------------------------- /foundation/Foundation/Foreign/Alloc.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MagicHash #-} 2 | module Foundation.Foreign.Alloc 3 | ( allocaBytes 4 | ) where 5 | 6 | import qualified Foreign.Marshal.Alloc as A (allocaBytes) 7 | import Basement.Imports 8 | import Basement.Types.OffsetSize 9 | 10 | allocaBytes :: CountOf Word8 -> (Ptr a -> IO b) -> IO b 11 | allocaBytes (CountOf i) f = A.allocaBytes i f 12 | -------------------------------------------------------------------------------- /foundation/Foundation/Foreign/MemoryMap.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | module Foundation.Foreign.MemoryMap 3 | ( fileMapRead 4 | , FileMapping(..) 5 | , fileMappingToFinalPtr 6 | ) where 7 | 8 | import Foundation.Foreign.MemoryMap.Types 9 | #ifdef mingw32_HOST_OS 10 | import Foundation.Foreign.MemoryMap.Windows 11 | #else 12 | import Foundation.Foreign.MemoryMap.Posix 13 | #endif 14 | 15 | {- 16 | fileMap :: Fd -> Int -> IO FileMap 17 | fileMap = undefined 18 | -} 19 | -------------------------------------------------------------------------------- /foundation/Foundation/Foreign/MemoryMap/Types.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Foundation.Foreign.MemoryMap.Types 3 | -- License : BSD-style 4 | -- Maintainer : Vincent Hanquez 5 | -- Stability : experimental 6 | -- Portability : portable 7 | -- 8 | module Foundation.Foreign.MemoryMap.Types 9 | ( FileMapping(..) 10 | , fileMappingToFinalPtr 11 | , FileMapReadF 12 | ) where 13 | 14 | import GHC.Ptr 15 | import Basement.FinalPtr 16 | import Basement.Types.OffsetSize 17 | import Basement.Compat.Base 18 | import Foundation.VFS (FilePath) 19 | 20 | -- | Contains all the information related to a file mapping, 21 | -- including the size and the finalizer function. 22 | data FileMapping = FileMapping 23 | { fileMappingPtr :: Ptr Word8 24 | , fileMappingSize :: FileSize 25 | , fileMappingUnmap :: IO () 26 | } 27 | 28 | -- | From a file mapping, create a final ptr which will automatically 29 | -- unmap memory when the pointer is garbage. 30 | fileMappingToFinalPtr :: FileMapping -> IO (FinalPtr Word8) 31 | fileMappingToFinalPtr (FileMapping ptr _ finalizer) = 32 | toFinalPtr ptr (const finalizer) 33 | 34 | type FileMapReadF = FilePath -> IO FileMapping 35 | -------------------------------------------------------------------------------- /foundation/Foundation/Foreign/MemoryMap/Windows.hs: -------------------------------------------------------------------------------- 1 | module Foundation.Foreign.MemoryMap.Windows 2 | ( fileMapRead 3 | ) where 4 | 5 | import System.Win32.Mem 6 | import System.Win32.File 7 | import System.Win32.FileMapping 8 | import Control.Exception hiding (handle) 9 | 10 | import Basement.Compat.Base 11 | import Basement.Types.OffsetSize 12 | import Foundation.VFS 13 | import Foundation.Foreign.MemoryMap.Types 14 | 15 | fileMapRead :: FileMapReadF 16 | fileMapRead path = bracket doOpen closeHandle doMapping 17 | where 18 | doOpen = createFile (filePathToLString path) gENERIC_READ fILE_SHARE_READ Nothing oPEN_EXISTING fILE_ATTRIBUTE_NORMAL Nothing 19 | doMapping handle = bracket (createFileMapping (Just handle) pAGE_READONLY 0 Nothing) 20 | closeHandle 21 | (getSizeAndMap handle) 22 | getSizeAndMap handle filemap = do 23 | fileInfo <- getFileInformationByHandle handle 24 | mask_ $ do 25 | ptr <- mapViewOfFile filemap fILE_MAP_READ 0 0 26 | return $ FileMapping ptr (FileSize $ bhfiSize fileInfo) (unmapViewOfFile ptr) 27 | -------------------------------------------------------------------------------- /foundation/Foundation/Format/CSV.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Foundation.Format.CSV 3 | -- License : BSD-style 4 | -- Maintainer : Foundation 5 | -- Stability : experimental 6 | -- Portability : portable 7 | -- 8 | -- Provies the support for Comma Separated Value 9 | 10 | {-# LANGUAGE FlexibleContexts #-} 11 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 12 | {-# LANGUAGE OverloadedStrings #-} 13 | {-# LANGUAGE FlexibleInstances #-} 14 | 15 | module Foundation.Format.CSV 16 | (-- * CSV 17 | CSV 18 | 19 | -- ** Builder 20 | -- *** String Bulider 21 | , csvStringBuilder 22 | , rowStringBuilder 23 | , fieldStringBuilder 24 | -- *** Block Builder 25 | , csvBlockBuilder 26 | , rowBlockBuilder 27 | , fieldBlockBuilder 28 | -- ** Conduit 29 | , rowC 30 | 31 | -- ** Parser 32 | -- *** String Bulider 33 | , file 34 | , record 35 | , record_ 36 | , field 37 | -- ** Conduit 38 | , recordC 39 | -- * Row 40 | , Row 41 | , Record(..) 42 | -- * Field 43 | , Field(..) 44 | , Escaping(..) 45 | , IsField(..) 46 | -- ** helpers 47 | , integral 48 | , float 49 | , string 50 | ) where 51 | 52 | import Foundation.Format.CSV.Types 53 | import Foundation.Format.CSV.Builder 54 | import Foundation.Format.CSV.Parser 55 | -------------------------------------------------------------------------------- /foundation/Foundation/Format/CSV/Builder.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Foundation.Format.CSV.Builder 3 | -- License : BSD-style 4 | -- Maintainer : Foundation 5 | -- Stability : experimental 6 | -- Portability : portable 7 | -- 8 | -- Provies the support for Comma Separated Value 9 | 10 | {-# LANGUAGE FlexibleContexts #-} 11 | {-# LANGUAGE OverloadedStrings #-} 12 | {-# LANGUAGE FlexibleInstances #-} 13 | 14 | module Foundation.Format.CSV.Builder 15 | ( -- * String Bulider 16 | csvStringBuilder 17 | , rowStringBuilder 18 | , fieldStringBuilder 19 | -- * Block Builder 20 | , csvBlockBuilder 21 | , rowBlockBuilder 22 | , fieldBlockBuilder 23 | -- * Conduit 24 | , rowC 25 | ) where 26 | 27 | import Basement.Imports 28 | import Basement.String (replace) 29 | import Foundation.Collection.Sequential (Sequential(intersperse)) 30 | import Foundation.Conduit.Internal 31 | 32 | import qualified Foundation.String.Builder as String 33 | import Basement.Block (Block) 34 | import qualified Basement.Block.Builder as Block 35 | 36 | import GHC.ST (runST) 37 | 38 | import Foundation.Format.CSV.Types 39 | 40 | -- | serialise the CSV document into a UTF8 string 41 | csvStringBuilder :: CSV -> String.Builder 42 | csvStringBuilder = String.unsafeStringBuilder . csvBlockBuilder 43 | 44 | rowStringBuilder :: Row -> String.Builder 45 | rowStringBuilder = String.unsafeStringBuilder . rowBlockBuilder 46 | 47 | fieldStringBuilder :: Field -> String.Builder 48 | fieldStringBuilder = String.unsafeStringBuilder . fieldBlockBuilder 49 | 50 | -- | serialise the CSV document into a UTF8 encoded (Block Word8) 51 | csvBlockBuilder :: CSV -> Block.Builder 52 | csvBlockBuilder = mconcat . intersperse (Block.emitString "\r\n") . fmap rowBlockBuilder . toList . unCSV 53 | 54 | rowBlockBuilder :: Row -> Block.Builder 55 | rowBlockBuilder = mconcat . intersperse (Block.emitUTF8Char ',') . fmap fieldBlockBuilder . toList . unRow 56 | 57 | fieldBlockBuilder :: Field -> Block.Builder 58 | fieldBlockBuilder (FieldInteger i) = Block.emitString $ show i 59 | fieldBlockBuilder (FieldDouble d) = Block.emitString $ show d 60 | fieldBlockBuilder (FieldString s e) = case e of 61 | NoEscape -> Block.emitString s 62 | Escape -> Block.emitUTF8Char '"' <> Block.emitString s <> Block.emitUTF8Char '"' 63 | DoubleEscape -> Block.emitUTF8Char '"' <> Block.emitString (replace "\"" "\"\"" s) <> Block.emitUTF8Char '"' 64 | 65 | rowC :: (Record row, Monad m) => Conduit row (Block Word8) m () 66 | rowC = await >>= go 67 | where 68 | go Nothing = pure () 69 | go (Just r) = 70 | let bytes = runST (Block.run $ rowBlockBuilder (toRow r) <> Block.emitString "\r\n") 71 | in yield bytes >> await >>= go 72 | -------------------------------------------------------------------------------- /foundation/Foundation/Hashing.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Foundation.Hashing 3 | -- License : BSD-style 4 | -- Maintainer : Foundation 5 | -- 6 | module Foundation.Hashing 7 | ( Hashable(..) 8 | , Hasher 9 | -- * Specific methods 10 | , FNV1_32 11 | , FNV1_64 12 | , FNV1a_32 13 | , FNV1a_64 14 | , Sip1_3 15 | , Sip2_4 16 | ) where 17 | 18 | import Foundation.Hashing.Hashable 19 | import Foundation.Hashing.Hasher 20 | import Foundation.Hashing.FNV 21 | import Foundation.Hashing.SipHash 22 | -------------------------------------------------------------------------------- /foundation/Foundation/Hashing/Hasher.hs: -------------------------------------------------------------------------------- 1 | module Foundation.Hashing.Hasher 2 | ( Hasher(..) 3 | ) where 4 | 5 | import Basement.Compat.Base 6 | import Basement.IntegralConv 7 | import Foundation.Array (UArray) 8 | import qualified Basement.UArray as A 9 | import Data.Bits 10 | 11 | -- | Incremental Hashing state. Represent an hashing algorithm 12 | -- 13 | -- the base primitive of this class is `hashMix8`, append 14 | -- mix a Word8 in the state 15 | -- 16 | -- The class allow to define faster mixing function that works on 17 | -- bigger Word size and any unboxed array of any PrimType elements 18 | class Hasher st where 19 | {-# MINIMAL hashNew, hashNewParam, hashMix8, hashEnd #-} 20 | 21 | -- | Associate type when finalizing the state with 'hashEnd' 22 | type HashResult st 23 | 24 | -- | Associate type when initializing the state (e.g. a Key or seed) 25 | type HashInitParam st 26 | 27 | -- | Create a new Hashing context 28 | hashNew :: st 29 | 30 | -- | Create a new Hashing context 31 | hashNewParam :: HashInitParam st -> st 32 | 33 | -- | Finalize the state and returns the hash result 34 | hashEnd :: st -> HashResult st 35 | 36 | -- | Mix a Word8 (Byte) into the state and return the new state 37 | hashMix8 :: Word8 -> st -> st 38 | 39 | -- | Mix a Word16 into the state and return the new state 40 | hashMix16 :: Word16 -> st -> st 41 | hashMix16 w st = hashMix8 w2 $ hashMix8 w1 st 42 | where 43 | !w1 = integralDownsize (w `unsafeShiftR` 8) 44 | !w2 = integralDownsize w 45 | 46 | -- | Mix a Word32 into the state and return the new state 47 | hashMix32 :: Word32 -> st -> st 48 | hashMix32 w st = hashMix8 w4 $ hashMix8 w3 $ hashMix8 w2 $ hashMix8 w1 st 49 | where 50 | !w1 = integralDownsize (w `unsafeShiftR` 24) 51 | !w2 = integralDownsize (w `unsafeShiftR` 16) 52 | !w3 = integralDownsize (w `unsafeShiftR` 8) 53 | !w4 = integralDownsize w 54 | 55 | -- | Mix a Word64 into the state and return the new state 56 | hashMix64 :: Word64 -> st -> st 57 | hashMix64 w st = hashMix32 w2 $ hashMix32 w1 st 58 | where 59 | !w1 = integralDownsize (w `unsafeShiftR` 32) 60 | !w2 = integralDownsize w 61 | 62 | -- | Mix an arbitrary sized unboxed array and return the new state 63 | hashMixBytes :: A.PrimType e => UArray e -> st -> st 64 | hashMixBytes ba st = A.foldl' (flip hashMix8) st (A.unsafeRecast ba) 65 | -------------------------------------------------------------------------------- /foundation/Foundation/IO.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Foundation.IO 3 | -- License : BSD-style 4 | -- Maintainer : Vincent Hanquez 5 | -- Stability : experimental 6 | -- Portability : portable 7 | -- 8 | -- IO Routine 9 | module Foundation.IO 10 | ( 11 | -- * Terminal 12 | Foundation.IO.Terminal.putStrLn 13 | , Foundation.IO.Terminal.putStr 14 | , Foundation.IO.Terminal.stdin 15 | , Foundation.IO.Terminal.stdout 16 | -- * File 17 | , Foundation.IO.File.IOMode(..) 18 | , Foundation.IO.File.openFile 19 | , Foundation.IO.File.closeFile 20 | , Foundation.IO.File.withFile 21 | , Foundation.IO.File.hGet 22 | , Foundation.IO.File.hPut 23 | , Foundation.IO.File.readFile 24 | ) where 25 | 26 | import qualified Foundation.IO.Terminal 27 | import qualified Foundation.IO.File 28 | -------------------------------------------------------------------------------- /foundation/Foundation/IO/FileMap.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Foundation.IO.FileMap 3 | -- License : BSD-style 4 | -- Maintainer : Vincent Hanquez 5 | -- Stability : experimental 6 | -- Portability : portable 7 | -- 8 | -- Note that the memory mapping is handled by the system, not at the haskell level. 9 | -- The system can modify the content of the memory as any moment under your feet. 10 | -- 11 | -- It also have the limitation of your system, no emulation or nice handling of all 12 | -- those corners cases is attempted here. 13 | -- 14 | -- for example mapping a large file (> 4G), on a 32 bits system is likely to just 15 | -- fail or returns inconsistent result. 16 | -- 17 | -- In doubt, use 'readFile' or other simple routine that brings 18 | -- the content of the file in IO. 19 | -- 20 | {-# LANGUAGE OverloadedStrings #-} 21 | module Foundation.IO.FileMap 22 | ( fileMapRead 23 | , fileMapReadWith 24 | ) where 25 | 26 | import Control.Exception 27 | import Basement.Types.OffsetSize 28 | import Basement.Imports 29 | import Foundation.VFS (FilePath) 30 | import Basement.FinalPtr 31 | import qualified Basement.UArray as V 32 | import qualified Foundation.Foreign.MemoryMap as I 33 | import qualified Prelude 34 | 35 | getSize :: I.FileMapping -> Int 36 | getSize fm 37 | | Prelude.fromIntegral (maxBound :: Int) < sz = error ("cannot map file in entirety as size overflow " <> show sz) 38 | | otherwise = Prelude.fromIntegral sz 39 | where 40 | (FileSize sz) = I.fileMappingSize fm 41 | 42 | -- | Map in memory the whole content of a file. 43 | -- 44 | -- Once the array goes out of scope, the memory get (eventually) unmap 45 | fileMapRead :: FilePath -> IO (V.UArray Word8) 46 | fileMapRead fp = do 47 | fileMapping <- I.fileMapRead fp 48 | fptr <- I.fileMappingToFinalPtr fileMapping 49 | return $ V.foreignMem fptr (CountOf $ getSize fileMapping) 50 | 51 | -- | Map in memory the whole content of a file, 52 | 53 | -- the whole map is unmapped at the end of function after the function has been called 54 | -- so any things that is still holding on to this memory will very likely trigger segfault 55 | -- or other really bad behavior. 56 | fileMapReadWith :: FilePath -> (V.UArray Word8 -> IO a) -> IO a 57 | fileMapReadWith fp f = do 58 | bracket (I.fileMapRead fp) I.fileMappingUnmap $ \fm -> do 59 | fptr <- toFinalPtr (I.fileMappingPtr fm) (\_ -> return ()) 60 | f (V.foreignMem fptr (CountOf $ getSize fm)) 61 | -------------------------------------------------------------------------------- /foundation/Foundation/IO/Terminal.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Foundation.IO.Terminal 3 | -- License : BSD-style 4 | -- Maintainer : Foundation 5 | -- Stability : experimental 6 | -- Portability : portable 7 | -- 8 | module Foundation.IO.Terminal 9 | ( putStrLn 10 | , putStr 11 | , stdin 12 | , stdout 13 | , getArgs 14 | , exitFailure 15 | , exitSuccess 16 | ) where 17 | 18 | import Basement.Imports 19 | import qualified Prelude 20 | import System.IO (stdin, stdout) 21 | import System.Exit 22 | import qualified System.Environment as SE (getArgs) 23 | 24 | -- | Print a string to standard output 25 | putStr :: String -> IO () 26 | putStr = Prelude.putStr . toList 27 | 28 | -- | Print a string with a newline to standard output 29 | putStrLn :: String -> IO () 30 | putStrLn = Prelude.putStrLn . toList 31 | 32 | -- | Get the arguments from the terminal command 33 | getArgs :: IO [String] 34 | getArgs = fmap fromList <$> SE.getArgs 35 | -------------------------------------------------------------------------------- /foundation/Foundation/Idea.hs: -------------------------------------------------------------------------------- 1 | -- this is a scratchpad for idea 2 | -- not meant to be exported, or be compiled as part of foundation 3 | module Foundation.Idea where 4 | 5 | import Foundation.Collection.Element 6 | 7 | class X c where 8 | xmap :: (Element c -> Element d) -> c -> d 9 | 10 | --isLength :: (Int -> Bool) -> c -> Bool 11 | --isLength (> 5) [] 12 | --isLength (== 0) [] 13 | -------------------------------------------------------------------------------- /foundation/Foundation/List/ListN.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Foundation.List.ListN 3 | -- License : BSD-style 4 | -- Maintainer : Vincent Hanquez 5 | -- Stability : experimental 6 | -- Portability : portable 7 | -- 8 | -- A Nat-sized list abstraction 9 | -- 10 | -- Using this module is limited to GHC 7.10 and above. 11 | -- 12 | module Foundation.List.ListN ( module X ) where 13 | 14 | import Basement.Sized.List as X 15 | -------------------------------------------------------------------------------- /foundation/Foundation/Math/Trigonometry.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeSynonymInstances #-} 2 | module Foundation.Math.Trigonometry 3 | ( Trigonometry(..) 4 | ) where 5 | 6 | import Basement.Compat.Base 7 | import qualified Prelude 8 | 9 | -- | Method to support basic trigonometric functions 10 | class Trigonometry a where 11 | -- | the famous pi value 12 | pi :: a 13 | -- | sine 14 | sin :: a -> a 15 | -- | cosine 16 | cos :: a -> a 17 | -- | tan 18 | tan :: a -> a 19 | -- | sine-1 20 | asin :: a -> a 21 | -- | cosine-1 22 | acos :: a -> a 23 | -- | tangent-1 24 | atan :: a -> a 25 | -- | hyperbolic sine 26 | sinh :: a -> a 27 | -- | hyperbolic cosine 28 | cosh :: a -> a 29 | -- | hyperbolic tangent 30 | tanh :: a -> a 31 | -- | hyperbolic sine-1 32 | asinh :: a -> a 33 | -- | hyperbolic cosine-1 34 | acosh :: a -> a 35 | -- | hyperbolic tangent-1 36 | atanh :: a -> a 37 | 38 | instance Trigonometry Float where 39 | pi = Prelude.pi 40 | sin = Prelude.sin 41 | cos = Prelude.cos 42 | tan = Prelude.tan 43 | asin = Prelude.asin 44 | acos = Prelude.acos 45 | atan = Prelude.atan 46 | sinh = Prelude.sinh 47 | cosh = Prelude.cosh 48 | tanh = Prelude.tanh 49 | asinh = Prelude.asinh 50 | acosh = Prelude.acosh 51 | atanh = Prelude.atanh 52 | 53 | instance Trigonometry Double where 54 | pi = Prelude.pi 55 | sin = Prelude.sin 56 | cos = Prelude.cos 57 | tan = Prelude.tan 58 | asin = Prelude.asin 59 | acos = Prelude.acos 60 | atan = Prelude.atan 61 | sinh = Prelude.sinh 62 | cosh = Prelude.cosh 63 | tanh = Prelude.tanh 64 | asinh = Prelude.asinh 65 | acosh = Prelude.acosh 66 | atanh = Prelude.atanh 67 | -------------------------------------------------------------------------------- /foundation/Foundation/Monad.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE DeriveDataTypeable #-} 4 | {-# LANGUAGE StandaloneDeriving #-} 5 | module Foundation.Monad 6 | ( MonadIO(..) 7 | , MonadFailure(..) 8 | , MonadThrow(..) 9 | , MonadCatch(..) 10 | , MonadBracket(..) 11 | , MonadTrans(..) 12 | , Identity(..) 13 | , replicateM 14 | ) where 15 | 16 | import Basement.Imports 17 | import Basement.Types.OffsetSize 18 | import Basement.Monad (MonadFailure(..)) 19 | import Foundation.Monad.MonadIO 20 | import Foundation.Monad.Exception 21 | import Foundation.Monad.Transformer 22 | import Foundation.Numerical 23 | 24 | #if MIN_VERSION_base(4,8,0) 25 | import Data.Functor.Identity 26 | 27 | #else 28 | 29 | import Control.Monad.Fix 30 | import Control.Monad.Zip 31 | import Basement.Compat.Base 32 | 33 | import GHC.Generics (Generic1) 34 | 35 | -- | Identity functor and monad. (a non-strict monad) 36 | -- 37 | -- @since 4.8.0.0 38 | newtype Identity a = Identity { runIdentity :: a } 39 | deriving (Eq, Ord, Data, Generic, Generic1, Typeable) 40 | 41 | instance Functor Identity where 42 | fmap f (Identity x) = Identity (f x) 43 | 44 | instance Applicative Identity where 45 | pure = Identity 46 | Identity f <*> Identity x = Identity (f x) 47 | 48 | instance Monad Identity where 49 | return = Identity 50 | m >>= k = k (runIdentity m) 51 | 52 | instance MonadFix Identity where 53 | mfix f = Identity (fix (runIdentity . f)) 54 | 55 | instance MonadZip Identity where 56 | mzipWith f (Identity x) (Identity y) = Identity (f x y) 57 | munzip (Identity (x, y)) = (Identity x, Identity y) 58 | 59 | #endif 60 | 61 | -- | @'replicateM' n act@ performs the action @n@ times, 62 | -- gathering the results. 63 | replicateM :: Applicative m => CountOf a -> m a -> m [a] 64 | replicateM (CountOf count) f = loop count 65 | where 66 | loop cnt 67 | | cnt <= 0 = pure [] 68 | | otherwise = (:) <$> f <*> (loop (cnt - 1)) 69 | {-# INLINEABLE replicateM #-} 70 | -------------------------------------------------------------------------------- /foundation/Foundation/Monad/Base.hs: -------------------------------------------------------------------------------- 1 | module Foundation.Monad.Base 2 | ( Functor(..) 3 | , Applicative(..) 4 | , Monad(..) 5 | , MonadIO(..) 6 | , MonadFailure(..) 7 | , MonadThrow(..) 8 | , MonadCatch(..) 9 | , MonadTrans(..) 10 | , MonadFix(..) 11 | , IdentityT 12 | ) where 13 | 14 | import Basement.Compat.Base (Functor(..), Applicative(..), Monad(..)) 15 | import Basement.Monad 16 | import Foundation.Monad.MonadIO 17 | import Foundation.Monad.Exception 18 | import Foundation.Monad.Transformer 19 | import Foundation.Monad.Identity 20 | import Control.Monad.Fix (MonadFix(..)) 21 | -------------------------------------------------------------------------------- /foundation/Foundation/Monad/Except.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeFamilies #-} 2 | {-# LANGUAGE ConstraintKinds #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | {-# LANGUAGE CPP #-} 5 | module Foundation.Monad.Except 6 | ( ExceptT(..) 7 | ) where 8 | 9 | import Basement.Imports 10 | import Foundation.Monad.Base 11 | import Foundation.Monad.Reader 12 | #if MIN_VERSION_base(4,13,0) 13 | import Control.Monad.Fail 14 | #endif 15 | 16 | newtype ExceptT e m a = ExceptT { runExceptT :: m (Either e a) } 17 | 18 | instance Functor m => Functor (ExceptT e m) where 19 | fmap f = ExceptT . fmap (fmap f) . runExceptT 20 | 21 | instance Monad m => Applicative (ExceptT e m) where 22 | pure a = ExceptT $ pure (Right a) 23 | ExceptT f <*> ExceptT v = ExceptT $ do 24 | mf <- f 25 | case mf of 26 | Left e -> pure (Left e) 27 | Right k -> do 28 | mv <- v 29 | case mv of 30 | Left e -> pure (Left e) 31 | Right x -> pure (Right (k x)) 32 | 33 | instance Monad m => MonadFailure (ExceptT e m) where 34 | type Failure (ExceptT e m) = e 35 | mFail = ExceptT . pure . Left 36 | 37 | instance Monad m => Monad (ExceptT e m) where 38 | return = pure 39 | m >>= k = ExceptT $ do 40 | a <- runExceptT m 41 | case a of 42 | Left e -> return (Left e) 43 | Right x -> runExceptT (k x) 44 | #if !MIN_VERSION_base(4,13,0) 45 | fail = ExceptT . fail 46 | #else 47 | instance MonadFail m => MonadFail (ExceptT e m) where 48 | fail = ExceptT . fail 49 | #endif 50 | 51 | instance (Monad m, MonadFix m) => MonadFix (ExceptT e m) where 52 | mfix f = ExceptT (mfix (runExceptT . f . fromEither)) 53 | where 54 | fromEither (Right x) = x 55 | fromEither (Left _) = error "mfix (ExceptT): inner computation returned Left value" 56 | {-# INLINE mfix #-} 57 | 58 | instance MonadReader m => MonadReader (ExceptT e m) where 59 | type ReaderContext (ExceptT e m) = ReaderContext m 60 | ask = ExceptT (Right <$> ask) 61 | 62 | instance MonadTrans (ExceptT e) where 63 | lift f = ExceptT (Right <$> f) 64 | 65 | instance MonadIO m => MonadIO (ExceptT e m) where 66 | liftIO f = ExceptT (Right <$> liftIO f) 67 | -------------------------------------------------------------------------------- /foundation/Foundation/Monad/Exception.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | {-# LANGUAGE ConstraintKinds #-} 3 | module Foundation.Monad.Exception 4 | ( MonadThrow(..) 5 | , MonadCatch(..) 6 | , MonadBracket(..) 7 | ) where 8 | 9 | import Basement.Compat.Base 10 | import qualified Control.Exception as E 11 | 12 | -- | Monad that can throw exception 13 | class Monad m => MonadThrow m where 14 | -- | Throw immediatity an exception. 15 | -- Only a 'MonadCatch' monad will be able to catch the exception using 'catch' 16 | throw :: Exception e => e -> m a 17 | 18 | -- | Monad that can catch exception 19 | class MonadThrow m => MonadCatch m where 20 | catch :: Exception e => m a -> (e -> m a) -> m a 21 | 22 | -- | Monad that can ensure cleanup actions are performed even in the 23 | -- case of exceptions, both synchronous and asynchronous. This usually 24 | -- excludes continuation-based monads. 25 | class MonadCatch m => MonadBracket m where 26 | -- | A generalized version of the standard bracket function which 27 | -- allows distinguishing different exit cases. 28 | generalBracket 29 | :: m a 30 | -- ^ acquire some resource 31 | -> (a -> b -> m ignored1) 32 | -- ^ cleanup, no exception thrown 33 | -> (a -> E.SomeException -> m ignored2) 34 | -- ^ cleanup, some exception thrown. The exception will be rethrown 35 | -> (a -> m b) 36 | -- ^ inner action to perform with the resource 37 | -> m b 38 | 39 | instance MonadThrow IO where 40 | throw = E.throwIO 41 | instance MonadCatch IO where 42 | catch = E.catch 43 | instance MonadBracket IO where 44 | generalBracket acquire onSuccess onException inner = E.mask $ \restore -> do 45 | x <- acquire 46 | res1 <- E.try $ restore $ inner x 47 | case res1 of 48 | Left (e1 :: E.SomeException) -> do 49 | -- explicitly ignore exceptions from the cleanup 50 | -- action so we keep the original exception 51 | E.uninterruptibleMask_ $ fmap (const ()) (onException x e1) `E.catch` 52 | (\(_ :: E.SomeException) -> return ()) 53 | E.throwIO e1 54 | Right y -> do 55 | -- Allow exceptions from the onSuccess function to propagate 56 | _ <- onSuccess x y 57 | return y 58 | -------------------------------------------------------------------------------- /foundation/Foundation/Monad/Identity.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- The identity monad transformer. 3 | -- 4 | -- This is useful for functions parameterized by a monad transformer. 5 | -- 6 | module Foundation.Monad.Identity 7 | ( IdentityT 8 | , runIdentityT 9 | ) where 10 | 11 | import Basement.Compat.Base hiding (throw) 12 | import Basement.Monad (MonadFailure(..)) 13 | import Foundation.Monad.MonadIO 14 | import Foundation.Monad.Exception 15 | import Foundation.Monad.Transformer 16 | 17 | -- | Identity Transformer 18 | newtype IdentityT m a = IdentityT { runIdentityT :: m a } 19 | 20 | instance Functor m => Functor (IdentityT m) where 21 | fmap f (IdentityT m) = IdentityT (f `fmap` m) 22 | {-# INLINE fmap #-} 23 | 24 | instance Applicative m => Applicative (IdentityT m) where 25 | pure x = IdentityT (pure x) 26 | {-# INLINE pure #-} 27 | fab <*> fa = IdentityT (runIdentityT fab <*> runIdentityT fa) 28 | {-# INLINE (<*>) #-} 29 | 30 | instance Monad m => Monad (IdentityT m) where 31 | return = pure 32 | {-# INLINE return #-} 33 | ma >>= mb = IdentityT $ runIdentityT ma >>= runIdentityT . mb 34 | {-# INLINE (>>=) #-} 35 | 36 | instance MonadTrans IdentityT where 37 | lift = IdentityT 38 | {-# INLINE lift #-} 39 | 40 | instance MonadIO m => MonadIO (IdentityT m) where 41 | liftIO f = lift (liftIO f) 42 | {-# INLINE liftIO #-} 43 | 44 | instance MonadFailure m => MonadFailure (IdentityT m) where 45 | type Failure (IdentityT m) = Failure m 46 | mFail = IdentityT . mFail 47 | 48 | instance MonadThrow m => MonadThrow (IdentityT m) where 49 | throw e = IdentityT (throw e) 50 | 51 | instance MonadCatch m => MonadCatch (IdentityT m) where 52 | catch (IdentityT m) c = IdentityT $ m `catch` (runIdentityT . c) 53 | -------------------------------------------------------------------------------- /foundation/Foundation/Monad/MonadIO.hs: -------------------------------------------------------------------------------- 1 | module Foundation.Monad.MonadIO 2 | ( MonadIO(..) 3 | ) where 4 | 5 | import Control.Monad.IO.Class 6 | -------------------------------------------------------------------------------- /foundation/Foundation/Monad/Reader.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- The Reader monad transformer. 3 | -- 4 | -- This is useful to keep a non-modifiable value 5 | -- in a context 6 | {-# LANGUAGE ConstraintKinds #-} 7 | module Foundation.Monad.Reader 8 | ( -- * MonadReader 9 | MonadReader(..) 10 | , -- * ReaderT 11 | ReaderT 12 | , runReaderT 13 | ) where 14 | 15 | import Basement.Compat.Base (($), (.), const) 16 | import Foundation.Monad.Base 17 | import Foundation.Monad.Exception 18 | 19 | class Monad m => MonadReader m where 20 | type ReaderContext m 21 | ask :: m (ReaderContext m) 22 | 23 | -- | Reader Transformer 24 | newtype ReaderT r m a = ReaderT { runReaderT :: r -> m a } 25 | 26 | instance Functor m => Functor (ReaderT r m) where 27 | fmap f m = ReaderT $ fmap f . runReaderT m 28 | {-# INLINE fmap #-} 29 | 30 | instance Applicative m => Applicative (ReaderT r m) where 31 | pure a = ReaderT $ const (pure a) 32 | {-# INLINE pure #-} 33 | fab <*> fa = ReaderT $ \r -> runReaderT fab r <*> runReaderT fa r 34 | {-# INLINE (<*>) #-} 35 | 36 | instance Monad m => Monad (ReaderT r m) where 37 | return = pure 38 | {-# INLINE return #-} 39 | ma >>= mab = ReaderT $ \r -> runReaderT ma r >>= \a -> runReaderT (mab a) r 40 | {-# INLINE (>>=) #-} 41 | 42 | instance (Monad m, MonadFix m) => MonadFix (ReaderT s m) where 43 | mfix f = ReaderT $ \r -> mfix $ \a -> runReaderT (f a) r 44 | {-# INLINE mfix #-} 45 | 46 | instance MonadTrans (ReaderT r) where 47 | lift f = ReaderT $ const f 48 | {-# INLINE lift #-} 49 | 50 | instance MonadIO m => MonadIO (ReaderT r m) where 51 | liftIO f = lift (liftIO f) 52 | {-# INLINE liftIO #-} 53 | 54 | instance MonadFailure m => MonadFailure (ReaderT r m) where 55 | type Failure (ReaderT r m) = Failure m 56 | mFail e = ReaderT $ \_ -> mFail e 57 | 58 | instance MonadThrow m => MonadThrow (ReaderT r m) where 59 | throw e = ReaderT $ \_ -> throw e 60 | 61 | instance MonadCatch m => MonadCatch (ReaderT r m) where 62 | catch (ReaderT m) c = ReaderT $ \r -> m r `catch` (\e -> runReaderT (c e) r) 63 | 64 | instance MonadBracket m => MonadBracket (ReaderT r m) where 65 | generalBracket acq cleanup cleanupExcept innerAction = do 66 | c <- ask 67 | lift $ generalBracket (runReaderT acq c) 68 | (\a b -> runReaderT (cleanup a b) c) 69 | (\a exn -> runReaderT (cleanupExcept a exn) c) 70 | (\a -> runReaderT (innerAction a) c) 71 | 72 | instance Monad m => MonadReader (ReaderT r m) where 73 | type ReaderContext (ReaderT r m) = r 74 | ask = ReaderT return 75 | -------------------------------------------------------------------------------- /foundation/Foundation/Monad/State.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TupleSections #-} 2 | module Foundation.Monad.State 3 | ( -- * MonadState 4 | MonadState(..) 5 | , get 6 | , put 7 | 8 | , -- * StateT 9 | StateT 10 | , runStateT 11 | ) where 12 | 13 | import Basement.Compat.Bifunctor (first) 14 | import Basement.Compat.Base (($), (.), const) 15 | import Foundation.Monad.Base 16 | import Control.Monad ((>=>)) 17 | 18 | class Monad m => MonadState m where 19 | type State m 20 | withState :: (State m -> (a, State m)) -> m a 21 | 22 | get :: MonadState m => m (State m) 23 | get = withState $ \s -> (s, s) 24 | 25 | put :: MonadState m => State m -> m () 26 | put s = withState $ const ((), s) 27 | 28 | -- | State Transformer 29 | newtype StateT s m a = StateT { runStateT :: s -> m (a, s) } 30 | 31 | instance Functor m => Functor (StateT s m) where 32 | fmap f m = StateT $ \s1 -> (first f) `fmap` runStateT m s1 33 | {-# INLINE fmap #-} 34 | 35 | instance (Applicative m, Monad m) => Applicative (StateT s m) where 36 | pure a = StateT $ \s -> (,s) `fmap` pure a 37 | {-# INLINE pure #-} 38 | fab <*> fa = StateT $ \s1 -> do 39 | (ab,s2) <- runStateT fab s1 40 | (a, s3) <- runStateT fa s2 41 | return (ab a, s3) 42 | {-# INLINE (<*>) #-} 43 | 44 | instance (Functor m, Monad m) => Monad (StateT s m) where 45 | return = pure 46 | {-# INLINE return #-} 47 | ma >>= mab = StateT $ runStateT ma >=> (\(a, s2) -> runStateT (mab a) s2) 48 | {-# INLINE (>>=) #-} 49 | 50 | instance (Functor m, MonadFix m) => MonadFix (StateT s m) where 51 | mfix f = StateT $ \s -> mfix $ \ ~(a, _) -> runStateT (f a) s 52 | {-# INLINE mfix #-} 53 | 54 | instance MonadTrans (StateT s) where 55 | lift f = StateT $ \s -> f >>= return . (,s) 56 | {-# INLINE lift #-} 57 | 58 | instance (Functor m, MonadIO m) => MonadIO (StateT s m) where 59 | liftIO f = lift (liftIO f) 60 | {-# INLINE liftIO #-} 61 | 62 | instance (Functor m, MonadFailure m) => MonadFailure (StateT s m) where 63 | type Failure (StateT s m) = Failure m 64 | mFail e = StateT $ \s -> ((,s) `fmap` mFail e) 65 | 66 | instance (Functor m, MonadThrow m) => MonadThrow (StateT s m) where 67 | throw e = StateT $ \_ -> throw e 68 | 69 | instance (Functor m, MonadCatch m) => MonadCatch (StateT s m) where 70 | catch (StateT m) c = StateT $ \s1 -> m s1 `catch` (\e -> runStateT (c e) s1) 71 | 72 | instance (Functor m, Monad m) => MonadState (StateT s m) where 73 | type State (StateT s m) = s 74 | withState f = StateT $ return . f 75 | -------------------------------------------------------------------------------- /foundation/Foundation/Monad/Transformer.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ConstraintKinds #-} 2 | module Foundation.Monad.Transformer 3 | ( MonadTrans(..) 4 | ) where 5 | 6 | import Basement.Compat.Base (Monad) 7 | 8 | -- | Basic Transformer class 9 | class MonadTrans trans where 10 | -- | Lift a computation from an inner monad to the current transformer monad 11 | lift :: Monad m => m a -> trans m a 12 | -------------------------------------------------------------------------------- /foundation/Foundation/Numerical/Floating.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeSynonymInstances #-} 2 | module Foundation.Numerical.Floating 3 | ( FloatingPoint(..) 4 | ) where 5 | 6 | import Basement.Compat.Base 7 | import Data.Proxy 8 | import qualified Prelude 9 | 10 | -- | IEEE754 Floating Point 11 | class FloatingPoint a where 12 | floatRadix :: Proxy a -> Integer 13 | floatDigits :: Proxy a -> Int 14 | floatRange :: Proxy a -> (Int, Int) 15 | floatDecode :: a -> (Integer, Int) 16 | floatEncode :: Integer -> Int -> a 17 | 18 | instance FloatingPoint Float where 19 | floatRadix _ = Prelude.floatRadix (0.0 :: Float) 20 | floatDigits _ = Prelude.floatDigits (0.0 :: Float) 21 | floatRange _ = Prelude.floatRange (0.0 :: Float) 22 | floatDecode = Prelude.decodeFloat 23 | floatEncode = Prelude.encodeFloat 24 | 25 | instance FloatingPoint Double where 26 | floatRadix _ = Prelude.floatRadix (0.0 :: Double) 27 | floatDigits _ = Prelude.floatDigits (0.0 :: Double) 28 | floatRange _ = Prelude.floatRange (0.0 :: Double) 29 | floatDecode = Prelude.decodeFloat 30 | floatEncode = Prelude.encodeFloat 31 | -------------------------------------------------------------------------------- /foundation/Foundation/Partial.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Foundation.Partial 3 | -- License : BSD-style 4 | -- Maintainer : Vincent Hanquez 5 | -- Stability : experimental 6 | -- Portability : portable 7 | -- 8 | -- Partial give a way to annotate your partial function with 9 | -- a simple wrapper, which can only evaluated using 'fromPartial' 10 | -- 11 | -- > fromPartial ( head [] ) 12 | -- 13 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 14 | module Foundation.Partial 15 | ( Partial 16 | , PartialError 17 | , partialError 18 | , partial 19 | , fromPartial 20 | , head 21 | , fromJust 22 | , fromLeft 23 | , fromRight 24 | ) where 25 | 26 | import Basement.Compat.Base 27 | import Basement.Compat.Identity 28 | 29 | -- | Partialiality wrapper. 30 | newtype Partial a = Partial (Identity a) 31 | deriving (Functor, Applicative, Monad) 32 | 33 | -- | An error related to the evaluation of a Partial value that failed. 34 | -- 35 | -- it contains the name of the function and the reason for failure 36 | data PartialError = PartialError [Char] [Char] 37 | deriving (Show,Eq,Typeable) 38 | 39 | instance Exception PartialError 40 | 41 | -- | Throw an asynchronous PartialError 42 | partialError :: [Char] -> [Char] -> a 43 | partialError lbl exp = throw (PartialError lbl exp) 44 | 45 | -- | Create a value that is partial. this can only be 46 | -- unwrap using the 'fromPartial' function 47 | partial :: a -> Partial a 48 | partial = pure 49 | 50 | -- | Dewrap a possible partial value 51 | fromPartial :: Partial a -> a 52 | fromPartial (Partial ida) = runIdentity ida 53 | 54 | -- | Partial function to get the head of a list 55 | head :: [a] -> Partial a 56 | head l = partial $ 57 | case l of 58 | [] -> partialError "head" "empty list" 59 | x:_ -> x 60 | 61 | -- | Partial function to grab the value inside a Maybe 62 | fromJust :: Maybe a -> Partial a 63 | fromJust x = partial $ 64 | case x of 65 | Nothing -> partialError "fromJust" "Nothing" 66 | Just y -> y 67 | 68 | -- Grab the Right value of an Either 69 | fromRight :: Either a b -> Partial b 70 | fromRight x = partial $ 71 | case x of 72 | Left _ -> partialError "fromRight" "Left" 73 | Right a -> a 74 | 75 | -- Grab the Left value of an Either 76 | fromLeft :: Either a b -> Partial a 77 | fromLeft x = partial $ 78 | case x of 79 | Right _ -> partialError "fromLeft" "Right" 80 | Left a -> a 81 | -------------------------------------------------------------------------------- /foundation/Foundation/Primitive.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Foundation.Primitive 3 | -- License : BSD-style 4 | -- Maintainer : Vincent Hanquez 5 | -- Stability : experimental 6 | -- Portability : portable 7 | -- 8 | -- 9 | {-# LANGUAGE FlexibleInstances #-} 10 | module Foundation.Primitive 11 | ( PrimType(..) 12 | , PrimMonad(..) 13 | 14 | -- * endianess 15 | , ByteSwap 16 | , LE(..), toLE, fromLE 17 | , BE(..), toBE, fromBE 18 | 19 | -- * Integral convertion 20 | , IntegralUpsize(..) 21 | , IntegralDownsize(..) 22 | 23 | -- * Evaluation 24 | , NormalForm(..) 25 | , force 26 | , deepseq 27 | 28 | -- * These 29 | , These(..) 30 | 31 | -- * Block of memory 32 | , Block 33 | , MutableBlock 34 | 35 | -- * Ascii 36 | , Char7 37 | , AsciiString 38 | ) where 39 | 40 | import Basement.PrimType 41 | import Basement.Types.Char7 42 | import Basement.Types.AsciiString 43 | import Basement.Monad 44 | import Basement.Endianness 45 | import Basement.IntegralConv 46 | import Basement.NormalForm 47 | import Basement.These 48 | import Basement.Block 49 | -------------------------------------------------------------------------------- /foundation/Foundation/Random.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Foundation.Random 3 | -- License : BSD-style 4 | -- Stability : experimental 5 | -- Portability : Good 6 | -- 7 | -- This module deals with the random subsystem abstractions. 8 | -- 9 | -- It provide 2 different set of abstractions: 10 | -- 11 | -- * The first abstraction that allow a monad to generate random 12 | -- through the 'MonadRandom' class. 13 | -- 14 | -- * The second abstraction to make generic random generator 'RandomGen' 15 | -- and a small State monad like wrapper 'MonadRandomState' to 16 | -- abstract a generator. 17 | -- 18 | {-# LANGUAGE ForeignFunctionInterface #-} 19 | {-# LANGUAGE ScopedTypeVariables #-} 20 | module Foundation.Random 21 | ( MonadRandom(..) 22 | , RandomGen(..) 23 | , MonadRandomState(..) 24 | , withRandomGenerator 25 | , RNG 26 | , RNGv1 27 | ) where 28 | 29 | import Foundation.Random.Class 30 | import Foundation.Random.DRG 31 | import qualified Foundation.Random.ChaChaDRG as ChaChaDRG 32 | 33 | -- | An alias to the default choice of deterministic random number generator 34 | -- 35 | -- Unless, you want to have the stability of a specific random number generator, 36 | -- e.g. for tests purpose, it's recommended to use this alias so that you would 37 | -- keep up to date with possible bugfixes, or change of algorithms. 38 | type RNG = RNGv1 39 | 40 | type RNGv1 = ChaChaDRG.State 41 | -------------------------------------------------------------------------------- /foundation/Foundation/Random/Class.hs: -------------------------------------------------------------------------------- 1 | module Foundation.Random.Class 2 | ( MonadRandom(..) 3 | ) where 4 | 5 | import Data.Proxy 6 | import Basement.Imports 7 | import Foundation.System.Entropy 8 | import qualified Basement.UArray as A 9 | 10 | -- | A monad constraint that allows to generate random bytes 11 | class (Functor m, Applicative m, Monad m) => MonadRandom m where 12 | getRandomBytes :: CountOf Word8 -> m (UArray Word8) 13 | getRandomWord64 :: m Word64 14 | getRandomF32 :: m Float 15 | getRandomF64 :: m Double 16 | 17 | instance MonadRandom IO where 18 | getRandomBytes = getEntropy 19 | getRandomWord64 = flip A.index 0 . A.unsafeRecast 20 | <$> getRandomBytes (A.primSizeInBytes (Proxy :: Proxy Word64)) 21 | getRandomF32 = flip A.index 0 . A.unsafeRecast 22 | <$> getRandomBytes (A.primSizeInBytes (Proxy :: Proxy Word64)) 23 | getRandomF64 = flip A.index 0 . A.unsafeRecast 24 | <$> getRandomBytes (A.primSizeInBytes (Proxy :: Proxy Word64)) 25 | -------------------------------------------------------------------------------- /foundation/Foundation/Random/DRG.hs: -------------------------------------------------------------------------------- 1 | module Foundation.Random.DRG 2 | ( RandomGen(..) 3 | , MonadRandomState(..) 4 | , withRandomGenerator 5 | ) where 6 | 7 | import Basement.Imports 8 | import Foundation.Random.Class 9 | 10 | -- | A Deterministic Random Generator (DRG) class 11 | class RandomGen gen where 12 | -- | Initialize a new random generator 13 | randomNew :: MonadRandom m => m gen 14 | 15 | -- | Initialize a new random generator from a binary seed. 16 | -- 17 | -- If `Nothing` is returned, then the data is not acceptable 18 | -- for creating a new random generator. 19 | randomNewFrom :: UArray Word8 -> Maybe gen 20 | 21 | -- | Generate N bytes of randomness from a DRG 22 | randomGenerate :: CountOf Word8 -> gen -> (UArray Word8, gen) 23 | 24 | -- | Generate a Word64 from a DRG 25 | randomGenerateWord64 :: gen -> (Word64, gen) 26 | 27 | randomGenerateF32 :: gen -> (Float, gen) 28 | 29 | randomGenerateF64 :: gen -> (Double, gen) 30 | 31 | -- | A simple Monad class very similar to a State Monad 32 | -- with the state being a RandomGenerator. 33 | newtype MonadRandomState gen a = MonadRandomState { runRandomState :: gen -> (a, gen) } 34 | 35 | instance Functor (MonadRandomState gen) where 36 | fmap f m = MonadRandomState $ \g1 -> 37 | let (a, g2) = runRandomState m g1 in (f a, g2) 38 | 39 | instance Applicative (MonadRandomState gen) where 40 | pure a = MonadRandomState $ \g -> (a, g) 41 | (<*>) fm m = MonadRandomState $ \g1 -> 42 | let (f, g2) = runRandomState fm g1 43 | (a, g3) = runRandomState m g2 44 | in (f a, g3) 45 | 46 | instance Monad (MonadRandomState gen) where 47 | return = pure 48 | (>>=) m1 m2 = MonadRandomState $ \g1 -> 49 | let (a, g2) = runRandomState m1 g1 50 | in runRandomState (m2 a) g2 51 | 52 | instance RandomGen gen => MonadRandom (MonadRandomState gen) where 53 | getRandomBytes n = MonadRandomState (randomGenerate n) 54 | getRandomWord64 = MonadRandomState randomGenerateWord64 55 | getRandomF32 = MonadRandomState randomGenerateF32 56 | getRandomF64 = MonadRandomState randomGenerateF64 57 | 58 | 59 | -- | Run a pure computation with a Random Generator in the 'MonadRandomState' 60 | withRandomGenerator :: RandomGen gen 61 | => gen 62 | -> MonadRandomState gen a 63 | -> (a, gen) 64 | withRandomGenerator gen m = runRandomState m gen 65 | -------------------------------------------------------------------------------- /foundation/Foundation/Strict.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Foundation.Strict 3 | -- License : BSD-style 4 | -- Maintainer : Foundation 5 | -- Stability : stable 6 | -- Portability : portable 7 | -- 8 | -- Enforce strictness when executing lambda 9 | -- 10 | 11 | module Foundation.Strict 12 | ( strict1 13 | , strict2 14 | , strict3 15 | , strict4 16 | , strict5 17 | , strict6 18 | ) where 19 | 20 | strict1 :: (a -> b) -> a -> b 21 | strict1 f !a = f a 22 | 23 | strict2 :: (a -> b -> c) -> a -> b -> c 24 | strict2 f !a !b = f a b 25 | 26 | strict3 :: (a -> b -> c -> d) -> a -> b -> c -> d 27 | strict3 f !a !b !c = f a b c 28 | 29 | strict4 :: (a -> b -> c -> d -> e) -> a -> b -> c -> d -> e 30 | strict4 f !a !b !c !d = f a b c d 31 | 32 | strict5 :: (a -> b -> c -> d -> e -> f) -> a -> b -> c -> d -> e -> f 33 | strict5 f !a !b !c !d !e = f a b c d e 34 | 35 | strict6 :: (a -> b -> c -> d -> e -> f -> g) -> a -> b -> c -> d -> e -> f -> g 36 | strict6 f !a !b !c !d !e !g = f a b c d e g 37 | 38 | -------------------------------------------------------------------------------- /foundation/Foundation/String.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Foundation.String 3 | -- License : BSD-style 4 | -- Maintainer : Vincent Hanquez 5 | -- Stability : experimental 6 | -- Portability : portable 7 | -- 8 | -- Opaque packed String encoded in UTF8. 9 | -- 10 | -- The type is an instance of IsString and IsList, which allow OverloadedStrings 11 | -- for string literal, and 'fromList' to convert a [Char] (Prelude String) to a packed 12 | -- representation 13 | -- 14 | -- > {-# LANGUAGE OverloadedStrings #-} 15 | -- > s = "Hello World" :: String 16 | -- 17 | -- > s = fromList ("Hello World" :: Prelude.String) :: String 18 | -- 19 | -- Each unicode code point is represented by a variable encoding of 1 to 4 bytes, 20 | -- 21 | -- For more information about UTF8: 22 | -- 23 | module Foundation.String 24 | ( String 25 | , Encoding(..) 26 | , fromBytes 27 | , fromBytesLenient 28 | , fromBytesUnsafe 29 | , toBytes 30 | , ValidationFailure(..) 31 | , lines 32 | , words 33 | , upper 34 | , lower 35 | , replace 36 | , indices 37 | , toBase64 38 | , toBase64URL 39 | , toBase64OpenBSD 40 | , breakLine 41 | ) where 42 | 43 | import Basement.String 44 | -------------------------------------------------------------------------------- /foundation/Foundation/String/Builder.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Foundation.String.Builder 3 | -- License : BSD-style 4 | -- Maintainer : Foundation 5 | -- 6 | -- String Builder 7 | -- 8 | module Foundation.String.Builder 9 | ( module Basement.String.Builder 10 | , toString 11 | ) where 12 | 13 | import Basement.String.Builder 14 | import Basement.String (String) 15 | import GHC.ST 16 | 17 | -- | run the builder and return a `String` 18 | -- 19 | -- alias to `runUnsafe` 20 | -- 21 | -- This function is not safe, prefer `run`. 22 | -- 23 | toString :: Builder -> String 24 | toString builder = runST (runUnsafe builder) 25 | -------------------------------------------------------------------------------- /foundation/Foundation/String/Read.hs: -------------------------------------------------------------------------------- 1 | module Foundation.String.Read 2 | ( readInteger 3 | , readIntegral 4 | , readNatural 5 | , readDouble 6 | , readRational 7 | , readFloatingExact 8 | ) where 9 | 10 | import Basement.String 11 | -------------------------------------------------------------------------------- /foundation/Foundation/System/Bindings.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_HADDOCK hide #-} 2 | {-# LANGUAGE CPP #-} 3 | module Foundation.System.Bindings 4 | ( module X 5 | ) where 6 | 7 | #ifdef mingw32_HOST_OS 8 | import Foundation.System.Bindings.Windows as X 9 | #else 10 | import Foundation.System.Bindings.Posix as X 11 | #endif 12 | -------------------------------------------------------------------------------- /foundation/Foundation/System/Bindings/Hs.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_HADDOCK hide #-} 2 | {-# LANGUAGE MagicHash #-} 3 | {-# LANGUAGE UnliftedFFITypes #-} 4 | module Foundation.System.Bindings.Hs 5 | where 6 | 7 | import GHC.IO 8 | import Basement.Compat.C.Types 9 | 10 | foreign import ccall unsafe "HsBase.h __hscore_get_errno" sysHsCoreGetErrno :: IO CInt 11 | -------------------------------------------------------------------------------- /foundation/Foundation/System/Bindings/Macos.hsc: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_HADDOCK hide #-} 2 | module Foundation.System.Bindings.Macos 3 | where 4 | 5 | import Basement.Compat.Base 6 | import Basement.Compat.C.Types 7 | import Foundation.System.Bindings.PosixDef 8 | import Basement.Types.OffsetSize 9 | 10 | #include 11 | #include 12 | #include 13 | #include 14 | #include 15 | #include 16 | 17 | sysMacos_O_SHLOCK 18 | , sysMacos_O_EXLOCK 19 | , sysMacos_O_SYMLINK 20 | , sysMacos_O_EVTONLY :: COpenFlags 21 | sysMacos_O_SHLOCK = (#const O_SHLOCK) 22 | sysMacos_O_EXLOCK = (#const O_EXLOCK) 23 | sysMacos_O_SYMLINK = (#const O_SYMLINK) 24 | sysMacos_O_EVTONLY = (#const O_EVTONLY) 25 | 26 | data MachTimebaseInfo 27 | 28 | size_MachTimebaseInfo :: CSize 29 | size_MachTimebaseInfo = #const sizeof(mach_timebase_info_data_t) 30 | 31 | ofs_MachTimebaseInfo_numer :: Offset Word8 32 | ofs_MachTimebaseInfo_numer = Offset (#offset mach_timebase_info_data_t, numer) 33 | 34 | ofs_MachTimebaseInfo_denom :: Offset Word8 35 | ofs_MachTimebaseInfo_denom = Offset (#offset mach_timebase_info_data_t, denom) 36 | 37 | foreign import ccall unsafe "mach_absolute_time" 38 | sysMacos_absolute_time :: IO Word64 39 | foreign import ccall unsafe "mach_timebase_info" 40 | sysMacos_timebase_info :: Ptr MachTimebaseInfo -> IO () 41 | -------------------------------------------------------------------------------- /foundation/Foundation/System/Bindings/Network.hsc: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Foundation.System.Bindings.HostName 3 | -- License : BSD-style 4 | -- Maintainer : Nicolas Di Prima 5 | -- Stability : provisional 6 | -- Portability : portable 7 | -- 8 | {-# OPTIONS_HADDOCK hide #-} 9 | module Foundation.System.Bindings.Network 10 | ( -- * error 11 | getHErrno 12 | , herr_HostNotFound 13 | , herr_NoData 14 | , herr_NoRecovery 15 | , herr_TryAgain 16 | ) where 17 | 18 | import Basement.Compat.Base 19 | import Basement.Compat.C.Types 20 | 21 | #ifdef mingw32_HOST_OS 22 | # include 23 | #else 24 | # include "netinet/in.h" 25 | # include "netdb.h" 26 | #endif 27 | 28 | herr_HostNotFound 29 | , herr_NoData 30 | , herr_NoRecovery 31 | , herr_TryAgain 32 | :: CInt 33 | #ifdef mingw32_HOST_OS 34 | herr_HostNotFound = (#const WSAHOST_NOT_FOUND) 35 | herr_NoData = (#const WSANO_DATA) 36 | herr_NoRecovery = (#const WSANO_RECOVERY) 37 | herr_TryAgain = (#const WSATRY_AGAIN) 38 | #else 39 | herr_HostNotFound = (#const HOST_NOT_FOUND) 40 | herr_NoData = (#const NO_DATA) 41 | herr_NoRecovery = (#const NO_RECOVERY) 42 | herr_TryAgain = (#const TRY_AGAIN) 43 | #endif 44 | 45 | foreign import ccall unsafe "foundation_network_get_h_errno" 46 | getHErrno :: IO CInt 47 | -------------------------------------------------------------------------------- /foundation/Foundation/System/Bindings/PosixDef.hsc: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_HADDOCK hide #-} 2 | module Foundation.System.Bindings.PosixDef 3 | ( CErrno 4 | , CFd 5 | , CMemProtFlags 6 | , CMemMappingFlags 7 | , CMemAdvice 8 | , CMemSyncFlags 9 | , CSysconfName 10 | , COpenFlags 11 | , COff(..) 12 | , CMode(..) 13 | ) where 14 | 15 | import Basement.Compat.C.Types 16 | 17 | type CErrno = CInt 18 | type CFd = CInt 19 | type CMemProtFlags = CInt 20 | type CMemMappingFlags = CInt 21 | type CMemAdvice = CInt 22 | type CMemSyncFlags = CInt 23 | type CSysconfName = CInt 24 | type COpenFlags = CInt 25 | -------------------------------------------------------------------------------- /foundation/Foundation/System/Bindings/Windows.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_HADDOCK hide #-} 2 | module Foundation.System.Bindings.Windows 3 | where 4 | -------------------------------------------------------------------------------- /foundation/Foundation/System/Entropy.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Foundation.System.Entropy 3 | -- License : BSD-style 4 | -- Maintainer : Foundation 5 | -- Stability : stable 6 | -- Portability : good 7 | -- 8 | {-# LANGUAGE CPP #-} 9 | module Foundation.System.Entropy 10 | ( getEntropy 11 | ) where 12 | 13 | 14 | import Basement.Compat.Base 15 | import Basement.Types.OffsetSize 16 | import qualified Basement.UArray.Mutable as A 17 | import qualified Basement.UArray as A 18 | import Control.Exception 19 | import Foreign.Ptr 20 | import Foundation.Numerical 21 | 22 | import Foundation.System.Entropy.Common 23 | #ifdef mingw32_HOST_OS 24 | import Foundation.System.Entropy.Windows 25 | #else 26 | import Foundation.System.Entropy.Unix 27 | #endif 28 | 29 | -- | Get some of the system entropy 30 | getEntropy :: CountOf Word8 -> IO (A.UArray Word8) 31 | getEntropy n@(CountOf x) = do 32 | m <- A.newPinned n 33 | bracket entropyOpen entropyClose $ \ctx -> A.withMutablePtr m $ loop ctx x 34 | A.unsafeFreeze m 35 | where 36 | loop :: EntropyCtx -> Int -> Ptr Word8 -> IO () 37 | loop _ 0 _ = return () 38 | loop ctx i p = do 39 | let chSz = min entropyMaximumSize i 40 | r <- entropyGather ctx p chSz 41 | if r 42 | then loop ctx (i-chSz) (p `plusPtr` chSz) 43 | else throwIO EntropySystemMissing 44 | -------------------------------------------------------------------------------- /foundation/Foundation/System/Entropy/Common.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Foundation.System.Entropy.Common 3 | -- License : BSD-style 4 | -- Maintainer : Vincent Hanquez 5 | -- Stability : experimental 6 | -- Portability : portable 7 | -- 8 | -- Common part for vectors 9 | -- 10 | {-# LANGUAGE DeriveDataTypeable #-} 11 | module Foundation.System.Entropy.Common 12 | ( EntropySystemMissing(..) 13 | ) where 14 | 15 | import Basement.Compat.Base 16 | 17 | data EntropySystemMissing = EntropySystemMissing 18 | deriving (Show,Eq,Typeable) 19 | 20 | instance Exception EntropySystemMissing 21 | -------------------------------------------------------------------------------- /foundation/Foundation/System/Entropy/Unix.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Foundation.System.Entropy.Unix 3 | -- License : BSD-style 4 | -- Maintainer : Vincent Hanquez 5 | -- Stability : experimental 6 | -- Portability : Good 7 | -- 8 | {-# LANGUAGE ScopedTypeVariables #-} 9 | {-# LANGUAGE ForeignFunctionInterface #-} 10 | module Foundation.System.Entropy.Unix 11 | ( EntropyCtx 12 | , entropyOpen 13 | , entropyGather 14 | , entropyClose 15 | , entropyMaximumSize 16 | ) where 17 | 18 | import Foreign.Ptr 19 | import Control.Exception as E 20 | import Control.Monad 21 | import System.IO 22 | import System.IO.Unsafe (unsafePerformIO) 23 | import Basement.Compat.Base 24 | import Basement.Compat.C.Types 25 | import Prelude (fromIntegral) 26 | import Foundation.System.Entropy.Common 27 | import Foundation.Numerical 28 | 29 | data EntropyCtx = 30 | EntropyCtx Handle 31 | | EntropySyscall 32 | 33 | entropyOpen :: IO EntropyCtx 34 | entropyOpen = do 35 | if supportSyscall 36 | then return EntropySyscall 37 | else do 38 | mh <- openDev "/dev/urandom" 39 | case mh of 40 | Nothing -> E.throwIO EntropySystemMissing 41 | Just h -> return $ EntropyCtx h 42 | 43 | -- | try to fill the ptr with the amount of data required. 44 | -- Return the number of bytes, or a negative number otherwise 45 | entropyGather :: EntropyCtx -> Ptr Word8 -> Int -> IO Bool 46 | entropyGather (EntropyCtx h) ptr n = gatherDevEntropy h ptr n 47 | entropyGather EntropySyscall ptr n = (==) 0 <$> c_sysrandom_linux ptr (fromIntegral n) 48 | 49 | entropyClose :: EntropyCtx -> IO () 50 | entropyClose (EntropyCtx h) = hClose h 51 | entropyClose EntropySyscall = return () 52 | 53 | entropyMaximumSize :: Int 54 | entropyMaximumSize = 4096 55 | 56 | openDev :: [Char] -> IO (Maybe Handle) 57 | openDev filepath = (Just `fmap` openAndNoBuffering) `E.catch` \(_ :: IOException) -> return Nothing 58 | where openAndNoBuffering = do 59 | h <- openBinaryFile filepath ReadMode 60 | hSetBuffering h NoBuffering 61 | return h 62 | 63 | gatherDevEntropy :: Handle -> Ptr Word8 -> Int -> IO Bool 64 | gatherDevEntropy h ptr sz = loop ptr sz `E.catch` failOnException 65 | where 66 | loop _ 0 = return True 67 | loop p n = do 68 | r <- hGetBufSome h p n 69 | if r >= 0 70 | then loop (p `plusPtr` r) (n - r) 71 | else return False 72 | failOnException :: E.IOException -> IO Bool 73 | failOnException _ = return False 74 | 75 | supportSyscall :: Bool 76 | supportSyscall = unsafePerformIO ((==) 0 <$> c_sysrandom_linux nullPtr 0) 77 | {-# NOINLINE supportSyscall #-} 78 | 79 | -- return 0 on success, !0 for failure 80 | foreign import ccall unsafe "foundation_sysrandom_linux" 81 | c_sysrandom_linux :: Ptr Word8 -> CSize -> IO Int 82 | -------------------------------------------------------------------------------- /foundation/Foundation/Time/Bindings.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | module Foundation.Time.Bindings 3 | ( measuringNanoSeconds 4 | , getMonotonicTime 5 | ) where 6 | 7 | import Basement.Imports 8 | import Basement.Types.OffsetSize 9 | import Basement.Types.Ptr 10 | import Foundation.System.Bindings.Time 11 | import Foundation.Time.Types 12 | import Foundation.Foreign.Alloc 13 | import Foreign.Storable 14 | 15 | measuringNanoSeconds :: IO a -> IO (a, NanoSeconds) 16 | measuringNanoSeconds f = 17 | allocaBytes (sizeOfCSize size_CTimeSpec) $ \t1 -> 18 | allocaBytes (sizeOfCSize size_CTimeSpec) $ \t2 -> do 19 | _err1 <- sysTimeClockGetTime sysTime_CLOCK_MONOTONIC t1 20 | r <- f 21 | _err2 <- sysTimeClockGetTime sysTime_CLOCK_MONOTONIC t2 22 | return (r, NanoSeconds 0) 23 | 24 | getMonotonicTime :: IO (Seconds, NanoSeconds) 25 | getMonotonicTime = 26 | allocaBytes (sizeOfCSize size_CTimeSpec) $ \tspec -> do 27 | _err1 <- sysTimeClockGetTime sysTime_CLOCK_MONOTONIC tspec 28 | s <- Seconds <$> peek (castPtr (tspec `ptrPlus` ofs_CTimeSpec_Seconds)) 29 | ns <- NanoSeconds <$> peek (castPtr (tspec `ptrPlus` ofs_CTimeSpec_NanoSeconds)) 30 | return (s,ns) 31 | -------------------------------------------------------------------------------- /foundation/Foundation/Time/Types.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Foundation.Timing 3 | -- License : BSD-style 4 | -- Maintainer : Foundation maintainers 5 | -- 6 | -- An implementation of a timing framework 7 | -- 8 | {-# LANGUAGE DataKinds #-} 9 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 10 | module Foundation.Time.Types 11 | ( NanoSeconds(..) 12 | , Seconds(..) 13 | ) where 14 | 15 | import Data.Proxy 16 | import Basement.Imports 17 | import Basement.PrimType 18 | import Foundation.Numerical 19 | import Data.Coerce 20 | 21 | -- | An amount of nanoseconds 22 | newtype NanoSeconds = NanoSeconds Word64 23 | deriving (Show,Eq,Ord,Additive,Enum,Bounded) 24 | 25 | 26 | instance PrimType NanoSeconds where 27 | type PrimSize NanoSeconds = 8 28 | primSizeInBytes _ = primSizeInBytes (Proxy :: Proxy Word64) 29 | primShiftToBytes _ = primShiftToBytes (Proxy :: Proxy Word64) 30 | primBaUIndex ba ofs = primBaUIndex ba (coerce ofs) 31 | primMbaURead mba ofs = primMbaURead mba (coerce ofs) 32 | primMbaUWrite mba ofs v = primMbaUWrite mba (coerce ofs) (coerce v :: Word64) 33 | primAddrIndex addr ofs = primAddrIndex addr (coerce ofs) 34 | primAddrRead addr ofs = primAddrRead addr (coerce ofs) 35 | primAddrWrite addr ofs v = primAddrWrite addr (coerce ofs) (coerce v :: Word64) 36 | 37 | -- | An amount of seconds 38 | newtype Seconds = Seconds Word64 39 | deriving (Show,Eq,Ord,Additive,Enum,Bounded) 40 | 41 | instance PrimType Seconds where 42 | type PrimSize Seconds = 8 43 | primSizeInBytes _ = primSizeInBytes (Proxy :: Proxy Word64) 44 | primShiftToBytes _ = primShiftToBytes (Proxy :: Proxy Word64) 45 | primBaUIndex ba ofs = primBaUIndex ba (coerce ofs) 46 | primMbaURead mba ofs = primMbaURead mba (coerce ofs) 47 | primMbaUWrite mba ofs v = primMbaUWrite mba (coerce ofs) (coerce v :: Word64) 48 | primAddrIndex addr ofs = primAddrIndex addr (coerce ofs) 49 | primAddrRead addr ofs = primAddrRead addr (coerce ofs) 50 | primAddrWrite addr ofs v = primAddrWrite addr (coerce ofs) (coerce v :: Word64) 51 | -------------------------------------------------------------------------------- /foundation/Foundation/Timing/Main.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Foundation.Timing.Main 3 | -- License : BSD-style 4 | -- Maintainer : Foundation maintainers 5 | -- 6 | -- An implementation of a timing framework 7 | -- 8 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 9 | {-# LANGUAGE OverloadedStrings #-} 10 | module Foundation.Timing.Main 11 | ( defaultMain 12 | ) where 13 | 14 | import Basement.Imports 15 | import Foundation.IO.Terminal 16 | import Foundation.Collection 17 | 18 | data MainConfig = MainConfig 19 | { mainHelp :: Bool 20 | , mainListBenchs :: Bool 21 | , mainVerbose :: Bool 22 | , mainOther :: [String] 23 | } 24 | 25 | newtype TimingPlan a = TimingPlan { runTimingPlan :: IO a } 26 | deriving (Functor, Applicative, Monad) 27 | 28 | defaultMainConfig :: MainConfig 29 | defaultMainConfig = MainConfig 30 | { mainHelp = False 31 | , mainListBenchs = False 32 | , mainVerbose = False 33 | , mainOther = [] 34 | } 35 | 36 | parseArgs :: [String] -> MainConfig -> Either String MainConfig 37 | parseArgs [] cfg = Right cfg 38 | parseArgs ("--list-benchs":xs) cfg = parseArgs xs $ cfg { mainListBenchs = True } 39 | parseArgs ("--verbose":xs) cfg = parseArgs xs $ cfg { mainVerbose = True } 40 | parseArgs ("--help":xs) cfg = parseArgs xs $ cfg { mainHelp = True } 41 | parseArgs (x:xs) cfg = parseArgs xs $ cfg { mainOther = x : mainOther cfg } 42 | 43 | configHelp :: [String] 44 | configHelp = [] 45 | 46 | defaultMain :: TimingPlan () -> IO () 47 | defaultMain tp = do 48 | ecfg <- flip parseArgs defaultMainConfig <$> getArgs 49 | cfg <- case ecfg of 50 | Left e -> do 51 | putStrLn e 52 | mapM_ putStrLn configHelp 53 | exitFailure 54 | Right c -> pure c 55 | 56 | when (mainHelp cfg) (mapM_ putStrLn configHelp >> exitSuccess) 57 | when (mainListBenchs cfg) (printAll >> exitSuccess) 58 | 59 | runTimingPlan tp 60 | 61 | return () 62 | where 63 | printAll = undefined 64 | -------------------------------------------------------------------------------- /foundation/Foundation/VFS.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Foundation.VFS 3 | -- License : BSD-style 4 | -- Maintainer : foundation 5 | -- Stability : experimental 6 | -- Portability : portable 7 | -- 8 | module Foundation.VFS 9 | ( Path(..) 10 | , filename 11 | , parent 12 | , prefix 13 | , suffix 14 | 15 | -- * FilePath 16 | , FilePath 17 | , FileName 18 | -- ** conversion 19 | , filePathToString 20 | , filePathToLString 21 | ) where 22 | 23 | 24 | import Foundation.VFS.Path 25 | ( Path(..) 26 | , filename, parent, suffix, prefix 27 | ) 28 | import Foundation.VFS.FilePath 29 | ( FilePath, FileName 30 | , filePathToString 31 | , filePathToLString 32 | ) 33 | -------------------------------------------------------------------------------- /foundation/Foundation/VFS/URI.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Foundation.VFS.URI 3 | -- License : BSD-style 4 | -- Maintainer : foundation 5 | -- Stability : experimental 6 | -- Portability : portable 7 | -- 8 | 9 | module Foundation.VFS.URI 10 | ( URI(..) 11 | , URISchema(..) 12 | , URIAuthority(..) 13 | , URIQuery(..) 14 | , URIFragment(..) 15 | , URIPath(..) 16 | ) where 17 | 18 | import Basement.Compat.Base 19 | import Foundation.VFS.Path(Path(..)) 20 | 21 | -- ------------------------------------------------------------------------- -- 22 | -- URI -- 23 | -- ------------------------------------------------------------------------- -- 24 | 25 | -- | TODO this is not implemented yet 26 | data URI = URI 27 | data URISchema = URISchema 28 | data URIAuthority = URIAuthority 29 | data URIQuery = URIQuery 30 | data URIFragment = URIFragment 31 | data URIPath = URIPath 32 | instance Path URI where 33 | type PathEnt URI = URIPath 34 | type PathPrefix URI = (URISchema, URIAuthority) 35 | type PathSuffix URI = (URIQuery, URIFragment) 36 | () = undefined 37 | splitPath = undefined 38 | buildPath = undefined 39 | -------------------------------------------------------------------------------- /foundation/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2015-2017 Vincent Hanquez 2 | Copyright (c) 2017-2019 Foundation Maintainers 3 | 4 | All rights reserved. 5 | 6 | Redistribution and use in source and binary forms, with or without 7 | modification, are permitted provided that the following conditions 8 | are met: 9 | 1. Redistributions of source code must retain the above copyright 10 | notice, this list of conditions and the following disclaimer. 11 | 2. Redistributions in binary form must reproduce the above copyright 12 | notice, this list of conditions and the following disclaimer in the 13 | documentation and/or other materials provided with the distribution. 14 | 3. Neither the name of the author nor the names of his contributors 15 | may be used to endorse or promote products derived from this software 16 | without specific prior written permission. 17 | 18 | THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS AS IS'' AND 19 | ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 20 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 21 | ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE 22 | FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 23 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 24 | OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 25 | HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 26 | LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY 27 | OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF 28 | SUCH DAMAGE. 29 | -------------------------------------------------------------------------------- /foundation/benchs/Array.hs: -------------------------------------------------------------------------------- 1 | module Main (main) where 2 | 3 | import Foundation 4 | import Foundation.Random 5 | import Foundation.Collection as F 6 | import Gauge.Main 7 | import qualified Prelude as P 8 | 9 | main = do 10 | rndInput <- getRandomBytes (CountOf n) 11 | defaultMain [ bgroup "Uarray" 12 | [ bench "fromList [Word8]" $ whnf (fromList :: [Word8] -> UArray Word8) [1..255] 13 | , bench "fromList [Word16]" $ whnf (fromList :: [Word16] -> UArray Word16) [1..1024] 14 | , bench "break" $ whnf (F.break (== 255)) input 15 | , bench "sort random" $ whnf sort rndInput 16 | , bench "sort sorted" $ whnf sort (sort rndInput) 17 | , bench "sort reverse" $ whnf sort (reverse.sort $ rndInput) 18 | , bench "sort cyclic" $ whnf sort inputLong 19 | ] 20 | ] 21 | where 22 | n = 100000 23 | input, inputLong :: UArray Word8 24 | input = fromList ([1..255] <> [1..255]) 25 | inputLong = fromList . P.take n . P.cycle $ [1..255] 26 | 27 | sort = F.sortBy compare 28 | -------------------------------------------------------------------------------- /foundation/benchs/BenchUtil/Common.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE NoImplicitPrelude #-} 3 | module BenchUtil.Common 4 | ( defaultMain 5 | , Benchmark 6 | , Benchmarkable 7 | , bgroup 8 | , bench 9 | , fbench 10 | , whnf 11 | , whnfIO 12 | , nf 13 | ) where 14 | 15 | import Gauge.Main hiding (bgroup, bench) 16 | import qualified Gauge.Main as C 17 | import Foundation 18 | 19 | fbench = bench "foundation" 20 | 21 | bgroup :: String -> [Benchmark] -> Benchmark 22 | bgroup n f = C.bgroup (toList n) f 23 | 24 | bench :: String -> Benchmarkable -> Benchmark 25 | bench n f = C.bench (toList n) f 26 | -------------------------------------------------------------------------------- /foundation/benchs/Break.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module Main where 3 | 4 | import qualified Foundation as F 5 | import qualified Foundation.Collection as F 6 | import qualified Foundation.String as F 7 | import Gauge.Main 8 | 9 | s :: F.String 10 | s = "Sed ut perspiciatis, unde omnis iste natus error sit voluptatem accusantium doloremque laudantium, totam rem aperiam eaque ipsa, quae ab illo inventore veritatis et quasi architecto beatae vitae dicta sunt, explicabo. Nemo enim ipsam voluptatem, quia voluptas sit, aspernatur aut odit aut fugit, sed quia consequuntur magni dolores eos, qui ratione voluptatem sequi nesciunt, neque porro quisquam est, qui dolorem ipsum, quia dolor sit amet consectetur adipisci[ng] velit, sed quia non numquam [do] eius modi tempora inci[di]dunt, ut labore et dolore magnam aliquam quaerat voluptatem. Ut enim ad minima veniam, quis nostrum exercitationem ullam corporis suscipit laboriosam, nisi ut aliquid ex ea commodi consequatur? Quis autem vel eum iure reprehenderit, qui in ea voluptate velit esse, quam nihil molestiae consequatur, vel illum, qui dolorem eum fugiat, quo voluptas nulla pariatur?" 11 | 12 | c :: Char 13 | c = '?' 14 | 15 | cAscii :: F.Word8 16 | cAscii = fromIntegral $ fromEnum c 17 | 18 | main = defaultMain 19 | [ bgroup "break" 20 | [ bench "string" $ whnf (fst . F.breakElem c) s 21 | , bench "uvec" $ whnf (fst . F.breakElem cAscii) (F.toBytes F.UTF8 s) 22 | ] 23 | ] 24 | -------------------------------------------------------------------------------- /foundation/benchs/Buildable.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeFamilies #-} 2 | module Main (main) where 3 | 4 | import Gauge.Main 5 | import Foundation 6 | import qualified Foundation.Collection as C 7 | import GHC.ST 8 | import qualified Prelude 9 | 10 | main :: IO () 11 | main = defaultMain 12 | [ bgroup "String" $ 13 | benches (Proxy :: Proxy ([Char] -> String)) 'a' '€' <$> [100000, 1000000, 10000000] 14 | , bgroup "UArray Word32" $ 15 | benches (Proxy :: Proxy ([Word32] -> UArray Word32)) 1 128 <$> [100000, 1000000, 10000000] 16 | , bgroup "Array Integer" $ 17 | benches (Proxy :: Proxy ([Integer] -> Array Integer)) 1 128 <$> [100000, 1000000, 10000000] 18 | ] 19 | where 20 | input n e = C.take n (Prelude.repeat e) 21 | 22 | builder es = runST $ C.build 65536 $ Prelude.mapM_ C.append es 23 | 24 | benches proxy e toE n = bgroup (show n) $ 25 | let !chars = input n e 26 | in [ bench "Buildable" $ whnf ( (builder . fmap (const toE)) `asProxyTypeOf` proxy ) chars 27 | , bench "fromList" $ whnf ( (fromList . fmap (const toE)) `asProxyTypeOf` proxy ) chars 28 | ] 29 | -------------------------------------------------------------------------------- /foundation/benchs/Fake/ByteString.hs: -------------------------------------------------------------------------------- 1 | module Fake.ByteString 2 | ( ByteString 3 | , pack 4 | , length 5 | , splitAt 6 | , take 7 | , takeWhile 8 | , break 9 | , reverse 10 | , filter 11 | , foldl' 12 | , foldl1' 13 | , foldr 14 | , and 15 | , all 16 | , any 17 | , readInt 18 | , readInteger 19 | , unpack 20 | , concat 21 | ) where 22 | 23 | import Prelude (undefined, Maybe(..)) 24 | import Data.Word 25 | 26 | data ByteString = ByteString 27 | 28 | pack _ = ByteString 29 | length = undefined 30 | splitAt _ _ = (undefined, undefined) 31 | take = undefined 32 | break _ _ = (undefined, undefined) 33 | takeWhile _ _ = undefined 34 | reverse = undefined 35 | filter _ = undefined 36 | foldl' :: (Word8 -> a -> a) -> a -> ByteString -> a 37 | foldl' _ _ _ = undefined 38 | foldl1' :: (Word8 -> Word8 -> Word8) -> ByteString -> a 39 | foldl1' _ _ = undefined 40 | foldr :: (a -> Word8 -> a) -> a -> ByteString -> a 41 | foldr _ _ _ = undefined 42 | and _ _ = undefined 43 | all _ _ = undefined 44 | any _ _ = undefined 45 | concat :: [ByteString] -> ByteString 46 | concat _ = undefined 47 | unpack :: ByteString -> [Word8] 48 | unpack = undefined 49 | 50 | readInt :: ByteString -> Maybe (a,b) 51 | readInt _ = undefined 52 | readInteger :: ByteString -> Maybe (a,b) 53 | readInteger _ = undefined 54 | -------------------------------------------------------------------------------- /foundation/benchs/Fake/Text.hs: -------------------------------------------------------------------------------- 1 | module Fake.Text 2 | ( Text 3 | , pack 4 | , unpack 5 | , length 6 | , splitAt 7 | , take 8 | , any 9 | , filter 10 | , reverse 11 | , decimal 12 | , double 13 | , decodeUtf8 14 | , toLower 15 | , toUpper 16 | ) where 17 | 18 | import Prelude (undefined, Either(..), Char) 19 | 20 | data Text = Text 21 | 22 | pack _ = Text 23 | unpack :: Text -> [Char] 24 | unpack _ = undefined 25 | length = undefined 26 | splitAt _ _ = (undefined, undefined) 27 | take = undefined 28 | filter _ = undefined 29 | reverse = undefined 30 | any = undefined 31 | decodeUtf8 = undefined 32 | toLower = undefined 33 | toUpper = undefined 34 | 35 | decimal :: Text -> Either a (b, c) 36 | decimal = undefined 37 | 38 | double :: Text -> Either a (b, c) 39 | double = undefined 40 | -------------------------------------------------------------------------------- /foundation/benchs/Fake/Vector.hs: -------------------------------------------------------------------------------- 1 | module Fake.Vector 2 | ( Vector 3 | , fromList 4 | , toList 5 | , length 6 | , splitAt 7 | , take 8 | , takeWhile 9 | , break 10 | , reverse 11 | , filter 12 | , foldl' 13 | , foldl1' 14 | , foldr 15 | , and 16 | , all 17 | , any 18 | , concat 19 | ) where 20 | 21 | import Prelude (undefined) 22 | 23 | data Vector ty = Vector 24 | 25 | fromList _ = Vector 26 | toList :: Vector ty -> [ty] 27 | toList _ = undefined 28 | length = undefined 29 | splitAt _ _ = (undefined, undefined) 30 | take = undefined 31 | break _ _ = (undefined, undefined) 32 | takeWhile _ _ = undefined 33 | reverse = undefined 34 | filter _ = undefined 35 | foldl' :: (ty -> a -> a) -> a -> Vector ty -> a 36 | foldl' _ _ _ = undefined 37 | foldl1' :: (ty -> ty -> ty) -> Vector ty -> a 38 | foldl1' _ _ = undefined 39 | foldr :: (a -> ty -> a) -> a -> Vector ty -> a 40 | foldr _ _ _ = undefined 41 | and _ _ = undefined 42 | all _ _ = undefined 43 | any _ _ = undefined 44 | concat = undefined 45 | -------------------------------------------------------------------------------- /foundation/benchs/LargeWords.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | {-# LANGUAGE RebindableSyntax #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | {-# LANGUAGE TypeApplications #-} 5 | module LargeWords where 6 | 7 | import Foundation 8 | import Basement.From 9 | import Basement.Types.Word128 (Word128) 10 | import Basement.Types.Word256 (Word256) 11 | import qualified Basement.Types.Word128 as Word128 12 | import qualified Basement.Types.Word256 as Word256 13 | import BenchUtil.Common 14 | 15 | largeNumber64 :: Natural 16 | largeNumber64 = 0xffffffffffffffff 17 | 18 | largeNumber128 :: Natural 19 | largeNumber128 = 0xfffffffffffffffffffffffffffffff 20 | 21 | largeNumber256 :: Natural 22 | largeNumber256 = 0xffffffffffffffffffffffffffffffffffffffffffffffff 23 | 24 | benchLargeWords = 25 | [ bgroup "Addition" 26 | [ bgroup "Word128" 27 | [ bench "Word128" $ whnf (+ 1240) (Word128.fromNatural largeNumber128) 28 | , bench "Natural" $ whnf (+ 1240) largeNumber128 29 | ] 30 | , bgroup "Word256" 31 | [ bench "Word256" $ whnf (+ 200) (Word256.fromNatural largeNumber256) 32 | , bench "Natural" $ whnf (+ 200) largeNumber256 33 | ] 34 | ] 35 | , bgroup "Multiplication" 36 | [ bgroup "Word128" 37 | [ bench "Word128" $ whnf (* 1240) (Word128.fromNatural largeNumber128) 38 | , bench "Natural" $ whnf (* 1240) largeNumber128 39 | ] 40 | , bgroup "Word256" 41 | [ bench "Word256" $ whnf (* 200) (Word256.fromNatural largeNumber256) 42 | , bench "Natural" $ whnf (* 200) largeNumber256 43 | ] 44 | ] 45 | ] 46 | -------------------------------------------------------------------------------- /foundation/benchs/SplitAt.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module Main where 3 | 4 | import qualified Foundation as F 5 | import qualified Foundation.Collection as F 6 | import qualified Foundation.String as F 7 | import Gauge.Main 8 | 9 | s :: F.String 10 | s = "Sed ut perspiciatis, unde omnis iste natus error sit voluptatem accusantium doloremque laudantium, totam rem aperiam eaque ipsa, quae ab illo inventore veritatis et quasi architecto beatae vitae dicta sunt, explicabo. Nemo enim ipsam voluptatem, quia voluptas sit, aspernatur aut odit aut fugit, sed quia consequuntur magni dolores eos, qui ratione voluptatem sequi nesciunt, neque porro quisquam est, qui dolorem ipsum, quia dolor sit amet consectetur adipisci[ng] velit, sed quia non numquam [do] eius modi tempora inci[di]dunt, ut labore et dolore magnam aliquam quaerat voluptatem. Ut enim ad minima veniam, quis nostrum exercitationem ullam corporis suscipit laboriosam, nisi ut aliquid ex ea commodi consequatur? Quis autem vel eum iure reprehenderit, qui in ea voluptate velit esse, quam nihil molestiae consequatur, vel illum, qui dolorem eum fugiat, quo voluptas nulla pariatur?" 11 | 12 | c :: Char 13 | c = '?' 14 | 15 | l :: Int 16 | l = F.length s - 1 17 | 18 | cAscii :: F.Word8 19 | cAscii = fromIntegral $ fromEnum c 20 | 21 | main = defaultMain 22 | [ bgroup "splitAt" [ bgroup "String" 23 | [ bench "splitAt 10" $ whnf (F.splitAt 10) s 24 | , bench "splitAt 100" $ whnf (F.splitAt 100) s 25 | , bench ("splitAt " ++ show l) $ whnf (F.splitAt l) s 26 | ] 27 | ]] 28 | -------------------------------------------------------------------------------- /foundation/benchs/Sys.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | {-# LANGUAGE RebindableSyntax #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | module Sys ( benchSys ) where 5 | 6 | import Foundation 7 | import Foundation.Collection 8 | import BenchUtil.Common 9 | import BenchUtil.RefData 10 | 11 | import Foundation.System.Entropy 12 | import Foundation.Random 13 | 14 | import qualified Prelude 15 | 16 | data NullRandom = NullRandom 17 | 18 | instance RandomGen NullRandom where 19 | randomNew = return NullRandom 20 | randomNewFrom = error "no randomNewFrom" 21 | randomGenerate (CountOf n) r = (fromList (Prelude.replicate n 0), r) 22 | randomGenerateWord64 r = (0, r) 23 | randomGenerateF32 r = (0.0, r) 24 | randomGenerateF64 r = (0.0, r) 25 | 26 | benchSys = 27 | [ bgroup "Random" 28 | [ bench "Entropy-1" $ whnfIO $ getEntropy 1 29 | , bench "Entropy-16" $ whnfIO $ getEntropy 16 30 | , bench "Entropy-1024" $ whnfIO $ getEntropy 1024 31 | ] 32 | , bgroup "RNGv1" 33 | [ bench "Entropy-1" $ benchRandom 1 randomNew (Proxy :: Proxy RNGv1) 34 | , bench "Entropy-1024" $ benchRandom 1024 randomNew (Proxy :: Proxy RNGv1) 35 | , bench "Entropy-1M" $ benchRandom (CountOf (1024 * 1024)) randomNew (Proxy :: Proxy RNGv1) 36 | ] 37 | ] 38 | 39 | benchRandom :: RandomGen rng => CountOf Word8 -> MonadRandomState NullRandom rng -> Proxy rng -> Benchmarkable 40 | benchRandom n rNew _ = whnf (fst . randomGenerate n) (fst $ withRandomGenerator NullRandom rNew) 41 | -------------------------------------------------------------------------------- /foundation/benchs/ToForeign.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -O2 -Wall #-} 2 | {-# LANGUAGE BangPatterns, OverloadedStrings #-} 3 | 4 | import qualified Data.ByteString.Char8 as BS 5 | import Gauge.Main 6 | import Data.ByteString (ByteString, unpack) 7 | import Data.ByteString.Internal (toForeignPtr, unsafeCreate, memcpy) 8 | import qualified Foundation as F 9 | import Foundation.Array 10 | import Foundation.Array.Internal (withPtr, fromForeignPtr, copyToPtr) 11 | import qualified Basement.Block as BLK 12 | 13 | fromByteString :: ByteString -> F.UArray F.Word8 14 | fromByteString = fromForeignPtr . toForeignPtr 15 | 16 | fromByteString2 :: ByteString -> F.UArray F.Word8 17 | fromByteString2 = fromForeignPtr . toForeignPtr 18 | 19 | 20 | toByteString :: F.UArray F.Word8 -> ByteString 21 | toByteString v = unsafeCreate len $ \dst -> withPtr v $ \src -> memcpy dst src len 22 | where !len = F.length v 23 | 24 | toByteString2 :: F.UArray F.Word8 -> ByteString 25 | toByteString2 v = unsafeCreate len $ copyToPtr v 26 | where !len = F.length v 27 | 28 | toByteStringBlock :: BLK.Block F.Word8 -> ByteString 29 | toByteStringBlock blk = unsafeCreate len $ BLK.unsafeCopyToPtr blk 30 | where !len = BLK.length blk 31 | 32 | bs = "foundation is the future" :: BS.ByteString 33 | str = fromByteString bs :: UArray F.Word8 34 | str2 = F.fromList (unpack bs) :: UArray F.Word8 35 | 36 | blk = BLK.fromList (unpack bs) :: BLK.Block F.Word8 37 | 38 | main = defaultMain 39 | [ bench "toByteString-copyPtr" $ whnf toByteString2 str 40 | , bench "toByteString-withPtr" $ whnf toByteString str 41 | , bench "toByteString-native-copyPtr" $ whnf toByteString2 str2 42 | , bench "toByteString-native-withPtr" $ whnf toByteString str2 43 | , bench "toByteString-block-copyPtr" $ whnf toByteStringBlock blk 44 | , bench "BS.copy" $ whnf BS.copy bs 45 | ] 46 | 47 | -------------------------------------------------------------------------------- /foundation/benchs/compare-libs/ByteString.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import BenchUtil.Common 4 | 5 | import qualified Foundation as F 6 | import qualified Foundation.Collection as F 7 | 8 | import qualified Data.ByteString as B 9 | 10 | dat = [0..255] 11 | 12 | abench = bench "bytestring" 13 | 14 | main = defaultMain 15 | [ bgroup "break" 16 | [ bgroup "#word8-start" 17 | [ fbench $ whnf (fst . F.breakElem 0) (F.fromList dat :: F.UArray F.Word8) 18 | , abench $ nf (fst . B.break (== 0)) (B.pack dat) 19 | ] 20 | , bgroup "#word8-middle" 21 | [ fbench $ whnf (fst . F.breakElem 120) (F.fromList dat :: F.UArray F.Word8) 22 | , abench $ nf (fst . B.break (== 120)) (B.pack dat) 23 | ] 24 | , bgroup "#word8-end" 25 | [ fbench $ whnf (fst . F.breakElem 255) (F.fromList dat :: F.UArray F.Word8) 26 | , abench $ nf (fst . B.break (== 255)) (B.pack dat) 27 | ] 28 | {- 29 | , bgroup "#japanese" 30 | [ bench "foundation" $ whnf (fst . F.breakElem '帝') (F.fromList textJapanese :: F.String) 31 | , bench "text" $ whnf (fst . T.break (== '帝')) (T.pack textJapanese) 32 | ] 33 | -} 34 | ] 35 | ] 36 | -------------------------------------------------------------------------------- /foundation/benchs/compare-libs/Text.hs: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env stack -- stack --install-ghc --resolver lts-5.13 runghc --package text --package foundation 2 | module Main where 3 | 4 | import qualified Foundation as F 5 | import qualified Foundation.Collection as F 6 | import Criterion.Main 7 | 8 | import qualified Data.Text as T 9 | 10 | textEnglish = "Set in the year 0 F.E. (\"Foundation Era\"), The Psychohistorians opens on Trantor, the capital of the 12,000-year-old Galactic Empire. Though the empire appears stable and powerful, it is slowly decaying in ways that parallel the decline of the Western Roman Empire. Hari Seldon, a mathematician and psychologist, has developed psychohistory, a new field of science and psychology that equates all possibilities in large societies to mathematics, allowing for the prediction of future events." 11 | 12 | textJapanese = "数学者ハリ・セルダンは、膨大な集団の行動を予測する心理歴史学を作りあげ発展させることで、銀河帝国が近いうちに崩壊することを予言する[1]。セルダンは、帝国崩壊後に3万年続くはずの暗黒時代を、あらゆる知識を保存することで千年に縮めようとし、知識の集大成となる銀河百科事典 (Encyclopedia Galactica) を編纂するグループ「ファウンデーション」をつくったが、帝国崩壊を公言し平和を乱したという罪で裁判にかけられ、グループは銀河系辺縁部にある資源の乏しい無人惑星ターミナスへ追放されることになった。しかし、この追放劇すらもセルダンの計画に予定されていた事柄であった。病で死期をさとっていたセルダンは、己の仕事が終わったことを確信する。" 13 | 14 | main = defaultMain 15 | [ bgroup "break" 16 | [ bgroup "#english-start" 17 | [ bench "foundation" $ whnf (fst . F.breakElem 'S') (F.fromList textEnglish :: F.String) 18 | , bench "text" $ nf (fst . T.break (== 'S')) (T.pack textEnglish) 19 | ] 20 | , bgroup "#english-middle" 21 | [ bench "foundation" $ whnf (fst . F.breakElem '2') (F.fromList textEnglish :: F.String) 22 | , bench "text" $ nf (fst . T.break (== '2')) (T.pack textEnglish) 23 | ] 24 | , bgroup "#english-notfound" 25 | [ bench "foundation" $ whnf (fst . F.breakElem 'z') (F.fromList textEnglish :: F.String) 26 | , bench "text" $ nf (fst . T.break (== 'z')) (T.pack textEnglish) 27 | ] 28 | {- 29 | , bgroup "#japanese" 30 | [ bench "foundation" $ whnf (fst . F.breakElem '帝') (F.fromList textJapanese :: F.String) 31 | , bench "text" $ whnf (fst . T.break (== '帝')) (T.pack textJapanese) 32 | ] 33 | -} 34 | ] 35 | ] 36 | -------------------------------------------------------------------------------- /foundation/benchs/compare-libs/Vector32.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import BenchUtil.Common 4 | 5 | import qualified Foundation as F 6 | import qualified Foundation.Collection as F 7 | 8 | import qualified Data.Vector.Unboxed as V 9 | 10 | dat = [0..255] 11 | 12 | fdat :: F.UArray F.Word32 13 | fdat = F.fromList dat 14 | 15 | vdat :: V.Vector F.Word32 16 | vdat = V.fromList dat 17 | 18 | abench = bench "vector-unboxed" 19 | 20 | main = defaultMain 21 | [ bgroup "break" 22 | [ bgroup "#word32-start" 23 | [ fbench $ whnf (fst . F.breakElem 0) fdat 24 | , abench $ nf (fst . V.break (== 0)) vdat 25 | ] 26 | , bgroup "#word32-middle" 27 | [ fbench $ whnf (fst . F.breakElem 120) fdat 28 | , abench $ nf (fst . V.break (== 120)) vdat 29 | ] 30 | , bgroup "#word32-end" 31 | [ fbench $ whnf (fst . F.breakElem 255) fdat 32 | , abench $ nf (fst . V.break (== 255)) vdat 33 | ] 34 | {- 35 | , bgroup "#japanese" 36 | [ bench "foundation" $ whnf (fst . F.breakElem '帝') (F.fromList textJapanese :: F.String) 37 | , bench "text" $ whnf (fst . T.break (== '帝')) (T.pack textJapanese) 38 | ] 39 | -} 40 | ] 41 | ] 42 | -------------------------------------------------------------------------------- /foundation/benchs/compare-libs/Vector8.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import BenchUtil.Common 4 | 5 | 6 | import qualified Foundation as F 7 | import qualified Foundation.Collection as F 8 | 9 | import qualified Data.Vector.Unboxed as V 10 | 11 | dat = [0..255] 12 | 13 | fdat :: F.UArray F.Word8 14 | fdat = F.fromList dat 15 | 16 | vdat :: V.Vector F.Word8 17 | vdat = V.fromList dat 18 | 19 | abench = bench "vector-unboxed" 20 | 21 | main = defaultMain 22 | [ bgroup "break" 23 | [ bgroup "#word8-start" 24 | [ fbench $ whnf (fst . F.breakElem 0) fdat 25 | , abench $ nf (fst . V.break (== 0)) vdat 26 | ] 27 | , bgroup "#word8-middle" 28 | [ fbench $ whnf (fst . F.breakElem 120) fdat 29 | , abench $ nf (fst . V.break (== 120)) vdat 30 | ] 31 | , bgroup "#word8-end" 32 | [ fbench $ whnf (fst . F.breakElem 255) fdat 33 | , abench $ nf (fst . V.break (== 255)) vdat 34 | ] 35 | {- 36 | , bgroup "#japanese" 37 | [ bench "foundation" $ whnf (fst . F.breakElem '帝') (F.fromList textJapanese :: F.String) 38 | , bench "text" $ whnf (fst . T.break (== '帝')) (T.pack textJapanese) 39 | ] 40 | -} 41 | ] 42 | ] 43 | -------------------------------------------------------------------------------- /foundation/cbits/foundation_network.c: -------------------------------------------------------------------------------- 1 | #include "foundation_system.h" 2 | 3 | #if defined(FOUNDATION_SYSTEM_WINDOWS) 4 | # include 5 | #else 6 | # include "netdb.h" 7 | #endif 8 | 9 | 10 | int foundation_network_get_h_errno(void) 11 | { 12 | #if defined(FOUNDATION_SYSTEM_WINDOWS) 13 | return WSAGetLastError(); 14 | #else 15 | return h_errno; 16 | #endif 17 | } 18 | -------------------------------------------------------------------------------- /foundation/cbits/foundation_prim.h: -------------------------------------------------------------------------------- 1 | #ifndef FOUNDATION_PRIM_H 2 | #define FOUNDATION_PRIM_H 3 | #include "Rts.h" 4 | 5 | typedef StgInt FsOffset; 6 | typedef StgInt FsCountOf; 7 | 8 | #endif 9 | -------------------------------------------------------------------------------- /foundation/cbits/foundation_system.h: -------------------------------------------------------------------------------- 1 | #ifndef FOUNDATION_SYSTEM_H 2 | # define FOUNDATION_SYSTEM_H 3 | 4 | #ifdef _WIN32 5 | #define FOUNDATION_SYSTEM_WINDOWS 6 | #define FOUNDATION_SYSTEM_API_NO_CLOCK 7 | 8 | //define something for Windows (32-bit and 64-bit, this part is common) 9 | #ifdef _WIN64 10 | #define FOUNDATION_SYSTEM_WINDOWS_64 11 | //define something for Windows (64-bit only) 12 | #else 13 | #define FOUNDATION_SYSTEM_WINDOWS_32 14 | //define something for Windows (32-bit only) 15 | #endif 16 | #elif __APPLE__ 17 | #include "TargetConditionals.h" 18 | #include "Availability.h" 19 | 20 | #if TARGET_OS_MAC 21 | #define FOUNDATION_SYSTEM_UNIX 22 | #define FOUNDATION_SYSTEM_MACOS 23 | 24 | #if !defined(__MAC_10_12) || __MAC_OS_X_VERSION_MIN_REQUIRED < __MAC_10_12 25 | #define FOUNDATION_SYSTEM_API_NO_CLOCK 26 | #endif 27 | // Other kinds of Mac OS 28 | #else 29 | # error "foundation: system: Unknown Apple platform" 30 | #endif 31 | #elif __linux__ 32 | #define FOUNDATION_SYSTEM_UNIX 33 | #define FOUNDATION_SYSTEM_LINUX 34 | // linux 35 | #elif defined(__FreeBSD__) 36 | #define FOUNDATION_SYSTEM_UNIX 37 | #define FOUNDATION_SYSTEM_BSD 38 | #define FOUNDATION_SYSTEM_FREEBSD 39 | // freeBSD 40 | #elif defined(__NetBSD__) 41 | #define FOUNDATION_SYSTEM_UNIX 42 | #define FOUNDATION_SYSTEM_BSD 43 | #define FOUNDATION_SYSTEM_NETBSD 44 | // NetBSD 45 | #elif defined(__OpenBSD__) 46 | #define FOUNDATION_SYSTEM_UNIX 47 | #define FOUNDATION_SYSTEM_BSD 48 | #define FOUNDATION_SYSTEM_OPENBSD 49 | // OpenBSD 50 | #elif __unix__ // all unices not caught above 51 | #define FOUNDATION_SYSTEM_UNIX 52 | // Unix 53 | #elif defined(_POSIX_VERSION) 54 | #define FOUNDATION_SYSTEM_UNIX 55 | // POSIX 56 | #else 57 | # error "foundation: system: Unknown compiler" 58 | #endif 59 | 60 | #endif 61 | -------------------------------------------------------------------------------- /foundation/cbits/foundation_utf8.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include "foundation_prim.h" 4 | 5 | #if 0 6 | static const uint64_t utf8_mask_80 = 0x8080808080808080ULL; 7 | static const uint64_t utf8_mask_40 = 0x4040404040404040ULL; 8 | 9 | typedef unsigned long pu; 10 | #define POPCOUNT(x) __builtin_popcountl(x) 11 | #define ALIGNED8(p) ((((uintptr_t) (p)) & (sizeof(pu)-1)) == 0) 12 | 13 | FsCountOf foundation_utf8_length(uint8_t *p8, const FsOffset start_offset, const FsOffset end_offset) 14 | { 15 | const uint8_t *end = p8 + end_offset; 16 | FsCountOf n = 0; 17 | 18 | p8 += start_offset; 19 | 20 | while (!ALIGNED8(p8) && p8 < end) { 21 | if ((*p8++ & 0xc0) != 0x80) { n++; } 22 | } 23 | 24 | /* process 8 bytes */ 25 | for (; (p8 + sizeof(pu)) <= end; p8 += sizeof(pu)) { 26 | pu h = *((pu *) p8); 27 | pu h80 = h & utf8_mask_80; 28 | 29 | /* only ASCII */ 30 | if (h80 == 0) { 31 | n += sizeof(pu); 32 | continue; 33 | } 34 | 35 | int nb_ascii = (h80 == utf8_mask_80) ? 0 : (8 - __builtin_popcountl(h80)); 36 | int nb_high = __builtin_popcountl( h & (h80 >> 1)); 37 | n += nb_ascii + nb_high; 38 | } 39 | 40 | while (p8 < end) { 41 | if ((*p8++ & 0xc0) != 0x80) { n++; } 42 | } 43 | 44 | return n; 45 | } 46 | 47 | #define IS_CONT(x) ((x & 0xc0) == 0x80) 48 | 49 | int foundation_utf8_validate(const uint8_t *c, size_t offset, size_t end) 50 | { 51 | while (offset < end) { 52 | uint8_t h = c[offset]; 53 | if (!(h & 0x80)) { 54 | offset++; 55 | continue; 56 | } 57 | 58 | /* continuation */ 59 | if (h < 0xC0) { goto fail1; } 60 | /* 2 bytes */ 61 | else if (h < 0xE0) { if (offset + 1 >= end) { goto fail2; } 62 | else if (IS_CONT(c[offset+1])) { offset += 2; } 63 | else { goto fail1; } 64 | } 65 | /* 3 bytes */ 66 | else if (h < 0xF0) { if (offset + 2 >= end) { goto fail2; } 67 | else if (IS_CONT(c[offset+1]) && IS_CONT(c[offset+2])) { offset += 3; } 68 | else { goto fail1; } 69 | } 70 | 71 | /* 4 bytes */ 72 | else if (h < 0xFE) { if (offset + 3 >= end) { goto fail2; } 73 | else if (IS_CONT(c[offset+1]) && IS_CONT(c[offset+2]) && IS_CONT(c[offset+3])) { offset += 4; } 74 | else { goto fail1; } 75 | } 76 | /* invalid > 4 bytes */ 77 | else { goto fail1; } 78 | } 79 | return 0; 80 | fail1: 81 | return 1; 82 | fail2: 83 | return 2; 84 | } 85 | #endif 86 | -------------------------------------------------------------------------------- /foundation/tests/DocTest.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Test.DocTest 4 | import Prelude 5 | 6 | main :: IO () 7 | main = doctest (extensions ++ flags ++ files) 8 | 9 | extensions :: [String] 10 | extensions = 11 | [ "-XBangPatterns" 12 | , "-XDeriveDataTypeable" 13 | , "-XNoImplicitPrelude" 14 | , "-XRebindableSyntax" 15 | , "-XOverloadedStrings" 16 | , "-XTypeFamilies" 17 | ] 18 | 19 | flags :: [String] 20 | flags = ["-fobject-code"] 21 | 22 | -- Would be nice to just use "src" here, but both Basement.String and 23 | -- Foundation.String.UTF8LL share the same module name, and doctest breaks. 24 | files :: [String] 25 | files = 26 | [ "Foundation/Collection/Buildable.hs" 27 | , "Foundation/VFS/FilePath.hs" 28 | , "Foundation/VFS/Path.hs" 29 | ] 30 | -------------------------------------------------------------------------------- /foundation/tests/Imports.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE CPP #-} 4 | module Imports 5 | ( diffList 6 | ) where 7 | 8 | import Foundation 9 | 10 | diffList :: (Eq a, Show a) => [a] -> [a] -> String 11 | diffList a b = "left : " <> show a <> "\nright: " <> show b <> "\ndiff : " <> show d 12 | where 13 | d = loop 0 a b 14 | loop :: (Eq a, Show a) => Int -> [a] -> [a] -> String 15 | loop _ [] [] = "internal error : list is equal" 16 | loop n l1@(_:_) [] = "offset=" <> show n <> " extra left=" <> show l1 17 | loop n [] l2@(_:_) = "offset=" <> show n <> " extra right=" <> show l2 18 | loop n l1@(x:xs) l2@(y:ys) 19 | | x == y = loop (n+1) xs ys 20 | | otherwise = "offset=" <> show n <> " left=" <> show l1 <> " right= " <> show l2 21 | -------------------------------------------------------------------------------- /foundation/tests/Profiling/ProfBreak.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Foundation 4 | import Foundation.Collection 5 | 6 | main = do 7 | let v = fromList [1..255] :: UArray Word8 8 | let (v1,v2) = break ((==) 128) v 9 | putStrLn $ (fromList $ show v1) <> (fromList $ show v2) 10 | -------------------------------------------------------------------------------- /foundation/tests/Scripts/Link.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | 3 | -- | This module is to test issue 4 | -- https://github.com/haskell-foundation/foundation/issues/326 5 | -- 6 | -- this test has been originaly proposed by https://github.com/RyanGlScott 7 | -- in comment of the issue 326: 8 | -- https://github.com/haskell-foundation/foundation/issues/326#issuecomment-309219955 9 | 10 | module Main (main) where 11 | 12 | import Foundation as F 13 | import Language.Haskell.TH 14 | 15 | main :: IO () 16 | main = $(do runIO $ F.putStrLn (F.fromString "Hello") 17 | [| return () |]) 18 | -------------------------------------------------------------------------------- /foundation/tests/Test/Basement.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | module Test.Basement 4 | ( tests 5 | ) where 6 | 7 | import Foundation 8 | import Foundation.Check 9 | import qualified Test.Basement.UTF8 as UTF8 10 | 11 | tests = Group "basement" 12 | [ UTF8.tests 13 | ] 14 | -------------------------------------------------------------------------------- /foundation/tests/Test/Basement/UTF8.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE NoImplicitPrelude #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | {-# LANGUAGE TypeFamilies #-} 5 | {-# LANGUAGE OverloadedStrings #-} 6 | module Test.Basement.UTF8 7 | ( tests ) 8 | where 9 | 10 | import Basement.Types.CharUTF8 11 | import Foundation 12 | import Foundation.Check 13 | import Foundation.String 14 | 15 | tests = Group "utf8" 16 | [ Property "CharUTF8" $ \c -> decodeCharUTF8 (encodeCharUTF8 c) === c 17 | ] 18 | -------------------------------------------------------------------------------- /foundation/tests/Test/Data/List.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | 3 | module Test.Data.List 4 | ( generateListOfElement 5 | , generateListOfElementMaxN 6 | , generateNonEmptyListOfElement 7 | , RandomList(..) 8 | ) where 9 | 10 | import Foundation 11 | import Foundation.Collection (nonEmpty_, NonEmpty) 12 | import Foundation.Check 13 | import Foundation.Monad 14 | 15 | import Basement.From (from) 16 | import Basement.Cast (cast) 17 | 18 | -- | convenient function to replicate thegiven Generator of `e` a randomly 19 | -- choosen amount of time. 20 | generateListOfElement :: Gen e -> Gen [e] 21 | generateListOfElement = generateListOfElementMaxN 100 22 | 23 | -- | convenient function to generate up to a certain amount of time the given 24 | -- generator. 25 | generateListOfElementMaxN :: CountOf e -> Gen e -> Gen [e] 26 | generateListOfElementMaxN n e = replicateBetween 0 (from n) e 27 | 28 | generateNonEmptyListOfElement :: CountOf e -> Gen e -> Gen (NonEmpty [e]) 29 | generateNonEmptyListOfElement n e = nonEmpty_ <$> replicateBetween 1 (from n) e 30 | 31 | data RandomList = RandomList [Int] 32 | deriving (Show,Eq) 33 | 34 | instance Arbitrary RandomList where 35 | arbitrary = RandomList <$> replicateBetween 100 400 (cast <$> between (0,8)) 36 | 37 | replicateBetween n1 n2 f = 38 | between (n1, n2) >>= \n -> replicateM (CountOf (toInt n)) f 39 | where 40 | toInt :: Word -> Int 41 | toInt = cast 42 | -------------------------------------------------------------------------------- /foundation/tests/Test/Data/Network.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module: 3 | -- Author: Nicolas Di Prima 4 | -- Date: 2017-01-18T17:34:06+00:00 5 | -- Email: nicolasdiprima@gmail.com 6 | -- 7 | 8 | {-# LANGUAGE NoImplicitPrelude #-} 9 | {-# LANGUAGE OverloadedStrings #-} 10 | {-# LANGUAGE FlexibleInstances #-} 11 | 12 | module Test.Data.Network 13 | ( genIPv4 14 | , genIPv4Tuple 15 | , genIPv4String 16 | , genIPv6 17 | , genIPv6Tuple 18 | , genIPv6String 19 | ) where 20 | 21 | import Foundation 22 | import Foundation.Check 23 | import Foundation.Network.IPv4 as IPv4 24 | import Foundation.Network.IPv6 as IPv6 25 | import Foundation.Class.Storable as F 26 | import qualified Foreign.Storable as Foreign 27 | 28 | instance Arbitrary IPv4 where 29 | arbitrary = genIPv4 30 | instance Foreign.Storable IPv4 where 31 | sizeOf a = let CountOf b = F.size (Just a) in b 32 | alignment a = let CountOf b = F.alignment (Just a) in b 33 | peek = F.peek 34 | poke = F.poke 35 | instance Arbitrary IPv6 where 36 | arbitrary = genIPv6 37 | instance Foreign.Storable IPv6 where 38 | sizeOf a = let CountOf b = F.size (Just a) in b 39 | alignment a = let CountOf b = F.alignment (Just a) in b 40 | peek = F.peek 41 | poke = F.poke 42 | 43 | genIPv4Tuple :: Gen (Word8, Word8, Word8, Word8) 44 | genIPv4Tuple = 45 | (,,,) <$> arbitrary 46 | <*> arbitrary 47 | <*> arbitrary 48 | <*> arbitrary 49 | 50 | genIPv6Tuple :: Gen (Word16, Word16, Word16, Word16, Word16, Word16, Word16, Word16) 51 | genIPv6Tuple = 52 | (,,,,,,,) <$> arbitrary 53 | <*> arbitrary 54 | <*> arbitrary 55 | <*> arbitrary 56 | <*> arbitrary 57 | <*> arbitrary 58 | <*> arbitrary 59 | <*> arbitrary 60 | 61 | genIPv4String :: Gen String 62 | genIPv4String = do 63 | (w1, w2, w3, w4) <- genIPv4Tuple 64 | return $ show w1 <> "." <> show w2 <> "." <> show w3 <> "." <> show w4 65 | 66 | genIPv6String :: Gen String 67 | genIPv6String = IPv6.toString <$> genIPv6 68 | 69 | genIPv6 :: Gen IPv6 70 | genIPv6 = IPv6.fromTuple <$> genIPv6Tuple 71 | 72 | -- | a better generator for unicode Character 73 | genIPv4 :: Gen IPv4 74 | genIPv4 = IPv4.fromTuple <$> genIPv4Tuple 75 | -------------------------------------------------------------------------------- /foundation/tests/Test/Foundation/Bits.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE ExistentialQuantification #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | {-# LANGUAGE TypeFamilies #-} 5 | module Test.Foundation.Bits 6 | ( tests 7 | ) where 8 | 9 | import Basement.Cast 10 | import Foundation.Bits 11 | import Foundation.Check 12 | import Foundation 13 | 14 | newtype Shifter = Shifter Int 15 | deriving (Show,Eq) 16 | 17 | instance Arbitrary Shifter where 18 | arbitrary = Shifter . applyMod <$> arbitrary 19 | where applyMod i = abs i `mod` 256 20 | 21 | testBits :: forall a . (Additive a, Bounded a, Difference a ~ a, Integral a, IsIntegral a, Bits a, Show a, Subtractive a, Eq a, Arbitrary a, Typeable a) 22 | => String 23 | -> Proxy a 24 | -> Gen a 25 | -> Test 26 | testBits n _ _ = Group n 27 | [ Property "shiftR" $ \(a :: a) (Shifter i) -> 28 | (a `shiftR` i) === convertBack (toInteger a `shiftR` i) 29 | , Property "shiftL" $ \(a :: a) (Shifter i) -> 30 | (a `shiftL` i) === convertBack (toInteger a `shiftL` i) 31 | , Property "maxBound value" $ \(a :: a) -> 32 | case bitSizeMaybe a of 33 | Just bs -> 34 | let actualMaxBound :: a 35 | actualMaxBound = maxBound 36 | expectedMaxBound :: Integer 37 | expectedMaxBound = 2^(cast bs :: Word) - (1 :: Integer) 38 | in toInteger actualMaxBound === expectedMaxBound 39 | Nothing -> propertyFail "Expected FiniteBits" 40 | , Property "complement maxBound" $ 41 | complement 0 === (maxBound :: a) 42 | , Property "overflow maxBound" $ 43 | maxBound + 1 === (0 :: a) 44 | , Property "underflow zero" $ 45 | (0 :: a) - 1 === maxBound 46 | ] 47 | where 48 | convertBack x 49 | | x <= 0 = 0 50 | | otherwise = fromInteger x 51 | 52 | tests = Group "Bits" 53 | {- 54 | [ Property "round-up" $ \(Positive m) n' -> n' >= 1 ==> 55 | let n = 2 ^ ((n' `mod` 30) :: Word) 56 | md = alignRoundUp m n 57 | in (md `mod` n) == 0 && md >= m 58 | -} 59 | [ testBits "W32" (Proxy :: Proxy Word32) arbitrary 60 | , testBits "W64" (Proxy :: Proxy Word64) arbitrary 61 | , testBits "W128" (Proxy :: Proxy Word128) arbitrary 62 | , testBits "W256" (Proxy :: Proxy Word256) arbitrary 63 | ] 64 | -------------------------------------------------------------------------------- /foundation/tests/Test/Foundation/Conduit.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE NoImplicitPrelude #-} 3 | 4 | module Test.Foundation.Conduit 5 | ( testConduit 6 | ) where 7 | 8 | import Foundation 9 | import Foundation.Check 10 | import Foundation.Conduit 11 | import Foundation.IO 12 | 13 | testConduit :: Test 14 | testConduit = Group "Conduit" 15 | [ CheckPlan "sourceHandle gives same data as readFile" testSourceFile 16 | , CheckPlan "sourceHandle/sinkHandle copies data" testCopyFile 17 | , CheckPlan "sourceFile/sinkFile copies data" testCopyFileRes 18 | ] 19 | where 20 | --testSourceFile :: Assertion 21 | testSourceFile = do 22 | let fp = "foundation.cabal" 23 | arrs <- pick "conduit-read" $ withFile fp ReadMode $ \h -> 24 | runConduit $ sourceHandle h .| sinkList 25 | arr <- pick "read-source" $ readFile fp 26 | validate "foundation.cabal contents" $ arr == (mconcat arrs) 27 | 28 | --testCopyFile :: Assertion 29 | testCopyFile = do 30 | let src = "foundation.cabal" 31 | dst = "temp-file" -- FIXME some temp file API? 32 | pick "conduit-duplicate" $ withFile src ReadMode $ \hin -> 33 | withFile dst WriteMode $ \hout -> 34 | runConduit $ sourceHandle hin .| sinkHandle hout 35 | orig <- pick "read-source" $ readFile src 36 | new <- pick "read-destination" $ readFile dst 37 | validate "copied foundation.cabal contents" $ orig == new 38 | 39 | --testCopyFileRes :: Assertion 40 | testCopyFileRes = do 41 | let src = "foundation.cabal" 42 | dst = "temp-file" -- FIXME some temp file API? 43 | pick "conduit-res" $ runConduitRes $ sourceFile src .| sinkFile dst 44 | orig <- pick "read-soure" $ readFile src 45 | new <- pick "read-destination" $ readFile dst 46 | validate "copied foundation.cabal contents" $ orig == new 47 | -------------------------------------------------------------------------------- /foundation/tests/Test/Foundation/Format.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module Test.Foundation.Format 3 | ( testFormat 4 | ) where 5 | 6 | import Foundation 7 | import Foundation.Check 8 | import Test.Foundation.Format.CSV 9 | 10 | 11 | testFormat :: Test 12 | testFormat = Group "Format" 13 | [ testFormatCSV 14 | ] 15 | -------------------------------------------------------------------------------- /foundation/tests/Test/Foundation/Misc.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module Test.Foundation.Misc 3 | ( testHexadecimal 4 | , testUUID 5 | ) where 6 | 7 | import Foundation 8 | import Foundation.Check 9 | 10 | import Foundation.Array.Internal (toHexadecimal) 11 | import Test.Checks.Property.Collection (fromListP) 12 | 13 | import qualified Foundation.UUID as UUID 14 | import Foundation.Parser 15 | 16 | instance Arbitrary UUID.UUID where 17 | arbitrary = UUID.UUID <$> arbitrary <*> arbitrary 18 | 19 | hex :: [Word8] -> [Word8] 20 | hex = loop 21 | where 22 | toHex :: Int -> Word8 23 | toHex n 24 | | n < 10 = fromIntegral (n + fromEnum '0') 25 | | otherwise = fromIntegral (n - 10 + fromEnum 'a') 26 | loop [] = [] 27 | loop (x:xs) = toHex (fromIntegral q):toHex (fromIntegral r):loop xs 28 | where 29 | (q,r) = x `divMod` 16 30 | 31 | testHexadecimal = Group "hexadecimal" 32 | [ Property "UArray(W8)" $ \l -> 33 | toList (toHexadecimal (fromListP (Proxy :: Proxy (UArray Word8)) l)) == hex l 34 | ] 35 | 36 | testUUID = Group "UUID" 37 | [ Property "show" $ show UUID.nil === "00000000-0000-0000-0000-000000000000" 38 | , Property "show-bin" $ fmap show (UUID.fromBinary (fromList [1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16])) === Just "100f0e0d-0c0b-0a09-0807-060504030201" 39 | , Property "parser . show = id" $ \uuid -> 40 | (either (error . show) id $ parseOnly UUID.uuidParser (show uuid)) === uuid 41 | ] 42 | -------------------------------------------------------------------------------- /foundation/tests/Test/Foundation/Network/IPv4.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | module Test.Foundation.Network.IPv4 4 | ( testNetworkIPv4 5 | ) where 6 | 7 | import Foundation 8 | import Foundation.Network.IPv4 9 | import Foundation.Check 10 | import Data.Either (isLeft) 11 | import Foundation.Parser (parseOnly) 12 | 13 | import Test.Data.Network 14 | import Test.Foundation.Storable 15 | 16 | -- | test property equality for the given Collection 17 | testEquality :: Gen IPv4 -> Test 18 | testEquality genElement = Group "equality" 19 | [ Property "x == x" $ forAll genElement (\x -> x === x) 20 | , Property "x == y" $ forAll ((,) <$> genElement <*> genElement) $ 21 | \(x,y) -> (toTuple x == toTuple y) === (x == y) 22 | ] 23 | 24 | -- | test ordering 25 | testOrdering :: Gen IPv4 -> Test 26 | testOrdering genElement = Property "ordering" $ 27 | forAll ((,) <$> genElement <*> genElement) $ \(x, y) -> 28 | (toTuple x `compare` toTuple y) === x `compare` y 29 | 30 | -- | generate IPv4 like string but with bigger numbers 31 | genOverflowingIPv4String :: Gen String 32 | genOverflowingIPv4String = do 33 | w1 <- bigWordGen 34 | w2 <- bigWordGen 35 | w3 <- bigWordGen 36 | w4 <- bigWordGen 37 | return $ show w1 <> "." <> show w2 <> "." <> show w3 <> "." <> show w4 where 38 | bigWordGen :: Gen Word 39 | bigWordGen = between (256,maxBound) 40 | 41 | testNetworkIPv4 :: Test 42 | testNetworkIPv4 = Group "IPv4" 43 | [ Property "toTuple . fromTuple == id" $ 44 | forAll genIPv4Tuple $ \x -> x === toTuple (fromTuple x) 45 | , Property "toString . fromString == id" $ 46 | forAll genIPv4String $ \x -> x === toString (fromString $ toList x) 47 | , testEquality genIPv4 48 | , testOrdering genIPv4 49 | , testPropertyStorable "Storable" (Proxy :: Proxy IPv4) 50 | , testPropertyStorableFixed "StorableFixed" (Proxy :: Proxy IPv4) 51 | , Property "Word8 overflow is detected" $ 52 | forAll genOverflowingIPv4String $ \x -> isLeft $ parseOnly ipv4Parser x 53 | , Property "www.example.com" $ 54 | isLeft $ parseOnly ipv4Parser ("www.example.com" :: String) 55 | ] 56 | -------------------------------------------------------------------------------- /foundation/tests/Test/Foundation/Network/IPv6.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE NoImplicitPrelude #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | module Test.Foundation.Network.IPv6 5 | ( testNetworkIPv6 6 | ) where 7 | 8 | import Foundation 9 | import Foundation.Check 10 | import Foundation.Network.IPv6 11 | 12 | import Test.Data.Network 13 | import Test.Foundation.Storable 14 | 15 | -- | test property equality for the given Collection 16 | testEquality :: Gen IPv6 -> Test 17 | testEquality genElement = Group "equality" 18 | [ Property "x == x" $ forAll genElement (\x -> x === x) 19 | , Property "x == y" $ forAll ((,) <$> genElement <*> genElement) $ 20 | \(x,y) -> (toTuple x == toTuple y) === (x == y) 21 | ] 22 | 23 | -- | test ordering 24 | testOrdering :: Gen IPv6 -> Test 25 | testOrdering genElement = Property "ordering" $ 26 | forAll ((,) <$> genElement <*> genElement) $ \(x, y) -> 27 | (toTuple x `compare` toTuple y) === x `compare` y 28 | 29 | testNetworkIPv6 :: Test 30 | testNetworkIPv6 = Group "IPv6" 31 | #if __GLASGOW_HASKELL__ >= 710 32 | [ Property "toTuple . fromTuple == id" $ 33 | forAll genIPv6Tuple $ \x -> x === toTuple (fromTuple x) 34 | , Property "toString . fromString == id" $ 35 | forAll genIPv6String $ \x -> x === toString (fromString $ toList x) 36 | , testEquality genIPv6 37 | , testOrdering genIPv6 38 | , testPropertyStorable "Storable" (Proxy :: Proxy IPv6) 39 | , testPropertyStorableFixed "StorableFixed" (Proxy :: Proxy IPv6) 40 | , Group "parse" 41 | [ Property "::" $ fromTuple (0,0,0,0,0,0,0,0) === fromString "::" 42 | , Property "::1" $ fromTuple (0,0,0,0,0,0,0,1) === fromString "::1" 43 | , Property "2001:DB8::8:800:200C:417A" $ fromTuple (0x2001,0xDB8,0,0,0x8,0x800,0x200c,0x417a) === fromString "2001:DB8::8:800:200C:417A" 44 | , Property "FF01::101" $ fromTuple (0xff01,0,0,0,0,0,0,0x101) === fromString "FF01::101" 45 | , Property "::13.1.68.3" $ (fromTuple (0,0,0,0,0,0,0x0d01,0x4403)) === (fromString "::13.1.68.3") 46 | , Property "::FFFF:129.144.52.38" $ (fromTuple (0,0,0,0,0,0xffff,0x8190,0x3426)) === (fromString "::FFFF:129.144.52.38") 47 | , Property "0::FFFF:129.144.52.38" $ (fromTuple (0,0,0,0,0,0xffff,0x8190,0x3426)) === (fromString "0::FFFF:129.144.52.38") 48 | , Property "0:0::FFFF:129.144.52.38" $ (fromTuple (0,0,0,0,0,0xffff,0x8190,0x3426)) === (fromString "0:0::FFFF:129.144.52.38") 49 | ] 50 | ] 51 | #else 52 | [] 53 | #endif 54 | -------------------------------------------------------------------------------- /foundation/tests/Test/Foundation/Primitive/BlockN.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE ExistentialQuantification #-} 4 | {-# LANGUAGE ScopedTypeVariables #-} 5 | {-# LANGUAGE TypeOperators #-} 6 | 7 | module Test.Foundation.Primitive.BlockN 8 | ( testBlockN 9 | ) where 10 | 11 | import Data.Proxy (Proxy(..)) 12 | import Foundation hiding (singleton, replicate, cons, uncons, elem) 13 | import Basement.Nat 14 | import Basement.Types.OffsetSize 15 | import qualified Basement.Block as B 16 | import Basement.Sized.Block 17 | import Basement.From 18 | import Foundation.Check 19 | 20 | testBlockN = Group "BlockN" 21 | [ testWithDifferentN 22 | , Property "singleton" $ B.singleton (1 :: Int) === toBlock (singleton 1) 23 | ] 24 | 25 | testWithDifferentN = 26 | Group "Multiple n" $ fmap (\(Foo p) -> testBlock p) ns 27 | 28 | testBlock :: forall n . (KnownNat n, NatWithinBound (CountOf Int) n) => Proxy n -> Test 29 | testBlock nProxy = 30 | Group ("n = " <> show size) 31 | [ Property "to/from block" $ block === (toBlock blockN) 32 | , Property "replicate" $ B.replicate size (7 :: Int) === toBlock (rep 7) 33 | , Property "length . cons" $ B.length (toBlock (cons 42 blockN)) === (size+1) 34 | , Property "elem" $ size == 0 || from size `elem` blockN 35 | ] 36 | where 37 | rep :: Int -> BlockN n Int 38 | rep = replicate 39 | 40 | size = natValCountOf nProxy 41 | block = createBlockSized size 42 | Just blockN = toBlockN block :: Maybe (BlockN n Int) 43 | 44 | createBlockSized :: CountOf Int -> B.Block Int 45 | createBlockSized n@(CountOf n') = B.create n (const n') 46 | 47 | data Foo = forall a . (KnownNat a, NatWithinBound (CountOf Int) a) => Foo (Proxy a) 48 | 49 | ns :: [Foo] 50 | ns = 51 | [ Foo (Proxy :: Proxy 0) 52 | , Foo (Proxy :: Proxy 1) 53 | , Foo (Proxy :: Proxy 2) 54 | , Foo (Proxy :: Proxy 3) 55 | , Foo (Proxy :: Proxy 4) 56 | , Foo (Proxy :: Proxy 5) 57 | , Foo (Proxy :: Proxy 6) 58 | , Foo (Proxy :: Proxy 7) 59 | , Foo (Proxy :: Proxy 8) 60 | , Foo (Proxy :: Proxy 33) 61 | , Foo (Proxy :: Proxy 42) 62 | ] 63 | -------------------------------------------------------------------------------- /foundation/tests/Test/Utils/Foreign.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ExistentialQuantification #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | module Test.Utils.Foreign 4 | ( Ptr 5 | , Storable 6 | , createPtr 7 | , free 8 | ) where 9 | 10 | import Foreign.Marshal.Alloc 11 | 12 | import Foreign.Ptr 13 | import Foundation 14 | import Prelude (zip) 15 | import Control.Monad (forM_) 16 | 17 | import Foundation.Foreign 18 | import Foundation.Class.Storable 19 | 20 | createPtr :: forall e . StorableFixed e => [e] -> IO (FinalPtr e) 21 | createPtr l 22 | | null l = toFinalPtr nullPtr (\_ -> return ()) 23 | | otherwise = do 24 | let (CountOf szElem) = size (Proxy :: Proxy e) 25 | nbBytes = szElem * (let (CountOf c) = length l in c) 26 | ptr <- mallocBytes nbBytes 27 | forM_ (zip [0..] l) $ uncurry (pokeOff ptr) 28 | toFinalPtr ptr free 29 | -------------------------------------------------------------------------------- /mkdocs.yml: -------------------------------------------------------------------------------- 1 | site_name: The Haskell Foundation Framework 2 | site_description: The Haskell Foundation Framework 3 | site_author: Foundation contributors 4 | repo_url: https://github.com/haskell-foundation/foundation/tree/master/docs 5 | copyright: Copyright (c) 2016-2017, Foundation contributors 6 | docs_dir: docs 7 | site_dir: _site 8 | theme: readthedocs 9 | 10 | pages: 11 | - Introduction: index.md 12 | - Home: home.md 13 | - Changelog: CHANGELOG.md 14 | - Core documentation: 15 | - Collection: core-collection.md 16 | - Numerical: core-numerical.md 17 | - Advanced: 18 | - Runtime option: advanced-runtime.md 19 | - Porting: porting.md 20 | - Project documentation: 21 | - Contributors Guide: contributing.md 22 | # - Maintainer guide: MAINTAINER_GUIDE.md 23 | 24 | markdown_extensions: 25 | - toc: 26 | permalink: true 27 | -------------------------------------------------------------------------------- /programs/InputOutputLines.hs: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env stack 2 | {-# LANGUAGE NoImplicitPrelude #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | module Main where 5 | 6 | import Foundation 7 | import Foundation.Conduit 8 | import Foundation.Conduit.Textual 9 | import Foundation.IO 10 | import Foundation.String (String, Encoding(..)) 11 | import Foundation.Collection 12 | 13 | -- | Capitalize all 'a' and returns all other character as is 14 | remap :: Monad m => Conduit String String m () 15 | remap = await >>= maybe (return ()) (\s -> yield (capitalizeA s <> "\n") >> remap) 16 | where 17 | capitalizeA :: String -> String 18 | capitalizeA s = flip imap s $ \c -> 19 | case c of 20 | 'a' -> 'A' 21 | _ -> c 22 | 23 | main = runConduit $ sourceHandle stdin 24 | .| fromBytes UTF8 .| lines 25 | .| remap 26 | .| toBytes UTF8 27 | .| sinkHandle stdout 28 | -------------------------------------------------------------------------------- /programs/SumDouble.hs: -------------------------------------------------------------------------------- 1 | #! /usr/bin/env stack 2 | -- stack resolver lts-8.15 --install-ghc script --package foundation 3 | {-# LANGUAGE RebindableSyntax #-} 4 | import Foundation 5 | import Foundation.Conduit 6 | import Foundation.Conduit.Textual 7 | import Foundation.String (Encoding(UTF8)) 8 | import Foundation.String.Read (readDouble) 9 | import Foundation.IO 10 | 11 | main :: IO () 12 | main = 13 | runConduit (sourceHandle stdin .| fromBytes UTF8 .| words .| sinkList) 14 | >>= putStrLn . show . foldl' (+) 0.0 . catMaybes . fmap readDouble 15 | -------------------------------------------------------------------------------- /programs/foundation-programs.cabal: -------------------------------------------------------------------------------- 1 | Name: foundation-programs 2 | Version: 0 3 | Build-Type: Simple 4 | Cabal-Version: >=1.10 5 | 6 | executable sum-double 7 | hs-source-dirs: . 8 | main-is: SumDouble.hs 9 | ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall 10 | build-depends: foundation 11 | default-language: Haskell2010 12 | 13 | executable input-output-lines 14 | hs-source-dirs: . 15 | main-is: InputOutputLines.hs 16 | ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall 17 | build-depends: foundation 18 | default-language: Haskell2010 19 | 20 | executable time 21 | hs-source-dirs: . 22 | main-is: Time.hs 23 | ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall 24 | build-depends: foundation 25 | , base 26 | , criterion 27 | default-language: Haskell2010 28 | cpp-options: -DUSE_CRITERION 29 | 30 | executable CSV 31 | hs-source-dirs: . 32 | main-is: CSV.hs 33 | ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall 34 | build-depends: foundation 35 | , base 36 | , criterion 37 | default-language: Haskell2010 38 | cpp-options: -DUSE_CRITERION 39 | -------------------------------------------------------------------------------- /programs/stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-8.11 2 | packages: 3 | - '.' 4 | - '../' 5 | flags: {} 6 | extra-package-dbs: [] 7 | -------------------------------------------------------------------------------- /scripts/algorithms.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | EDITDIFFTOOL=vimdiff 4 | DIFFTOOL=diff 5 | 6 | PREF=basement/Basement/Alg/Native 7 | 8 | case $1 in 9 | editdiff) 10 | if [ ! -f $PREF/$2 ]; then echo "$2 doesn't exist"; exit 1; fi 11 | $EDITDIFFTOOL $PREF/$2 ${PREF/Native/Foreign}/$2 12 | ;; 13 | editdiff) 14 | if [ ! -f $PREF/$2 ]; then echo "$2 doesn't exist"; exit 1; fi 15 | $DIFFTOOL $PREF/$2 ${PREF/Native/Foreign}/$2 16 | ;; 17 | gen) 18 | for file in $PREF/*.hs 19 | do 20 | dest=${file/Native/Foreign} 21 | if [ "$file" != "$PREF/Prim.hs" ]; then 22 | echo "GENERATING $dest from $file" 23 | sed -n ' 24 | /Basement.Alg.Native./ !{ 25 | p 26 | } 27 | /Basement.Alg.Native./ { 28 | /NO SUBST/ { 29 | p 30 | } 31 | /NO SUBST/ !{ 32 | s;Basement.Alg.Native.;Basement.Alg.Foreign.; 33 | p 34 | } 35 | }' $file > $dest 36 | fi 37 | done 38 | ;; 39 | *) 40 | echo "unknown mode: $1" 41 | echo "expecting editdiff, diff, gen" 42 | exit 1 43 | ;; 44 | esac 45 | 46 | -------------------------------------------------------------------------------- /scripts/caseMapping/CaseFolding.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module CaseFolding 4 | ( 5 | CaseFolding(..) 6 | , Fold(..) 7 | , parseCF 8 | , mapCF 9 | ) where 10 | 11 | import Foundation 12 | import Foundation.IO 13 | import qualified Foundation.Parser as P 14 | import qualified Foundation.String as S (lower, fromBytesUnsafe) 15 | import Foundation.VFS.FilePath 16 | 17 | import UnicodeParsers 18 | 19 | data Fold = Fold { 20 | code :: String 21 | , status :: Char 22 | , mapping :: [String] 23 | , name :: String 24 | } deriving (Eq, Ord, Show) 25 | 26 | data CaseFolding = CF { cfComments :: [Comment], cfFolding :: [Fold] } 27 | deriving (Show) 28 | 29 | entries :: P.Parser String CaseFolding 30 | entries = CF <$> P.many comment <*> P.some entry 31 | where 32 | entry = Fold <$> unichar <* semiCol 33 | <*> oneOf "CFST" <* P.string ";" 34 | <*> unichars <* semiCol 35 | <*> (P.string "# " *> P.takeWhile (/= '\n')) <* P.string "\n" 36 | 37 | parseCF :: FilePath -> IO (Either (P.ParseError String) CaseFolding) 38 | parseCF name = P.parseOnly entries . S.fromBytesUnsafe <$> readFile name 39 | 40 | mapCF :: (String -> String) -> CaseFolding -> [String] 41 | mapCF twiddle (CF _ ms) = typ <> (fmap nice . filter p $ ms) <> [last] 42 | where 43 | typ = ["foldMapping :: Char -> CM", 44 | "{-# NOINLINE foldMapping #-}"] 45 | last = "foldMapping c = CM (toLower c) '\\0' '\\0'" 46 | p f = status f `elem` ("CF" :: String) && 47 | mapping f /= [twiddle (code f)] 48 | nice c = "-- " <> name c <> "\n" <> 49 | "foldMapping " <> niceMap (code c) <> " = CM " <> x <> " " <> y <> " " <> z 50 | where pMap = (niceMap <$> mapping c) <> ["'\\0'","'\\0'","'\\0'"] 51 | niceMap x = "'\\x" <> x <> "'" 52 | [x,y,z] = take (CountOf 3) pMap 53 | -------------------------------------------------------------------------------- /scripts/caseMapping/CaseMapping.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module CaseMapping ( 3 | main 4 | ) where 5 | 6 | import qualified Basement.String as BS (charMap) 7 | import Data.Char (toUpper, toLower) 8 | import Foundation 9 | import Foundation.IO 10 | import qualified Foundation.String as S 11 | 12 | import CaseFolding 13 | import SpecialCasing 14 | 15 | main = do 16 | psc <- parseSC "SpecialCasing.txt" 17 | pcf <- parseCF "CaseFolding.txt" 18 | scs <- case psc of 19 | Left err -> putStrLn (show err) >> undefined 20 | Right sc -> return sc 21 | cfs <- case pcf of 22 | Left err -> putStrLn (show err) >> undefined 23 | Right cf -> return cf 24 | h <- openFile ("NewCaseMapping.hs") WriteMode 25 | let comments = ("--" <>) <$> 26 | take 2 (cfComments cfs) <> take 2 (scComments scs) 27 | (hPut h) . S.toBytes S.UTF8 . intercalate "\n" $ 28 | ["{-# LANGUAGE Rank2Types #-}" 29 | ,"-- AUTOMATICALLY GENERATED - DO NOT EDIT" 30 | ,"-- Generated by scripts/caseMapping/generateCaseMapping.sh"] 31 | <> comments <> 32 | ["" 33 | ,"module Basement.String.CaseMapping where" 34 | ,"" 35 | ,"import Data.Char" 36 | ,"import Basement.UTF8.Types" 37 | ,"",""] 38 | (hPut h) . S.toBytes S.UTF8 . intercalate "\n" $ (mapSC "upper" upper) (BS.charMap toUpper) scs 39 | (hPut h) . S.toBytes S.UTF8 . intercalate "\n" $ (mapSC "lower" lower) (BS.charMap toLower) scs 40 | (hPut h) . S.toBytes S.UTF8 . intercalate "\n" $ (mapSC "title" title) (BS.charMap toUpper) scs 41 | (hPut h) . S.toBytes S.UTF8 . intercalate "\n" $ mapCF (BS.charMap toLower) cfs 42 | closeFile h 43 | -------------------------------------------------------------------------------- /scripts/caseMapping/SpecialCasing.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module SpecialCasing 4 | ( 5 | SpecialCasing(..) 6 | , Case(..) 7 | , parseSC 8 | , mapSC 9 | ) where 10 | 11 | import qualified Data.Char as C (toUpper) 12 | 13 | import Foundation 14 | import Foundation.IO 15 | import qualified Foundation.Parser as P 16 | import Foundation.VFS.FilePath 17 | import Foundation.Collection (nonEmpty_) 18 | import qualified Foundation.String as S 19 | 20 | import UnicodeParsers 21 | 22 | data SpecialCasing = SC {scComments :: [Comment], scCasing :: [Case]} 23 | deriving (Show) 24 | 25 | data Case = Case { 26 | code :: String 27 | , lower :: [String] 28 | , title :: [String] 29 | , upper :: [String] 30 | , conditions :: String 31 | , name :: String 32 | } deriving (Eq, Ord, Show) 33 | 34 | 35 | entries :: P.Parser String SpecialCasing 36 | entries = SC <$> P.many comment <*> P.many (entry <* P.many comment) 37 | where 38 | entry = Case <$> unichar <* P.string ";" 39 | <*> unichars <* P.string ";" 40 | <*> unichars <* P.string ";" 41 | <*> unichars <* P.string "; " 42 | <*> (P.takeWhile (/= '#') <* P.string "# ") 43 | <*> P.takeWhile (/= '\n') <* P.string "\n" 44 | 45 | parseSC :: FilePath -> IO (Either (P.ParseError String) SpecialCasing) 46 | parseSC name = P.parseOnly entries . S.fromBytesUnsafe <$> readFile name 47 | 48 | mapSC :: String -> (Case -> [String]) -> (String -> String) -> SpecialCasing -> [String] 49 | mapSC wich access twiddle (SC _ ms) = 50 | typ `mappend` (fmap nice . filter p $ ms) `mappend` last 51 | where 52 | typ = [wich <> "Mapping :: Char -> CM", 53 | "{-# NOINLINE " <> wich <> "Mapping #-}"] 54 | last = [wich <> "Mapping c = CM (to" <> ucFst wich 55 | <> " c) '\\0' '\\0'","",""] 56 | p c = [k] /= a && a /= [twiddle k] && null (conditions c) 57 | where a = access c 58 | k = code c 59 | nice c = "-- " <> name c <> "\n" <> 60 | wich <> "Mapping " <> pHex(code c) <> " = CM " 61 | <> x <> " " <> y <> " " <> z 62 | where pMap = (pHex <$> access c) <> ["'\\0'","'\\0'","'\\0'"] 63 | pHex x = "'\\x" <> x <> "'" 64 | [x,y,z] = take (CountOf 3) pMap 65 | 66 | ucFst :: String -> String 67 | ucFst s 68 | | null s = "" 69 | | otherwise = (fromString [C.toUpper (head neS)]) <> tail neS 70 | where neS = nonEmpty_ s 71 | -------------------------------------------------------------------------------- /scripts/caseMapping/UnicodeParsers.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module UnicodeParsers where 3 | 4 | import Foundation 5 | import qualified Foundation.Parser as P 6 | import Foundation.String as S 7 | import Foundation.Collection (Element) 8 | 9 | type Comment = String 10 | 11 | hexDigits :: String 12 | hexDigits = "1234567890ABCDEF" 13 | 14 | comment :: P.Parser String Comment 15 | comment = (P.string "#" *> P.takeWhile (/= '\n') <* P.string "\n") <|> (P.string "\n" *> pure "") 16 | 17 | unichar :: P.Parser String String 18 | unichar = P.takeWhile (`elem` hexDigits) 19 | 20 | unichars :: P.Parser String [String] 21 | unichars = P.some elemz 22 | where elemz = P.string " " *> unichar 23 | 24 | semiCol :: P.Parser String () 25 | semiCol = P.string "; " 26 | 27 | oneOf :: String -> P.Parser String Char 28 | oneOf s = P.satisfy_ (`elem` s) 29 | 30 | spaces :: P.Parser String () 31 | spaces = P.skipWhile (== ' ') 32 | -------------------------------------------------------------------------------- /scripts/caseMapping/generateCaseMapping.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | # This script will generate the unicode case mappings tables using unicode's 4 | # CaseFolding 5 | # and SpecialCasing.txt files. 6 | # 7 | curl "https://unicode.org/Public/UNIDATA/CaseFolding.txt" >> CaseFolding.txt 8 | curl "https://unicode.org/Public/UNIDATA/SpecialCasing.txt" >> SpecialCasing.txt 9 | 10 | stack runghc -- -XNoImplicitPrelude -XTypeFamilies -XBangPatterns CaseMapping.hs 11 | 12 | if [ "$(head -n 7 "NewCaseMapping.hs")" = "$(head -n 7 "../../basement/Basement/String/CaseMapping.hs")" ] 13 | then 14 | echo "Unicode case mapping table up to date." 15 | else 16 | echo "A new Unicode case mapping has been released." 17 | echo "Please run /scripts/caseMapping/generateCaseMapping.sh locally, then move the generated file to /basement/Basement/String/NewCaseMapping.hs" 18 | exit 1 19 | fi 20 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | # ~*~ auto-generated by haskell-ci with config : 3de811e97e86e191bcc37197cf3c81d3d54dcc04f2838ea87b9e78be24ac0adf ~*~ 2 | { resolver: nightly-2023-05-25, packages: [ foundation/, basement/ ], extra-deps: [], flags: {} } 3 | 4 | -------------------------------------------------------------------------------- /with-edge.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-13.5 2 | packages: 3 | - foundation 4 | - edge 5 | extra-deps: 6 | - basement 7 | --------------------------------------------------------------------------------