foundation 0.0.8 → 0.0.9

raw patch · 54 files changed

+2162/−755 lines, 54 filesdep ~basePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• Foundation.hs +3/−10
• Foundation/Array.hs +1/−1
• Foundation/Array/Bitmap.hs +1/−1
• Foundation/Array/Boxed.hs +1/−1
• Foundation/Array/Chunked/Unboxed.hs +1/−1
• Foundation/Array/Common.hs +0/−62
• Foundation/Array/Internal.hs +1/−0
• Foundation/Array/Unboxed.hs +27/−5
• Foundation/Array/Unboxed/Mutable.hs +4/−4
• Foundation/Check.hs +266/−81
• Foundation/Check/Arbitrary.hs +3/−5
• Foundation/Check/Gen.hs +2/−2
• Foundation/Check/Property.hs +15/−9
• Foundation/Class/Storable.hs +44/−48
• Foundation/Collection/Collection.hs +10/−0
• Foundation/Collection/Copy.hs +5/−0
• Foundation/Collection/Element.hs +2/−0
• Foundation/Collection/Foldable.hs +5/−0
• Foundation/Collection/Indexed.hs +14/−1
• Foundation/Collection/Mutable.hs +22/−3
• Foundation/Collection/Sequential.hs +21/−1
• Foundation/Conduit/Internal.hs +2/−1
• Foundation/IO/File.hs +4/−4
• Foundation/IO/FileMap.hs +2/−1
• Foundation/IO/Terminal.hs +1/−2
• Foundation/Internal/Base.hs +2/−8
• Foundation/Internal/Environment.hs +3/−25
• Foundation/Internal/Error.hs +0/−38
• Foundation/Internal/Primitive.hs +18/−0
• Foundation/Internal/Typeable.hs +37/−0
• Foundation/Math/Trigonometry.hs +2/−2
• Foundation/Numerical/Floating.hs +8/−8
• Foundation/Primitive.hs +9/−0
• Foundation/Primitive/Block.hs +386/−0
• Foundation/Primitive/Block/Base.hs +282/−0
• Foundation/Primitive/Block/Mutable.hs +122/−0
• Foundation/Primitive/Error.hs +38/−0
• Foundation/Primitive/Exception.hs +62/−0
• Foundation/Primitive/Imports.hs +105/−0
• Foundation/Primitive/Runtime.hs +30/−0
• Foundation/Primitive/Show.hs +14/−0
• Foundation/Primitive/These.hs +36/−0
• Foundation/Primitive/Types.hs +4/−8
• Foundation/Primitive/Types/OffsetSize.hs +11/−0
• Foundation/Primitive/UTF8/Base.hs +220/−0
• Foundation/Primitive/UTF8/Helper.hs +127/−0
• Foundation/Primitive/UTF8/Table.hs +83/−0
• Foundation/String.hs +2/−0
• Foundation/String/ModifiedUTF8.hs +1/−1
• Foundation/String/UTF8.hs +23/−294
• Foundation/String/UTF8Table.hs +0/−83
• foundation.cabal +16/−6
• tests/Checks.hs +56/−39
• tests/Test/Checks/Property/Collection.hs +8/−0

@@ -27,7 +27,7 @@     , Prelude.either     , Prelude.flip     , Prelude.const-    , Foundation.Internal.Error.error+    , Foundation.Primitive.Error.error     , Foundation.IO.Terminal.putStr     , Foundation.IO.Terminal.putStrLn     --, print@@ -164,7 +164,7 @@ import           Foundation.Internal.IsList import qualified Foundation.Internal.Base (ifThenElse) import qualified Foundation.Internal.Proxy-import qualified Foundation.Internal.Error+import qualified Foundation.Primitive.Error  import qualified Foundation.Numerical import qualified Foundation.Partial@@ -173,6 +173,7 @@ import qualified Foundation.Class.Bifunctor import           Foundation.Primitive.Types.OffsetSize (Size(..), Offset(..)) import qualified Foundation.Primitive+import           Foundation.Primitive.Show import           Foundation.Internal.NumLiteral import           Foundation.Internal.Natural @@ -190,14 +191,6 @@  -- | Alias to Prelude String ([Char]) for compatibility purpose type LString = Prelude.String---- | Use the Show class to create a String.------ Note that this is not efficient, since--- an intermediate [Char] is going to be--- created before turning into a real String.-show :: Prelude.Show a => a -> String-show = fromList Prelude.. Prelude.show  -- | Returns a list of the program's command line arguments (not including the program name). getArgs :: Prelude.IO [String]

@@ -24,7 +24,7 @@     , OutOfBound     ) where -import           Foundation.Array.Common+import           Foundation.Primitive.Exception import           Foundation.Array.Boxed import           Foundation.Array.Unboxed import           Foundation.Array.Unboxed.Mutable

@@ -32,7 +32,7 @@ import           Foundation.Array.Unboxed (UArray) import qualified Foundation.Array.Unboxed as A import           Foundation.Array.Unboxed.Mutable (MUArray)-import           Foundation.Array.Common+import           Foundation.Primitive.Exception import           Foundation.Internal.Base import           Foundation.Primitive.Types.OffsetSize import           Foundation.Primitive.Monad

@@ -74,7 +74,7 @@ import           Foundation.Primitive.NormalForm import           Foundation.Primitive.IntegralConv import           Foundation.Primitive.Monad-import           Foundation.Array.Common+import           Foundation.Primitive.Exception import           Foundation.Boot.Builder import qualified Foundation.Boot.List as List import qualified Prelude

@@ -21,7 +21,7 @@ import           Control.Arrow ((***)) import           Foundation.Array.Boxed (Array) import qualified Foundation.Array.Boxed as A-import           Foundation.Array.Common+import           Foundation.Primitive.Exception import           Foundation.Array.Unboxed (UArray) import qualified Foundation.Array.Unboxed as U import           Foundation.Class.Bifunctor

@@ -1,62 +0,0 @@--- |--- Module      : Foundation.Array.Common--- License     : BSD-style--- Maintainer  : Vincent Hanquez <vincent@snarc.org>--- Stability   : experimental--- Portability : portable------ Common part for vectors----{-# LANGUAGE DeriveDataTypeable #-}-module Foundation.Array.Common-    ( OutOfBound(..)-    , OutOfBoundOperation(..)-    , isOutOfBound-    , outOfBound-    , primOutOfBound-    , InvalidRecast(..)-    , RecastSourceSize(..)-    , RecastDestinationSize(..)-    ) where--import           Foundation.Internal.Base-import           Foundation.Primitive.Types.OffsetSize-import           Foundation.Primitive.Monad---- | The type of operation that triggers an OutOfBound exception.------ * OOB_Index: reading an immutable vector--- * OOB_Read: reading a mutable vector--- * OOB_Write: write a mutable vector-data OutOfBoundOperation = OOB_Read | OOB_Write | OOB_MemSet | OOB_Index-    deriving (Show,Eq,Typeable)---- | Exception during an operation accessing the vector out of bound------ Represent the type of operation, the index accessed, and the total length of the vector.-data OutOfBound = OutOfBound OutOfBoundOperation Int Int-    deriving (Show,Typeable)--instance Exception OutOfBound--outOfBound :: OutOfBoundOperation -> Offset ty -> Size ty -> a-outOfBound oobop (Offset ofs) (Size sz) = throw (OutOfBound oobop ofs sz)-{-# INLINE outOfBound #-}--primOutOfBound :: PrimMonad prim => OutOfBoundOperation -> Offset ty -> Size ty -> prim a-primOutOfBound oobop (Offset ofs) (Size sz) = primThrow (OutOfBound oobop ofs sz)-{-# INLINE primOutOfBound #-}--isOutOfBound :: Offset ty -> Size ty -> Bool-isOutOfBound (Offset ty) (Size sz) = ty < 0 || ty >= sz-{-# INLINE isOutOfBound #-}--newtype RecastSourceSize      = RecastSourceSize Int-    deriving (Show,Eq,Typeable)-newtype RecastDestinationSize = RecastDestinationSize Int-    deriving (Show,Eq,Typeable)--data InvalidRecast = InvalidRecast RecastSourceSize RecastDestinationSize-    deriving (Show,Typeable)--instance Exception InvalidRecast

@@ -15,6 +15,7 @@     ( UArray(..)     , fromForeignPtr     , withPtr+    , copyToPtr     , recast     , toHexadecimal     -- * Mutable facilities

@@ -37,6 +37,7 @@     , create     , createFromIO     , sub+    , copyToPtr     , withPtr     , withMutablePtr     , unsafeFreezeShrink@@ -95,6 +96,7 @@ import           GHC.ST import           GHC.Ptr import           GHC.ForeignPtr (ForeignPtr)+import           Foreign.Marshal.Utils (copyBytes) import qualified Prelude import           Foundation.Internal.Base import           Foundation.Internal.Primitive@@ -108,7 +110,7 @@ import           Foundation.Primitive.IntegralConv import           Foundation.Primitive.FinalPtr import           Foundation.Primitive.Utils-import           Foundation.Array.Common+import           Foundation.Primitive.Exception import           Foundation.Array.Unboxed.Mutable hiding (sub) import           Foundation.Numerical import           Foundation.Boot.Builder@@ -503,6 +505,24 @@                 {-# INLINE loop #-}         {-# INLINE doUpdate #-} +-- | Copy all the block content to the memory starting at the destination address+copyToPtr :: forall ty prim . (PrimType ty, PrimMonad prim)+          => UArray ty -- ^ the source array to copy+          -> Ptr ty    -- ^ The destination address where the copy is going to start+          -> prim ()+copyToPtr (UVecBA start sz _ ba) (Ptr p) = primitive $ \s1 ->+    (# compatCopyByteArrayToAddr# ba offset p szBytes s1, () #)+  where+    !(Offset (I# offset)) = primOffsetOfE start+    !(Size (I# szBytes)) = sizeInBytes sz+copyToPtr (UVecAddr start sz fptr) dst =+    unsafePrimFromIO $ withFinalPtr fptr $ \ptr -> copyBytes dst (ptr `plusPtr` os) szBytes+  where+    !(Offset os)    = primOffsetOfE start+    !(Size szBytes) = sizeInBytes sz++data TmpBA = TmpBA ByteArray#+ withPtr :: (PrimMonad prim, PrimType ty)         => UArray ty         -> (Ptr ty -> prim a)@@ -517,15 +537,17 @@     | otherwise        = do         -- TODO don't copy the whole vector, and just allocate+copy the slice.         let !sz# = sizeofByteArray# a-        a' <- primitive $ \s -> do+        (TmpBA ba) <- primitive $ \s -> do             case newAlignedPinnedByteArray# sz# 8# s of { (# s2, mba #) ->             case copyByteArray# a 0# mba 0# sz# s2 of { s3 ->-            case unsafeFreezeByteArray# mba s3 of { (# s4, ba #) ->-                (# s4, Ptr (byteArrayContents# ba) `plusPtr` os #) }}}-        f a'+            case unsafeFreezeByteArray# mba s3 of { (# s4, ba #) -> (# s4, TmpBA ba #) }}}+        r <- f (Ptr (byteArrayContents# ba))+        unsafePrimFromIO $ primitive $ \s -> case touch# ba s of { s2 -> (# s2, () #) }+        pure r   where     sz           = primSizeInBytes (vectorProxyTy vec)     !(Offset os) = offsetOfE sz start+{-# INLINE withPtr #-}  recast :: (PrimType a, PrimType b) => UArray a -> UArray b recast = recast_ Proxy Proxy

@@ -40,14 +40,14 @@ import           GHC.Types import           GHC.Ptr import           Foundation.Internal.Base-import qualified Foundation.Internal.Environment as Environment+import qualified Foundation.Primitive.Runtime as Runtime import           Foundation.Internal.Primitive import           Foundation.Internal.Proxy import           Foundation.Primitive.Types.OffsetSize import           Foundation.Primitive.Monad import           Foundation.Primitive.Types import           Foundation.Primitive.FinalPtr-import           Foundation.Array.Common+import           Foundation.Primitive.Exception import           Foundation.Numerical -- import           Foreign.Marshal.Utils (copyBytes) @@ -155,7 +155,7 @@   where     -- Safe to use here: If the value changes during runtime, this will only     -- have an impact on newly created arrays.-    maxSizeUnpinned = Environment.unsafeUArrayUnpinnedMaxSize+    maxSizeUnpinned = Runtime.unsafeUArrayUnpinnedMaxSize {-# INLINE new #-}  mutableSame :: MUArray ty st -> MUArray ty st -> Bool@@ -293,7 +293,7 @@ -- and the change will be reflected in the mutable array -- -- If the mutable array is unpinned, a trampoline buffer--- is created and the data is only copy when 'f' return.+-- is created and the data is only copied when 'f' return. withMutablePtr :: (PrimMonad prim, PrimType ty)                => MUArray ty (PrimState prim)                -> (Ptr ty -> prim a)

@@ -3,6 +3,7 @@ {-# LANGUAGE Rank2Types #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-} module Foundation.Check     ( Gen     , Arbitrary(..)@@ -26,7 +27,10 @@     , defaultMain     ) where +import qualified Prelude (fromIntegral, read) import           Foundation.Internal.Base+import           Foundation.Class.Bifunctor (bimap)+import           Foundation.System.Info (os, OS(..)) import           Foundation.Collection import           Foundation.Numerical import           Foundation.String@@ -36,8 +40,11 @@ import           Foundation.Check.Property import           Foundation.Random import           Foundation.Monad+import           Foundation.Monad.State+import           Foundation.List.DList import           Control.Exception (evaluate, SomeException) import           System.Exit+import           System.Environment (getArgs)  -- different type of tests data Test where@@ -54,17 +61,10 @@ testName (Property s _) = s testName (Group s _)    = s -data Context = Context-    { contextLevel  :: !Word-    , contextGroups :: [String]-    , contextSeed   :: !Word64-    }--appendContext :: String -> Context -> Context-appendContext s ctx = ctx-    { contextLevel = 1 + contextLevel ctx-    , contextGroups = s : contextGroups ctx-    }+groupHasSubGroup :: [Test] -> Bool+groupHasSubGroup [] = False+groupHasSubGroup (Group{}:_) = True+groupHasSubGroup (_:xs) = groupHasSubGroup xs  data PropertyResult =       PropertySuccess@@ -76,32 +76,232 @@     | GroupResult    String HasFailures [TestResult]     deriving (Show) -type HasFailures = Word+type HasFailures = Word64  nbFail :: TestResult -> HasFailures nbFail (PropertyResult _ _ (PropertyFailed _)) = 1 nbFail (PropertyResult _ _ PropertySuccess)    = 0 nbFail (GroupResult    _ t _)                  = t --- | return the number of tests runned and the result-runProp :: Context -> String -> Property -> IO (PropertyResult, Word64)-runProp ctx s prop = iterProp 1+nbTests :: TestResult -> Word64+nbTests (PropertyResult _ t _) = t+nbTests (GroupResult _ _ l) = foldl' (+) 0 $ fmap nbTests l++parseArgs :: [[Char]] -> Config -> Config+parseArgs [] cfg = cfg+parseArgs ("--seed":[])     _  = error "option `--seed' is missing a parameter"+parseArgs ("--seed":x:xs)  cfg = parseArgs xs $ cfg { getSeed = Prelude.read x }+parseArgs ("--tests":[])   _   = error "option `--tests' is missing a parameter"+parseArgs ("--tests":x:xs) cfg = parseArgs xs $ cfg { numTests = Prelude.read x }+parseArgs ("--quiet":xs)   cfg = parseArgs xs $ cfg { displayOptions = DisplayTerminalErrorOnly }+parseArgs ("--verbose":xs) cfg = parseArgs xs $ cfg { displayOptions = DisplayTerminalVerbose }+parseArgs ("--help":_)     _   = error $ mconcat+    [ "--seed <seed>: the seed to use to generate arbitrary value.\n"+    , "--tests <tests>: the number of tests to perform for every property tests.\n"+    , "--quiet: print only the errors to the standard output\n"+    , "--verbose: print every property tests to the stand output.\n"+    ]+parseArgs (x:_) _ = error $ "unknown parameter: " <> show x++-- | Run tests+defaultMain :: Test -> IO ()+defaultMain t = do+    -- generate a new seed+    seed <- getRandomPrimType+    -- parse arguments+    cfg <- flip parseArgs (defaultConfig seed) <$> getArgs++    putStrLn $ "\nSeed: " <> fromList (show $ getSeed cfg) <> "\n"++    (_, cfg') <- runStateT (runCheck $ test t) cfg+    let oks = testPassed cfg'+        kos = testFailed cfg'+        tot = oks + kos+    if kos > 0+        then do+          putStrLn $ "Failed " <> fromList (show kos) <> " out of " <> fromList (show tot)+          exitFailure+        else do+          putStrLn $ "Succeed " <> fromList (show oks) <> " test(s)"+          exitSuccess++-- | internal check monad for facilitating the tests traversal+newtype Check a = Check { runCheck :: StateT Config IO a }+  deriving (Functor, Applicative, Monad, MonadIO)+instance MonadState Check where+    type State Check = Config+    withState = Check . withState++type Seed = Word64+data Config = Config+    { testPath     :: !(DList String)+        -- ^ for internal use when pretty printing+    , indent       :: !Word+        -- ^ for internal use when pretty printing+    , testPassed   :: !Word+    , testFailed   :: !Word+    , getSeed      :: !Seed+        -- ^ the seed for the tests+    , getGenParams :: !GenParams+        -- ^ Parameters for the generator+        --+        -- default:+        --   * 32bits long numbers;+        --   * array of 512 elements max;+        --   * string of 8192 bytes max.+        --+    , numTests     :: !Word64+        -- ^ the number of tests to perform on every property.+        --+        -- default: 100+    , displayOptions :: !DisplayOption+    }++data DisplayOption+    = DisplayTerminalErrorOnly+    | DisplayGroupOnly+    | DisplayTerminalVerbose+  deriving (Eq, Ord, Enum, Bounded, Show)++onDisplayOption :: DisplayOption -> Check () -> Check ()+onDisplayOption opt chk = do+    on <- (<=) opt . displayOptions <$> get+    if on then chk else return ()++whenErrorOnly :: Check () -> Check ()+whenErrorOnly = onDisplayOption DisplayTerminalErrorOnly++whenGroupOnly :: Check () -> Check ()+whenGroupOnly = onDisplayOption DisplayGroupOnly++whenVerbose :: Check () -> Check ()+whenVerbose = onDisplayOption DisplayTerminalVerbose++passed :: Check ()+passed = withState $ \s -> ((), s { testPassed = testPassed s + 1 })++failed :: Check ()+failed = withState $ \s -> ((), s { testFailed = testFailed s + 1 })++-- | create the default configuration+--+-- see @Config@ for details+defaultConfig :: Seed -> Config+defaultConfig s = Config+    { testPath     = mempty+    , indent       = 0+    , testPassed   = 0+    , testFailed   = 0+    , getSeed      = s+    , getGenParams = params+    , numTests     = 100+    , displayOptions = DisplayGroupOnly+    }   where-    nbTests = 100-    iterProp :: Word64 -> IO (PropertyResult, Word64)-    iterProp i-        | i == nbTests = return (PropertySuccess, i)-        | otherwise    = do-            r <- toResult i-            case r of-                (PropertyFailed e, _)               -> return (PropertyFailed e, i)-                (PropertySuccess, cont) | cont      -> iterProp (i+1)-                                        | otherwise -> return (PropertySuccess, i)-    toResult :: Word64 -> IO (PropertyResult, Bool)-    toResult it =-                (propertyToResult <$> evaluate (runGen (unProp prop) (rngIt it) params))-        `catch` (\(e :: SomeException) -> return (PropertyFailed (fromList $ show e), False))+    params = GenParams+        { genMaxSizeIntegral = 32   -- 256 bits maximum numbers+        , genMaxSizeArray    = 512  -- 512 elements+        , genMaxSizeString   = 8192 -- 8K string+        } +test :: Test -> Check TestResult+test (Group s l) = pushGroup s l+test (Unit _ _) = undefined+test (Property name prop) = do+    r'@(PropertyResult _ nb r) <- testProperty name (property prop)+    case r of+        PropertySuccess  -> whenVerbose $ displayPropertySucceed name nb+        PropertyFailed w -> whenErrorOnly $ displayPropertyFailed name nb w+    return r'++displayCurrent :: String -> Check ()+displayCurrent name = do+    i <- indent <$> get+    liftIO $ putStrLn $ replicate i ' ' <> name++displayPropertySucceed :: String -> Word64 -> Check ()+displayPropertySucceed name nb = do+    i <- indent <$> get+    liftIO $ putStrLn $ mconcat+        [ replicate i ' '+        , successString, name+        , " ("+        , fromList $ show nb+        , if nb == 1 then " test)" else " tests)"+        ]++successString :: String+successString = case os of+    Right Linux -> " ✓ "+    Right OSX   -> " ✓ "+    _           -> "[SUCCESS]"+{-# NOINLINE successString #-}++failureString :: String+failureString = case os of+    Right Linux -> " ✗ "+    Right OSX   -> " ✗ "+    _           -> "[ ERROR ]"+{-# NOINLINE failureString #-}++displayPropertyFailed :: String -> Word64 -> String -> Check ()+displayPropertyFailed name nb w = do+    seed <- getSeed <$> get+    i <- indent <$> get+    liftIO $ do+        putStrLn $ mconcat+          [ replicate i ' '+          , failureString, name+          , " failed after "+          , fromList $ show nb+          , if nb == 1 then " test" else " tests:"+          ]+        putStrLn $ replicate i ' ' <> "   use param: --seed " <> fromList (show seed)+        putStrLn w++pushGroup :: String -> [Test] -> Check TestResult+pushGroup name list = do+    whenGroupOnly $ if groupHasSubGroup list then displayCurrent name else return ()+    withState $ \s -> ((), s { testPath = push (testPath s) name, indent = indent s + 2 })+    results <- mapM test list+    withState $ \s -> ((), s { testPath = pop (testPath s), indent = indent s - 2 })+    let totFail = foldl' (+) 0 $ fmap nbFail results+        tot = foldl'(+) 0 $ fmap nbTests results+    whenGroupOnly $ case (groupHasSubGroup list, totFail) of+        (True, _)              -> return ()+        (False, n) | n > 0     -> displayPropertyFailed name n ""+                   | otherwise -> displayPropertySucceed name tot+    return $ GroupResult name totFail results+  where+    push = snoc+    pop = maybe mempty fst . unsnoc++testProperty :: String -> Property -> Check TestResult+testProperty name prop = do+    seed <- getSeed <$> get+    path <- testPath <$> get+    let rngIt = genRng seed (name : toList path)++    maxTests <- numTests <$> get++    (res, nb) <- iterProp 1 maxTests rngIt+    return (PropertyResult name nb res)+  where+    iterProp !n !limit !rngIt+      | n == limit = passed >> return (PropertySuccess, n)+      | otherwise  = do+          params <- getGenParams <$> get+          r <- liftIO $ toResult n params+          case r of+              (PropertyFailed e, _)               -> failed >> return (PropertyFailed e, n)+              (PropertySuccess, cont) | cont      -> iterProp (n+1) limit rngIt+                                      | otherwise -> passed >> return (PropertySuccess, n)+        where+          toResult :: Word64 -> GenParams -> IO (PropertyResult, Bool)+          toResult it params =+                    (propertyToResult <$> evaluate (runGen (unProp prop) (rngIt it) params))+            `catch` (\(e :: SomeException) -> return (PropertyFailed (fromList $ show e), False))+     propertyToResult p =         let args   = getArgs p             checks = getChecks p@@ -115,66 +315,51 @@         loop _ []      = printChecks checks         loop !i (a:as) = "parameter " <> fromList (show i) <> " : " <> a <> "\n" : loop (i+1) as     printChecks (PropertyBinaryOp True _ _ _)     = []-    printChecks (PropertyBinaryOp False name a b) = [name <> " checked fail\n" <> "   left: " <> a <> "\n" <> "  right: " <> b]+    printChecks (PropertyBinaryOp False n a b) =+        [ "Property `a " <> n <> " b' failed where:\n"+        , "    a = " <> a <> "\n"+        , "        " <> bl1 <> "\n"+        , "    b = " <> b <> "\n"+        , "        " <> bl2 <> "\n"+        ]+      where+        (bl1, bl2) = diffBlame a b     printChecks (PropertyNamed True _)            = []-    printChecks (PropertyNamed False name)        = ["Check " <> name <> " failed"]+    printChecks (PropertyNamed False e)           = ["Property " <> e <> " failed"]     printChecks (PropertyBoolean True)            = []-    printChecks (PropertyBoolean False)           = ["Check failed"]-    printChecks (PropertyFail _ e)                = ["Check failed: " <> e]+    printChecks (PropertyBoolean False)           = ["Property failed"]+    printChecks (PropertyFail _ e)                = ["Property failed: " <> e]     printChecks (PropertyAnd True _ _)            = []-    printChecks (PropertyAnd False a1 a2)-        | checkHasFailed a1 && checkHasFailed a2  = ["And Property failed:\n    && left: "] <> printChecks a1 <> ["\n"] <> ["   && right: "] <> printChecks a2-        | checkHasFailed a1                       = ["And Property failed:\n    && left: "] <> printChecks a1 <> ["\n"]-        | otherwise                               = ["And Property failed:\n   && right: "] <> printChecks a2 <> ["\n"]+    printChecks (PropertyAnd False a1 a2) =+            [ "Property `cond1 && cond2' failed where:\n"+            , "   cond1 = " <> h1 <> "\n" +            ]+            <> ((<>) "           " <$>  hs1)+            <>+            [ "   cond2 = " <> h2 <> "\n"+            ]+            <> ((<>) "           " <$> hs2)+      where+        (h1, hs1) = f a1+        (h2, hs2) = f a2+        f a = case printChecks a of+                      [] -> ("Succeed", [])+                      (x:xs) -> (x, xs)+     getArgs (PropertyArg a p) = a : getArgs p     getArgs (PropertyEOA _) = []      getChecks (PropertyArg _ p) = getChecks p     getChecks (PropertyEOA c  ) = c -    !rngIt  = genRng (contextSeed ctx) (s : contextGroups ctx)-    !params = GenParams { genMaxSizeIntegral = 32   -- 256 bits maximum numbers-                        , genMaxSizeArray    = 512  -- 512 elements-                        , genMaxSizeString   = 8192 -- 8K string-                        }---- | Run tests-defaultMain :: Test -> IO ()-defaultMain test = do-    -- parse arguments-    --let arguments = [ "seed", "j" ]--    -- generate a new seed-    seed <- getRandomPrimType--    let context = Context { contextLevel  = 0-                          , contextGroups = []-                          , contextSeed   = seed-                          }--    printHeader context-    tr <- runTest context test-    if nbFail tr > 0-        then putStrLn (fromList (show $ nbFail tr) <> " failure(s)") >> exitFailure-        else putStrLn "Success" >> exitSuccess+diffBlame :: String -> String -> (String, String)+diffBlame a b = bimap fromList fromList $ go ([], []) (toList a) (toList b)   where-    printHeader ctx = do-        putStrLn ("seed: " <> fromList (show (contextSeed ctx))) -- TODO hexadecimal--    runTest :: Context -> Test -> IO TestResult-    runTest ctx (Group s l) = do-        printIndent ctx s-        results <- mapM (runTest (appendContext s ctx)) l-        return $ GroupResult s (foldl' (+) 0 $ fmap nbFail results) results-    runTest ctx (Property name prop) = do-        (res, nbTests) <- runProp ctx name (property prop)-        case res of-            PropertySuccess  -> printIndent ctx $ "[  OK   ]   " <> name <> " (" <> fromList (show nbTests) <> " completed)"-            PropertyFailed e -> printIndent ctx $ "[ ERROR ]   " <> name <> " after " <> fromList (show (nbTests-1)) <> " tests\n" <> e-        return (PropertyResult name nbTests res)--    runTest _ (Unit _ _) = do-        error "not implemented"--    printIndent ctx s = putStrLn (replicate (contextLevel ctx) ' ' <> s)+    go (acc1, acc2) [] [] = (acc1, acc2)+    go (acc1, acc2) l1 [] = (acc1 <> blaming (length l1), acc2)+    go (acc1, acc2) [] l2 = (acc1                       , acc2 <> blaming (length l2))+    go (acc1, acc2) (x:xs) (y:ys)+        | x == y    = go (acc1 <> " ", acc2 <> " ") xs ys+        | otherwise = go (acc1 <> "^", acc2 <> "^") xs ys+    blaming n = replicate (Prelude.fromIntegral n) '^'

@@ -1,5 +1,6 @@ {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-} module Foundation.Check.Arbitrary     ( Arbitrary(..)     , frequency@@ -8,8 +9,7 @@     , between     ) where -import           Foundation.Internal.Base-import           Foundation.Internal.Natural+import           Foundation.Primitive.Imports import           Foundation.Primitive import           Foundation.Primitive.IntegralConv (wordToChar) import           Foundation.Primitive.Floating@@ -17,9 +17,7 @@ import           Foundation.Random import           Foundation.Bits import           Foundation.Collection-import           Foundation.Array import           Foundation.Numerical-import           Foundation.String import           Control.Monad (replicateM)  -- | How to generate an arbitrary value for 'a'@@ -137,7 +135,7 @@     pickOne ((k,x):xs) n         | n <= k    = x         | otherwise = pickOne xs (n-k)-    pickOne _ _ = internalError "frequency"+    pickOne _ _ = error "frequency"  oneof :: NonEmpty [Gen a] -> Gen a oneof ne = frequency (nonEmptyFmap (\x -> (1, x)) ne)

@@ -11,7 +11,7 @@     , genWithParams     ) where -import           Foundation.Internal.Base+import           Foundation.Primitive.Imports import           Foundation.Collection import           Foundation.Random import           Foundation.String@@ -38,7 +38,7 @@     w3 = rngSeed * 4      (SipHash rngSeed) = hashEnd $ hashMixBytes hashData iHashState-    hashData = toBytes UTF8 $ intercalate "::" (reverse groups)+    hashData = toBytes UTF8 $ intercalate "::" groups     iHashState :: Sip1_3     iHashState = hashNewParam (SipKey seed 0x12345678) 

@@ -16,11 +16,14 @@     , propertyFail     ) where -import Foundation.Internal.Base+import Foundation.Primitive.Imports hiding (Typeable)+import Foundation.Internal.Proxy (Proxy(..))+import Foundation.Internal.Typeable import Foundation.Check.Gen import Foundation.Check.Arbitrary-import Foundation.String +import Data.Typeable+ type PropertyTestResult = Bool  -- | The type of check this test did for a property@@ -65,24 +68,27 @@     a <- generator     augment a <$> unProp (property (tst a))   where-    augment a arg = PropertyArg (fromList $ show a) arg+    augment a arg = PropertyArg (show a) arg -(===) :: (Show a, Eq a) => a -> a -> PropertyCheck+(===) :: (Show a, Eq a, Typeable a) => a -> a -> PropertyCheck (===) a b =-    let sa = fromList (show a)-        sb = fromList (show b)+    let sa = pretty a Proxy+        sb = pretty b Proxy      in PropertyBinaryOp (a == b) "==" sa sb infix 4 === -propertyCompare :: Show a+pretty :: (Show a, Typeable a) => a -> Proxy a -> String+pretty a pa = show a <> " :: " <> show (typeRep pa)++propertyCompare :: (Show a, Typeable a)                 => String           -- ^ name of the function used for comparaison, e.g. (<)                 -> (a -> a -> Bool) -- ^ function used for value comparaison                 -> a                -- ^ value left of the operator                 -> a                -- ^ value right of the operator                 -> PropertyCheck propertyCompare name op a b =-    let sa = fromList (show a)-        sb = fromList (show b)+    let sa = pretty a Proxy+        sb = pretty b Proxy      in PropertyBinaryOp (a `op` b) name sa sb  propertyAnd :: PropertyCheck -> PropertyCheck -> PropertyCheck

@@ -11,6 +11,7 @@  {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE CPP #-}  module Foundation.Class.Storable     ( Storable(..)@@ -27,25 +28,23 @@     , pokeArrayEndedBy     ) where +#include "MachDeps.h"+ import GHC.Types (Double, Float)  import Foreign.Ptr (castPtr) import qualified Foreign.Ptr-import qualified Foreign.Storable (peek, poke, sizeOf, alignment)+import qualified Foreign.Storable (peek, poke) import           Foreign.C.Types (CChar, CUChar)  import Foundation.Internal.Base import Foundation.Primitive.Types.OffsetSize-import Foundation.Internal.Proxy import Foundation.Collection import Foundation.Collection.Buildable (builderLift) import Foundation.Primitive.Types import Foundation.Primitive.Endianness import Foundation.Numerical -toProxy :: proxy ty -> Proxy ty-toProxy _ = Proxy- -- | Storable type of self determined size. -- class Storable a where@@ -170,65 +169,62 @@     poke = Foreign.Storable.poke  instance StorableFixed CChar where-    size      = primSizeInBytes . toProxy-    alignment = primSizeInBytes . toProxy+    size      = const SIZEOF_CHAR+    alignment = const ALIGNMENT_CHAR instance StorableFixed CUChar where-    size      = primSizeInBytes . toProxy-    alignment = primSizeInBytes . toProxy+    size      = const SIZEOF_WORD8+    alignment = const ALIGNMENT_WORD8 instance StorableFixed Char where-    size      = primSizeInBytes . toProxy-    alignment = primSizeInBytes . toProxy+    size      = const SIZEOF_HSCHAR+    alignment = const ALIGNMENT_HSCHAR instance StorableFixed Double where-    size      = primSizeInBytes . toProxy-    alignment = primSizeInBytes . toProxy+    size      = const SIZEOF_HSDOUBLE+    alignment = const ALIGNMENT_HSDOUBLE instance StorableFixed Float where-    size      = primSizeInBytes . toProxy-    alignment = primSizeInBytes . toProxy+    size      = const SIZEOF_HSFLOAT+    alignment = const ALIGNMENT_HSFLOAT instance StorableFixed Int8 where-    size      = primSizeInBytes . toProxy-    alignment = primSizeInBytes . toProxy+    size      = const SIZEOF_INT8+    alignment = const ALIGNMENT_INT8 instance StorableFixed Int16 where-    size      = primSizeInBytes . toProxy-    alignment = primSizeInBytes . toProxy+    size      = const SIZEOF_INT16+    alignment = const ALIGNMENT_INT16 instance StorableFixed Int32 where-    size      = primSizeInBytes . toProxy-    alignment = primSizeInBytes . toProxy+    size      = const SIZEOF_INT32+    alignment = const ALIGNMENT_INT32 instance StorableFixed Int64 where-    size      = primSizeInBytes . toProxy-    alignment = primSizeInBytes . toProxy+    size      = const SIZEOF_INT64+    alignment = const ALIGNMENT_INT64 instance StorableFixed Word8 where-    size      = primSizeInBytes . toProxy-    alignment = primSizeInBytes . toProxy+    size      = const SIZEOF_WORD8+    alignment = const ALIGNMENT_WORD8 instance StorableFixed Word16 where-    size      = primSizeInBytes . toProxy-    alignment = primSizeInBytes . toProxy+    size      = const SIZEOF_WORD16+    alignment = const ALIGNMENT_WORD16 instance StorableFixed (BE Word16) where-    size      = primSizeInBytes . toProxy-    alignment = primSizeInBytes . toProxy+    size      = const SIZEOF_WORD16+    alignment = const ALIGNMENT_WORD16 instance StorableFixed (LE Word16) where-    size      = primSizeInBytes . toProxy-    alignment = primSizeInBytes . toProxy+    size      = const SIZEOF_WORD16+    alignment = const ALIGNMENT_WORD16 instance StorableFixed Word32 where-    size      = primSizeInBytes . toProxy-    alignment = primSizeInBytes . toProxy+    size      = const SIZEOF_WORD32+    alignment = const ALIGNMENT_WORD32 instance StorableFixed (BE Word32) where-    size      = primSizeInBytes . toProxy-    alignment = primSizeInBytes . toProxy+    size      = const SIZEOF_WORD32+    alignment = const ALIGNMENT_WORD32 instance StorableFixed (LE Word32) where-    size      = primSizeInBytes . toProxy-    alignment = primSizeInBytes . toProxy+    size      = const SIZEOF_WORD32+    alignment = const ALIGNMENT_WORD32 instance StorableFixed Word64 where-    size      = primSizeInBytes . toProxy-    alignment = primSizeInBytes . toProxy+    size      = const SIZEOF_WORD64+    alignment = const ALIGNMENT_WORD64 instance StorableFixed (BE Word64) where-    size      = primSizeInBytes . toProxy-    alignment = primSizeInBytes . toProxy+    size      = const SIZEOF_WORD64+    alignment = const ALIGNMENT_WORD64 instance StorableFixed (LE Word64) where-    size      = primSizeInBytes . toProxy-    alignment = primSizeInBytes . toProxy+    size      = const SIZEOF_WORD64+    alignment = const ALIGNMENT_WORD64 instance StorableFixed (Ptr a) where-    size      = Size . Foreign.Storable.sizeOf    . toUndefined-    alignment = Size . Foreign.Storable.alignment . toUndefined--toUndefined :: proxy a -> a-toUndefined _ = undefined+    size      = const SIZEOF_HSPTR+    alignment = const ALIGNMENT_HSPTR

@@ -31,6 +31,7 @@ import           Foundation.Internal.Base import           Foundation.Collection.Element import qualified Data.List+import qualified Foundation.Primitive.Block as BLK import qualified Foundation.Array.Unboxed as UV import qualified Foundation.Array.Boxed as BA import qualified Foundation.String.UTF8 as S@@ -108,6 +109,15 @@      any = Data.List.any     all = Data.List.all++instance UV.PrimType ty => Collection (BLK.Block ty) where+    null = (==) 0 . BLK.length+    length = BLK.length+    elem = BLK.elem+    minimum = Data.List.minimum . toList . getNonEmpty+    maximum = Data.List.maximum . toList . getNonEmpty+    all = BLK.all+    any = BLK.any  instance UV.PrimType ty => Collection (UV.UArray ty) where     null = UV.null

@@ -2,6 +2,9 @@     ( Copy(..)     ) where +import           GHC.ST (runST)+import           Foundation.Internal.Base ((>>=))+import qualified Foundation.Primitive.Block as BLK import qualified Foundation.Array.Unboxed as UA import qualified Foundation.Array.Boxed as BA import qualified Foundation.String.UTF8 as S@@ -10,6 +13,8 @@     copy :: a -> a instance Copy [ty] where     copy a = a+instance UA.PrimType ty => Copy (BLK.Block ty) where+    copy blk = runST (BLK.thaw blk >>= BLK.unsafeFreeze) instance UA.PrimType ty => Copy (UA.UArray ty) where     copy = UA.copy instance Copy (BA.Array ty) where

@@ -10,6 +10,7 @@     ) where  import Foundation.Internal.Base+import Foundation.Primitive.Block (Block) import Foundation.Array.Unboxed (UArray) import Foundation.Array.Boxed (Array) import Foundation.String.UTF8 (String)@@ -17,6 +18,7 @@ -- | Element type of a collection type family Element container type instance Element [a] = a+type instance Element (Block ty) = ty type instance Element (UArray ty) = ty type instance Element (Array ty) = ty type instance Element String = Char

@@ -15,6 +15,7 @@ import           Foundation.Collection.Element import qualified Data.List import qualified Foundation.Array.Unboxed as UV+import qualified Foundation.Primitive.Block as BLK import qualified Foundation.Array.Boxed as BA  -- | Give the ability to fold a collection on itself@@ -59,3 +60,7 @@     foldl = BA.foldl     foldr = BA.foldr     foldl' = BA.foldl'+instance UV.PrimType ty => Foldable (BLK.Block ty) where+    foldl = BLK.foldl+    foldr = BLK.foldr+    foldl' = BLK.foldl'

@@ -15,9 +15,10 @@ import           Foundation.Primitive.Types.OffsetSize import           Foundation.Collection.Element import qualified Data.List+import qualified Foundation.Primitive.Block as BLK import qualified Foundation.Array.Unboxed as UV import qualified Foundation.Array.Boxed as BA-import qualified Foundation.Array.Common as A+import qualified Foundation.Primitive.Exception as A import qualified Foundation.String.UTF8 as S  -- | Collection of elements that can indexed by int@@ -32,6 +33,18 @@                         []  -> Nothing                         x:_ -> Just x     findIndex predicate = fmap Offset . Data.List.findIndex predicate++instance UV.PrimType ty => IndexedCollection (BLK.Block ty) where+    (!) l n+        | A.isOutOfBound n (BLK.lengthSize l) = Nothing+        | otherwise                           = Just $ BLK.index l n+    findIndex predicate c = loop 0+      where+        !len = BLK.lengthSize c+        loop i+            | i .==# len                      = Nothing+            | predicate (BLK.unsafeIndex c i) = Just i+            | otherwise                       = Nothing  instance UV.PrimType ty => IndexedCollection (UV.UArray ty) where     (!) l n

@@ -9,9 +9,11 @@     ( MutableCollection(..)     ) where -import Foundation.Primitive.Monad-import Foundation.Primitive.Types.OffsetSize-import Foundation.Internal.Base+import           Foundation.Primitive.Monad+import           Foundation.Primitive.Types.OffsetSize+import qualified Foundation.Primitive.Block         as BLK+import qualified Foundation.Primitive.Block.Mutable as BLK+import           Foundation.Internal.Base  import qualified Foundation.Array.Unboxed.Mutable as MUV import qualified Foundation.Array.Unboxed as UV@@ -56,6 +58,23 @@     mutUnsafeRead = MUV.unsafeRead     mutWrite = MUV.write     mutRead = MUV.read++instance UV.PrimType ty => MutableCollection (BLK.MutableBlock ty) where+    type MutableFreezed (BLK.MutableBlock ty) = BLK.Block ty+    type MutableKey (BLK.MutableBlock ty) = Offset ty+    type MutableValue (BLK.MutableBlock ty) = ty++    thaw = BLK.thaw+    freeze = BLK.freeze+    unsafeThaw = BLK.unsafeThaw+    unsafeFreeze = BLK.unsafeFreeze++    mutNew i = BLK.new (Size i)++    mutUnsafeWrite = BLK.unsafeWrite+    mutUnsafeRead = BLK.unsafeRead+    mutWrite = BLK.write+    mutRead = BLK.read  instance MutableCollection (BA.MArray ty) where     type MutableFreezed (BA.MArray ty) = BA.Array ty

@@ -18,11 +18,13 @@  import           Foundation.Internal.Base import           Foundation.Primitive.IntegralConv+import           Foundation.Primitive.Types.OffsetSize import           Foundation.Collection.Element import           Foundation.Collection.Collection import qualified Foundation.Collection.List as ListExtra import qualified Data.List import qualified Foundation.Array.Unboxed as UV+import qualified Foundation.Primitive.Block as BLK import qualified Foundation.Array.Boxed as BA import qualified Foundation.String.UTF8 as S @@ -194,6 +196,24 @@     isPrefixOf = Data.List.isPrefixOf     isSuffixOf = Data.List.isSuffixOf +instance UV.PrimType ty => Sequential (BLK.Block ty) where+    splitAt n = BLK.splitAt (Size n)+    revSplitAt n = BLK.revSplitAt (Size n)+    splitOn = BLK.splitOn+    break = BLK.break+    intersperse = BLK.intersperse+    span = BLK.span+    filter = BLK.filter+    reverse = BLK.reverse+    uncons = BLK.uncons+    unsnoc = BLK.unsnoc+    snoc = BLK.snoc+    cons = BLK.cons+    find = BLK.find+    sortBy = BLK.sortBy+    singleton = BLK.singleton+    replicate = BLK.replicate+ instance UV.PrimType ty => Sequential (UV.UArray ty) where     take = UV.take     revTake = UV.revTake@@ -236,7 +256,7 @@     cons = BA.cons     find = BA.find     sortBy = BA.sortBy-    singleton = fromList . (:[])+    singleton = BA.singleton     replicate = BA.replicate  instance Sequential S.String where

@@ -10,6 +10,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE Rank2Types #-}+{-# LANGUAGE OverloadedStrings #-} module Foundation.Conduit.Internal     ( Pipe(..)     , Conduit(..)@@ -29,7 +30,7 @@     , bracketConduit     ) where -import Foundation.Internal.Base hiding (throw)+import Foundation.Primitive.Imports hiding (throw) import Foundation.Monad import Foundation.Numerical import Foundation.Primitive.Monad

@@ -5,6 +5,7 @@ -- Stability   : experimental -- Portability : portable --+{-# LANGUAGE OverloadedStrings #-} module Foundation.IO.File     ( FilePath     , openFile@@ -25,9 +26,7 @@ import           Foundation.Collection import           Foundation.VFS import           Foundation.Primitive.Types.OffsetSize-import           Foundation.Internal.Base-import           Foundation.String-import           Foundation.Array+import           Foundation.Primitive.Imports import           Foundation.Array.Internal import           Foundation.Numerical import qualified Foundation.Array.Unboxed.Mutable as V@@ -89,7 +88,7 @@ invalidBufferSize :: [Char] -> Handle -> Int -> IO a invalidBufferSize functionName handle size =     ioError $ mkIOError illegalOperationErrorType-                        (functionName <> " invalid array size: " <> show size)+                        (functionName <> " invalid array size: " <> toList (show size))                         (Just handle)                         Nothing @@ -148,6 +147,7 @@                             error ("foldTextFile: invalid UTF8 sequence: byte position: " <> show (absPos + pos))                     chunkf s acc >>= loop (absPos + Offset r)                 else error ("foldTextFile: read failed") -- FIXME+{-# DEPRECATED foldTextFile "use conduit instead" #-}  blockSize :: Int blockSize = 4096

@@ -17,6 +17,7 @@ -- In doubt, use 'readFile' or other simple routine that brings -- the content of the file in IO. --+{-# LANGUAGE OverloadedStrings #-} module Foundation.IO.FileMap     ( fileMapRead     , fileMapReadWith@@ -24,7 +25,7 @@  import           Control.Exception import           Foundation.Primitive.Types.OffsetSize-import           Foundation.Internal.Base+import           Foundation.Primitive.Imports import           Foundation.VFS (FilePath) import           Foundation.Primitive.FinalPtr import qualified Foundation.Array.Unboxed as V

@@ -12,8 +12,7 @@     , stdout     ) where -import           Foundation.Internal.Base-import           Foundation.String+import           Foundation.Primitive.Imports import qualified Prelude import           System.IO (stdin, stdout) 

@@ -47,8 +47,6 @@     , Data.Word.Word8, Data.Word.Word16, Data.Word.Word32, Data.Word.Word64, Data.Word.Word     , Prelude.Double, Prelude.Float     , Prelude.IO-    , FP32-    , FP64     , Foundation.Internal.IsList.IsList (..)     , GHC.Exts.IsString (..)     , GHC.Generics.Generic (..)@@ -56,7 +54,7 @@     , Data.Data.Data (..)     , Data.Data.mkNoRepType     , Data.Data.DataType-    , Data.Typeable.Typeable+    , Foundation.Internal.Typeable.Typeable     , Data.Monoid.Monoid (..)     , (Data.Monoid.<>)     , Control.Exception.Exception@@ -64,7 +62,6 @@     , Control.Exception.throwIO     , GHC.Ptr.Ptr(..)     , ifThenElse-    -- * Errors     , internalError     ) where @@ -74,11 +71,11 @@ import qualified Control.Exception import qualified Data.Monoid import qualified Data.Data-import qualified Data.Typeable import qualified Data.Word import qualified Data.Int import qualified Foundation.Internal.IsList import qualified Foundation.Internal.NumLiteral+import qualified Foundation.Internal.Typeable import qualified GHC.Exts import qualified GHC.Generics import qualified GHC.Ptr@@ -92,6 +89,3 @@ ifThenElse :: Prelude.Bool -> a -> a -> a ifThenElse Prelude.True  e1 _  = e1 ifThenElse Prelude.False _  e2 = e2--type FP32 = Prelude.Float-type FP64 = Prelude.Double

@@ -2,25 +2,20 @@ -- Module      : Foundation.Internal.Environment -- License     : BSD-style -- Maintainer  : foundation--- Stability   : experimental--- Portability : portable ----- Global configuration environment+-- environment variable compat  {-# LANGUAGE CPP #-}  module Foundation.Internal.Environment-    ( unsafeUArrayUnpinnedMaxSize+    ( lookupEnv, readMaybe     ) where -import           Foundation.Internal.Base-import           Foundation.Primitive.Types.OffsetSize-import           System.IO.Unsafe          (unsafePerformIO)- #if MIN_VERSION_base(4,6,0) import           System.Environment (lookupEnv) import           Text.Read (readMaybe) #else+import           Foundation.Internal.Base import           System.Environment (getEnvironment) import           Data.List (lookup) import           Text.Read (Read, minPrec, readPrec, lift)@@ -50,20 +45,3 @@     Right a -> Just a  #endif---- | Defines the maximum size in bytes of unpinned arrays.------ You can change this value by setting the environment variable--- @HS_FOUNDATION_UARRAY_UNPINNED_MAX@ to an unsigned integer number.------ Note: We use 'unsafePerformIO' here. If the environment variable--- changes during runtime and the runtime system decides to recompute--- this value, referential transparency is violated (like the First--- Order violated the Galactic Concordance!).------ TODO The default value of 1024 bytes is arbitrarily chosen for now.-unsafeUArrayUnpinnedMaxSize :: Size8-unsafeUArrayUnpinnedMaxSize = unsafePerformIO $ do-    maxSize <- (>>= readMaybe) <$> lookupEnv "HS_FOUNDATION_UARRAY_UNPINNED_MAX"-    return $ maybe (Size 1024) Size maxSize-{-# NOINLINE unsafeUArrayUnpinnedMaxSize #-}

@@ -1,38 +0,0 @@-{-# LANGUAGE MagicHash #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE ImplicitParams #-}-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE CPP #-}-module Foundation.Internal.Error-    ( error-    ) where--import           GHC.Prim-import           Foundation.String.UTF8-import           Foundation.Internal.CallStack--#if MIN_VERSION_base(4,9,0)--import           GHC.Types (RuntimeRep)-import           GHC.Exception (errorCallWithCallStackException)---- | stop execution and displays an error message-error :: forall (r :: RuntimeRep) . forall (a :: TYPE r) . HasCallStack => String -> a-error s = raise# (errorCallWithCallStackException (sToList s) ?callstack)--#elif MIN_VERSION_base(4,7,0)--import           GHC.Exception (errorCallException)--error :: String -> a-error s = raise# (errorCallException (sToList s))--#else--import           GHC.Types-import           GHC.Exception--error :: String -> a-error s = throw (ErrorCall (sToList s))--#endif

@@ -14,6 +14,7 @@     , compatAndI#     , compatQuotRemInt#     , compatCopyAddrToByteArray#+    , compatCopyByteArrayToAddr#     , compatMkWeak#     , compatGetSizeofMutableByteArray#     , compatShrinkMutableByteArray#@@ -94,6 +95,23 @@                 (# st2, w #) -> loop (o +# 1#) (i +# 1#) (writeWord8Array# ba o w st2) #endif {-# INLINE compatCopyAddrToByteArray# #-}++-- | A version friendly fo copyByteArrayToAddr#+--+-- only available from GHC 7.8+compatCopyByteArrayToAddr# :: ByteArray# -> Int# -> Addr# -> Int# -> State# s -> State# s+#if MIN_VERSION_base(4,7,0)+compatCopyByteArrayToAddr# = copyByteArrayToAddr#+#else+compatCopyByteArrayToAddr# ba ofs addr sz stini =+    loop ofs 0# stini+  where+    loop o i st+        | bool# (i ==# sz)  = st+        | Prelude.otherwise =+            loop (o +# 1#) (i +# 1#) (writeWord8OffAddr# addr i (indexWord8Array# ba o) st)+#endif+{-# INLINE compatCopyByteArrayToAddr# #-}  -- | A mkWeak# version that keep working on 8.0 --

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

@@ -36,7 +36,7 @@     -- | hyperbolic tangent-1     atanh :: a -> a -instance Trigonometry FP32 where+instance Trigonometry Float where     pi = Prelude.pi     sin = Prelude.sin     cos = Prelude.cos@@ -51,7 +51,7 @@     acosh = Prelude.acosh     atanh = Prelude.atanh -instance Trigonometry FP64 where+instance Trigonometry Double where     pi = Prelude.pi     sin = Prelude.sin     cos = Prelude.cos

@@ -15,16 +15,16 @@     floatDecode :: a -> (Integer, Int)     floatEncode :: Integer -> Int -> a -instance FloatingPoint FP32 where-    floatRadix _ = Prelude.floatRadix (0.0 :: FP32)-    floatDigits _ = Prelude.floatDigits (0.0 :: FP32)-    floatRange _ = Prelude.floatRange (0.0 :: FP32)+instance FloatingPoint Float where+    floatRadix _ = Prelude.floatRadix (0.0 :: Float)+    floatDigits _ = Prelude.floatDigits (0.0 :: Float)+    floatRange _ = Prelude.floatRange (0.0 :: Float)     floatDecode = Prelude.decodeFloat     floatEncode = Prelude.encodeFloat -instance FloatingPoint FP64 where-    floatRadix _ = Prelude.floatRadix (0.0 :: FP64)-    floatDigits _ = Prelude.floatDigits (0.0 :: FP64)-    floatRange _ = Prelude.floatRange (0.0 :: FP64)+instance FloatingPoint Double where+    floatRadix _ = Prelude.floatRadix (0.0 :: Double)+    floatDigits _ = Prelude.floatDigits (0.0 :: Double)+    floatRange _ = Prelude.floatRange (0.0 :: Double)     floatDecode = Prelude.decodeFloat     floatEncode = Prelude.encodeFloat

@@ -28,6 +28,13 @@     , NormalForm(..)     , force     , deepseq++    -- * These+    , These(..)++    -- * Block of memory+    , Block+    , MutableBlock     ) where  import Foundation.Primitive.Types@@ -35,3 +42,5 @@ import Foundation.Primitive.Endianness import Foundation.Primitive.IntegralConv import Foundation.Primitive.NormalForm+import Foundation.Primitive.These+import Foundation.Primitive.Block

@@ -0,0 +1,386 @@+-- |+-- Module      : Foundation.Primitive.Block+-- License     : BSD-style+-- Maintainer  : Haskell Foundation+--+-- A block of memory that contains elements of a type,+-- very similar to an unboxed array but with the key difference:+--+-- * It doesn't have slicing capability (no cheap take or drop)+-- * It consume less memory: 1 Offset, 1 Size, 1 Pinning status trimmed+-- * It's unpackable in any constructor+-- * It uses unpinned memory by default+--+{-# LANGUAGE MagicHash           #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE UnboxedTuples       #-}+module Foundation.Primitive.Block+    ( Block(..)+    , MutableBlock(..)+    -- * Properties+    , length+    , lengthSize+    -- * Lowlevel functions+    , unsafeThaw+    , unsafeFreeze+    , unsafeIndex+    , thaw+    , freeze+    , copy+    -- * safer api+    , create+    , singleton+    , replicate+    , index+    , map+    , foldl+    , foldl'+    , foldr+    , cons+    , snoc+    , uncons+    , unsnoc+    , sub+    , splitAt+    , revSplitAt+    , splitOn+    , break+    , span+    , elem+    , all+    , any+    , find+    , filter+    , reverse+    , sortBy+    , intersperse+    -- * Foreign interfaces+    , unsafeCopyToPtr+    ) where++import           GHC.Prim+import           GHC.Types+import           GHC.ST+import qualified Data.List+import           Foundation.Internal.Base+import           Foundation.Internal.Proxy+import           Foundation.Internal.Primitive+import           Foundation.Primitive.Types.OffsetSize+import           Foundation.Primitive.Monad+import           Foundation.Primitive.Exception+import           Foundation.Primitive.IntegralConv+import           Foundation.Primitive.Types+import qualified Foundation.Primitive.Block.Mutable as M+import           Foundation.Primitive.Block.Mutable (Block(..), MutableBlock(..), new, unsafeThaw, unsafeFreeze)+import           Foundation.Primitive.Block.Base+import           Foundation.Numerical++-- | return the number of elements of the array.+length :: PrimType ty => Block ty -> Int+length a = let (Size len) = lengthSize a in len+{-# INLINE[1] length #-}++-- | Copy all the block content to the memory starting at the destination address+unsafeCopyToPtr :: forall ty prim . PrimMonad prim+                => Block ty -- ^ the source block to copy+                -> Ptr ty   -- ^ The destination address where the copy is going to start+                -> prim ()+unsafeCopyToPtr (Block blk) (Ptr p) = primitive $ \s1 ->+    (# compatCopyByteArrayToAddr# blk 0# p (sizeofByteArray# blk) s1, () #)++-- | Create a new array of size @n by settings each cells through the+-- function @f.+create :: forall ty . PrimType ty+       => Size ty           -- ^ the size of the block (in element of ty)+       -> (Offset ty -> ty) -- ^ the function that set the value at the index+       -> Block ty          -- ^ the array created+create n initializer+    | n == 0    = mempty+    | otherwise = runST $ do+        mb <- new n+        M.iterSet initializer mb+        unsafeFreeze mb++singleton :: PrimType ty => ty -> Block ty+singleton ty = create 1 (const ty)++replicate :: PrimType ty => Word -> ty -> Block ty+replicate sz ty = create (Size (integralCast sz)) (const ty)++-- | Thaw a Block into a MutableBlock+--+-- the Block is not modified, instead a new Mutable Block is created+-- and its content is copied to the mutable block+thaw :: (PrimMonad prim, PrimType ty) => Block ty -> prim (MutableBlock ty (PrimState prim))+thaw array = do+    ma <- M.unsafeNew (lengthBytes array)+    M.unsafeCopyBytesRO ma 0 array 0 (lengthBytes array)+    return ma+{-# INLINE thaw #-}++freeze :: (PrimType ty, PrimMonad prim) => MutableBlock ty (PrimState prim) -> prim (Block ty)+freeze ma = do+    ma' <- unsafeNew len+    M.unsafeCopyBytes ma' 0 ma 0 len+    --M.copyAt ma' (Offset 0) ma (Offset 0) len+    unsafeFreeze ma'+  where+    len = M.mutableLengthBytes ma++-- | Copy every cells of an existing Block to a new Block+copy :: PrimType ty => Block ty -> Block ty+copy array = runST (thaw array >>= unsafeFreeze)++-- | Return the element at a specific index from an array.+--+-- If the index @n is out of bounds, an error is raised.+index :: PrimType ty => Block ty -> Offset ty -> ty+index array n+    | isOutOfBound n len = outOfBound OOB_Index n len+    | otherwise          = unsafeIndex array n+  where+    !len = lengthSize array+{-# INLINE index #-}++-- | Map all element 'a' from a block to a new block of 'b'+map :: (PrimType a, PrimType b) => (a -> b) -> Block a -> Block b+map f a = create lenB (\i -> f $ unsafeIndex a (offsetCast Proxy i))+  where !lenB = sizeCast (Proxy :: Proxy (a -> b)) (lengthSize a)++foldl :: PrimType ty => (a -> ty -> a) -> a -> Block ty -> a+foldl f initialAcc vec = loop 0 initialAcc+  where+    !len = lengthSize vec+    loop i acc+        | i .==# len = acc+        | otherwise  = loop (i+1) (f acc (unsafeIndex vec i))++foldr :: PrimType ty => (ty -> a -> a) -> a -> Block ty -> a+foldr f initialAcc vec = loop 0+  where+    !len = lengthSize vec+    loop i+        | i .==# len = initialAcc+        | otherwise  = unsafeIndex vec i `f` loop (i+1)++foldl' :: PrimType ty => (a -> ty -> a) -> a -> Block ty -> a+foldl' f initialAcc vec = loop 0 initialAcc+  where+    !len = lengthSize vec+    loop i !acc+        | i .==# len = acc+        | otherwise  = loop (i+1) (f acc (unsafeIndex vec i))++cons :: PrimType ty => ty -> Block ty -> Block ty+cons e vec+    | len == 0  = singleton e+    | otherwise = runST $ do+        muv <- new (len + 1)+        M.unsafeCopyElementsRO muv 1 vec 0 len+        M.unsafeWrite muv 0 e+        unsafeFreeze muv+  where+    !len = lengthSize vec++snoc :: PrimType ty => Block ty -> ty -> Block ty+snoc vec e+    | len == Size 0 = singleton e+    | otherwise     = runST $ do+        muv <- new (len + 1)+        M.unsafeCopyElementsRO muv 0 vec 0 len+        M.unsafeWrite muv (0 `offsetPlusE` lengthSize vec) e+        unsafeFreeze muv+  where+     !len = lengthSize vec++sub :: PrimType ty => Block ty -> Offset ty -> Offset ty -> Block ty+sub blk start end+    | start >= end = mempty+    | otherwise    = runST $ do+        dst <- new newLen+        M.unsafeCopyElementsRO dst 0 blk start newLen+        unsafeFreeze dst+  where+    newLen = end' - start+    end' = min end (start `offsetPlusE` (end - start))+    !len = lengthSize blk++uncons :: PrimType ty => Block ty -> Maybe (ty, Block ty)+uncons vec+    | nbElems == 0 = Nothing+    | otherwise    = Just (unsafeIndex vec 0, sub vec 1 (0 `offsetPlusE` nbElems))+  where+    !nbElems = lengthSize vec++unsnoc :: PrimType ty => Block ty -> Maybe (Block ty, ty)+unsnoc vec+    | nbElems == 0 = Nothing+    | otherwise    = Just (sub vec 0 lastElem, unsafeIndex vec lastElem)+  where+    !lastElem = 0 `offsetPlusE` (nbElems - 1)+    !nbElems = lengthSize vec++splitAt :: PrimType ty => Size ty -> Block ty -> (Block ty, Block ty)+splitAt nbElems blk+    | nbElems <= 0 = (mempty, blk)+    | n == vlen    = (blk, mempty)+    | otherwise    = runST $ do+        left  <- new nbElems+        right <- new (vlen - nbElems)+        M.unsafeCopyElementsRO left  0 blk 0                      nbElems+        M.unsafeCopyElementsRO right 0 blk (sizeAsOffset nbElems) (vlen - nbElems)++        (,) <$> unsafeFreeze left <*> unsafeFreeze right+  where+    n    = min nbElems vlen+    vlen = lengthSize blk++revSplitAt :: PrimType ty => Size ty -> Block ty -> (Block ty, Block ty)+revSplitAt n blk+    | n <= 0    = (mempty, blk)+    | otherwise = let (x,y) = splitAt (lengthSize blk - n) blk in (y,x)++break :: PrimType ty => (ty -> Bool) -> Block ty -> (Block ty, Block ty)+break predicate blk = findBreak 0+  where+    !len = lengthSize blk+    findBreak !i+        | i .==# len                    = (blk, mempty)+        | predicate (unsafeIndex blk i) = splitAt (offsetAsSize i) blk+        | otherwise                     = findBreak (i + 1)+    {-# INLINE findBreak #-}++span :: PrimType ty => (ty -> Bool) -> Block ty -> (Block ty, Block ty)+span p = break (not . p)++elem :: PrimType ty => ty -> Block ty -> Bool+elem v blk = loop 0+  where+    !len = lengthSize blk+    loop i+        | i .==# len             = False+        | unsafeIndex blk i == v = True+        | otherwise              = loop (i+1)++all :: PrimType ty => (ty -> Bool) -> Block ty -> Bool+all p blk = loop 0+  where+    !len = lengthSize blk+    loop i+        | i .==# len            = True+        | p (unsafeIndex blk i) = loop (i+1)+        | otherwise             = False++any :: PrimType ty => (ty -> Bool) -> Block ty -> Bool+any p blk = loop 0+  where+    !len = lengthSize blk+    loop i+        | i .==# len            = False+        | p (unsafeIndex blk i) = True+        | otherwise             = loop (i+1)++splitOn :: PrimType ty => (ty -> Bool) -> Block ty -> [Block ty]+splitOn predicate blk+    | len == 0  = [mempty]+    | otherwise = go 0 0+  where+    !len = lengthSize blk+    go !prevIdx !idx+        | idx .==# len = [sub blk prevIdx idx]+        | otherwise    =+            let e = unsafeIndex blk idx+                idx' = idx + 1+             in if predicate e+                    then sub blk prevIdx idx : go idx' idx'+                    else go prevIdx idx'++find :: PrimType ty => (ty -> Bool) -> Block ty -> Maybe ty+find predicate vec = loop 0+  where+    !len = lengthSize vec+    loop i+        | i .==# len = Nothing+        | otherwise  =+            let e = unsafeIndex vec i+             in if predicate e then Just e else loop (i+1)++filter :: PrimType ty => (ty -> Bool) -> Block ty -> Block ty+filter predicate vec = fromList $ Data.List.filter predicate $ toList vec++reverse :: forall ty . PrimType ty => Block ty -> Block ty+reverse blk+    | len == 0  = mempty+    | otherwise = runST $ do+        mb <- new len+        go mb+        unsafeFreeze mb+  where+    !len = lengthSize blk+    !endOfs = 0 `offsetPlusE` len++    go :: MutableBlock ty s -> ST s ()+    go mb = loop endOfs 0+      where+        loop o i+            | i .==# len = pure ()+            | otherwise  = unsafeWrite mb o' (unsafeIndex blk i) >> loop o' (i+1)+          where o' = pred o++sortBy :: forall ty . PrimType ty => (ty -> ty -> Ordering) -> Block ty -> Block ty+sortBy xford vec+    | len == 0  = mempty+    | otherwise = runST (thaw vec >>= doSort xford)+  where+    len = lengthSize vec+    doSort :: (PrimType ty, PrimMonad prim) => (ty -> ty -> Ordering) -> MutableBlock ty (PrimState prim) -> prim (Block ty)+    doSort ford ma = qsort 0 (sizeLastOffset len) >> unsafeFreeze ma+      where+        qsort lo hi+            | lo >= hi  = return ()+            | otherwise = do+                p <- partition lo hi+                qsort lo (pred p)+                qsort (p+1) hi+        partition lo hi = do+            pivot <- unsafeRead ma hi+            let loop i j+                    | j == hi   = pure i+                    | otherwise = do+                        aj <- unsafeRead ma j+                        i' <- if ford aj pivot == GT+                                then pure i+                                else do+                                    ai <- unsafeRead ma i+                                    unsafeWrite ma j ai+                                    unsafeWrite ma i aj+                                    pure $ i + 1+                        loop i' (j+1)++            i <- loop lo lo+            ai  <- unsafeRead ma i+            ahi <- unsafeRead ma hi+            unsafeWrite ma hi ai+            unsafeWrite ma i ahi+            pure i++intersperse :: forall ty . PrimType ty => ty -> Block ty -> Block ty+intersperse sep blk+    | len <= 1  = blk+    | otherwise = runST $ do+        mb <- new newSize+        go mb+        unsafeFreeze mb+  where+    !len = lengthSize blk+    newSize = len + len - 1++    go :: MutableBlock ty s -> ST s ()+    go mb = loop 0 0+      where+        loop !o !i+            | i .==# (len - 1) = unsafeWrite mb o (unsafeIndex blk i)+            | otherwise        = do+                unsafeWrite mb o     (unsafeIndex blk i)+                unsafeWrite mb (o+1) sep+                loop (o+2) (i+1)

@@ -0,0 +1,282 @@+{-# LANGUAGE MagicHash           #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE UnboxedTuples       #-}+module Foundation.Primitive.Block.Base+    ( Block(..)+    , MutableBlock(..)+    -- * Basic accessor+    , unsafeNew+    , unsafeThaw+    , unsafeFreeze+    , unsafeCopyElements+    , unsafeCopyElementsRO+    , unsafeCopyBytes+    , unsafeCopyBytesRO+    , unsafeRead+    , unsafeWrite+    , unsafeIndex+    -- * Properties+    , lengthSize+    , lengthBytes+    -- * Other methods+    , new+    ) where++import           GHC.Prim+import           GHC.Types+import           GHC.ST+import qualified Data.List+import           Foundation.Internal.Base+import           Foundation.Internal.Proxy+import           Foundation.Primitive.Types.OffsetSize+import           Foundation.Primitive.Monad+import           Foundation.Primitive.NormalForm+import           Foundation.Numerical+import           Foundation.Primitive.Types++-- | A block of memory containing unpacked bytes representing values of type 'ty'+data Block ty = Block ByteArray#+    deriving (Typeable)++instance Data ty => Data (Block ty) where+    dataTypeOf _ = blockType+    toConstr _   = error "toConstr"+    gunfold _ _  = error "gunfold"++blockType :: DataType+blockType = mkNoRepType "Foundation.Block"++instance NormalForm (Block ty) where+    toNormalForm (Block !_) = ()+instance (PrimType ty, Show ty) => Show (Block ty) where+    show v = show (toList v)+instance (PrimType ty, Eq ty) => Eq (Block ty) where+    (==) = equal+instance (PrimType ty, Ord ty) => Ord (Block ty) where+    compare = internalCompare++instance PrimType ty => Monoid (Block ty) where+    mempty  = empty+    mappend = append+    mconcat = concat++instance PrimType ty => IsList (Block ty) where+    type Item (Block ty) = ty+    fromList = internalFromList+    toList = internalToList++lengthSize :: forall ty . PrimType ty => Block ty -> Size ty+lengthSize (Block ba) =+    let !(Size (I# szBits)) = primSizeInBytes (Proxy :: Proxy ty)+        !elems              = quotInt# (sizeofByteArray# ba) szBits+     in Size (I# elems)+{-# INLINE[1] lengthSize #-}++lengthBytes :: Block ty -> Size Word8+lengthBytes (Block ba) = Size (I# (sizeofByteArray# ba))+{-# INLINE[1] lengthBytes #-}++-- | Create an empty block of memory+empty :: Block ty+empty = Block ba where !(Block ba) = empty_++empty_ :: Block ()+empty_ = runST $ primitive $ \s1 ->+    case newByteArray# 0# s1           of { (# s2, mba #) ->+    case unsafeFreezeByteArray# mba s2 of { (# s3, ba  #) ->+        (# s3, Block ba #) }}++-- | Return the element at a specific index from an array without bounds checking.+--+-- Reading from invalid memory can return unpredictable and invalid values.+-- use 'index' if unsure.+unsafeIndex :: forall ty . PrimType ty => Block ty -> Offset ty -> ty+unsafeIndex (Block ba) n = primBaIndex ba n+{-# INLINE unsafeIndex #-}++-- | make a block from a list of elements.+internalFromList :: PrimType ty => [ty] -> Block ty+internalFromList l = runST $ do+    ma <- new (Size len)+    iter 0 l $ \i x -> unsafeWrite ma i x+    unsafeFreeze ma+  where len = Data.List.length l+        iter _  []     _ = return ()+        iter !i (x:xs) z = z i x >> iter (i+1) xs z++-- | transform a block to a list.+internalToList :: forall ty . PrimType ty => Block ty -> [ty]+internalToList blk@(Block ba)+    | len == 0  = []+    | otherwise = loop 0+  where+    !len = lengthSize blk+    loop !i | i .==# len = []+            | otherwise  = primBaIndex ba i : loop (i+1)++-- | Check if two vectors are identical+equal :: (PrimType ty, Eq ty) => Block ty -> Block ty -> Bool+equal a b+    | la /= lb  = False+    | otherwise = loop 0+  where+    !la = lengthSize a+    !lb = lengthSize b+    loop n | n .==# la = True+           | otherwise = (unsafeIndex a n == unsafeIndex b n) && loop (n+1)++-- | Compare 2 vectors+internalCompare :: (Ord ty, PrimType ty) => Block ty -> Block ty -> Ordering+internalCompare a b = loop 0+  where+    !la = lengthSize a+    !lb = lengthSize b+    loop n+        | n .==# la = if la == lb then EQ else LT+        | n .==# lb = GT+        | otherwise =+            case unsafeIndex a n `compare` unsafeIndex b n of+                EQ -> loop (n+1)+                r  -> r++-- | Append 2 arrays together by creating a new bigger array+append :: Block ty -> Block ty -> Block ty+append a b+    | la == 0 = b+    | lb == 0 = a+    | otherwise = runST $ do+        r  <- unsafeNew (la+lb)+        unsafeCopyBytesRO r 0                 a 0 la+        unsafeCopyBytesRO r (sizeAsOffset la) b 0 lb+        unsafeFreeze r+  where+    !la = lengthBytes a+    !lb = lengthBytes b++concat :: [Block ty] -> Block ty+concat [] = empty+concat l  =+    case filterAndSum 0 [] l of+        (_,[])            -> empty+        (_,[x])           -> x+        (totalLen,chunks) -> runST $ do+            r <- unsafeNew totalLen+            doCopy r 0 chunks+            unsafeFreeze r+  where+    -- TODO would go faster not to reverse but pack from the end instead+    filterAndSum !totalLen acc []     = (totalLen, Data.List.reverse acc)+    filterAndSum !totalLen acc (x:xs)+        | len == 0  = filterAndSum totalLen acc xs+        | otherwise = filterAndSum (len+totalLen) (x:acc) xs+      where len = lengthBytes x++    doCopy _ _ []     = return ()+    doCopy r i (x:xs) = do+        unsafeCopyBytesRO r i x 0 lx+        doCopy r (i `offsetPlusE` lx) xs+      where !lx = lengthBytes x++-- | A Mutable block of memory containing unpacked bytes representing values of type 'ty'+data MutableBlock ty st = MutableBlock (MutableByteArray# st)++-- | Freeze a mutable block into a block.+--+-- If the mutable block is still use after freeze,+-- then the modification will be reflected in an unexpected+-- way in the Block.+unsafeFreeze :: PrimMonad prim => MutableBlock ty (PrimState prim) -> prim (Block ty)+unsafeFreeze (MutableBlock mba) = primitive $ \s1 ->+    case unsafeFreezeByteArray# mba s1 of+        (# s2, ba #) -> (# s2, Block ba #)+{-# INLINE unsafeFreeze #-}++-- | Thaw an immutable block.+--+-- If the immutable block is modified, then the original immutable block will+-- be modified too, but lead to unexpected results when querying+unsafeThaw :: (PrimType ty, PrimMonad prim) => Block ty -> prim (MutableBlock ty (PrimState prim))+unsafeThaw (Block ba) = primitive $ \st -> (# st, MutableBlock (unsafeCoerce# ba) #)++-- | Create a new mutable block of a specific size in bytes.+--+-- Note that no checks are made to see if the size in bytes is compatible with the size+-- of the underlaying element 'ty' in the block.+--+-- use 'new' if unsure+unsafeNew :: PrimMonad prim => Size Word8 -> prim (MutableBlock ty (PrimState prim))+unsafeNew (Size (I# bytes)) =+    primitive $ \s1 -> case newByteArray# bytes s1 of { (# s2, mba #) -> (# s2, MutableBlock mba #) }++-- | Create a new mutable block of a specific N size of 'ty' elements+new :: forall prim ty . (PrimMonad prim, PrimType ty) => Size ty -> prim (MutableBlock ty (PrimState prim))+new n = unsafeNew (sizeOfE (primSizeInBytes (Proxy :: Proxy ty)) n)++-- | Copy a number of elements from an array to another array with offsets+unsafeCopyElements :: forall prim ty . (PrimMonad prim, PrimType ty)+                   => MutableBlock ty (PrimState prim) -- ^ destination mutable block+                   -> Offset ty                        -- ^ offset at destination+                   -> MutableBlock ty (PrimState prim) -- ^ source mutable block+                   -> Offset ty                        -- ^ offset at source+                   -> Size ty                          -- ^ number of elements to copy+                   -> prim ()+unsafeCopyElements dstMb destOffset srcMb srcOffset n = -- (MutableBlock dstMba) ed (MutableBlock srcBa) es n =+    unsafeCopyBytes dstMb (offsetOfE sz destOffset)+                    srcMb (offsetOfE sz srcOffset)+                    (sizeOfE sz n)+  where+    !sz = primSizeInBytes (Proxy :: Proxy ty)++unsafeCopyElementsRO :: forall prim ty . (PrimMonad prim, PrimType ty)+                     => MutableBlock ty (PrimState prim) -- ^ destination mutable block+                     -> Offset ty                        -- ^ offset at destination+                     -> Block ty                         -- ^ source block+                     -> Offset ty                        -- ^ offset at source+                     -> Size ty                          -- ^ number of elements to copy+                     -> prim ()+unsafeCopyElementsRO dstMb destOffset srcMb srcOffset n =+    unsafeCopyBytesRO dstMb (offsetOfE sz destOffset)+                      srcMb (offsetOfE sz srcOffset)+                      (sizeOfE sz n)+  where+    !sz = primSizeInBytes (Proxy :: Proxy ty)++-- | Copy a number of bytes from a MutableBlock to another MutableBlock with specific byte offsets+unsafeCopyBytes :: forall prim ty . PrimMonad prim+                => MutableBlock ty (PrimState prim) -- ^ destination mutable block+                -> Offset Word8                     -- ^ offset at destination+                -> MutableBlock ty (PrimState prim) -- ^ source mutable block+                -> Offset Word8                     -- ^ offset at source+                -> Size Word8                       -- ^ number of elements to copy+                -> prim ()+unsafeCopyBytes (MutableBlock dstMba) (Offset (I# d)) (MutableBlock srcBa) (Offset (I# s)) (Size (I# n)) =+    primitive $ \st -> (# copyMutableByteArray# srcBa s dstMba d n st, () #)+{-# INLINE unsafeCopyBytes #-}++-- | Copy a number of bytes from a Block to a MutableBlock with specific byte offsets+unsafeCopyBytesRO :: forall prim ty . PrimMonad prim+                  => MutableBlock ty (PrimState prim) -- ^ destination mutable block+                  -> Offset Word8                     -- ^ offset at destination+                  -> Block ty                         -- ^ source block+                  -> Offset Word8                     -- ^ offset at source+                  -> Size Word8                       -- ^ number of elements to copy+                  -> prim ()+unsafeCopyBytesRO (MutableBlock dstMba) (Offset (I# d)) (Block srcBa) (Offset (I# s)) (Size (I# n)) =+    primitive $ \st -> (# copyByteArray# srcBa s dstMba d n st, () #)+{-# INLINE unsafeCopyBytesRO #-}++-- | read from a cell in a mutable block without bounds checking.+--+-- Reading from invalid memory can return unpredictable and invalid values.+-- use 'read' if unsure.+unsafeRead :: (PrimMonad prim, PrimType ty) => MutableBlock ty (PrimState prim) -> Offset ty -> prim ty+unsafeRead (MutableBlock mba) i = primMbaRead mba i+{-# INLINE unsafeRead #-}++-- | write to a cell in a mutable block without bounds checking.+--+-- Writing with invalid bounds will corrupt memory and your program will+-- become unreliable. use 'write' if unsure.+unsafeWrite :: (PrimMonad prim, PrimType ty) => MutableBlock ty (PrimState prim) -> Offset ty -> ty -> prim ()+unsafeWrite (MutableBlock mba) i v = primMbaWrite mba i v+{-# INLINE unsafeWrite #-}

@@ -0,0 +1,122 @@+-- |+-- Module      : Foundation.Primitive.Block.Mutable+-- License     : BSD-style+-- Maintainer  : Haskell Foundation+--+-- A block of memory that contains elements of a type,+-- very similar to an unboxed array but with the key difference:+--+-- * It doesn't have slicing capability (no cheap take or drop)+-- * It consume less memory: 1 Offset, 1 Size, 1 Pinning status trimmed+-- * It's unpackable in any constructor+-- * It uses unpinned memory by default+--+-- It should be rarely needed in high level API, but+-- in lowlevel API or some data structure containing lots+-- of unboxed array that will benefit from optimisation.+--+-- Because it's unpinned, the blocks are compactable / movable,+-- at the expense of making them less friendly to C layer / address.+--+-- Note that sadly the bytearray primitive type automatically create+-- a pinned bytearray if the size is bigger than a certain threshold+--+-- GHC Documentation associated:+--+-- includes/rts/storage/Block.h+--   * LARGE_OBJECT_THRESHOLD ((uint32_t)(BLOCK_SIZE * 8 / 10))+--   * BLOCK_SIZE   (1<<BLOCK_SHIFT)+--+-- includes/rts/Constant.h+--   * BLOCK_SHIFT  12+--+{-# LANGUAGE MagicHash           #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE UnboxedTuples       #-}+module Foundation.Primitive.Block.Mutable+    ( Block(..)+    , MutableBlock(..)+    , mutableLengthSize+    , mutableLengthBytes+    , new+    , isPinned+    , iterSet+    , read+    , write+    , unsafeNew+    , unsafeWrite+    , unsafeRead+    , unsafeFreeze+    , unsafeThaw+    , unsafeCopyElements+    , unsafeCopyElementsRO+    , unsafeCopyBytes+    , unsafeCopyBytesRO+    ) where++import           GHC.Prim+import           GHC.Types+import           Foundation.Internal.Base+import           Foundation.Internal.Proxy+import           Foundation.Primitive.Exception+import           Foundation.Primitive.Types.OffsetSize+import           Foundation.Primitive.Monad+import           Foundation.Numerical+import           Foundation.Primitive.Types+import           Foundation.Primitive.Block.Base++-- | Return the length of a Mutable Block+--+-- note: we don't allow resizing yet, so this can remain a pure function+mutableLengthSize :: forall ty st . PrimType ty => MutableBlock ty st -> Size ty+mutableLengthSize (MutableBlock mba) =+    let !(Size (I# szBits)) = primSizeInBytes (Proxy :: Proxy ty)+        !elems              = quotInt# (sizeofMutableByteArray# mba) szBits+     in Size (I# elems)+{-# INLINE[1] mutableLengthSize #-}++mutableLengthBytes :: MutableBlock ty st -> Size Word8+mutableLengthBytes (MutableBlock mba) = Size (I# (sizeofMutableByteArray# mba))+{-# INLINE[1] mutableLengthBytes #-}++-- | Return if a Mutable Block is pinned or not+isPinned :: MutableBlock ty st -> Bool+isPinned (MutableBlock mba) =+    -- TODO use the exact value where the array become pinned (LARGE_OBJECT_THRESHOLD)+    -- in 8.2, there's a primitive to know if an array in pinned+    I# (sizeofMutableByteArray# mba) > 3000+++-- | Set all mutable block element to a value+iterSet :: (PrimType ty, PrimMonad prim)+        => (Offset ty -> ty)+        -> MutableBlock ty (PrimState prim)+        -> prim ()+iterSet f ma = loop 0+  where+    !sz = mutableLengthSize ma+    loop i+        | i .==# sz = pure ()+        | otherwise = unsafeWrite ma i (f i) >> loop (i+1)+    {-# INLINE loop #-}++-- | read a cell in a mutable array.+--+-- If the index is out of bounds, an error is raised.+read :: (PrimMonad prim, PrimType ty) => MutableBlock ty (PrimState prim) -> Offset ty -> prim ty+read array n+    | isOutOfBound n len = primOutOfBound OOB_Read n len+    | otherwise          = unsafeRead array n+  where len = mutableLengthSize array+{-# INLINE read #-}++-- | Write to a cell in a mutable array.+--+-- If the index is out of bounds, an error is raised.+write :: (PrimMonad prim, PrimType ty) => MutableBlock ty (PrimState prim) -> Offset ty -> ty -> prim ()+write array n val+    | isOutOfBound n len = primOutOfBound OOB_Write n len+    | otherwise          = unsafeWrite array n val+  where+    len = mutableLengthSize array+{-# INLINE write #-}

@@ -0,0 +1,38 @@+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE ImplicitParams #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE CPP #-}+module Foundation.Primitive.Error+    ( error+    ) where++import           GHC.Prim+import           Foundation.Primitive.UTF8.Base+import           Foundation.Internal.CallStack++#if MIN_VERSION_base(4,9,0)++import           GHC.Types (RuntimeRep)+import           GHC.Exception (errorCallWithCallStackException)++-- | stop execution and displays an error message+error :: forall (r :: RuntimeRep) . forall (a :: TYPE r) . HasCallStack => String -> a+error s = raise# (errorCallWithCallStackException (sToList s) ?callstack)++#elif MIN_VERSION_base(4,7,0)++import           GHC.Exception (errorCallException)++error :: String -> a+error s = raise# (errorCallException (sToList s))++#else++import           GHC.Types+import           GHC.Exception++error :: String -> a+error s = throw (ErrorCall (sToList s))++#endif

@@ -0,0 +1,62 @@+-- |+-- Module      : Foundation.Primitive.Exception+-- License     : BSD-style+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>+-- Stability   : experimental+-- Portability : portable+--+-- Common part for vectors+--+{-# LANGUAGE DeriveDataTypeable #-}+module Foundation.Primitive.Exception+    ( OutOfBound(..)+    , OutOfBoundOperation(..)+    , isOutOfBound+    , outOfBound+    , primOutOfBound+    , InvalidRecast(..)+    , RecastSourceSize(..)+    , RecastDestinationSize(..)+    ) where++import           Foundation.Internal.Base+import           Foundation.Primitive.Types.OffsetSize+import           Foundation.Primitive.Monad++-- | The type of operation that triggers an OutOfBound exception.+--+-- * OOB_Index: reading an immutable vector+-- * OOB_Read: reading a mutable vector+-- * OOB_Write: write a mutable vector+data OutOfBoundOperation = OOB_Read | OOB_Write | OOB_MemSet | OOB_Index+    deriving (Show,Eq,Typeable)++-- | Exception during an operation accessing the vector out of bound+--+-- Represent the type of operation, the index accessed, and the total length of the vector.+data OutOfBound = OutOfBound OutOfBoundOperation Int Int+    deriving (Show,Typeable)++instance Exception OutOfBound++outOfBound :: OutOfBoundOperation -> Offset ty -> Size ty -> a+outOfBound oobop (Offset ofs) (Size sz) = throw (OutOfBound oobop ofs sz)+{-# INLINE outOfBound #-}++primOutOfBound :: PrimMonad prim => OutOfBoundOperation -> Offset ty -> Size ty -> prim a+primOutOfBound oobop (Offset ofs) (Size sz) = primThrow (OutOfBound oobop ofs sz)+{-# INLINE primOutOfBound #-}++isOutOfBound :: Offset ty -> Size ty -> Bool+isOutOfBound (Offset ty) (Size sz) = ty < 0 || ty >= sz+{-# INLINE isOutOfBound #-}++newtype RecastSourceSize      = RecastSourceSize Int+    deriving (Show,Eq,Typeable)+newtype RecastDestinationSize = RecastDestinationSize Int+    deriving (Show,Eq,Typeable)++data InvalidRecast = InvalidRecast RecastSourceSize RecastDestinationSize+    deriving (Show,Typeable)++instance Exception InvalidRecast

@@ -0,0 +1,105 @@+-- |+-- Module      : Foundation.Primitive.Imports+-- License     : BSD-style+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>+-- Stability   : experimental+-- Portability : portable+--+-- re-export of all the base prelude and basic primitive stuffs+module Foundation.Primitive.Imports+    ( (Prelude.$)+    , (Prelude.$!)+    , (Prelude.&&)+    , (Prelude.||)+    , (Control.Category..)+    , (Control.Applicative.<$>)+    , Prelude.not+    , Prelude.otherwise+    , Prelude.fst+    , Prelude.snd+    , Control.Category.id+    , Prelude.maybe+    , Prelude.either+    , Prelude.flip+    , Prelude.const+    , Foundation.Primitive.Error.error+    , Prelude.and+    , Prelude.undefined+    , Prelude.seq+    , Prelude.Show+    , Foundation.Primitive.Show.show+    , Prelude.Ord (..)+    , Prelude.Eq (..)+    , Prelude.Bounded (..)+    , Prelude.Enum (..)+    , Prelude.Functor (..)+    , Control.Applicative.Applicative (..)+    , Prelude.Monad (..)+    , Prelude.Maybe (..)+    , Prelude.Ordering (..)+    , Prelude.Bool (..)+    , Prelude.Int+    , Prelude.Integer+    , Foundation.Internal.Natural.Natural+    , Foundation.Primitive.Types.OffsetSize.Offset+    , Foundation.Primitive.Types.OffsetSize.Size+    , Prelude.Char+    , Foundation.Primitive.UTF8.Base.String+    , Foundation.Array.Unboxed.UArray+    , Foundation.Array.Boxed.Array+    , Foundation.Internal.NumLiteral.Integral (..)+    , Foundation.Internal.NumLiteral.Fractional (..)+    , Foundation.Internal.NumLiteral.HasNegation (..)+    , Data.Int.Int8, Data.Int.Int16, Data.Int.Int32, Data.Int.Int64+    , Data.Word.Word8, Data.Word.Word16, Data.Word.Word32, Data.Word.Word64, Data.Word.Word+    , Prelude.Double, Prelude.Float+    , Prelude.IO+    , FP32+    , FP64+    , Foundation.Internal.IsList.IsList (..)+    , GHC.Exts.IsString (..)+    , GHC.Generics.Generic (..)+    , Prelude.Either (..)+    , Data.Data.Data (..)+    , Data.Data.mkNoRepType+    , Data.Data.DataType+    , Data.Typeable.Typeable+    , Data.Monoid.Monoid (..)+    , (Data.Monoid.<>)+    , Control.Exception.Exception+    , Control.Exception.throw+    , Control.Exception.throwIO+    , GHC.Ptr.Ptr(..)+    , ifThenElse+    ) where++import qualified Prelude+import qualified Control.Category+import qualified Control.Applicative+import qualified Control.Exception+import qualified Data.Monoid+import qualified Data.Data+import qualified Data.Typeable+import qualified Data.Word+import qualified Data.Int+import qualified Foundation.Internal.IsList+import qualified Foundation.Internal.Natural+import qualified Foundation.Internal.NumLiteral+import qualified Foundation.Array.Unboxed+import qualified Foundation.Array.Boxed+import qualified Foundation.Primitive.UTF8.Base+import qualified Foundation.Primitive.Error+import qualified Foundation.Primitive.Show+import qualified Foundation.Primitive.Types.OffsetSize+import qualified GHC.Exts+import qualified GHC.Generics+import qualified GHC.Ptr+import           GHC.Exts (fromString)++-- | for support of if .. then .. else+ifThenElse :: Prelude.Bool -> a -> a -> a+ifThenElse Prelude.True  e1 _  = e1+ifThenElse Prelude.False _  e2 = e2++type FP32 = Prelude.Float+type FP64 = Prelude.Double

@@ -0,0 +1,30 @@+-- |+-- Module      : Foundation.Primitive.Runtime+-- License     : BSD-style+-- Maintainer  : foundation+--+-- Global configuration environment+module Foundation.Primitive.Runtime+    where++import           Foundation.Internal.Base+import           Foundation.Internal.Environment+import           Foundation.Primitive.Types.OffsetSize+import           System.IO.Unsafe          (unsafePerformIO)++-- | Defines the maximum size in bytes of unpinned arrays.+--+-- You can change this value by setting the environment variable+-- @HS_FOUNDATION_UARRAY_UNPINNED_MAX@ to an unsigned integer number.+--+-- Note: We use 'unsafePerformIO' here. If the environment variable+-- changes during runtime and the runtime system decides to recompute+-- this value, referential transparency is violated (like the First+-- Order violated the Galactic Concordance!).+--+-- TODO The default value of 1024 bytes is arbitrarily chosen for now.+unsafeUArrayUnpinnedMaxSize :: Size8+unsafeUArrayUnpinnedMaxSize = unsafePerformIO $ do+    maxSize <- (>>= readMaybe) <$> lookupEnv "HS_FOUNDATION_UARRAY_UNPINNED_MAX"+    return $ maybe (Size 1024) Size maxSize+{-# NOINLINE unsafeUArrayUnpinnedMaxSize #-}

@@ -0,0 +1,14 @@+module Foundation.Primitive.Show+    where++import qualified Prelude+import           Foundation.Internal.Base+import           Foundation.Primitive.UTF8.Base (String)++-- | Use the Show class to create a String.+--+-- Note that this is not efficient, since+-- an intermediate [Char] is going to be+-- created before turning into a real String.+show :: Prelude.Show a => a -> String+show = fromList . Prelude.show

@@ -0,0 +1,36 @@+-- |+-- Module      : Foundation.Primitive.These+-- License     : BSD-style+-- Maintainer  : Nicolas Di Prima <nicolas@primetype.co.uk>+-- Stability   : stable+-- Portability : portable+--+-- @These a b@, sum type to represent either @a@ or @b@ or both.+--+module Foundation.Primitive.These+    ( These(..)+    ) where++import Foundation.Internal.Base+import Foundation.Primitive.NormalForm+import Foundation.Class.Bifunctor++-- | Either a or b or both.+data These a b+    = This a+    | That b+    | These a b+  deriving (Eq, Ord, Show, Typeable)++instance (NormalForm a, NormalForm b) => NormalForm (These a b) where+    toNormalForm (This a) = toNormalForm a+    toNormalForm (That b) = toNormalForm b+    toNormalForm (These a b) = toNormalForm a `seq` toNormalForm b++instance Bifunctor These where+    bimap fa _  (This a)    = This  (fa a)+    bimap _  fb (That b)    = That  (fb b)+    bimap fa fb (These a b) = These (fa a) (fb b)++instance Functor (These a) where+    fmap = second

@@ -22,6 +22,7 @@     , sizeRecast     , offsetAsSize     , sizeAsOffset+    , sizeInBytes     , primWordGetByteAndShift     , primWord64GetByteAndShift     , primWord64GetHiLo@@ -482,6 +483,9 @@                 (Size bytes) = sizeOfE szA sz              in Size (bytes `Prelude.quot` szB) +sizeInBytes :: forall a . PrimType a => Size a -> Size Word8+sizeInBytes sz = sizeOfE (primSizeInBytes (Proxy :: Proxy a)) sz+ primOffsetRecast :: (PrimType a, PrimType b) => Offset a -> Offset b primOffsetRecast = doRecast Proxy Proxy   where doRecast :: (PrimType a, PrimType b) => Proxy a -> Proxy b -> Offset a -> Offset b@@ -495,14 +499,6 @@ primOffsetOfE = getOffset Proxy   where getOffset :: PrimType a => Proxy a -> Offset a -> Offset8         getOffset proxy = offsetOfE (primSizeInBytes proxy)--sizeAsOffset :: Size a -> Offset a-sizeAsOffset (Size a) = Offset a-{-# INLINE sizeAsOffset #-}--offsetAsSize :: Offset a -> Size a-offsetAsSize (Offset a) = Size a-{-# INLINE offsetAsSize #-}  primWordGetByteAndShift :: Word# -> (# Word#, Word# #) primWordGetByteAndShift w = (# and# w 0xff##, uncheckedShiftRL# w 8# #)

@@ -18,6 +18,8 @@     , offsetCast     , sizeCast     , sizeLastOffset+    , sizeAsOffset+    , offsetAsSize     , (+.)     , (.==#)     , Size(..)@@ -105,6 +107,15 @@ sizeLastOffset (Size s)     | s > 0     = Offset (pred s)     | otherwise = error "last offset on size 0"++sizeAsOffset :: Size a -> Offset a+sizeAsOffset (Size a) = Offset a+{-# INLINE sizeAsOffset #-}++offsetAsSize :: Offset a -> Size a+offsetAsSize (Offset a) = Size a+{-# INLINE offsetAsSize #-}+  -- | Size of a data structure in bytes. type Size8 = Size Word8

@@ -0,0 +1,220 @@+-- |+-- Module      : Foundation.String.UTF8+-- License     : BSD-style+-- Maintainer  : Foundation+--+-- A String type backed by a UTF8 encoded byte array and all the necessary+-- functions to manipulate the string.+--+{-# LANGUAGE BangPatterns               #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MagicHash                  #-}+{-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE UnboxedTuples              #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE CPP                        #-}+module Foundation.Primitive.UTF8.Base+    where++import           GHC.ST (ST, runST)+import           GHC.Int+import           GHC.Types+import           GHC.Word+import           GHC.Prim+import           Foundation.Internal.Base+import           Foundation.Internal.Primitive+import           Foundation.Numerical+import           Foundation.Bits+import           Foundation.Primitive.NormalForm+import           Foundation.Primitive.Types.OffsetSize+import           Foundation.Primitive.Monad+import           Foundation.Primitive.UTF8.Table+import           Foundation.Primitive.UTF8.Helper+import           Foundation.Array.Unboxed           (UArray)+import qualified Foundation.Array.Unboxed           as Vec+import qualified Foundation.Array.Unboxed           as C+import           Foundation.Array.Unboxed.ByteArray (MutableByteArray)+import qualified Foundation.Array.Unboxed.Mutable   as MVec+import           Foundation.String.ModifiedUTF8     (fromModified)+import           GHC.CString                        (unpackCString#, unpackCStringUtf8#)++import           Data.Data+import           Foundation.Boot.List as List++-- | Opaque packed array of characters in the UTF8 encoding+newtype String = String (UArray Word8)+    deriving (Typeable, Monoid, Eq, Ord)++-- | Mutable String Buffer.+--+-- Use as an *append* buffer, as UTF8 variable encoding+-- doesn't really allow to change previously written+-- character without potentially shifting bytes.+newtype MutableString st = MutableString (MutableByteArray st)+    deriving (Typeable)++instance Show String where+    show = show . sToList+instance IsString String where+    fromString = sFromList+instance IsList String where+    type Item String = Char+    fromList = sFromList+    toList = sToList++instance Data String where+    toConstr s   = mkConstr stringType (show s) [] Prefix+    dataTypeOf _ = stringType+    gunfold _ _  = error "gunfold"++instance NormalForm String where+    toNormalForm (String ba) = toNormalForm ba++stringType :: DataType+stringType = mkNoRepType "Foundation.String"++-- | size in bytes.+--+-- this size is available in o(1)+size :: String -> Size Word8+size (String ba) = Vec.lengthSize ba++-- | Convert a String to a list of characters+--+-- The list is lazily created as evaluation needed+sToList :: String -> [Char]+sToList s = loop 0+  where+    !nbBytes = size s+    loop idx+        | idx .==# nbBytes = []+        | otherwise        =+            let (# c , idx' #) = next s idx in c : loop idx'++{-# RULES+"String sFromList" forall s .+  sFromList (unpackCString# s) = String $ fromModified s+  #-}+{-# RULES+"String sFromList" forall s .+  sFromList (unpackCStringUtf8# s) = String $ fromModified s+  #-}++-- | Create a new String from a list of characters+--+-- The list is strictly and fully evaluated before+-- creating the new String, as the size need to be+-- computed before filling.+sFromList :: [Char] -> String+sFromList l = runST (new bytes >>= startCopy)+  where+    -- count how many bytes+    !bytes = List.sum $ fmap (charToBytes . fromEnum) l++    startCopy :: MutableString (PrimState (ST st)) -> ST st String+    startCopy ms = loop 0 l+      where+        loop _   []     = freeze ms+        loop idx (c:xs) = write ms idx c >>= \idx' -> loop idx' xs+{-# INLINE [0] sFromList #-}++next :: String -> Offset8 -> (# Char, Offset8 #)+next (String ba) n =+    case getNbBytes# h of+        0# -> (# toChar h, n + 1 #)+        1# -> (# toChar (decode2 (Vec.unsafeIndex ba (n + 1))) , n + 2 #)+        2# -> (# toChar (decode3 (Vec.unsafeIndex ba (n + 1))+                                 (Vec.unsafeIndex ba (n + 2))) , n + 3 #)+        3# -> (# toChar (decode4 (Vec.unsafeIndex ba (n + 1))+                                 (Vec.unsafeIndex ba (n + 2))+                                 (Vec.unsafeIndex ba (n + 3))) , n + 4 #)+        r -> error ("next: internal error: invalid input: offset=" <> show n <> " table=" <> show (I# r) <> " h=" <> show (W# h))+  where+    !(W8# h) = Vec.unsafeIndex ba n++    toChar :: Word# -> Char+    toChar w = C# (chr# (word2Int# w))++    decode2 :: Word8 -> Word#+    decode2 (W8# c1) =+        or# (uncheckedShiftL# (and# h 0x1f##) 6#)+            (and# c1 0x3f##)++    decode3 :: Word8 -> Word8 -> Word#+    decode3 (W8# c1) (W8# c2) =+        or# (uncheckedShiftL# (and# h 0xf##) 12#)+            (or# (uncheckedShiftL# (and# c1 0x3f##) 6#)+                 (and# c2 0x3f##))++    decode4 :: Word8 -> Word8 -> Word8 -> Word#+    decode4 (W8# c1) (W8# c2) (W8# c3) =+        or# (uncheckedShiftL# (and# h 0x7##) 18#)+            (or# (uncheckedShiftL# (and# c1 0x3f##) 12#)+                (or# (uncheckedShiftL# (and# c2 0x3f##) 6#)+                    (and# c3 0x3f##))+            )++-- A variant of 'next' when you want the next character+-- to be ASCII only. if Bool is False, then it's not ascii,+-- otherwise it is and the return Word8 is valid.+nextAscii :: String -> Offset8 -> (# Word8, Bool #)+nextAscii (String ba) n = (# w, not (testBit w 7) #)+  where+    !w = Vec.unsafeIndex ba n++expectAscii :: String -> Offset8 -> Word8 -> Bool+expectAscii (String ba) n v = Vec.unsafeIndex ba n == v+{-# INLINE expectAscii #-}++write :: PrimMonad prim => MutableString (PrimState prim) -> Offset8 -> Char -> prim Offset8+write (MutableString mba) i c =+    if      bool# (ltWord# x 0x80##   ) then encode1+    else if bool# (ltWord# x 0x800##  ) then encode2+    else if bool# (ltWord# x 0x10000##) then encode3+    else                                     encode4+  where+    !(I# xi) = fromEnum c+    !x       = int2Word# xi++    encode1 = Vec.unsafeWrite mba i (W8# x) >> return (i + 1)++    encode2 = do+        let x1  = or# (uncheckedShiftRL# x 6#) 0xc0##+            x2  = toContinuation x+        Vec.unsafeWrite mba i     (W8# x1)+        Vec.unsafeWrite mba (i+1) (W8# x2)+        return (i + 2)++    encode3 = do+        let x1  = or# (uncheckedShiftRL# x 12#) 0xe0##+            x2  = toContinuation (uncheckedShiftRL# x 6#)+            x3  = toContinuation x+        Vec.unsafeWrite mba i     (W8# x1)+        Vec.unsafeWrite mba (i+1) (W8# x2)+        Vec.unsafeWrite mba (i+2) (W8# x3)+        return (i + 3)++    encode4 = do+        let x1  = or# (uncheckedShiftRL# x 18#) 0xf0##+            x2  = toContinuation (uncheckedShiftRL# x 12#)+            x3  = toContinuation (uncheckedShiftRL# x 6#)+            x4  = toContinuation x+        Vec.unsafeWrite mba i     (W8# x1)+        Vec.unsafeWrite mba (i+1) (W8# x2)+        Vec.unsafeWrite mba (i+2) (W8# x3)+        Vec.unsafeWrite mba (i+3) (W8# x4)+        return (i + 4)++    toContinuation :: Word# -> Word#+    toContinuation w = or# (and# w 0x3f##) 0x80##+{-# INLINE write #-}++-- | Allocate a MutableString of a specific size in bytes.+new :: PrimMonad prim+    => Size8 -- ^ in number of bytes, not of elements.+    -> prim (MutableString (PrimState prim))+new n = MutableString `fmap` MVec.new n++freeze :: PrimMonad prim => MutableString (PrimState prim) -> prim String+freeze (MutableString mba) = String `fmap` C.unsafeFreeze mba+{-# INLINE freeze #-}

@@ -0,0 +1,127 @@+-- |+-- Module      : Foundation.Primitive.UTF8.Helper+-- License     : BSD-style+-- Maintainer  : Foundation+--+-- Some low level helpers to use UTF8+--+-- Most helpers are lowlevel and unsafe, don't use+-- directly.+{-# LANGUAGE BangPatterns               #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MagicHash                  #-}+{-# LANGUAGE NoImplicitPrelude          #-}+{-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE UnboxedTuples              #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE CPP                        #-}+module Foundation.Primitive.UTF8.Helper+    where++import           Foundation.Internal.Base+import           Foundation.Internal.Primitive+import           Foundation.Bits+import           Foundation.Primitive.Types.OffsetSize+import           Foundation.Numerical+import           Foundation.Primitive.Types+import           GHC.Prim+import           GHC.Types+import           GHC.Word++-- same as nextAscii but with a ByteArray#+nextAsciiBA :: ByteArray# -> Offset8 -> (# Word8, Bool #)+nextAsciiBA ba n = (# w, not (testBit w 7) #)+  where+    !w = primBaIndex ba n+{-# INLINE nextAsciiBA #-}++-- same as nextAscii but with a ByteArray#+nextAsciiPtr :: Ptr Word8 -> Offset8 -> (# Word8, Bool #)+nextAsciiPtr (Ptr addr) n = (# w, not (testBit w 7) #)+  where !w = primAddrIndex addr n+{-# INLINE nextAsciiPtr #-}++-- | nextAsciiBa specialized to get a digit between 0 and 9 (included)+nextAsciiDigitBA :: ByteArray# -> Offset8 -> (# Word8, Bool #)+nextAsciiDigitBA ba n = (# d, d < 0xa #)+  where !d = primBaIndex ba n - 0x30+{-# INLINE nextAsciiDigitBA #-}++nextAsciiDigitPtr :: Ptr Word8 -> Offset8 -> (# Word8, Bool #)+nextAsciiDigitPtr (Ptr addr) n = (# d, d < 0xa #)+  where !d = primAddrIndex addr n - 0x30+{-# INLINE nextAsciiDigitPtr #-}++expectAsciiBA :: ByteArray# -> Offset8 -> Word8 -> Bool+expectAsciiBA ba n v = primBaIndex ba n == v+{-# INLINE expectAsciiBA #-}++expectAsciiPtr :: Ptr Word8 -> Offset8 -> Word8 -> Bool+expectAsciiPtr (Ptr ptr) n v = primAddrIndex ptr n == v+{-# INLINE expectAsciiPtr #-}++-- | Different way to encode a Character in UTF8 represented as an ADT+data UTF8Char =+      UTF8_1 {-# UNPACK #-} !Word8+    | UTF8_2 {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8+    | UTF8_3 {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8+    | UTF8_4 {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8++-- | Transform a Unicode code point 'Char' into+--+-- note that we expect here a valid unicode code point in the *allowed* range.+-- bits will be lost if going above 0x10ffff+asUTF8Char :: Char -> UTF8Char+asUTF8Char !c+  | bool# (ltWord# x 0x80##   ) = encode1+  | bool# (ltWord# x 0x800##  ) = encode2+  | bool# (ltWord# x 0x10000##) = encode3+  | otherwise                   = encode4+    where+      !(I# xi) = fromEnum c+      !x       = int2Word# xi++      encode1 = UTF8_1 (W8# x)+      encode2 =+          let !x1 = W8# (or# (uncheckedShiftRL# x 6#) 0xc0##)+              !x2 = toContinuation x+           in UTF8_2 x1 x2+      encode3 =+          let !x1 = W8# (or# (uncheckedShiftRL# x 12#) 0xe0##)+              !x2 = toContinuation (uncheckedShiftRL# x 6#)+              !x3 = toContinuation x+           in UTF8_3 x1 x2 x3+      encode4 =+          let !x1 = W8# (or# (uncheckedShiftRL# x 18#) 0xf0##)+              !x2 = toContinuation (uncheckedShiftRL# x 12#)+              !x3 = toContinuation (uncheckedShiftRL# x 6#)+              !x4 = toContinuation x+           in UTF8_4 x1 x2 x3 x4++      toContinuation :: Word# -> Word8+      toContinuation w = W8# (or# (and# w 0x3f##) 0x80##)+      {-# INLINE toContinuation #-}++-- given the encoding of UTF8 Char, get the number of bytes of this sequence+numBytes :: UTF8Char -> Size8+numBytes UTF8_1{} = Size 1+numBytes UTF8_2{} = Size 2+numBytes UTF8_3{} = Size 3+numBytes UTF8_4{} = Size 4++-- given the leading byte of a utf8 sequence, get the number of bytes of this sequence+skipNextHeaderValue :: Word8 -> Size Word8+skipNextHeaderValue !x+    | x < 0xC0  = Size 1 -- 0b11000000+    | x < 0xE0  = Size 2 -- 0b11100000+    | x < 0xF0  = Size 3 -- 0b11110000+    | otherwise = Size 4+{-# INLINE skipNextHeaderValue #-}++charToBytes :: Int -> Size8+charToBytes c+    | c < 0x80     = Size 1+    | c < 0x800    = Size 2+    | c < 0x10000  = Size 3+    | c < 0x110000 = Size 4+    | otherwise    = error ("invalid code point: " `mappend` show c)

@@ -0,0 +1,83 @@+-- |+-- Module      : Foundation.Primitive.UTF8.Table+-- License     : BSD-style+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>+-- Stability   : experimental+-- Portability : portable+--+-- UTF8 lookup tables for fast continuation & nb bytes per header queries+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE UnboxedTuples #-}+module Foundation.Primitive.UTF8.Table+    ( isContinuation+    , getNbBytes+    , isContinuation#+    , getNbBytes#+    ) where++import           GHC.Prim+import           GHC.Types+import           GHC.Word+import           Foundation.Internal.Base++-- | Check if the byte is a continuation byte+isContinuation :: Word8 -> Bool+isContinuation (W8# w) = isContinuation# w+{-# INLINE isContinuation #-}++-- | Get the number of following bytes given the first byte of a UTF8 sequence.+getNbBytes :: Word8 -> Int+getNbBytes (W8# w) = I# (getNbBytes# w)+{-# INLINE getNbBytes #-}++-- | Check if the byte is a continuation byte+isContinuation# :: Word# -> Bool+isContinuation# w = W# (indexWord8OffAddr# (unTable contTable) (word2Int# w)) /= W# 0##+{-# INLINE isContinuation# #-}++-- | Get the number of following bytes given the first byte of a UTF8 sequence.+getNbBytes# :: Word# -> Int#+getNbBytes# w = word2Int# (indexWord8OffAddr# (unTable headTable) (word2Int# w))+{-# INLINE getNbBytes# #-}++data Table = Table { unTable :: !Addr# }++contTable :: Table+contTable = Table+        "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\+        \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\+        \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\+        \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\+        \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\+        \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\+        \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\+        \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\+        \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\+        \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\+        \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\+        \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\+        \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\+        \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\+        \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\+        \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"#+{-# NOINLINE contTable #-}++headTable :: Table+headTable = Table+        "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\+        \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\+        \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\+        \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\+        \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\+        \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\+        \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\+        \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\+        \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\+        \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\+        \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\+        \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\+        \\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\+        \\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\+        \\x02\x02\x02\x02\x02\x02\x02\x02\x02\x02\x02\x02\x02\x02\x02\x02\+        \\x03\x03\x03\x03\x03\x03\x03\x03\xff\xff\xff\xff\xff\xff\xff\xff"#+{-# NOINLINE headTable #-}

@@ -30,6 +30,8 @@     , ValidationFailure(..)     , lines     , words+    , upper+    , lower     ) where  import Foundation.String.UTF8

@@ -30,7 +30,7 @@ import           Foundation.Array.Unboxed (UArray) import           Foundation.Numerical import           Foundation.Primitive.FinalPtr-import           Foundation.String.UTF8Table+import           Foundation.Primitive.UTF8.Table  -- helper function to read some bytes from the given byte reader accessBytes :: Offset Word8 -> (Offset Word8 -> Word8) -> ([Word8], Offset Word8)

@@ -38,7 +38,6 @@     , copy     , ValidationFailure(..)     , index-    , sToList     , null     , drop     , take@@ -72,6 +71,8 @@     , readDouble     , readRational     , readFloatingExact+    , upper+    , lower     -- * Legacy utility     , lines     , words@@ -83,7 +84,6 @@ import           Foundation.Array.Unboxed.ByteArray (MutableByteArray) import qualified Foundation.Array.Unboxed.Mutable   as MVec import           Foundation.Internal.Base-import           Foundation.Bits import           Foundation.Internal.Natural import           Foundation.Internal.MonadTrans import           Foundation.Internal.Primitive@@ -91,12 +91,12 @@ import           Foundation.Numerical import           Foundation.Primitive.Monad import           Foundation.Primitive.Types-import           Foundation.Primitive.NormalForm import           Foundation.Primitive.IntegralConv import           Foundation.Primitive.Floating import           Foundation.Boot.Builder-import qualified Foundation.Boot.List as List-import           Foundation.String.UTF8Table+import           Foundation.Primitive.UTF8.Table+import           Foundation.Primitive.UTF8.Helper+import           Foundation.Primitive.UTF8.Base import           GHC.Prim import           GHC.ST import           GHC.Types@@ -107,54 +107,16 @@   -- temporary import qualified Data.List-import           Data.Data import           Data.Ratio+import           Data.Char (toUpper, toLower) import qualified Prelude -import           Foundation.String.ModifiedUTF8     (fromModified)-import           GHC.CString                  (unpackCString#,-                                               unpackCStringUtf8#)- import qualified Foundation.String.Encoding.Encoding   as Encoder import qualified Foundation.String.Encoding.ASCII7     as Encoder import qualified Foundation.String.Encoding.UTF16      as Encoder import qualified Foundation.String.Encoding.UTF32      as Encoder import qualified Foundation.String.Encoding.ISO_8859_1 as Encoder --- | Opaque packed array of characters in the UTF8 encoding-newtype String = String (UArray Word8)-    deriving (Typeable, Monoid, Eq, Ord)--instance Data String where-    toConstr s   = mkConstr stringType (show s) [] Prefix-    dataTypeOf _ = stringType-    gunfold _ _  = error "gunfold"--instance NormalForm String where-    toNormalForm (String ba) = toNormalForm ba--stringType :: DataType-stringType = mkNoRepType "Foundation.String"---- | Mutable String Buffer.------ Note that it's hard to use properly since the UTF8 encoding--- is variable, and thus you can't mutable previously filled--- data without potentially have to move all the data around.------ See 'charMap' for an idea of the scale of the problem-newtype MutableString st = MutableString (MutableByteArray st)-    deriving (Typeable)--instance Show String where-    show = show . sToList-instance IsString String where-    fromString = sFromList-instance IsList String where-    type Item String = Char-    fromList = sFromList-    toList = sToList- -- | Possible failure related to validating bytes of UTF8 sequences. data ValidationFailure = InvalidHeader                        | InvalidContinuation@@ -274,30 +236,18 @@                                 else return (pos, Just InvalidContinuation)                         _ -> error "internal error" -skipNextHeaderValue :: Word8 -> Size Word8-skipNextHeaderValue !x-    | x < 0xC0  = Size 1 -- 0b11000000-    | x < 0xE0  = Size 2 -- 0b11100000-    | x < 0xF0  = Size 3 -- 0b11110000-    | otherwise = Size 4-{-# INLINE skipNextHeaderValue #-}- nextWithIndexer :: (Offset Word8 -> Word8)                 -> Offset Word8                 -> (Char, Offset Word8) nextWithIndexer getter off =     case getNbBytes# h of-        0# -> (toChar h, off + aone)-        1# -> (toChar (decode2 (getter $ off + aone)), off + atwo)-        2# -> (toChar (decode3 (getter $ off + aone) (getter $ off + atwo)), off + athree)-        3# -> (toChar (decode4 (getter $ off + aone) (getter $ off + atwo) (getter $ off + athree))-              , off + afour)+        0# -> (toChar h, off + 1)+        1# -> (toChar (decode2 (getter $ off + 1)), off + 2)+        2# -> (toChar (decode3 (getter $ off + 1) (getter $ off + 2)), off + 3)+        3# -> (toChar (decode4 (getter $ off + 1) (getter $ off + 2) (getter $ off + 3))+              , off + 4)         r -> error ("next: internal error: invalid input: " <> show (I# r) <> " " <> show (W# h))   where-    aone = Offset 1-    atwo = Offset 2-    athree = Offset 3-    afour = Offset 4     !(W8# h) = getter off      toChar :: Word# -> Char@@ -357,130 +307,6 @@     toContinuation :: Word# -> Word#     toContinuation w = or# (and# w 0x3f##) 0x80## --- A variant of 'next' when you want the next character--- to be ASCII only. if Bool is False, then it's not ascii,--- otherwise it is and the return Word8 is valid.-nextAscii :: String -> Offset8 -> (# Word8, Bool #)-nextAscii (String ba) n = (# w, not (testBit w 7) #)-  where-    !w = Vec.unsafeIndex ba n---- same as nextAscii but with a ByteArray#-nextAsciiBA :: ByteArray# -> Offset8 -> (# Word8, Bool #)-nextAsciiBA ba n = (# w, not (testBit w 7) #)-  where-    !w = primBaIndex ba n-{-# INLINE nextAsciiBA #-}---- same as nextAscii but with a ByteArray#-nextAsciiPtr :: Ptr Word8 -> Offset8 -> (# Word8, Bool #)-nextAsciiPtr (Ptr addr) n = (# w, not (testBit w 7) #)-  where !w = primAddrIndex addr n-{-# INLINE nextAsciiPtr #-}---- | nextAsciiBa specialized to get a digit between 0 and 9 (included)-nextAsciiDigitBA :: ByteArray# -> Offset8 -> (# Word8, Bool #)-nextAsciiDigitBA ba n = (# d, d < 0xa #)-  where !d = primBaIndex ba n - 0x30-{-# INLINE nextAsciiDigitBA #-}--nextAsciiDigitPtr :: Ptr Word8 -> Offset8 -> (# Word8, Bool #)-nextAsciiDigitPtr (Ptr addr) n = (# d, d < 0xa #)-  where !d = primAddrIndex addr n - 0x30-{-# INLINE nextAsciiDigitPtr #-}--expectAscii :: String -> Offset8 -> Word8 -> Bool-expectAscii (String ba) n v = Vec.unsafeIndex ba n == v-{-# INLINE expectAscii #-}--expectAsciiBA :: ByteArray# -> Offset8 -> Word8 -> Bool-expectAsciiBA ba n v = primBaIndex ba n == v-{-# INLINE expectAsciiBA #-}--expectAsciiPtr :: Ptr Word8 -> Offset8 -> Word8 -> Bool-expectAsciiPtr (Ptr ptr) n v = primAddrIndex ptr n == v-{-# INLINE expectAsciiPtr #-}--next :: String -> Offset8 -> (# Char, Offset8 #)-next (String ba) n =-    case getNbBytes# h of-        0# -> (# toChar h, n + 1 #)-        1# -> (# toChar (decode2 (Vec.unsafeIndex ba (n + 1))) , n + 2 #)-        2# -> (# toChar (decode3 (Vec.unsafeIndex ba (n + 1))-                                 (Vec.unsafeIndex ba (n + 2))) , n + 3 #)-        3# -> (# toChar (decode4 (Vec.unsafeIndex ba (n + 1))-                                 (Vec.unsafeIndex ba (n + 2))-                                 (Vec.unsafeIndex ba (n + 3))) , n + 4 #)-        r -> error ("next: internal error: invalid input: offset=" <> show n <> " table=" <> show (I# r) <> " h=" <> show (W# h))-  where-    !(W8# h) = Vec.unsafeIndex ba n--    toChar :: Word# -> Char-    toChar w = C# (chr# (word2Int# w))--    decode2 :: Word8 -> Word#-    decode2 (W8# c1) =-        or# (uncheckedShiftL# (and# h 0x1f##) 6#)-            (and# c1 0x3f##)--    decode3 :: Word8 -> Word8 -> Word#-    decode3 (W8# c1) (W8# c2) =-        or# (uncheckedShiftL# (and# h 0xf##) 12#)-            (or# (uncheckedShiftL# (and# c1 0x3f##) 6#)-                 (and# c2 0x3f##))--    decode4 :: Word8 -> Word8 -> Word8 -> Word#-    decode4 (W8# c1) (W8# c2) (W8# c3) =-        or# (uncheckedShiftL# (and# h 0x7##) 18#)-            (or# (uncheckedShiftL# (and# c1 0x3f##) 12#)-                (or# (uncheckedShiftL# (and# c2 0x3f##) 6#)-                    (and# c3 0x3f##))-            )---- | Different way to encode a Character in UTF8 represented as an ADT-data UTF8Char =-      UTF8_1 {-# UNPACK #-} !Word8-    | UTF8_2 {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8-    | UTF8_3 {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8-    | UTF8_4 {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8--asUTF8Char :: Char -> UTF8Char-asUTF8Char !c-  | bool# (ltWord# x 0x80##   ) = encode1-  | bool# (ltWord# x 0x800##  ) = encode2-  | bool# (ltWord# x 0x10000##) = encode3-  | otherwise                   = encode4-    where-      !(I# xi) = fromEnum c-      !x       = int2Word# xi--      encode1 = UTF8_1 (W8# x)-      encode2 =-          let !x1 = W8# (or# (uncheckedShiftRL# x 6#) 0xc0##)-              !x2 = toContinuation x-           in UTF8_2 x1 x2-      encode3 =-          let !x1 = W8# (or# (uncheckedShiftRL# x 12#) 0xe0##)-              !x2 = toContinuation (uncheckedShiftRL# x 6#)-              !x3 = toContinuation x-           in UTF8_3 x1 x2 x3-      encode4 =-          let !x1 = W8# (or# (uncheckedShiftRL# x 18#) 0xf0##)-              !x2 = toContinuation (uncheckedShiftRL# x 12#)-              !x3 = toContinuation (uncheckedShiftRL# x 6#)-              !x4 = toContinuation x-           in UTF8_4 x1 x2 x3 x4--      toContinuation :: Word# -> Word8-      toContinuation w = W8# (or# (and# w 0x3f##) 0x80##)-      {-# INLINE toContinuation #-}--numBytes :: UTF8Char -> Size8-numBytes UTF8_1{} = Size 1-numBytes UTF8_2{} = Size 2-numBytes UTF8_3{} = Size 3-numBytes UTF8_4{} = Size 4- writeUTF8Char :: PrimMonad prim => MutableString (PrimState prim) -> Offset8 -> UTF8Char -> prim () writeUTF8Char (MutableString mba) i (UTF8_1 x1) =     Vec.unsafeWrite mba i     x1@@ -498,53 +324,6 @@     Vec.unsafeWrite mba (i+3) x4 {-# INLINE writeUTF8Char #-} -write :: PrimMonad prim => MutableString (PrimState prim) -> Offset8 -> Char -> prim Offset8-write (MutableString mba) i c =-    if      bool# (ltWord# x 0x80##   ) then encode1-    else if bool# (ltWord# x 0x800##  ) then encode2-    else if bool# (ltWord# x 0x10000##) then encode3-    else                                     encode4-  where-    !(I# xi) = fromEnum c-    !x       = int2Word# xi--    encode1 = Vec.unsafeWrite mba i (W8# x) >> return (i + 1)--    encode2 = do-        let x1  = or# (uncheckedShiftRL# x 6#) 0xc0##-            x2  = toContinuation x-        Vec.unsafeWrite mba i     (W8# x1)-        Vec.unsafeWrite mba (i+1) (W8# x2)-        return (i + 2)--    encode3 = do-        let x1  = or# (uncheckedShiftRL# x 12#) 0xe0##-            x2  = toContinuation (uncheckedShiftRL# x 6#)-            x3  = toContinuation x-        Vec.unsafeWrite mba i     (W8# x1)-        Vec.unsafeWrite mba (i+1) (W8# x2)-        Vec.unsafeWrite mba (i+2) (W8# x3)-        return (i + 3)--    encode4 = do-        let x1  = or# (uncheckedShiftRL# x 18#) 0xf0##-            x2  = toContinuation (uncheckedShiftRL# x 12#)-            x3  = toContinuation (uncheckedShiftRL# x 6#)-            x4  = toContinuation x-        Vec.unsafeWrite mba i     (W8# x1)-        Vec.unsafeWrite mba (i+1) (W8# x2)-        Vec.unsafeWrite mba (i+2) (W8# x3)-        Vec.unsafeWrite mba (i+3) (W8# x4)-        return (i + 4)--    toContinuation :: Word# -> Word#-    toContinuation w = or# (and# w 0x3f##) 0x80##-{-# INLINE write #-}--freeze :: PrimMonad prim => MutableString (PrimState prim) -> prim String-freeze (MutableString mba) = String `fmap` C.unsafeFreeze mba-{-# INLINE freeze #-}- unsafeFreezeShrink :: PrimMonad prim => MutableString (PrimState prim) -> Size Word8 -> prim String unsafeFreezeShrink (MutableString mba) s = String <$> Vec.unsafeFreezeShrink mba s {-# INLINE unsafeFreezeShrink #-}@@ -552,46 +331,6 @@ ------------------------------------------------------------------------ -- real functions --- | Convert a String to a list of characters------ The list is lazily created as evaluation needed-sToList :: String -> [Char]-sToList s = loop azero-  where-    !nbBytes = size s-    end = azero `offsetPlusE` nbBytes-    loop idx-        | idx == end = []-        | otherwise  =-            let (# c , idx' #) = next s idx in c : loop idx'--{-# RULES-"String sFromList" forall s .-  sFromList (unpackCString# s) = String $ fromModified s-  #-}-{-# RULES-"String sFromList" forall s .-  sFromList (unpackCStringUtf8# s) = String $ fromModified s-  #-}---- | Create a new String from a list of characters------ The list is strictly and fully evaluated before--- creating the new String, as the size need to be--- computed before filling.-sFromList :: [Char] -> String-sFromList l = runST (new bytes >>= startCopy)-  where-    -- count how many bytes-    !bytes = List.sum $ fmap (charToBytes . fromEnum) l--    startCopy :: MutableString (PrimState (ST st)) -> ST st String-    startCopy ms = loop azero l-      where-        loop _   []     = freeze ms-        loop idx (c:xs) = write ms idx c >>= \idx' -> loop idx' xs-{-# INLINE [0] sFromList #-}- -- | Check if a String is null null :: String -> Bool null (String ba) = C.length ba == 0@@ -628,13 +367,13 @@ indexN !n (String ba) = Vec.unsafeDewrap goVec goAddr ba   where     goVec :: ByteArray# -> Offset Word8 -> Offset Word8-    goVec !ma !start = loop start (Offset 0)+    goVec !ma !start = loop start 0       where         !len = start `offsetPlusE` Vec.lengthSize ba         loop :: Offset Word8 -> Offset Char -> Offset Word8         loop !idx !i             | idx >= len || i >= n = sizeAsOffset (idx - start)-            | otherwise              = loop (idx `offsetPlusE` d) (i + Offset 1)+            | otherwise            = loop (idx `offsetPlusE` d) (i + Offset 1)           where d = skipNextHeaderValue (primBaIndex ma idx)     {-# INLINE goVec #-} @@ -829,12 +568,6 @@         | otherwise = do (nextSrcIdx, nextDstIdx) <- f' src srcI srcIdx dst' dstIdx                          fill (srcI + Offset 1) nextSrcIdx nextDstIdx f' dst' --- | size in bytes.------ this size is available in o(1)-size :: String -> Size8-size (String ba) = Size $ C.length ba- -- | Length of a String using Size -- -- this size is available in o(n)@@ -893,12 +626,6 @@   where     !nbBytes = charToBytes (fromEnum c) --- | Allocate a MutableString of a specific size in bytes.-new :: PrimMonad prim-    => Size8 -- ^ in number of bytes, not of elements.-    -> prim (MutableString (PrimState prim))-new n = MutableString `fmap` MVec.new n- -- | Unsafely create a string of up to @sz@ bytes. -- -- The callback @f@ needs to return the number of bytes filled in the underlaying@@ -912,14 +639,6 @@         then freeze ms         else take filled `fmap` freeze ms -charToBytes :: Int -> Size8-charToBytes c-    | c < 0x80     = Size 1-    | c < 0x800    = Size 2-    | c < 0x10000  = Size 3-    | c < 0x110000 = Size 4-    | otherwise    = error ("invalid code point: " `mappend` show c)- -- | Monomorphically map the character in a string and return the transformed one charMap :: (Char -> Char) -> String -> String charMap f src@@ -1574,3 +1293,13 @@ {-# SPECIALIZE decimalDigitsPtr :: Natural -> Ptr Word8 -> Offset Word8 -> Offset Word8 -> (# Natural, Bool, Offset Word8 #) #-} {-# SPECIALIZE decimalDigitsPtr :: Int -> Ptr Word8 -> Offset Word8 -> Offset Word8 -> (# Int, Bool, Offset Word8 #) #-} {-# SPECIALIZE decimalDigitsPtr :: Word -> Ptr Word8 -> Offset Word8 -> Offset Word8 -> (# Word, Bool, Offset Word8 #) #-}++-- | Convert a 'String' to the upper-case equivalent.+--   Does not properly support multicharacter Unicode conversions.+upper :: String -> String+upper = charMap toUpper++-- | Convert a 'String' to the upper-case equivalent.+--   Does not properly support multicharacter Unicode conversions.+lower :: String -> String+lower = charMap toLower

@@ -1,83 +0,0 @@--- |--- Module      : Foundation.String.UTF8Table--- License     : BSD-style--- Maintainer  : Vincent Hanquez <vincent@snarc.org>--- Stability   : experimental--- Portability : portable------ UTF8 lookup tables for fast continuation & nb bytes per header queries-{-# LANGUAGE MagicHash #-}-{-# LANGUAGE UnboxedTuples #-}-module Foundation.String.UTF8Table-    ( isContinuation-    , getNbBytes-    , isContinuation#-    , getNbBytes#-    ) where--import           GHC.Prim-import           GHC.Types-import           GHC.Word-import           Foundation.Internal.Base---- | Check if the byte is a continuation byte-isContinuation :: Word8 -> Bool-isContinuation (W8# w) = isContinuation# w-{-# INLINE isContinuation #-}---- | Get the number of following bytes given the first byte of a UTF8 sequence.-getNbBytes :: Word8 -> Int-getNbBytes (W8# w) = I# (getNbBytes# w)-{-# INLINE getNbBytes #-}---- | Check if the byte is a continuation byte-isContinuation# :: Word# -> Bool-isContinuation# w = W# (indexWord8OffAddr# (unTable contTable) (word2Int# w)) /= W# 0##-{-# INLINE isContinuation# #-}---- | Get the number of following bytes given the first byte of a UTF8 sequence.-getNbBytes# :: Word# -> Int#-getNbBytes# w = word2Int# (indexWord8OffAddr# (unTable headTable) (word2Int# w))-{-# INLINE getNbBytes# #-}--data Table = Table { unTable :: !Addr# }--contTable :: Table-contTable = Table-        "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\-        \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\-        \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\-        \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\-        \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\-        \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\-        \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\-        \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\-        \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\-        \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\-        \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\-        \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\-        \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\-        \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\-        \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\-        \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"#-{-# NOINLINE contTable #-}--headTable :: Table-headTable = Table-        "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\-        \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\-        \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\-        \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\-        \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\-        \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\-        \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\-        \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\-        \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\-        \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\-        \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\-        \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\-        \\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\-        \\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\x01\-        \\x02\x02\x02\x02\x02\x02\x02\x02\x02\x02\x02\x02\x02\x02\x02\x02\-        \\x03\x03\x03\x03\x03\x03\x03\x03\xff\xff\xff\xff\xff\xff\xff\xff"#-{-# NOINLINE headTable #-}

@@ -1,5 +1,5 @@ Name:                foundation-Version:             0.0.8+Version:             0.0.9 Synopsis:            Alternative prelude with batteries and no dependencies Description:     A custom prelude with no dependencies apart from base.@@ -30,7 +30,7 @@ Homepage:            https://github.com/haskell-foundation/foundation Bug-Reports:         https://github.com/haskell-foundation/foundation/issues Cabal-Version:       >=1.10-tested-with:         GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.3, GHC == 8.0.2+tested-with:         GHC == 7.8.4, GHC == 7.10.3, GHC == 8.0.2 extra-source-files:  README.md                      cbits/*.h @@ -88,6 +88,7 @@                      Foundation.Foreign                      Foundation.Collection                      Foundation.Primitive+                     Foundation.Primitive.Block                      Foundation.List.DList                      Foundation.Monad                      Foundation.Monad.Reader@@ -111,7 +112,6 @@                      Foundation.String.Encoding.UTF32                      Foundation.String.Encoding.ASCII7                      Foundation.String.Encoding.ISO_8859_1-                     Foundation.String.UTF8Table                      Foundation.String.ModifiedUTF8                      Foundation.Tuple                      Foundation.Hashing.FNV@@ -139,7 +139,7 @@                      Foundation.Internal.ByteSwap                      Foundation.Internal.CallStack                      Foundation.Internal.Environment-                     Foundation.Internal.Error+                     Foundation.Primitive.Error                      Foundation.Internal.Primitive                      Foundation.Internal.IsList                      Foundation.Internal.Identity@@ -148,6 +148,7 @@                      Foundation.Internal.MonadTrans                      Foundation.Internal.Natural                      Foundation.Internal.NumLiteral+                     Foundation.Internal.Typeable                      Foundation.Numerical.Primitives                      Foundation.Numerical.Number                      Foundation.Numerical.Additive@@ -157,7 +158,10 @@                      Foundation.IO.File                      Foundation.IO.Terminal                      Foundation.Primitive.Base16+                     Foundation.Primitive.Block.Base+                     Foundation.Primitive.Block.Mutable                      Foundation.Primitive.Endianness+                     Foundation.Primitive.Exception                      Foundation.Primitive.Types                      Foundation.Primitive.Types.OffsetSize                      Foundation.Primitive.Monad@@ -166,13 +170,19 @@                      Foundation.Primitive.IntegralConv                      Foundation.Primitive.Floating                      Foundation.Primitive.FinalPtr+                     Foundation.Primitive.These+                     Foundation.Primitive.Show+                     Foundation.Primitive.UTF8.Table+                     Foundation.Primitive.UTF8.Helper+                     Foundation.Primitive.UTF8.Base+                     Foundation.Primitive.Runtime+                     Foundation.Primitive.Imports                      Foundation.Monad.MonadIO                      Foundation.Monad.Exception                      Foundation.Monad.Transformer                      Foundation.Monad.Identity                      Foundation.Monad.Base                      Foundation.Array.Chunked.Unboxed-                     Foundation.Array.Common                      Foundation.Array.Unboxed                      Foundation.Array.Unboxed.Mutable                      Foundation.Array.Unboxed.ByteArray@@ -215,7 +225,7 @@                       TypeFamilies                       BangPatterns                       DeriveDataTypeable-  Build-depends:     base >= 4 && < 5+  Build-depends:     base >= 4.7 && < 5                    , ghc-prim   -- FIXME add suport for armel mipsel   --  CPP-options: -DARCH_IS_LITTLE_ENDIAN

@@ -1,6 +1,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE Rank2Types #-} module Main where  @@ -10,13 +11,57 @@ import Foundation.List.DList import Foundation.Primitive import Foundation.Check+import Foundation.String import Foundation.String.Read import qualified Prelude import Data.Ratio  import Test.Checks.Property.Collection -testAdditive :: forall a . (Show a, Eq a, Additive a, Arbitrary a) => Proxy a -> Test+applyFstToSnd :: (String, String -> b) -> b+applyFstToSnd (a, fab) = fab a++matrixToGroup name l = Group name $ Prelude.concat $ fmap (fmap applyFstToSnd . snd) l++functorProxy :: Proxy f -> Proxy ty -> Proxy (f ty)+functorProxy _ _ = Proxy++primTypesMatrixArbitrary :: (forall ty . (PrimType ty, Typeable ty, Show ty, Ord ty) => Proxy ty -> Gen ty -> a)+                         -> [(String, [(String, a)])]+primTypesMatrixArbitrary f =+    [ ("Words",+        [ ("W8", f (Proxy :: Proxy Word8) arbitrary)+        , ("W16", f (Proxy :: Proxy Word16) arbitrary)+        , ("W32", f (Proxy :: Proxy Word32) arbitrary)+        , ("W64", f (Proxy :: Proxy Word64) arbitrary)+        , ("Word", f (Proxy :: Proxy Word) arbitrary)+        ])+    , ("Ints",+        [ ("I8", f (Proxy :: Proxy Int8) arbitrary)+        , ("I16", f (Proxy :: Proxy Int16) arbitrary)+        , ("I32", f (Proxy :: Proxy Int32) arbitrary)+        , ("I64", f (Proxy :: Proxy Int64) arbitrary)+        , ("Int", f (Proxy :: Proxy Int) arbitrary)+        ])+    , ("Floating",+        [ ("FP32", f (Proxy :: Proxy Float) arbitrary)+        , ("FP64", f (Proxy :: Proxy Double) arbitrary)+        ])+    , ("C-Types",+        [ ("CChar", f (Proxy :: Proxy CChar) (CChar <$> arbitrary))+        , ("CUChar", f (Proxy :: Proxy CUChar) (CUChar <$> arbitrary))+        ])+    , ("Endian",+        [ ("BE-W16", f (Proxy :: Proxy (BE Word16)) (toBE <$> arbitrary))+        , ("BE-W32", f (Proxy :: Proxy (BE Word32)) (toBE <$> arbitrary))+        , ("BE-W64", f (Proxy :: Proxy (BE Word64)) (toBE <$> arbitrary))+        , ("LE-W16", f (Proxy :: Proxy (LE Word16)) (toLE <$> arbitrary))+        , ("LE-W32", f (Proxy :: Proxy (LE Word32)) (toLE <$> arbitrary))+        , ("LE-W64", f (Proxy :: Proxy (LE Word64)) (toLE <$> arbitrary))+        ])+    ]++testAdditive :: forall a . (Show a, Eq a, Typeable a, Additive a, Arbitrary a) => Proxy a -> Test testAdditive _ = Group "Additive"     [ Property "eq"             $ azero === (azero :: a)     , Property "a + azero == a" $ \(v :: a)     -> v + azero === v@@ -86,29 +131,17 @@                 [ Property "case1" $ readRational "124.098" === Just (124098 % 1000)                 ]             ]+        , Group "conversion"+            [ Property "lower" $ lower "This is MY test" === "this is my test"+            , Property "upper" $ upper "This is MY test" === "THIS IS MY TEST"+            ]         ]     , collectionProperties "DList a" (Proxy :: Proxy (DList Word8)) arbitrary     , Group "Array"-      [ Group "Unboxed"-        [ collectionProperties "UArray(W8)"  (Proxy :: Proxy (UArray Word8))  arbitrary-        , collectionProperties "UArray(W16)" (Proxy :: Proxy (UArray Word16)) arbitrary-        , collectionProperties "UArray(W32)" (Proxy :: Proxy (UArray Word32)) arbitrary-        , collectionProperties "UArray(W64)" (Proxy :: Proxy (UArray Word64)) arbitrary-        , collectionProperties "UArray(I8)"  (Proxy :: Proxy (UArray Int8))   arbitrary-        , collectionProperties "UArray(I16)" (Proxy :: Proxy (UArray Int16))  arbitrary-        , collectionProperties "UArray(I32)" (Proxy :: Proxy (UArray Int32))  arbitrary-        , collectionProperties "UArray(I64)" (Proxy :: Proxy (UArray Int64))  arbitrary-        , collectionProperties "UArray(F32)" (Proxy :: Proxy (UArray Float))  arbitrary-        , collectionProperties "UArray(F64)" (Proxy :: Proxy (UArray Double)) arbitrary-        , collectionProperties "UArray(CChar)"  (Proxy :: Proxy (UArray CChar))  (CChar <$> arbitrary)-        , collectionProperties "UArray(CUChar)" (Proxy :: Proxy (UArray CUChar)) (CUChar <$> arbitrary)-        , collectionProperties "UArray(BE W16)" (Proxy :: Proxy (UArray (BE Word16))) (toBE <$> arbitrary)-        , collectionProperties "UArray(BE W32)" (Proxy :: Proxy (UArray (BE Word32))) (toBE <$> arbitrary)-        , collectionProperties "UArray(BE W64)" (Proxy :: Proxy (UArray (BE Word64))) (toBE <$> arbitrary)-        , collectionProperties "UArray(LE W16)" (Proxy :: Proxy (UArray (LE Word16))) (toLE <$> arbitrary)-        , collectionProperties "UArray(LE W32)" (Proxy :: Proxy (UArray (LE Word32))) (toLE <$> arbitrary)-        , collectionProperties "UArray(LE W64)" (Proxy :: Proxy (UArray (LE Word64))) (toLE <$> arbitrary)-        ]+      [ matrixToGroup "Block" $ primTypesMatrixArbitrary $ \prx arb ->+            \s -> collectionProperties ("Block " <> s) (functorProxy (Proxy :: Proxy Block) prx) arb+      , matrixToGroup "Unboxed" $ primTypesMatrixArbitrary $ \prx arb ->+            \s -> collectionProperties ("Unboxed " <> s) (functorProxy (Proxy :: Proxy UArray) prx) arb       , Group "Boxed"         [ collectionProperties "Array(W8)"  (Proxy :: Proxy (Array Word8))  arbitrary         , collectionProperties "Array(W16)" (Proxy :: Proxy (Array Word16)) arbitrary@@ -134,23 +167,7 @@         ]       ]     , Group "ChunkedUArray"-      [ Group "Unboxed"-        [ collectionProperties "ChunkedUArray(W8)"  (Proxy :: Proxy (ChunkedUArray Word8))  arbitrary-        , collectionProperties "ChunkedUArray(W16)" (Proxy :: Proxy (ChunkedUArray Word16)) arbitrary-        , collectionProperties "ChunkedUArray(W32)" (Proxy :: Proxy (ChunkedUArray Word32)) arbitrary-        , collectionProperties "ChunkedUArray(W64)" (Proxy :: Proxy (ChunkedUArray Word64)) arbitrary-        , collectionProperties "ChunkedUArray(I8)"  (Proxy :: Proxy (ChunkedUArray Int8))   arbitrary-        , collectionProperties "ChunkedUArray(I16)" (Proxy :: Proxy (ChunkedUArray Int16))  arbitrary-        , collectionProperties "ChunkedUArray(I32)" (Proxy :: Proxy (ChunkedUArray Int32))  arbitrary-        , collectionProperties "ChunkedUArray(I64)" (Proxy :: Proxy (ChunkedUArray Int64))  arbitrary-        , collectionProperties "ChunkedUArray(F32)" (Proxy :: Proxy (ChunkedUArray Float))  arbitrary-        , collectionProperties "ChunkedUArray(F64)" (Proxy :: Proxy (ChunkedUArray Double)) arbitrary-        , collectionProperties "ChunkedUArray(BE W16)" (Proxy :: Proxy (ChunkedUArray (BE Word16))) (toBE <$> arbitrary)-        , collectionProperties "ChunkedUArray(BE W32)" (Proxy :: Proxy (ChunkedUArray (BE Word32))) (toBE <$> arbitrary)-        , collectionProperties "ChunkedUArray(BE W64)" (Proxy :: Proxy (ChunkedUArray (BE Word64))) (toBE <$> arbitrary)-        , collectionProperties "ChunkedUArray(LE W16)" (Proxy :: Proxy (ChunkedUArray (LE Word16))) (toLE <$> arbitrary)-        , collectionProperties "ChunkedUArray(LE W32)" (Proxy :: Proxy (ChunkedUArray (LE Word32))) (toLE <$> arbitrary)-        , collectionProperties "ChunkedUArray(LE W64)" (Proxy :: Proxy (ChunkedUArray (LE Word64))) (toLE <$> arbitrary)-        ]+      [ matrixToGroup "Unboxed" $ primTypesMatrixArbitrary $ \prx arb ->+            \s -> collectionProperties ("Unboxed " <> s) (functorProxy (Proxy :: Proxy ChunkedUArray) prx) arb       ]     ]

@@ -72,6 +72,7 @@ -- collectionProperties :: forall collection                       . ( Sequential collection+                        , Typeable collection, Typeable (Element collection)                         , Eq collection,   Eq (Element collection)                         , Show collection, Show (Element collection)                         , Ord collection,  Ord (Element collection)@@ -95,6 +96,7 @@ testEqualityProperties :: forall collection                         . ( IsList collection                           , Element collection ~ Item collection+                          , Typeable collection                           , Eq collection,   Eq (Element collection)                           , Show collection, Show (Element collection)                           , Ord collection,  Ord (Element collection)@@ -115,6 +117,7 @@ testOrderingProperties :: forall collection                         . ( IsList collection                           , Element collection ~ Item collection+                          , Typeable collection                           , Eq collection,   Eq (Element collection)                           , Show collection, Show (Element collection)                           , Ord collection,  Ord (Element collection)@@ -131,6 +134,7 @@  testIsListPropertyies :: forall collection                        . ( IsList collection, Eq collection, Show collection+                         , Typeable collection, Typeable (Element collection)                          , Element collection ~ Item collection                          , Eq (Item collection), Show (Item collection)                          )@@ -145,6 +149,7 @@  testMonoidProperties :: forall collection                       . ( Monoid collection, IsList collection, Eq collection, Show collection+                        , Typeable collection, Typeable (Element collection)                         , Element collection ~ Item collection                         , Eq (Item collection), Show (Item collection)                         )@@ -168,6 +173,7 @@ -- testCollectionProperties :: forall collection                           . ( Collection collection+                            , Typeable collection, Typeable (Element collection)                             , Show (Element collection), Eq (Element collection)                                                        , Ord (Element collection)                             , Ord collection@@ -200,6 +206,7 @@  testSequentialProperties :: forall collection                           . ( Sequential collection+                            , Typeable collection, Typeable (Element collection)                             , Eq collection, Eq (Element collection)                             , Ord collection, Ord (Element collection)                             , Show collection, Show (Element collection)@@ -291,6 +298,7 @@      testSplitOn :: ( Sequential a                    , Show a, Show (Element a)+                   , Typeable a                    , Eq (Element a)                    , Eq a, Ord a, Ord (Item a), Show a                    )