packages feed

ral (empty) → 0.1

raw patch · 13 files changed

+2863/−0 lines, 13 filesdep +QuickCheckdep +adjunctionsdep +base

Dependencies added: QuickCheck, adjunctions, base, bin, criterion, deepseq, distributive, fin, hashable, ral, semigroupoids, semigroups, vector

Files

+ ChangeLog.md view
@@ -0,0 +1,5 @@+# Version history for ral++## 0.1++- First version. Released on an unsuspecting world.
+ LICENSE view
@@ -0,0 +1,17 @@+SPDX-License-Identifier: GPL-2.0-or-later++Copyright (c) 2019  Oleg Grenrus <oleg.grenrus@iki.fi>++    This library is free software: you may copy, redistribute and/or modify it+    under the terms of the GNU General Public License as published by the+    Free Software Foundation, either version 2 of the License, or (at your+    option) any later version.++    This library is distributed in the hope that it will be useful, but+    WITHOUT ANY WARRANTY; without even the implied warranty of+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU+    General Public License for more details.++    You should have received a copy of the GNU General Public License+    along with this program (see `LICENSE.GPLv2` and `LICENSE.GPLv3`).+    If not, see <https://www.gnu.org/licenses/gpl-3.0.html>.
+ bench/Bench.hs view
@@ -0,0 +1,59 @@+module Main where++import Criterion.Main (bench, bgroup, defaultMain, whnf)++import qualified Data.List            as L+import qualified Data.RAList          as R+import qualified Data.RAList.NonEmpty as NER+import qualified Data.Vector          as V+import qualified Data.Vector.Unboxed  as U++list :: [Int]+list = [1 .. 10000]++ralist :: R.RAList Int+ralist = R.fromList list++vector :: V.Vector Int+vector = V.fromList list++uvector :: U.Vector Int+uvector = U.fromList list++rlast :: R.RAList a -> a+rlast (R.NonEmpty r) = NER.last r+rlast R.Empty        = error "rlast Empty"++main :: IO ()+main = defaultMain+    [ bgroup "Last"+        [ bench "List"           $ whnf L.last list+        , bench "RAList"         $ whnf  rlast ralist+        , bench "Vector"         $ whnf V.last vector+        , bench "Vector.Unboxed" $ whnf U.last uvector+        ]+    , bgroup "Index"+        [ bench "List"           $ whnf (\xs -> xs L.!! (L.length xs - 1)) list+        , bench "RAList"         $ whnf (\xs -> xs R.!  (R.length xs - 1)) ralist+        , bench "Vector"         $ whnf (\xs -> xs V.!  (V.length xs - 1)) vector+        , bench "Vector.Unboxed" $ whnf (\xs -> xs U.!  (U.length xs - 1)) uvector+        ]+    , bgroup "Cons"+        [ bench "List"           $ whnf (0 :)      list+        , bench "RAList"         $ whnf (R.cons 0) ralist+        , bench "Vector"         $ whnf (V.cons 0) vector+        , bench "Vector.Unboxed" $ whnf (U.cons 0) uvector+        ]+    , bgroup "Length"+        [ bench "List"           $ whnf L.length list+        , bench "RAList"         $ whnf R.length ralist+        , bench "Vector"         $ whnf V.length vector+        , bench "Vector.Unboxed" $ whnf U.length uvector+        ]+    , bgroup "LastAfterCons"+        [ bench "List"           $ whnf (\xs -> L.last $ 0 : xs     ) list+        , bench "RAList"         $ whnf (\xs ->  rlast $ R.cons 0 xs) ralist+        , bench "Vector"         $ whnf (\xs -> V.last $ V.cons 0 xs) vector+        , bench "Vector.Unboxed" $ whnf (\xs -> U.last $ U.cons 0 xs) uvector+        ]+    ]
+ ral.cabal view
@@ -0,0 +1,123 @@+cabal-version:      2.2+name:               ral+version:            0.1+synopsis:           Random access lists+category:           Data, Dependent Types, Singletons+description:+  This package provides ordinary random access list, 'RAList', and also +  a length indexed variant, 'RAVec'.+  .+  The data structure allows fast cons-operation (like ordinary list) but also fast random access (like non-functional arrays).+  .+  For @lens@ or @optics@ support see [ral-lens](https://hackage.haskell.org/package/ral-lens) and [ral-optics](https://hackage.haskell.org/package/ral-optics) packages respectively.+  .+  === Similar packages+  .+  This packages don't provide length-indexed variant, and their 'RAList' has+  opaque structure.+  .+  * https://hackage.haskell.org/package/ralist+  * https://hackage.haskell.org/package/random-access-list++homepage:           https://github.com/phadej/vec+bug-reports:        https://github.com/phadej/vec/issues+license:            GPL-2.0-or-later+license-file:       LICENSE+author:             Oleg Grenrus <oleg.grenrus@iki.fi>+maintainer:         Oleg.Grenrus <oleg.grenrus@iki.fi>+copyright:          (c) 2019 Oleg Grenrus+build-type:         Simple+extra-source-files: ChangeLog.md+tested-with:+  GHC ==7.8.4+   || ==7.10.3+   || ==8.0.2+   || ==8.2.2+   || ==8.4.4+   || ==8.6.5+   || ==8.8.1++source-repository head+  type:     git+  location: https://github.com/phadej/vec.git+  subdir:   ral++flag adjunctions+  description: Depend on @adjunctions@ to provide its instances+  manual:      True+  default:     True++flag distributive+  description:+    Depend on @distributive@ to provide its instances. Turning on, disables @adjunctions@ too.++  manual:      True+  default:     True++flag semigroupoids+  description:+    Depend on @semigroupoids@ to provide its instances, and `traverse1`.++  manual:      True+  default:     True++library+  default-language: Haskell2010+  hs-source-dirs:   src+  ghc-options:      -Wall -fprint-explicit-kinds+  exposed-modules:+    Data.RAList+    Data.RAList.NonEmpty+    Data.RAList.Tree+    Data.RAVec+    Data.RAVec.NonEmpty+    Data.RAVec.Tree++  other-modules:+    Data.RAList.Internal+    Data.RAList.NonEmpty.Internal+    Data.RAList.Tree.Internal++  -- GHC boot libs+  build-depends:+    , base     >=4.7     && <4.14+    , deepseq  >=1.3.0.1 && <1.5++  if !impl(ghc >=8.0)+    build-depends: semigroups >=0.18.4 && <0.20++  -- siblings+  build-depends:+    , bin  ^>=0.1+    , fin  ^>=0.1.1++  -- other dependencies+  build-depends:+    , hashable    >=1.2.7.0 && <1.4+    , QuickCheck  ^>=2.13.2++  if flag(distributive)+    build-depends: distributive >=0.5.3 && <0.7++    if flag(adjunctions)+      build-depends: adjunctions ^>=4.4++  if flag(semigroupoids)+    build-depends: semigroupoids >=5.2.2 && <5.4++-- dump-core+-- if impl(ghc >= 8.0)+--  build-depends: dump-core+--  ghc-options: -fplugin=DumpCore -fplugin-opt DumpCore:core-html++benchmark ral-bench+  type:             exitcode-stdio-1.0+  default-language: Haskell2010+  hs-source-dirs:   bench+  ghc-options:      -Wall -fprint-explicit-kinds -threaded+  main-is:          Bench.hs+  build-depends:+    , base+    , criterion+    , ral+    , vector
+ src/Data/RAList.hs view
@@ -0,0 +1,54 @@+-- | Random access list.+--+-- This module is designed to imported qualifed.+--+module Data.RAList (+    RAList (..),+    -- * Showing+    explicitShow,+    explicitShowsPrec,+    -- * Construction+    empty,+    singleton,+    cons,+    -- * Indexing+    (!),+    (!?),+    uncons,+    length,+    null,+    -- * Conversions+    toList,+    fromList,+    -- * Folding+    ifoldMap,+    -- * Mapping+    adjust,+    map,+    imap,+    itraverse,+    ) where++import Prelude (Maybe (..))+import Data.RAList.Internal++import qualified Data.RAList.NonEmpty as NE++-- $setup+-- >>> import Prelude (($))++-------------------------------------------------------------------------------+-- Extras+-------------------------------------------------------------------------------++-- |+--+-- >>> uncons $ fromList []+-- Nothing+--+-- >>> uncons $ fromList "abcdef"+-- Just ('a',fromList "bcdef")+--+uncons :: RAList a -> Maybe (a, RAList a)+uncons Empty        = Nothing+uncons (NonEmpty r) = Just (NE.uncons r)
+ src/Data/RAList/Internal.hs view
@@ -0,0 +1,291 @@+{-# LANGUAGE CPP                 #-}+{-# LANGUAGE DeriveFoldable      #-}+{-# LANGUAGE DeriveFunctor       #-}+{-# LANGUAGE DeriveTraversable   #-}+{-# LANGUAGE FlexibleContexts    #-}+{-# LANGUAGE InstanceSigs        #-}+{-# LANGUAGE KindSignatures      #-}+{-# LANGUAGE ScopedTypeVariables #-}+module Data.RAList.Internal (+    RAList (..),+    -- * Showing+    explicitShow,+    explicitShowsPrec,+    -- * Construction+    empty,+    singleton,+    cons,+    -- * Indexing+    (!),+    (!?),+    length,+    null,+    -- * Conversions+    toList,+    fromList,+    -- * Folding+    ifoldMap,+    -- * Mapping+    adjust,+    map,+    imap,+    itraverse,+    ) where++import Prelude+       (Bool (..), Eq, Functor (..), Int, Maybe (..), Ord (..), Show (..),+       ShowS, String, showParen, showString, ($), (.))++import Control.Applicative (Applicative (..), (<$>))+import Control.DeepSeq     (NFData (..))+import Control.Exception   (ArrayException (IndexOutOfBounds), throw)+import Data.Hashable       (Hashable (..))+import Data.List.NonEmpty  (NonEmpty (..))+import Data.Monoid         (Monoid (..))+import Data.Semigroup      (Semigroup (..))++import qualified Data.Foldable    as I (Foldable (..))+import qualified Data.Traversable as I (Traversable (..))+import qualified Test.QuickCheck  as QC++import qualified Data.RAList.NonEmpty.Internal as NE++-- $setup+-- >>> import Data.Char (toUpper)++-------------------------------------------------------------------------------+-- Type+-------------------------------------------------------------------------------++-- | Random access list.+data RAList a+    = Empty+    | NonEmpty (NE.NERAList a)+  deriving (Eq, Ord, Functor, I.Traversable)++-------------------------------------------------------------------------------+-- Instances+-------------------------------------------------------------------------------++-- |+--+-- >>> I.length $ fromList $ ['a' .. 'z']+-- 26+--+instance I.Foldable RAList where+    foldMap _ Empty = mempty+    foldMap f (NonEmpty xs) = I.foldMap f xs++#if MIN_VERSION_base(4,8,0)+    length = length+    null   = null+#endif++instance NFData a => NFData (RAList a) where+    rnf Empty         = ()+    rnf (NonEmpty xs) = rnf xs++instance Hashable a => Hashable (RAList a) where+    hashWithSalt salt Empty        = hashWithSalt salt (0 :: Int)+    hashWithSalt salt (NonEmpty r) = hashWithSalt salt r+++-- |+--+-- >>> fromList "abc" <> fromList "xyz"+-- fromList "abcxyz"+--+instance Semigroup (RAList a) where+    Empty       <> ys          = ys+    xs          <> Empty       = xs+    NonEmpty xs <> NonEmpty ys = NonEmpty (xs <> ys)++instance Monoid (RAList a) where+    mempty  = Empty+    mappend = (<>)++-- TODO: Applicative, Monad++#ifdef MIN_VERSION_semigroupoids+-- Apply, Bind+#endif++-------------------------------------------------------------------------------+-- Showing+-------------------------------------------------------------------------------++instance Show a => Show (RAList a) where+    showsPrec d xs = showParen (d > 10) $ showString "fromList " . showsPrec 11 (toList xs)++explicitShow :: Show a => RAList a -> String+explicitShow xs = explicitShowsPrec 0 xs ""++explicitShowsPrec :: Show a => Int -> RAList a -> ShowS+explicitShowsPrec _ Empty         = showString "Empty"+explicitShowsPrec d (NonEmpty xs) = showParen (d > 10) $ showString "NonEmpty " . NE.explicitShowsPrec 11 xs++-------------------------------------------------------------------------------+-- Construction+-------------------------------------------------------------------------------++-- | Empty 'RAList'.+--+-- >>> empty :: RAList Int+-- fromList []+--+empty :: RAList a+empty = Empty++-- | Single element 'RAList'.+singleton :: a -> RAList a+singleton = NonEmpty . NE.singleton++-- | 'cons' for non-empty rals.+cons :: a -> RAList a -> RAList a+cons x Empty         = singleton x+cons x (NonEmpty xs) = NonEmpty (NE.cons x xs)++toList :: RAList a -> [a]+toList Empty         = []+toList (NonEmpty xs) = I.foldr (:) [] xs++-- |+--+-- >>> fromList ['a' .. 'f']+-- fromList "abcdef"+--+-- >>> explicitShow $ fromList ['a' .. 'f']+-- "NonEmpty (NE (Cons0 (Cons1 (Nd (Lf 'a') (Lf 'b')) (Last (Nd (Nd (Lf 'c') (Lf 'd')) (Nd (Lf 'e') (Lf 'f')))))))"+--+fromList :: [a] -> RAList a+fromList []     = Empty+fromList (x:xs) = NonEmpty (NE.fromNonEmpty (x :| xs))++-------------------------------------------------------------------------------+-- Indexing+-------------------------------------------------------------------------------++-- | List index.+--+--- >>> fromList ['a'..'f'] ! 0+-- 'a'+--+-- >>> fromList ['a'..'f'] ! 5+-- 'f'+--+-- >>> fromList ['a'..'f'] ! 6+-- *** Exception: array index out of range: RAList+-- ...+--+(!) :: RAList a -> Int -> a+(!) Empty         _ = throw $ IndexOutOfBounds "RAList"+(!) (NonEmpty xs) i = xs NE.! i++-- | safe list index.+--+-- >>> fromList ['a'..'f'] !? 0+-- Just 'a'+--+-- >>> fromList ['a'..'f'] !? 5+-- Just 'f'+--+-- >>> fromList ['a'..'f'] !? 6+-- Nothing+--+(!?) :: RAList a -> Int -> Maybe a+Empty       !? _ = Nothing+NonEmpty xs !? i = xs NE.!? i++length :: RAList a -> Int+length Empty         = 0+length (NonEmpty xs) = NE.length xs++null :: RAList a -> Bool+null Empty        = True+null (NonEmpty _) = False++-------------------------------------------------------------------------------+-- Folds+-------------------------------------------------------------------------------++ifoldMap :: Monoid m => (Int -> a -> m) -> RAList a -> m+ifoldMap _ Empty        = mempty+ifoldMap f (NonEmpty r) = NE.ifoldMap f r++-------------------------------------------------------------------------------+-- Mapping+-------------------------------------------------------------------------------++-- |+-- >>> map toUpper (fromList ['a'..'f'])+-- fromList "ABCDEF"+--+map :: (a -> b) -> RAList a -> RAList b+map = fmap++-- |+--+-- >>> imap (,) $ fromList ['a' .. 'f']+-- fromList [(0,'a'),(1,'b'),(2,'c'),(3,'d'),(4,'e'),(5,'f')]+imap :: (Int -> a -> b) -> RAList a -> RAList b+imap f xs = unI (itraverse (\i x -> I (f i x)) xs)++itraverse :: forall f a b. Applicative f => (Int -> a -> f b) -> RAList a -> f (RAList b)+itraverse _ Empty         = pure Empty+itraverse f (NonEmpty xs) = NonEmpty <$> NE.itraverse f xs++-- | Adjust a value in the list.+--+-- >>> adjust 3 toUpper $ fromList "bcdef"+-- fromList "bcdEf"+--+-- If index is out of bounds, the list is returned unmodified.+--+-- >>> adjust 10 toUpper $ fromList "bcdef"+-- fromList "bcdef"+--+-- >>> adjust (-1) toUpper $ fromList "bcdef"+-- fromList "bcdef"+--+adjust :: forall a. Int -> (a -> a) -> RAList a -> RAList a+adjust _ _ Empty         = Empty+adjust i f (NonEmpty xs) = NonEmpty (NE.adjust i f xs)++-------------------------------------------------------------------------------+-- QuickCheck+-------------------------------------------------------------------------------++instance QC.Arbitrary1 RAList where+    liftArbitrary = fmap fromList . QC.liftArbitrary+    liftShrink shr = fmap fromList . QC.liftShrink shr . toList++instance QC.Arbitrary a => QC.Arbitrary (RAList a) where+    arbitrary = QC.arbitrary1+    shrink    = QC.shrink1++instance QC.CoArbitrary a => QC.CoArbitrary (RAList a) where+    coarbitrary = QC.coarbitrary . toList++instance QC.Function a => QC.Function (RAList a) where+    function = QC.functionMap toList fromList++-------------------------------------------------------------------------------+-- Utilities+-------------------------------------------------------------------------------++newtype I a = I a+unI :: I a -> a+unI (I a) = a++instance Functor I where+    fmap f (I x) = I (f x)++instance Applicative I where+    pure        = I+    I f <*> I x = I (f x)+    _ *> x      = x+    x <* _      = x+#if MIN_VERSION_base(4,10,0)+    liftA2 f (I x) (I y) = I (f x y)+#endif+
+ src/Data/RAList/NonEmpty.hs view
@@ -0,0 +1,78 @@+{-# LANGUAGE CPP #-}+-- | Non-empty random access list.+--+-- This module is designed to imported qualifed.+--+module Data.RAList.NonEmpty (+    NERAList (..),+    NERAList' (..),+    -- * Showing+    explicitShow,+    explicitShowsPrec,+    -- * Construction+    singleton,+    cons,+    -- * Indexing+    (!),+    (!?),+    head,+    last,+    uncons,+    tail,+    length,+    null,+    -- * Conversions+    toNonEmpty,+    fromNonEmpty,+    -- * Folding+    foldMap1,+    foldr1Map,+    ifoldMap,+    ifoldMap1,+    ifoldr1Map,+    -- * Mapping+    adjust,+    map,+    imap,+    itraverse,+#ifdef MIN_VERSION_semigroupoids+    itraverse1,+#endif+    ) where++import Prelude (snd)+import Data.RAList.NonEmpty.Internal++import Data.RAList.Tree (Leaf (..), Node (..))+import Data.RAList.Internal (RAList (..))++-- $setup+-- >>> import Prelude (($))+-- >>> import Data.List.NonEmpty (NonEmpty (..))++-------------------------------------------------------------------------------+-- Extras+-------------------------------------------------------------------------------++-- | Tail of non-empty list can be empty.+--+-- >>> tail $ fromNonEmpty $ 'a' :| "bcdef"+-- fromList "bcdef"+--+tail :: NERAList a -> RAList a+tail r = snd (uncons r)++-- | +-- >>> uncons $ fromNonEmpty $ 'a' :| "bcdef"+-- ('a',fromList "bcdef")+uncons :: NERAList a -> (a, RAList a)+uncons (NE (Last  (Lf x)))   = (x, Empty)+uncons (NE (Cons1 (Lf x) r)) = (x, NonEmpty (NE (Cons0 r)))+uncons (NE (Cons0        r)) = +    let (Lf x, r') = unconsTree r in (x, NonEmpty (NE r'))++unconsTree :: NERAList' (Node t) a -> (t a, NERAList' t a)+unconsTree (Last  (Nd x y))   = (x, Last y)+unconsTree (Cons1 (Nd x y) r) = (x, Cons1 y (Cons0 r))+unconsTree (Cons0          r) = +    let (Nd x y, r') = unconsTree r in (x, Cons1 y r')
+ src/Data/RAList/NonEmpty/Internal.hs view
@@ -0,0 +1,460 @@+{-# LANGUAGE BangPatterns        #-}+{-# LANGUAGE CPP                 #-}+{-# LANGUAGE DeriveFoldable      #-}+{-# LANGUAGE DeriveFunctor       #-}+{-# LANGUAGE DeriveTraversable   #-}+{-# LANGUAGE FlexibleContexts    #-}+{-# LANGUAGE InstanceSigs        #-}+{-# LANGUAGE KindSignatures      #-}+{-# LANGUAGE ScopedTypeVariables #-}+module Data.RAList.NonEmpty.Internal (+    NERAList (..),+    NERAList' (..),+    -- * Showing+    explicitShow,+    explicitShowsPrec,+    -- * Construction+    singleton,+    cons,+    -- * Indexing+    (!),+    (!?),+    head,+    last,+    length,+    null,+    -- * Conversions+    toNonEmpty,+    toList,+    fromNonEmpty,+    -- * Folding+    foldMap1,+    foldr1Map,+    ifoldMap,+    ifoldMap1,+    ifoldr1Map,+    -- * Mapping+    adjust,+    map,+    imap,+    itraverse,+#ifdef MIN_VERSION_semigroupoids+    itraverse1,+#endif+    ) where++import Prelude+       (Bool (..), Eq, Functor (..), Int, Maybe, Num (..), Ord (..), Show (..),+       ShowS, String, otherwise, seq, showParen, showString, ($), (.))++import Control.Applicative (Applicative (..), (<$>))+import Control.DeepSeq     (NFData (..))+import Control.Exception   (ArrayException (IndexOutOfBounds), throw)+import Data.Hashable       (Hashable (..))+import Data.List.NonEmpty  (NonEmpty (..))+import Data.Maybe          (fromMaybe)+import Data.Monoid         (Monoid (..))+import Data.Semigroup      (Semigroup (..))++import qualified Data.Foldable      as I (Foldable (..))+import qualified Data.List.NonEmpty as NEList+import qualified Data.Traversable   as I (Traversable (..))+import qualified Test.QuickCheck    as QC++#ifdef MIN_VERSION_semigroupoids+import Data.Functor.Apply (Apply (..))++import qualified Data.Semigroup.Foldable    as I (Foldable1 (..))+import qualified Data.Semigroup.Traversable as I (Traversable1 (..))+#endif++#if !MIN_VERSION_base(4,11,0)+import Data.Semigroup (WrappedMonoid (..))+#endif++import qualified Data.RAList.Tree.Internal as Tr++import Data.RAList.Tree (Leaf (..), Node (..))++-- $setup+-- >>> import Data.Char (toUpper)++-------------------------------------------------------------------------------+-- Type+-------------------------------------------------------------------------------++-- | Non-empty random access list.+newtype NERAList a = NE (NERAList' Leaf a)+  deriving (Eq, Ord, Functor, I.Traversable)++-- | Non-empty random access list, underlying representation.+--+-- The structure doesn't need to be hidden, as polymorphic+-- recursion of 'Node's starting from 'Leaf' keeps the 'NERAList' values well-formed.+--+data NERAList' f a+    = Last (f a)+    | Cons0 (NERAList' (Node f) a)+    | Cons1 (f a) (NERAList' (Node f) a)+  deriving (Eq, Show, Functor, I.Foldable, I.Traversable)++-------------------------------------------------------------------------------+-- Instances+-------------------------------------------------------------------------------++instance (Ord a, I.Foldable f, Eq (f a)) => Ord (NERAList' f a) where+    compare xs ys = compare (I.foldr (:) [] xs) (I.foldr (:) [] ys)++-- |+--+-- >>> I.length $ fromNonEmpty $ 'x' :| ['a' .. 'z']+-- 27+--+instance I.Foldable NERAList where+    foldMap f (NE xs) = I.foldMap f xs++#if MIN_VERSION_base(4,8,0)+    length = length+    null   = null+#endif++#ifdef MIN_VERSION_semigroupoids+instance I.Foldable1 NERAList where+    foldMap1 f (NE xs) = I.foldMap1 f xs++instance I.Foldable1 t => I.Foldable1 (NERAList' t) where+    foldMap1 f (Last  t)   = I.foldMap1 f t+    foldMap1 f (Cons0   r) = I.foldMap1 f r+    foldMap1 f (Cons1 t r) = I.foldMap1 f t <> I.foldMap1 f r++instance I.Traversable1 NERAList where+    traverse1 f (NE xs) = NE <$> I.traverse1 f xs where++instance I.Traversable1 t => I.Traversable1 (NERAList' t) where+    traverse1 f (Last  t)   = Last <$> I.traverse1 f t+    traverse1 f (Cons0   r) = Cons0 <$> I.traverse1 f r+    traverse1 f (Cons1 t r) = Cons1 <$> I.traverse1 f t <.> I.traverse1 f r+#endif++instance NFData a => NFData (NERAList a) where+    rnf (NE r) = rnf r++instance NFData (t a) => NFData (NERAList' t a) where+    rnf (Last t)    = rnf t+    rnf (Cons0   r) = rnf r+    rnf (Cons1 t r) = rnf t `seq` rnf r++instance Hashable a => Hashable (NERAList a) where+    hashWithSalt salt (NE r) = hashWithSalt salt r++instance Hashable (t a) => Hashable (NERAList' t a) where+    hashWithSalt salt (Last t)    = salt `hashWithSalt` t+    hashWithSalt salt (Cons0   r) = salt `hashWithSalt` r+    hashWithSalt salt (Cons1 t r) = salt `hashWithSalt` t `hashWithSalt` r++-- |+--+-- >>> fromNonEmpty ('a' :| "bc") <> fromNonEmpty ('x' :| "yz")+-- fromNonEmpty ('a' :| "bcxyz")+--+instance Semigroup (NERAList a) where+    NE xs <> ys = I.foldr cons ys xs++-- TODO: Applicative, Monad++#ifdef MIN_VERSION_semigroupoids+-- Apply, Bind+#endif++-------------------------------------------------------------------------------+-- Showing+-------------------------------------------------------------------------------++instance Show a => Show (NERAList a) where+    showsPrec d xs = showParen (d > 10) $ showString "fromNonEmpty " . showsPrec 11 (toNonEmpty xs)++explicitShow :: Show a => NERAList a -> String+explicitShow xs = explicitShowsPrec 0 xs ""++explicitShowsPrec :: Show a => Int -> NERAList a -> ShowS+explicitShowsPrec d (NE xs) = showParen (d > 10) $ showString "NE " . showsPrec 11 xs++-------------------------------------------------------------------------------+-- Construction+-------------------------------------------------------------------------------++-- | Single element 'NERAList'.+singleton :: a -> NERAList a+singleton = NE . singleton'++singleton' :: a -> NERAList' Leaf a+singleton' = Last . Lf++-- | 'cons' for non-empty rals.+cons :: a -> NERAList a -> NERAList a+cons x (NE xs) = NE (consTree (Lf x) xs)++consTree :: f a -> NERAList' f a -> NERAList' f a+consTree x (Last t)    = Cons0 (Last (Nd x t))+consTree x (Cons0 r)   = Cons1 x r+consTree x (Cons1 t r) = Cons0 (consTree (Nd x t) r)++-------------------------------------------------------------------------------+-- Conversions+-------------------------------------------------------------------------------++toNonEmpty :: NERAList a -> NonEmpty a+toNonEmpty = foldr1Map NEList.cons (:|[])++toList :: NERAList a -> [a]+toList = I.foldr (:) []++-- |+--+-- >>> fromNonEmpty ('a' :| ['b'..'f'])+-- fromNonEmpty ('a' :| "bcdef")+--+-- >>> explicitShow (fromNonEmpty ('a' :| ['b'..'f']))+-- "NE (Cons0 (Cons1 (Nd (Lf 'a') (Lf 'b')) (Last (Nd (Nd (Lf 'c') (Lf 'd')) (Nd (Lf 'e') (Lf 'f'))))))"+--+fromNonEmpty :: NonEmpty a -> NERAList a+fromNonEmpty (z :| zs) = go z zs where+    go x []     = singleton x+    go x (y:ys) = cons x (go y ys)++-------------------------------------------------------------------------------+-- Indexing+-------------------------------------------------------------------------------++-- | List index.+--+-- >>> fromNonEmpty ('a' :| ['b'..'f']) ! 0+-- 'a'+--+-- >>> fromNonEmpty ('a' :| ['b'..'f']) ! 5+-- 'f'+--+-- >>> fromNonEmpty ('a' :| ['b'..'f']) ! 6+-- *** Exception: array index out of range: NERAList+-- ...+--+(!) :: NERAList a -> Int -> a+(!) (NE xs) i = fromMaybe (throw $ IndexOutOfBounds "NERAList") (safeIndex' xs i)++-- | safe list index.+--+-- >>> fromNonEmpty ('a' :| ['b'..'f']) !? 0+-- Just 'a'+--+-- >>> fromNonEmpty ('a' :| ['b'..'f']) !? 5+-- Just 'f'+--+-- >>> fromNonEmpty ('a' :| ['b'..'f']) !? 6+-- Nothing+--+(!?) :: NERAList a -> Int -> Maybe a+NE xs !? i = safeIndex' xs i++safeIndex' :: Tr.IsTree f => NERAList' f a -> Int -> Maybe a+safeIndex' = go 1 where+    go :: Tr.IsTree g => Int -> NERAList' g a -> Int -> Maybe a+    go !s (Last  t)   i = Tr.safeIndex s t i+    go  s (Cons0   r) i = go (s * 2) r i+    go  s (Cons1 t r) i+        | i < s         = Tr.safeIndex s t i+        | otherwise     = go (s * 2) r (i - s)++-- | First value, head of the list.+--+-- >>> head $ fromNonEmpty $ 'a' :| ['b'..'f']+-- 'a'+head :: NERAList a -> a+head (NE x) = head' x++-- | Last value of the list+--+-- >>> last $ fromNonEmpty $  'a' :| ['b'..'f']+-- 'f'+--+last :: NERAList a -> a+last (NE x) = last' x++head' :: Tr.IsTree f => NERAList' f a -> a+head' (Last t)    = Tr.head t+head' (Cons0 r)   = head' r+head' (Cons1 t _) = Tr.head t++last' :: Tr.IsTree f => NERAList' f a -> a+last' (Last t)    = Tr.last t+last' (Cons0 r)   = last' r+last' (Cons1 _ r) = last' r++length :: NERAList a -> Int+length (NE xs) = go 0 1 xs where+    go :: Int -> Int -> NERAList' n a -> Int+    go !acc s (Last  _)   = acc + s+    go  acc s (Cons0   r) = go acc       (s + s) r+    go  acc s (Cons1 _ r) = go (acc + s) (s + s) r++null :: NERAList a -> Bool+null _ = False++-------------------------------------------------------------------------------+-- Folds+-------------------------------------------------------------------------------++foldMap1 :: forall a s. Semigroup s => (a -> s) -> NERAList a -> s+foldMap1 f (NE xs) = go (\(Lf x) -> f x) xs where+    go :: (t a -> s) -> NERAList' t a -> s+    go g (Last  t)   = g t+    go g (Cons0   r) = go (\(Nd x y) -> g x <> g y) r+    go g (Cons1 t r) = g t <> go (\(Nd x y) -> g x <> g y) r++foldr1Map :: (a -> b -> b) -> (a -> b) -> NERAList a -> b+foldr1Map f z (NE xs) = foldr1Map' f z xs++foldr1Map' :: Tr.IsTree f => (a -> b -> b) -> (a -> b) -> NERAList' f a -> b+foldr1Map' f z (Last  t)   = Tr.foldr1Map f z t+foldr1Map' f z (Cons0  r)  = foldr1Map' f z r+foldr1Map' f z (Cons1 t r) = I.foldr f (foldr1Map' f z r) t++ifoldMap :: Monoid m => (Int -> a -> m) -> NERAList a -> m+#if MIN_VERSION_base(4,11,0)+ifoldMap = ifoldMap1+#else+ifoldMap f = unwrapMonoid . ifoldMap1 (\i a -> WrapMonoid (f i a))+#endif++-- |+--+-- >>> import Data.Semigroup (Min (..))+--+-- >>> ifoldMap1 (\_ x -> Min x) $ fromNonEmpty $ 5 :| [3,1,2,4]+-- Min {getMin = 1}+--+-- >>> ifoldMap1 (\i x -> Min (i + x)) $ fromNonEmpty $ 5 :| [3,1,2,4]+-- Min {getMin = 3}+--+ifoldMap1 :: forall a s. Semigroup s => (Int -> a -> s) -> NERAList a -> s+ifoldMap1 f (NE xs) = go 0 1 xs where+    go :: Tr.IsTree t => Tr.Offset -> Tr.Size -> NERAList' t a -> s+    go o s (Last t)    = Tr.ifoldMap1 o s f t+    go o s (Cons0   r) = go o (s + s) r+    go o s (Cons1 t r) = Tr.ifoldMap1 o s f t <> go (o + s) (s + s) r++ifoldr1Map :: forall a b. (Int -> a -> b -> b) -> (Int -> a -> b) -> NERAList a -> b+ifoldr1Map f z (NE xs) = go 0 1 xs where+    go :: Tr.IsTree t => Tr.Offset -> Tr.Size -> NERAList' t a -> b+    go o s (Last  t)   = Tr.ifoldr1Map o s f z t+    go o s (Cons0   r) = go o (s * 2) r+    go o s (Cons1 t r) = Tr.ifoldr o s f (go (o + s) (s + s) r) t++-------------------------------------------------------------------------------+-- Mapping+-------------------------------------------------------------------------------++-- |+-- >>> map toUpper (fromNonEmpty ('a' :| ['b'..'f']))+-- fromNonEmpty ('A' :| "BCDEF")+--+map :: (a -> b) -> NERAList a -> NERAList b+map = fmap++-- |+--+-- >>> imap (,) (fromNonEmpty ('a' :| ['b'..'f']))+-- fromNonEmpty ((0,'a') :| [(1,'b'),(2,'c'),(3,'d'),(4,'e'),(5,'f')])+imap :: (Int -> a -> b) -> NERAList a -> NERAList b+imap f xs = unI (itraverse (\i x -> I (f i x)) xs)++itraverse :: forall f a b. Applicative f => (Int -> a -> f b) -> NERAList a -> f (NERAList b)+itraverse f (NE xs) = NE <$> go 0 1 xs where+    go :: Tr.IsTree t => Tr.Offset -> Tr.Size -> NERAList' t a -> f (NERAList' t b)+    go !o !s (Last  t)   = Last <$> Tr.itraverse o s f t+    go  o  s (Cons0   r) = Cons0 <$> go o (2 * s) r+    go  o  s (Cons1 t r) = Cons1+      <$> Tr.itraverse o s f t+      <*> go (o + s) (2 * s) r++#ifdef MIN_VERSION_semigroupoids+itraverse1 :: forall f a b. Apply f => (Int -> a -> f b) -> NERAList a -> f (NERAList b)+itraverse1 f (NE xs) = NE <$> go 0 1 xs where+    go :: Tr.IsTree t => Tr.Offset -> Tr.Size -> NERAList' t a -> f (NERAList' t b)+    go !o !s (Last  t)   = Last <$> Tr.itraverse1 o s f t+    go  o  s (Cons0   r) = Cons0 <$> go o (2 * s) r+    go  o  s (Cons1 t r) = Cons1+      <$> Tr.itraverse1 o s f t+      <.> go (o + s) (2 * s) r+#endif++-- | Adjust a value in the list.+--+-- >>> adjust 3 toUpper $ fromNonEmpty $ 'a' :| "bcdef"+-- fromNonEmpty ('a' :| "bcDef")+--+-- If index is out of bounds, the list is returned unmodified.+--+-- >>> adjust 10 toUpper $ fromNonEmpty $ 'a' :| "bcdef"+-- fromNonEmpty ('a' :| "bcdef")+--+-- >>> adjust (-1) toUpper $ fromNonEmpty $ 'a' :| "bcdef"+-- fromNonEmpty ('a' :| "bcdef")+--+adjust :: forall a. Int -> (a -> a) -> NERAList a -> NERAList a+adjust i _ xs | i < 0 = xs+adjust i f (NE xs) = NE (go 0 1 xs) where+    go :: Tr.IsTree t => Tr.Offset -> Tr.Size -> NERAList' t a -> NERAList' t a+    go !o !s (Last  t)   = Last (Tr.adjust s (i - o) f t)+    go  o  s (Cons0   r) = Cons0 (go o (s + s) r)+    go  o  s (Cons1 t r)+        | i - o < s = Cons1 (Tr.adjust s (i - o) f t) r+        | otherwise = Cons1 t (go (o + s) (s + s) r)++-------------------------------------------------------------------------------+-- QuickCheck+-------------------------------------------------------------------------------++instance QC.Arbitrary1 NERAList where+    liftArbitrary arb = do+        x  <- arb+        xs <- QC.liftArbitrary arb+        pure (fromNonEmpty (x :| xs))++    liftShrink shr+        = fmap (\(x,xs) -> fromNonEmpty (x:|xs))+        . QC.liftShrink2 shr (QC.liftShrink shr)+        . (\(x:|xs) -> (x,xs)) . toNonEmpty++instance QC.Arbitrary a => QC.Arbitrary (NERAList a) where+    arbitrary = QC.arbitrary1+    shrink    = QC.shrink1++instance QC.CoArbitrary a => QC.CoArbitrary (NERAList a) where+    coarbitrary xs = QC.coarbitrary (y, ys) where+        (y:|ys) = toNonEmpty xs++instance QC.Function a => QC.Function (NERAList a) where+    function = QC.functionMap (fwd . toNonEmpty) (fromNonEmpty . bwd) where+        fwd (x :| xs) = (x, xs)+        bwd (x, xs) = x :| xs++-------------------------------------------------------------------------------+-- Utilities+-------------------------------------------------------------------------------++newtype I a = I a+unI :: I a -> a+unI (I a) = a++instance Functor I where+    fmap f (I x) = I (f x)++instance Applicative I where+    pure        = I+    I f <*> I x = I (f x)+    _ *> x      = x+    x <* _      = x+#if MIN_VERSION_base(4,10,0)+    liftA2 f (I x) (I y) = I (f x y)+#endif+
+ src/Data/RAList/Tree.hs view
@@ -0,0 +1,7 @@+module Data.RAList.Tree (+    Leaf (..),+    Node (..),+    Dir (..),+    ) where++import Data.RAList.Tree.Internal
+ src/Data/RAList/Tree/Internal.hs view
@@ -0,0 +1,285 @@+{-# LANGUAGE BangPatterns      #-}+{-# LANGUAGE CPP               #-}+{-# LANGUAGE DeriveFoldable    #-}+{-# LANGUAGE DeriveFunctor     #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE FlexibleContexts  #-}+{-# LANGUAGE TypeFamilies      #-}+module Data.RAList.Tree.Internal (+    Leaf (..),+    Node (..),+    Dir (..),+    -- * Tree class+    -- | TODO move to private module so new instances cannot be defined+    IsTree (..),+    Size,+    Offset,+    ) where++import Prelude+       (Bool (..), Eq (..), Functor (..), Int, Maybe (..), Num (..), Ord (..),+       Show, div, otherwise, seq, (&&), (.))++import Control.Applicative (Applicative (..), (<$>))+import Control.DeepSeq     (NFData (..))+import Data.Hashable       (Hashable (..))+import Data.Monoid         (Monoid (..))+import Data.Semigroup      (Semigroup (..))++import qualified Data.Foldable    as I (Foldable (..))+import qualified Data.Traversable as I (Traversable (..))++#ifdef MIN_VERSION_distributive+import qualified Data.Distributive as I (Distributive (..))++#ifdef MIN_VERSION_adjunctions+import qualified Data.Functor.Rep as I (Representable (..))+#endif+#endif++#ifdef MIN_VERSION_semigroupoids+import Data.Functor.Apply (Apply (..))++import qualified Data.Semigroup.Foldable    as I (Foldable1 (..))+import qualified Data.Semigroup.Traversable as I (Traversable1 (..))+#endif++-------------------------------------------------------------------------------+-- Types+-------------------------------------------------------------------------------++-- | A 'Leaf' is isomorphic to 'Identity', but we reimplement it here+-- to have domain specific type. The short constructor name is a bonus.+newtype Leaf a = Lf a+  deriving (Eq, Ord, Show, Functor, I.Traversable)++-- | 'Node' is a product of two @f@. This way we can form a perfect binary tree.+data Node f a = Nd (f a) (f a)+  deriving (Eq, Ord, Show, Functor, I.Traversable)++-- | Direction in 'Node'.+data Dir a = L a | R a+  deriving (Eq, Ord, Show, Functor, I.Foldable, I.Traversable)++-------------------------------------------------------------------------------+-- Instances+-------------------------------------------------------------------------------++-- These instances are manually implemented, because we can have efficient+-- foldr and foldl+instance I.Foldable Leaf where+    foldMap f (Lf x) = f x+    foldr f z (Lf x) = f x z+    foldl f z (Lf x) = f z x+    foldr' f z (Lf x) = f x z+    foldl' f z (Lf x) = f z x++#if MIN_VERSION_base(4,8,0)+    length _ = 1+    null _ = False+#endif++instance I.Foldable f => I.Foldable (Node f) where+    foldMap f (Nd x y) = mappend (I.foldMap f x) (I.foldMap f y)++    foldr f z (Nd x y) = I.foldr f (I.foldr f z y) x+    foldl f z (Nd x y) = I.foldl f (I.foldl f z x) y++    foldr' f z (Nd x y) = let !acc = I.foldr' f z y in I.foldr' f acc x+    foldl' f z (Nd x y) = let !acc = I.foldl' f z x in I.foldl' f acc y++#if MIN_VERSION_base(4,8,0)+    length (Nd x y) = I.length x + I.length y+    null (Nd x y)   = I.null x && I.null y+#endif++#ifdef MIN_VERSION_semigroupoids+instance I.Foldable1 Leaf where+    foldMap1 f (Lf x) = f x++instance I.Traversable1 Leaf where+    traverse1 f (Lf x) = Lf <$> f x++instance I.Foldable1 f => I.Foldable1 (Node f) where+    foldMap1 f (Nd x y) = I.foldMap1 f x <> I.foldMap1 f y++instance I.Traversable1 f => I.Traversable1 (Node f) where+    traverse1 f (Nd x y) = Nd <$> I.traverse1 f x <.> I.traverse1 f y+#endif++instance NFData a => NFData (Leaf a) where+    rnf (Lf a) = rnf a++instance NFData (f a) => NFData (Node f a) where+    rnf (Nd x y) = rnf x `seq` rnf y++instance Hashable a => Hashable (Leaf a) where+    hashWithSalt salt (Lf x) = hashWithSalt salt x++instance Hashable (f a) => Hashable (Node f a)  where+    hashWithSalt salt (Nd x y) = salt+        `hashWithSalt` x+        `hashWithSalt` y++#ifdef MIN_VERSION_distributive+instance I.Distributive Leaf where+    distribute xs = Lf (fmap (\(Lf x) -> x) xs)++instance I.Distributive f => I.Distributive (Node f) where+    distribute xs = Nd+        (I.distribute (fmap (\(Nd x _) -> x) xs))+        (I.distribute (fmap (\(Nd _ y) -> y) xs))++#ifdef MIN_VERSION_adjunctions+instance I.Representable Leaf where+    type Rep Leaf = ()+    index (Lf x) _ = x+    tabulate f     = Lf (f ())++instance I.Representable f => I.Representable (Node f) where+    type Rep (Node f) = Dir (I.Rep f)++    index (Nd x _) (L i) = I.index x i+    index (Nd _ y) (R j) = I.index y j++    tabulate f = Nd (I.tabulate (f . L)) (I.tabulate (f . R))+#endif+#endif++-------------------------------------------------------------------------------+-- IsLeaf+-------------------------------------------------------------------------------++-- | Size of a tree.+type Size = Int+type Offset = Int++class (+#ifdef MIN_VERSION_semigroupoids+    I.Traversable1 t+#else+    I.Traversable t+#endif+    ) => IsTree t where+    -- indexing+    safeIndex :: Size -> t a -> Int -> Maybe a++    head :: t a -> a+    last :: t a -> a++    -- folding++    ifoldr :: Offset -> Size+           -> (Int -> a -> b -> b) -> b -> t a -> b++    ifoldMap1 :: Semigroup s => Offset -> Size+              -> (Int -> a -> s) -> t a -> s++    foldr1Map  :: (        a -> b -> b) -> (a -> b) -> t a -> b+    ifoldr1Map :: Offset -> Size+               -> (Int ->  a -> b -> b) -> (Int -> a -> b) -> t a -> b++    -- mapping++    adjust :: Size -> Int -> (a -> a) -> t a -> t a++    itraverse+        :: Applicative f+        => Offset+        -> Size+        -> (Int -> a -> f b) -> t a -> f (t b)++#ifdef MIN_VERSION_semigroupoids+    traverse1  :: Apply f => (a -> f b) -> t a -> f (t b)+    itraverse1 :: Apply f => Offset -> Size -> (Int -> a -> f b) -> t a -> f (t b)+#endif++-------------------------------------------------------------------------------+-- IsTree Leaf+-------------------------------------------------------------------------------++instance IsTree Leaf where+    -- indexing+    safeIndex _ (Lf x) 0 = Just x+    safeIndex  _ _     _ = Nothing++    head (Lf x) = x+    last = head+++    -- folding+    foldr1Map       _ z (Lf x) = z x++    ifoldr     !o _ f z (Lf x) = f o x z+    ifoldMap1  !o _ f   (Lf x) = f o x+    ifoldr1Map !o _ _ z (Lf x) = z o x++    -- mapping+    adjust _ !i f (Lf x)+        | 0 == i    = Lf (f x)+        | otherwise = Lf x++    itraverse !o _ f (Lf x) = fmap Lf (f o x)++#ifdef MIN_VERSION_semigroupoids+    traverse1       f (Lf x) = fmap Lf (f x)+    itraverse1 !o _ f (Lf x) = fmap Lf (f o x)+#endif++-------------------------------------------------------------------------------+-- IsTree Node+-------------------------------------------------------------------------------++instance IsTree f => IsTree (Node f) where+    -- indexing++    safeIndex s (Nd x y) i+        | i < s2    = safeIndex s2 x i+        | otherwise = safeIndex s2 y (i - s2)+      where+        s2 = s `div` 2++    head (Nd x _) = head x+    last (Nd _ y) = last y++    -- folding++    foldr1Map f z (Nd x y) = I.foldr f (foldr1Map f z y) x++    ifoldr1Map !o !s f z (Nd x y) = ifoldr o s2 f (ifoldr1Map (o + s2) s2 f z y) x+      where+        s2 = s `div` 2++    ifoldr !o !s f z (Nd x y) = ifoldr o s2 f (ifoldr (o + s2) s2 f z y) x+      where+        s2 = s `div` 2++    ifoldMap1 !o !s f (Nd x y) = ifoldMap1 o s2 f x <> ifoldMap1 (o + s2) s2 f y+      where+        s2 = s `div` 2++    -- mapping++    adjust s i f nd@(Nd x y)+        | i < s2    = Nd (adjust s2 i f x) y+        | i < s     = Nd x (adjust s2 (i - s2) f y)+        | otherwise = nd+      where+        s2 = s `div` 2++    itraverse !o !s f (Nd x y) = Nd+        <$> itraverse o        s2 f x+        <*> itraverse (o + s2) s2 f y+      where+        s2 = s `div` 2++#ifdef MIN_VERSION_semigroupoids+    traverse1 f (Nd x y) = Nd <$> traverse1 f x <.> traverse1 f y++    itraverse1 !o !s f (Nd x y) = Nd+        <$> itraverse1 o        s2 f x+        <.> itraverse1 (o + s2) s2 f y+      where+        s2 = s `div` 2+#endif+
+ src/Data/RAVec.hs view
@@ -0,0 +1,461 @@+{-# LANGUAGE CPP                   #-}+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE DeriveDataTypeable    #-}+{-# LANGUAGE EmptyCase             #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE GADTs                 #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes            #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE StandaloneDeriving    #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE TypeOperators         #-}+-- | Length-indexed random access list.+--+-- See <http://www.staff.science.uu.nl/~swier004/publications/2019-jfp-submission.pdf>+module Data.RAVec (+    -- * Random access list+    RAVec (..),++    -- * Construction+    empty,+    singleton,+    cons,+    withCons,+    head,+    last,++    -- * Conversion+    toList,+    toNonEmpty,+    fromList,+    reifyNonEmpty,++    -- * Indexing+    (!),+    tabulate,++    -- * Folds+    foldMap,+    foldMap1,+    ifoldMap,+    ifoldMap1,+    foldr,+    ifoldr,++    -- * Mapping+    map,+    imap,+    traverse,+    itraverse,+#ifdef MIN_VERSION_semigroupoids+    traverse1,+    itraverse1,+#endif++    -- * Zipping+    zipWith,+    izipWith,++    -- * Universe+    universe,+    repeat,++    -- * QuickCheck+    liftArbitrary,+    liftShrink,+    )  where++import Prelude+       (Bool (..), Eq (..), Functor (..), Int, Maybe (..), Ord (..), Show, ($), (.))++import Control.Applicative (Applicative (..), (<$>))+import Control.DeepSeq     (NFData (..))+import Data.Bin            (Bin (..))+import Data.Bin.Pos        (Pos (..))+import Data.Hashable       (Hashable (..))+import Data.List.NonEmpty  (NonEmpty (..))+import Data.Monoid         (Monoid (..))+import Data.Semigroup      (Semigroup (..))+import Data.Type.Bin       (SBin (..), SBinI (..), SBinPI (..))+import Data.Type.Equality  ((:~:) (..))+import Data.Typeable       (Typeable)++import qualified Data.RAVec.NonEmpty as NE+import qualified Data.Type.Bin       as B++import qualified Data.Foldable    as I (Foldable (..))+import qualified Data.Traversable as I (Traversable (..))+import qualified Test.QuickCheck  as QC++#ifdef MIN_VERSION_distributive+import qualified Data.Distributive as I (Distributive (..))++#ifdef MIN_VERSION_adjunctions+import qualified Data.Functor.Rep as I (Representable (..))+#endif+#endif++#ifdef MIN_VERSION_semigroupoids+import Data.Functor.Apply (Apply (..))++import qualified Data.Semigroup.Foldable    as I (Foldable1 (..))+import qualified Data.Semigroup.Traversable as I (Traversable1 (..))+#endif++import Data.RAVec.NonEmpty (NERAVec (..))++-- $setup+-- >>> :set -XScopedTypeVariables -XDataKinds+-- >>> import Prelude (print, Char, Bounded (..))+-- >>> import Data.List (sort)+-- >>> import Data.Wrd (Wrd (..))+-- >>> import Data.Bin.Pos (top, pop)+-- >>> import Data.BinP.PosP (PosP (..), PosP' (..))+-- >>> import qualified Data.Bin.Pos as P++-------------------------------------------------------------------------------+-- Random access vec+-------------------------------------------------------------------------------++-- | Length indexed random access lists.+data RAVec (b :: Bin) a where+    Empty    :: RAVec 'BZ a+    NonEmpty :: NERAVec b a -> RAVec ('BP b) a+  deriving (Typeable)++-------------------------------------------------------------------------------+-- Instances+-------------------------------------------------------------------------------++deriving instance Eq a   => Eq   (RAVec b a)+deriving instance Show a => Show (RAVec b a)++instance Ord a => Ord (RAVec b a) where+    compare xs ys = compare (toList xs) (toList ys)++instance Functor (RAVec b) where+    fmap = map++instance I.Foldable (RAVec b) where+    foldMap    = foldMap+    foldr      = foldr++#if MIN_VERSION_base(4,8,0)+    null = null+#endif++instance I.Traversable (RAVec b) where+    traverse = traverse++#ifdef MIN_VERSION_semigroupoids+instance b ~ 'BP n => I.Foldable1 (RAVec b) where+    foldMap1   = foldMap1+    toNonEmpty = toNonEmpty++instance b ~ 'BP n => I.Traversable1 (RAVec b) where+    traverse1 = traverse1+#endif++instance NFData a => NFData (RAVec b a) where+    rnf Empty          = ()+    rnf (NonEmpty ral) = rnf ral++instance Hashable a => Hashable (RAVec b a) where+    hashWithSalt salt = hashWithSalt salt . toList++instance SBinI b => Applicative (RAVec b) where+    pure   = repeat+    (<*>)  = zipWith ($)+    x <* _ = x+    _ *> x = x+#if MIN_VERSION_base(4,10,0)+    liftA2 = zipWith+#endif++-- TODO: Monad?++#ifdef MIN_VERSION_distributive+instance SBinI b => I.Distributive (RAVec b) where+    distribute f = tabulate (\k -> fmap (! k) f)++#ifdef MIN_VERSION_adjunctions+instance SBinI b => I.Representable (RAVec b) where+    type Rep (RAVec b) = Pos b+    index    = (!)+    tabulate = tabulate++#endif+#endif++instance Semigroup a => Semigroup (RAVec b a) where+    (<>) = zipWith (<>)++instance (Monoid a, SBinI b) => Monoid (RAVec b a) where+    mempty  = repeat mempty+    mappend = zipWith mappend++#ifdef MIN_VERSION_semigroupoids+instance Apply (RAVec b) where+    (<.>) = zipWith ($)+    liftF2 = zipWith+    _ .> x = x+    x <. _ = x+#endif++-- TODO: I.Bind?++-------------------------------------------------------------------------------+-- Construction+-------------------------------------------------------------------------------++empty :: RAVec B.Bin0 a+empty = Empty++singleton :: a -> RAVec B.Bin1 a+singleton = NonEmpty . NE.singleton++-- | Cons an element in front of 'RAVec'.+--+-- >>> reifyList "xyz" (print . toList . cons 'a')+-- "axyz"+--+cons :: a -> RAVec b a -> RAVec (B.Succ b) a+cons x Empty         = singleton x+cons x (NonEmpty xs) = NonEmpty (NE.cons x xs)++-- | Variant of 'cons' which computes the 'SBinI' dictionary at the same time.+withCons :: SBinI b => a -> RAVec b a -> (SBinPI (B.Succ' b) => RAVec (B.Succ b) a -> r) -> r+withCons = go sbin where+    go :: SBin b -> a -> RAVec b a -> (SBinPI (B.Succ' b) => RAVec (B.Succ b) a -> r) -> r+    go SBZ x Empty k         = k (singleton x)+    go SBP x (NonEmpty xs) k = NE.withCons x xs $ k . NonEmpty++-- | The first element of a non-empty 'RAVec'.+--+-- >>> reifyNonEmpty ('x' :| "yz") head+-- 'x'+--+head :: RAVec ('BP b) a -> a+head (NonEmpty ral) = NE.head ral++-- | The last element of a non-empty 'RAVec'.+--+-- >>> reifyNonEmpty ('x' :| "yz") last+-- 'z'+--+last :: RAVec ('BP b) a -> a+last (NonEmpty ral) = NE.last ral++-------------------------------------------------------------------------------+-- Conversions+-------------------------------------------------------------------------------++toList :: RAVec b a -> [a]+toList Empty          = []+toList (NonEmpty ral) = NE.toList ral++toNonEmpty :: RAVec ('BP b) a -> NonEmpty a+toNonEmpty (NonEmpty ral) = NE.toNonEmpty ral++-- | Convert a list @[a]@ to @'RAVec' b a@.+-- Returns 'Nothing' if lengths don't match.+--+-- >>> fromList "foo" :: Maybe (RAVec B.Bin3 Char)+-- Just (NonEmpty (NE (Cons1 (Leaf 'f') (Last (Node (Leaf 'o') (Leaf 'o'))))))+--+-- >>> fromList "quux" :: Maybe (RAVec B.Bin3 Char)+-- Nothing+--+-- >>> fromList "xy" :: Maybe (RAVec B.Bin3 Char)+-- Nothing+--+fromList :: forall b a. SBinI b => [a] -> Maybe (RAVec b a)+fromList xs = reifyList xs mk where+    mk :: forall c. SBinI c => RAVec c a -> Maybe (RAVec b a)+    mk ral = do+        Refl <- B.eqBin :: Maybe (b :~: c)+        Just ral++-- |+--+-- >>> reifyList "foo" print+-- NonEmpty (NE (Cons1 (Leaf 'f') (Last (Node (Leaf 'o') (Leaf 'o')))))+--+-- >>> reifyList "xyzzy" toList+-- "xyzzy"+reifyList :: [a] -> (forall b. SBinI b => RAVec b a -> r) -> r+reifyList []     k = k Empty+reifyList (x:xs) k = reifyList xs $ \ral -> withCons x ral k++reifyNonEmpty :: NonEmpty a -> (forall b. SBinPI b => RAVec ('BP b) a -> r) -> r+reifyNonEmpty xs k = NE.reifyNonEmpty xs $ k . NonEmpty++-------------------------------------------------------------------------------+-- Indexing+-------------------------------------------------------------------------------++-- | Indexing.+--+-- >>> let ral :: RAVec B.Bin4 Char; Just ral = fromList "abcd"+--+-- >>> ral ! minBound+-- 'a'+--+-- >>> ral ! maxBound+-- 'd'+--+-- >>> ral ! pop top+-- 'b'+--+(!) :: RAVec b a -> Pos b -> a+(!) Empty        p       = case p of {}+(!) (NonEmpty b) (Pos i) = b NE.! i++tabulate :: forall b a. SBinI b => (Pos b -> a) -> RAVec b a+tabulate f = case sbin :: SBin b of+    SBZ -> Empty+    SBP -> NonEmpty (NE.tabulate (f . Pos))++-------------------------------------------------------------------------------+-- Folds+-------------------------------------------------------------------------------++foldMap :: Monoid m => (a -> m) -> RAVec n a -> m+foldMap _ Empty        = mempty+foldMap f (NonEmpty r) = NE.foldMap f r++ifoldMap :: Monoid m => (Pos b -> a -> m) -> RAVec b a -> m+ifoldMap _ Empty        = mempty+ifoldMap f (NonEmpty r) = NE.ifoldMap (f . Pos) r++foldMap1 :: Semigroup m => (a -> m) -> RAVec ('BP b) a -> m+foldMap1 f (NonEmpty r) = NE.foldMap1 f r++ifoldMap1 :: Semigroup m => (Pos ('BP b) -> a -> m) -> RAVec ('BP b) a -> m+ifoldMap1 f (NonEmpty r) = NE.ifoldMap1 (f . Pos) r++foldr :: (a -> b -> b) -> b -> RAVec n a -> b+foldr _ z Empty          = z+foldr f z (NonEmpty ral) = NE.foldr f z ral++ifoldr :: (Pos n -> a -> b -> b) -> b -> RAVec n a -> b+ifoldr _ z Empty          = z+ifoldr f z (NonEmpty ral) = NE.ifoldr (f . Pos) z ral++null :: RAVec n a -> Bool+null Empty        = True+null (NonEmpty _) = False++-------------------------------------------------------------------------------+-- Special folds+-------------------------------------------------------------------------------++-- TBW++-------------------------------------------------------------------------------+-- Mapping+-------------------------------------------------------------------------------++map :: (a -> b) -> RAVec n a -> RAVec n b+map _ Empty        = Empty+map f (NonEmpty r) = NonEmpty (NE.map f r)++imap :: (Pos n -> a -> b) -> RAVec n a -> RAVec n b+imap _ Empty = Empty+imap f (NonEmpty r) = NonEmpty (NE.imap (f . Pos) r)++traverse :: Applicative f => (a -> f b) -> RAVec n a -> f (RAVec n b)+traverse _ Empty          = pure empty+traverse f (NonEmpty ral) = NonEmpty <$> NE.traverse f ral++itraverse :: Applicative f => (Pos n -> a -> f b) -> RAVec n a -> f (RAVec n b)+itraverse _ Empty        = pure Empty+itraverse f (NonEmpty r) = NonEmpty <$> NE.itraverse (f . Pos) r++#ifdef MIN_VERSION_semigroupoids+traverse1 :: Apply f => (a -> f b) -> RAVec ('BP n) a -> f (RAVec ('BP n) b)+traverse1 f (NonEmpty r) = NonEmpty <$> NE.traverse1 f r++itraverse1 :: Apply f => (Pos ('BP n) -> a -> f b) -> RAVec ('BP n) a -> f (RAVec ('BP n) b)+itraverse1 f (NonEmpty r) = NonEmpty <$> NE.itraverse1 (f . Pos) r+#endif++-------------------------------------------------------------------------------+-- Zipping+-------------------------------------------------------------------------------++-- | Zip two 'RAVec's with a function.+zipWith :: (a -> b -> c) -> RAVec n a -> RAVec n b -> RAVec n c+zipWith _ Empty         Empty         = Empty+zipWith f (NonEmpty xs) (NonEmpty ys) = NonEmpty (NE.zipWith f xs ys)++-- | Zip two 'RAVec's with a function which also takes 'Pos' index.+izipWith :: (Pos n -> a -> b -> c) -> RAVec n a -> RAVec n b -> RAVec n c+izipWith _ Empty         Empty         = Empty+izipWith f (NonEmpty xs) (NonEmpty ys) = NonEmpty (NE.izipWith (f . Pos) xs ys)++-- | Repeat a value.+--+-- >>> repeat 'x' :: RAVec B.Bin5 Char+-- NonEmpty (NE (Cons1 (Leaf 'x') (Cons0 (Last (Node (Node (Leaf 'x') (Leaf 'x')) (Node (Leaf 'x') (Leaf 'x')))))))+--+repeat :: forall b a. SBinI b => a -> RAVec b a+repeat x = case sbin :: SBin b of+    SBZ -> Empty+    SBP -> NonEmpty (NE.repeat x)++-------------------------------------------------------------------------------+-- Universe+-------------------------------------------------------------------------------++-- |+--+-- >>> universe :: RAVec B.Bin2 (Pos B.Bin2)+-- NonEmpty (NE (Cons0 (Last (Node (Leaf 0) (Leaf 1)))))+--+-- >>> let u = universe :: RAVec B.Bin3 (Pos B.Bin3)+-- >>> u+-- NonEmpty (NE (Cons1 (Leaf 0) (Last (Node (Leaf 1) (Leaf 2)))))+--+-- >>> P.explicitShow $ u ! Pos (PosP (Here WE))+-- "Pos (PosP (Here WE))"+--+-- >>> let u' = universe :: RAVec B.Bin5 (Pos B.Bin5)+--+-- >>> toList u' == sort (toList u')+-- True+--+universe :: forall b. SBinI b => RAVec b (Pos b)+universe = case sbin :: SBin b of+    SBZ -> Empty+    SBP -> NonEmpty (fmap Pos NE.universe)++-------------------------------------------------------------------------------+-- QuickCheck+-------------------------------------------------------------------------------++liftArbitrary :: B.SBinI b => QC.Gen a -> QC.Gen (RAVec b a)+liftArbitrary = liftArbitrary++liftShrink :: (a -> [a]) -> RAVec b a -> [RAVec b a]+liftShrink _   Empty        = []+liftShrink shr (NonEmpty r) = NonEmpty <$> NE.liftShrink shr r++instance B.SBinI b => QC.Arbitrary1 (RAVec b) where+    liftArbitrary = liftArbitrary+    liftShrink    = liftShrink++instance (B.SBinI b, QC.Arbitrary a) => QC.Arbitrary (RAVec b a) where+    arbitrary = QC.arbitrary1+    shrink    = QC.shrink1++instance QC.CoArbitrary a => QC.CoArbitrary (RAVec b a) where+    coarbitrary Empty        = QC.variant (0 :: Int)+    coarbitrary (NonEmpty r) = QC.variant (1 :: Int) . QC.coarbitrary r++instance (B.SBinI b, QC.Function a) => QC.Function (RAVec b a) where+    function = case B.sbin :: B.SBin b of+        SBZ -> QC.functionMap (\Empty -> ())       (\() -> Empty) +        SBP -> QC.functionMap (\(NonEmpty r) -> r) NonEmpty
+ src/Data/RAVec/NonEmpty.hs view
@@ -0,0 +1,614 @@+{-# LANGUAGE CPP                   #-}+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE DeriveDataTypeable    #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE GADTs                 #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes            #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE StandaloneDeriving    #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE TypeOperators         #-}+-- | Non-empty length-indexed random access list.+module Data.RAVec.NonEmpty (+    -- * Random access list+    NERAVec (..),+    NERAVec' (..),++    -- * Construction+    singleton, singleton',+    cons, consTree,+    withCons, withConsTree,++    -- * Conversion+    toList, toList',+    toNonEmpty, toNonEmpty',+    reifyNonEmpty, reifyNonEmpty',++    -- * Indexing+    (!), index',+    tabulate, tabulate',++    unsingleton,+    head, head',+    last, last',++    -- * Folds+    foldMap, foldMap',+    foldMap1, foldMap1',+    ifoldMap, ifoldMap',+    ifoldMap1, ifoldMap1',+    foldr, foldr',+    ifoldr, ifoldr',+    foldr1Map, foldr1Map',+    ifoldr1Map, ifoldr1Map',++    -- * Mapping+    map, map',+    imap, imap',+    traverse, traverse',+    itraverse, itraverse',+#ifdef MIN_VERSION_semigroupoids+    traverse1, traverse1',+    itraverse1, itraverse1',+#endif++    -- * Zipping+    zipWith, zipWith',+    izipWith, izipWith',+    repeat, repeat',++    -- * Universe+    universe, universe',++    -- * QuickCheck+    liftArbitrary, liftArbitrary',+    liftShrink, liftShrink',+    ) where++import Prelude (Bool (..), uncurry, Int, Eq (..), Functor (..), Ord (..), Show, seq, ($), (.))++import Control.Applicative (Applicative (..), (<$>))+import Control.DeepSeq     (NFData (..))+import Data.Bin            (BinP (..))+import Data.BinP.PosP      (PosP (..), PosP' (..))+import Data.Coerce         (coerce)+import Data.Hashable       (Hashable (..))+import Data.List.NonEmpty  (NonEmpty (..))+import Data.Monoid         (Monoid (..))+import Data.Nat            (Nat (..))+import Data.Semigroup      (Semigroup (..))+import Data.Type.BinP      (SBinP (..), SBinPI (..))+import Data.Typeable       (Typeable)++import qualified Data.List.NonEmpty as NEList+import qualified Data.RAVec.Tree    as Tree+import qualified Data.Type.BinP     as BP+import qualified Data.Type.Nat      as N++import qualified Data.Foldable    as I (Foldable (..))+import qualified Data.Traversable as I (Traversable (..))+import qualified Test.QuickCheck  as QC++#ifdef MIN_VERSION_distributive+import qualified Data.Distributive as I (Distributive (..))++#ifdef MIN_VERSION_adjunctions+import qualified Data.Functor.Rep as I (Representable (..))+#endif+#endif++#ifdef MIN_VERSION_semigroupoids+import Data.Functor.Apply (Apply (..))++import qualified Data.Semigroup.Foldable    as I (Foldable1 (..))+import qualified Data.Semigroup.Traversable as I (Traversable1 (..))+#endif++import Data.RAVec.Tree (Tree (..))++-- $setup+-- >>> :set -XScopedTypeVariables -XDataKinds+-- >>> import Prelude (print, Char, Bounded (..))+-- >>> import Data.List (sort)+-- >>> import Data.Wrd (Wrd (..))+-- >>> import Data.Bin.Pos (top, pop)+-- >>> import qualified Data.Bin.Pos as P++-------------------------------------------------------------------------------+-- Random access vec+-------------------------------------------------------------------------------++-- | Non-empty random access list.+newtype NERAVec (b :: BinP) a = NE (NERAVec' 'Z b a)+  deriving (Eq, Ord, Show, Typeable)++-- | Non-empty random access list, undelying representation.+data NERAVec' (n :: Nat) (b :: BinP) a where+    Last  :: Tree n a -> NERAVec' n 'BE a+    Cons0 ::             NERAVec' ('S n) b a -> NERAVec' n ('B0 b) a+    Cons1 :: Tree n a -> NERAVec' ('S n) b a -> NERAVec' n ('B1 b) a+  deriving (Typeable)++-------------------------------------------------------------------------------+-- Instances+-------------------------------------------------------------------------------++deriving instance Eq a   => Eq   (NERAVec' n b a)+deriving instance Show a => Show (NERAVec' n b a)++instance Ord a => Ord (NERAVec' n b a) where+    compare xs ys = compare (toList' xs) (toList' ys)++instance Functor (NERAVec b) where+    fmap = map++instance Functor (NERAVec' n b) where+    fmap = map'++instance I.Foldable (NERAVec b) where+    foldMap = foldMap+    foldr   = foldr++#if MIN_VERSION_base(4,8,0)+    null _ = False+#endif++instance I.Foldable (NERAVec' n b) where+    foldMap = foldMap'+    foldr   = foldr'++#if MIN_VERSION_base(4,8,0)+    null _ = False+#endif++instance I.Traversable (NERAVec b) where+    traverse = traverse++instance I.Traversable (NERAVec' n b) where+    traverse = traverse'++#ifdef MIN_VERSION_semigroupoids+instance I.Foldable1 (NERAVec b) where+    foldMap1   = foldMap1+    toNonEmpty = toNonEmpty++instance I.Foldable1 (NERAVec' n b) where+    foldMap1   = foldMap1'+    toNonEmpty = toNonEmpty'++instance I.Traversable1 (NERAVec b) where+    traverse1 = traverse1++instance I.Traversable1 (NERAVec' n b) where+    traverse1 = traverse1'+#endif++instance NFData a => NFData (NERAVec b a) where+    rnf (NE xs) = rnf xs++instance NFData a => NFData (NERAVec' n b a) where+    rnf (Last  t)   = rnf t+    rnf (Cons0   r) = rnf r+    rnf (Cons1 t r) = rnf t `seq` rnf r++instance Hashable a => Hashable (NERAVec b a) where+    hashWithSalt salt (NE xs) = hashWithSalt salt xs++instance Hashable a => Hashable (NERAVec' n b a) where+    hashWithSalt salt = hashWithSalt salt . toList'++instance SBinPI b => Applicative (NERAVec b) where+    pure   = repeat+    (<*>)  = zipWith ($)+    x <* _ = x+    _ *> x = x+#if MIN_VERSION_base(4,10,0)+    liftA2 = zipWith+#endif++instance (SBinPI b, N.SNatI n) => Applicative (NERAVec' n b) where+    pure   = repeat'+    (<*>)  = zipWith' ($)+    x <* _ = x+    _ *> x = x+#if MIN_VERSION_base(4,10,0)+    liftA2 = zipWith'+#endif++#ifdef MIN_VERSION_distributive+instance SBinPI b => I.Distributive (NERAVec b) where+    distribute f = tabulate (\k -> fmap (! k) f)++instance (SBinPI b, N.SNatI n) => I.Distributive (NERAVec' n b) where+    distribute f = tabulate' (\k -> fmap (`index'` k) f)++#ifdef MIN_VERSION_adjunctions+instance SBinPI b => I.Representable (NERAVec b) where+    type Rep (NERAVec b) = PosP b+    index    = (!)+    tabulate = tabulate++instance (SBinPI b, N.SNatI n) => I.Representable (NERAVec' n b) where+    type Rep (NERAVec' n b) = PosP' n b+    index    = index'+    tabulate = tabulate'+#endif+#endif++instance Semigroup a => Semigroup (NERAVec b a) where+    (<>) = zipWith (<>)++instance Semigroup a => Semigroup (NERAVec' n b a) where+    (<>) = zipWith' (<>)++instance (Monoid a, SBinPI b) => Monoid (NERAVec b a) where+    mempty  = repeat mempty+    mappend = zipWith mappend++instance (Monoid a, SBinPI b, N.SNatI n) => Monoid (NERAVec' n b a) where+    mempty  = repeat' mempty+    mappend = zipWith' mappend++#ifdef MIN_VERSION_semigroupoids+instance Apply (NERAVec b) where+    (<.>)  = zipWith ($)+    liftF2 = zipWith+    _ .> x = x+    x <. _ = x++instance Apply (NERAVec' n b) where+    (<.>) = zipWith' ($)+    liftF2 = zipWith'+    _ .> x = x+    x <. _ = x+#endif++-------------------------------------------------------------------------------+-- Construction+-------------------------------------------------------------------------------++singleton :: forall a. a -> NERAVec BP.BinP1 a+singleton = coerce (singleton' :: a -> NERAVec' 'Z BP.BinP1 a)++singleton' :: a -> NERAVec' 'Z BP.BinP1 a+singleton' = Last . Tree.singleton++-- | 'cons' for non-empty rals.+cons :: forall a b. a -> NERAVec b a -> NERAVec (BP.Succ b) a+cons x (NE xs) = NE (consTree (Leaf x) xs)++consTree :: Tree n a -> NERAVec' n b a -> NERAVec' n (BP.Succ b) a+consTree x (Last t)    = Cons0 (Last (Node x t))+consTree x (Cons0 r)   = Cons1 x r+consTree x (Cons1 t r) = Cons0 (consTree (Node x t) r)++-- | 'withCons' for non-empty rals.+withCons :: SBinPI b => a -> NERAVec b a -> (SBinPI (BP.Succ b) => NERAVec (BP.Succ b) a -> r) -> r+withCons x (NE xs) k = withConsTree sbinp (Leaf x) xs $ k . NE++withConsTree :: SBinP b -> Tree n a -> NERAVec' n b a -> (SBinPI (BP.Succ b) => NERAVec' n (BP.Succ b) a -> r) -> r+withConsTree SBE x (Last t)    k = k (Cons0 (Last (Node x t)))+withConsTree SB0 x (Cons0 r)   k = k (Cons1 x r)+withConsTree SB1 x (Cons1 t r) k = withConsTree sbinp (Node x t) r $ k . Cons0++unsingleton :: NERAVec 'BE a -> a+unsingleton (NE (Last (Tree.Leaf x))) = x++head :: NERAVec b a -> a+head (NE x) = head' x++head' :: NERAVec' n b a -> a+head' (Last t)     = Tree.leftmost t+head' (Cons0 ral) = head' ral+head' (Cons1 t _) = Tree.leftmost t++last :: NERAVec b a -> a+last (NE x) = last' x++last' :: NERAVec' n b a -> a+last' (Last t)       = Tree.rightmost t+last' (Cons0 ral)   = head' ral+last' (Cons1 _ ral) = last' ral++-------------------------------------------------------------------------------+-- Conversions+-------------------------------------------------------------------------------++toList :: NERAVec b a -> [a]+toList (NE xs) = toList' xs++toList' :: NERAVec' n b a -> [a]+toList' = foldr' (:) []++toNonEmpty :: NERAVec b a -> NonEmpty a+toNonEmpty (NE xs) = toNonEmpty' xs++toNonEmpty' :: NERAVec' n b a -> NonEmpty a+toNonEmpty' = foldr1Map' NEList.cons (:|[])++reifyNonEmpty :: NonEmpty a -> (forall b. SBinPI b => NERAVec b a -> r) -> r+reifyNonEmpty xs k = reifyNonEmpty' xs $ k . NE++reifyNonEmpty' :: forall a r. NonEmpty a -> (forall b. SBinPI b => NERAVec' 'Z b a -> r) -> r+reifyNonEmpty' (x0 :| xs0) = go x0 xs0 where+    go :: forall k. a -> [a] -> (forall b. SBinPI b => NERAVec' 'Z b a -> k) -> k+    go x []     k = k (Last (Leaf x))+    go x (y:ys) k = go y ys $ \zs -> withConsTree sbinp (Leaf x) zs k++-------------------------------------------------------------------------------+-- Indexing+-------------------------------------------------------------------------------++(!) :: NERAVec b a -> PosP b -> a+(!) (NE xs) (PosP p) = index' xs p++index' :: NERAVec' n b a -> PosP' n b -> a+index' (Last t)      (AtEnd i)  = t Tree.! i+index' (Cons0 ral)   (There0 i) = index' ral i+index' (Cons1 t _)   (Here i)   = t Tree.! i+index' (Cons1 _ ral) (There1 i) = index' ral i++tabulate :: SBinPI b => (PosP b -> a) -> NERAVec b a+tabulate f = NE (tabulate' (f . PosP))++tabulate' :: forall b n a. (SBinPI b, N.SNatI n) => (PosP' n b -> a) -> NERAVec' n b a+tabulate' f = case sbinp :: SBinP b of+    SBE -> Last (Tree.tabulate (f . AtEnd))+    SB0 -> Cons0 (tabulate' (f . There0))+    SB1 -> Cons1 (Tree.tabulate (f . Here)) (tabulate' (f . There1))++-------------------------------------------------------------------------------+-- Folds+-------------------------------------------------------------------------------++foldMap :: Monoid m => (a -> m) -> NERAVec b a -> m+foldMap f (NE xs) = foldMap' f xs++foldMap' :: Monoid m => (a -> m) -> NERAVec' n b a -> m+foldMap' f (Last  t)   = Tree.foldMap f t+foldMap' f (Cons0   r) = foldMap' f r+foldMap' f (Cons1 t r) = mappend (Tree.foldMap f t) (foldMap' f r)++ifoldMap :: Monoid m => (PosP b -> a -> m) -> NERAVec b a -> m+ifoldMap f (NE xs) = ifoldMap' (f . PosP) xs++ifoldMap' :: Monoid m => (PosP' n b -> a -> m) -> NERAVec' n b a -> m+ifoldMap' f (Last  t)   = Tree.ifoldMap (f . AtEnd) t+ifoldMap' f (Cons0   r) = ifoldMap' (f . There0) r+ifoldMap' f (Cons1 t r) = Tree.ifoldMap (f . Here) t `mappend` ifoldMap' (f . There1) r++foldMap1 :: Semigroup m => (a -> m) -> NERAVec b a -> m+foldMap1 f (NE xs) = foldMap1' f xs++foldMap1' :: Semigroup m => (a -> m) -> NERAVec' n b a -> m+foldMap1' f (Last  t)   = Tree.foldMap1 f t+foldMap1' f (Cons0   r) = foldMap1' f r+foldMap1' f (Cons1 t r) = Tree.foldMap1 f t <> foldMap1' f r++ifoldMap1 :: Semigroup m => (PosP b -> a -> m) -> NERAVec b a -> m+ifoldMap1 f (NE xs) = ifoldMap1' (f . PosP) xs++ifoldMap1' :: Semigroup m => (PosP' n b -> a -> m) -> NERAVec' n b a -> m+ifoldMap1' f (Last  t)   = Tree.ifoldMap1 (f . AtEnd) t+ifoldMap1' f (Cons0   r) = ifoldMap1' (f . There0) r+ifoldMap1' f (Cons1 t r) = Tree.ifoldMap1 (f . Here) t <> ifoldMap1' (f . There1) r++foldr :: (a -> b -> b) -> b -> NERAVec m a -> b+foldr f z (NE xs) = foldr' f z xs++foldr1Map :: (a -> b -> b) -> (a -> b) -> NERAVec m a -> b+foldr1Map f z (NE xs) = foldr1Map' f z xs++ifoldr1Map :: (PosP m -> a -> b -> b) -> (PosP m -> a -> b) -> NERAVec m a -> b+ifoldr1Map f z (NE xs) = ifoldr1Map' (f . PosP) (z . PosP) xs++foldr' :: (a -> b -> b) -> b -> NERAVec' n m a -> b+foldr' f z (Last  t)   = Tree.foldr f z t+foldr' f z (Cons0   r) = foldr' f z r+foldr' f z (Cons1 t r) = Tree.foldr f (foldr' f z r) t++foldr1Map' :: (a -> b -> b) -> (a -> b) -> NERAVec' n m a -> b+foldr1Map' f z (Last t)    = Tree.foldr1Map f z t+foldr1Map' f z (Cons0   r) = foldr1Map' f z r+foldr1Map' f z (Cons1 t r) = Tree.foldr f (foldr1Map' f z r) t++ifoldr1Map' :: (PosP' n m -> a -> b -> b) -> (PosP' n m -> a -> b) -> NERAVec' n m a -> b+ifoldr1Map' f z (Last t)    = Tree.ifoldr1Map (f . AtEnd) (z . AtEnd) t+ifoldr1Map' f z (Cons0   r) = ifoldr1Map' (f . There0) (z . There0) r+ifoldr1Map' f z (Cons1 t r) = Tree.ifoldr (f . Here) (ifoldr1Map' (f . There1) (z . There1) r) t++ifoldr :: (PosP m -> a -> b -> b) -> b -> NERAVec m a -> b+ifoldr  f z (NE xs) = ifoldr' (f . PosP) z xs++ifoldr' :: (PosP' n m -> a -> b -> b) -> b -> NERAVec' n m a -> b+ifoldr' f z (Last  t)   = Tree.ifoldr (f . AtEnd) z t+ifoldr' f z (Cons0   r) = ifoldr' (f . There0) z r+ifoldr' f z (Cons1 t r) = Tree.ifoldr (f . Here) (ifoldr' (f . There1) z r) t++-------------------------------------------------------------------------------+-- Special folds+-------------------------------------------------------------------------------++-- TBW++-------------------------------------------------------------------------------+-- Mapping+-------------------------------------------------------------------------------++map :: (a -> b) -> NERAVec m a -> NERAVec m b+map f (NE xs) = NE (map' f xs)++map' :: (a -> b) -> NERAVec' n m a -> NERAVec' n m b+map' f (Last   t ) = Last (Tree.map f t)+map' f (Cons0   r) = Cons0 (map' f r)+map' f (Cons1 t r) = Cons1 (Tree.map f t) (map' f r)++imap :: (PosP m -> a -> b) -> NERAVec m a -> NERAVec m b+imap f (NE xs) = NE (imap' (f . PosP) xs)++imap' :: (PosP' n m -> a -> b) -> NERAVec' n m a -> NERAVec' n m b+imap' f (Last  t)   = Last (Tree.imap (f . AtEnd) t)+imap' f (Cons0   r) = Cons0 (imap' (f . There0) r)+imap' f (Cons1 t r) = Cons1 (Tree.imap (f . Here) t) (imap' (f . There1) r)++traverse :: Applicative f => (a -> f b) -> NERAVec m a -> f (NERAVec m b)+traverse f (NE xs) = fmap NE (traverse' f xs)++traverse' :: Applicative f => (a -> f b) -> NERAVec' n m a -> f (NERAVec' n m b)+traverse' f (Last  t)   = Last <$> Tree.traverse f t+traverse' f (Cons0   r) = Cons0 <$> traverse' f r+traverse' f (Cons1 t r) = Cons1 <$> Tree.traverse f t <*> traverse' f r++itraverse :: Applicative f => (PosP m -> a -> f b) -> NERAVec m a -> f (NERAVec m b)+itraverse f (NE xs) = fmap NE (itraverse' (f . PosP) xs)++itraverse' :: Applicative f => (PosP' n m -> a -> f b) -> NERAVec' n m a -> f (NERAVec' n m b)+itraverse' f (Last  t)   = Last <$> Tree.itraverse (f . AtEnd) t+itraverse' f (Cons0   r) = Cons0 <$> itraverse' (f . There0) r+itraverse' f (Cons1 t r) = Cons1 <$> Tree.itraverse (f . Here) t <*> itraverse' (f . There1) r++#ifdef MIN_VERSION_semigroupoids+traverse1 :: Apply f => (a -> f b) -> NERAVec m a -> f (NERAVec m b)+traverse1 f (NE xs) = fmap NE (traverse1' f xs)++traverse1' :: Apply f => (a -> f b) -> NERAVec' n m a -> f (NERAVec' n m b)+traverse1' f (Last  t)   = Last <$> Tree.traverse1 f t+traverse1' f (Cons0   r) = Cons0 <$> traverse1' f r+traverse1' f (Cons1 t r) = Cons1 <$> Tree.traverse1 f t <.> traverse1' f r++itraverse1 :: Apply f => (PosP m -> a -> f b) -> NERAVec m a -> f (NERAVec m b)+itraverse1 f (NE xs) = fmap NE (itraverse1' (f . PosP) xs)++itraverse1' :: Apply f => (PosP' n m -> a -> f b) -> NERAVec' n m a -> f (NERAVec' n m b)+itraverse1' f (Last  t)   = Last <$> Tree.itraverse1 (f . AtEnd) t+itraverse1' f (Cons0   r) = Cons0 <$> itraverse1' (f . There0) r+itraverse1' f (Cons1 t r) = Cons1 <$> Tree.itraverse1 (f . Here) t <.> itraverse1' (f . There1) r+#endif++-------------------------------------------------------------------------------+-- Zipping+-------------------------------------------------------------------------------++zipWith :: (a -> b -> c) -> NERAVec m a -> NERAVec m b -> NERAVec m c+zipWith f (NE xs) (NE ys) = NE (zipWith' f xs ys)++-- | Zip two 'NERAVec''s with a function.+zipWith' :: (a -> b -> c) -> NERAVec' n m a -> NERAVec' n m b -> NERAVec' n m c+zipWith' f (Last  t)   (Last  t')    = Last (Tree.zipWith f t t')+zipWith' f (Cons0   r) (Cons0    r') = Cons0 (zipWith' f r r')+zipWith' f (Cons1 t r) (Cons1 t' r') = Cons1 (Tree.zipWith f t t') (zipWith' f r r')++izipWith :: (PosP m -> a -> b -> c) -> NERAVec m a -> NERAVec m b -> NERAVec m c+izipWith f (NE xs) (NE ys) = NE (izipWith' (f . PosP) xs ys)++-- | Zip two 'NERAVec''s with a function which also takes 'PosP'' index.+izipWith' :: (PosP' n m -> a -> b -> c) -> NERAVec' n m a -> NERAVec' n m b -> NERAVec' n m c+izipWith' f (Last  t)   (Last  t')    = Last (Tree.izipWith (f . AtEnd) t t')+izipWith' f (Cons0   r) (Cons0    r') = Cons0 (izipWith' (f . There0) r r')+izipWith' f (Cons1 t r) (Cons1 t' r') = Cons1 (Tree.izipWith (f . Here) t t') (izipWith' (f . There1) r r')++repeat :: SBinPI b => a -> NERAVec b a+repeat = NE . repeat'++repeat' :: forall b n a. (N.SNatI n, SBinPI b) => a -> NERAVec' n b a+repeat' x = case sbinp :: SBinP b of+    SBE -> Last (Tree.repeat x)+    SB0 -> Cons0 (repeat' x)+    SB1 -> Cons1 (Tree.repeat x) (repeat' x)++-------------------------------------------------------------------------------+-- Universe+-------------------------------------------------------------------------------++universe :: forall b. SBinPI b => NERAVec b (PosP b)+universe = coerce (universe' :: NERAVec' 'Z b (PosP' 'Z b))++universe' :: forall n b. (N.SNatI n, SBinPI b) => NERAVec' n b (PosP' n b)+universe' = case sbinp :: SBinP b of+    SBE -> Last  (fmap AtEnd Tree.universe)+    SB0 -> Cons0 (fmap There0 universe')+    SB1 -> Cons1 (fmap Here Tree.universe) (fmap There1 universe')++-------------------------------------------------------------------------------+-- Out-of-order combining+-------------------------------------------------------------------------------++{-+appendB0 :: NERAVec b a -> NERAVec b a -> NERAVec ('B0 b) a+appendB0 (NE xs) (NE ys) = NE (Cons0 (appendB' xs ys)) where++appendB1 :: a -> NERAVec b a -> NERAVec b a -> NERAVec ('B1 b) a+appendB1 x (NE ys) (NE zs) = NE (Cons1 (Tree.Leaf x) (appendB' ys zs))++appendB' :: NERAVec' n b a -> NERAVec' n b a -> NERAVec' ('S n) b a+appendB' (Last  t)   (Last  t')    = Last (Tree.Node t t')+appendB' (Cons0   r) (Cons0    r') = Cons0 (appendB' r r')+appendB' (Cons1 t r) (Cons1 t' r') = Cons1 (Tree.Node t t') (appendB' r r')++splitB0 :: NERAVec ('B0 b) a -> (NERAVec b a, NERAVec b a)+splitB0 (NE (Cons0 xs)) =+    let (ys, zs) = splitB' xs in (NE ys, NE zs)++splitB1 :: NERAVec ('B1 b) a -> (a, NERAVec b a, NERAVec b a)+splitB1 (NE (Cons1 (Tree.Leaf x) xs)) =+    let (ys, zs) = splitB' xs in (x, NE ys, NE zs)++splitB' :: NERAVec' ('S n) b a -> (NERAVec' n b a, NERAVec' n b a)+splitB' (Last (Tree.Node t t'))    = (Last t, Last t')+splitB' (Cons0                  r) =+    let (a, b) = splitB' r in (Cons0 a, Cons0 b)+splitB' (Cons1 (Tree.Node t t') r) =+    let (a, b) = splitB' r in (Cons1 t a, Cons1 t' b)+-}++-------------------------------------------------------------------------------+-- QuickCheck+-------------------------------------------------------------------------------++instance BP.SBinPI b => QC.Arbitrary1 (NERAVec b) where+    liftArbitrary = liftArbitrary+    liftShrink    = liftShrink++liftArbitrary :: BP.SBinPI b => QC.Gen a -> QC.Gen (NERAVec b a)+liftArbitrary = fmap NE . liftArbitrary'++liftShrink :: (a -> [a]) -> NERAVec b a -> [NERAVec b a]+liftShrink shr (NE r) = fmap NE (liftShrink' shr r)++instance (BP.SBinPI b, N.SNatI n) => QC.Arbitrary1 (NERAVec' n b) where+    liftArbitrary = liftArbitrary'+    liftShrink    = liftShrink'++liftArbitrary' :: forall b n a. (BP.SBinPI b, N.SNatI n) => QC.Gen a -> QC.Gen (NERAVec' n b a)+liftArbitrary' arb = case BP.sbinp :: BP.SBinP b of+    BP.SBE -> Last  <$> QC.liftArbitrary arb+    BP.SB0 -> Cons0 <$> liftArbitrary' arb+    BP.SB1 -> Cons1 <$> QC.liftArbitrary arb <*> liftArbitrary' arb++liftShrink' :: forall b n a. (a -> [a]) -> NERAVec' n b a -> [NERAVec' n b a]+liftShrink' shr (Last  t)   = Last <$> Tree.liftShrink shr t+liftShrink' shr (Cons0   r) = Cons0 <$> liftShrink' shr r+liftShrink' shr (Cons1 t r) = uncurry Cons1 <$> QC.liftShrink2 (Tree.liftShrink shr) (liftShrink' shr) (t, r)++instance (BP.SBinPI b, QC.Arbitrary a) => QC.Arbitrary (NERAVec b a) where+    arbitrary = QC.arbitrary1+    shrink    = QC.shrink1++instance QC.CoArbitrary a => QC.CoArbitrary (NERAVec b a) where+    coarbitrary (NE r) = QC.coarbitrary r++instance QC.CoArbitrary a => QC.CoArbitrary (NERAVec' n b a) where+    coarbitrary (Last  t)   = QC.variant (0 :: Int) . QC.coarbitrary t+    coarbitrary (Cons0   r) = QC.variant (1 :: Int) . QC.coarbitrary r+    coarbitrary (Cons1 t r) = QC.variant (2 :: Int) . QC.coarbitrary (t, r)++instance (BP.SBinPI b, QC.Function a) => QC.Function (NERAVec b a) where+    function = QC.functionMap (\(NE r) -> r) NE++instance (N.SNatI n, BP.SBinPI b, QC.Function a) => QC.Function (NERAVec' n b a) where+    function = case BP.sbinp :: BP.SBinP b of+        SBE -> QC.functionMap (\(Last t) -> t)         Last+        SB0 -> QC.functionMap (\(Cons0 r) -> r)        Cons0+        SB1 -> QC.functionMap (\(Cons1 t r) -> (t, r)) (uncurry Cons1)
+ src/Data/RAVec/Tree.hs view
@@ -0,0 +1,409 @@+{-# LANGUAGE BangPatterns           #-}+{-# LANGUAGE CPP                    #-}+{-# LANGUAGE DataKinds              #-}+{-# LANGUAGE DeriveDataTypeable     #-}+{-# LANGUAGE FlexibleInstances      #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE GADTs                  #-}+{-# LANGUAGE RankNTypes             #-}+{-# LANGUAGE ScopedTypeVariables    #-}+{-# LANGUAGE StandaloneDeriving     #-}+{-# LANGUAGE TypeFamilies           #-}+-- | Depth indexed perfect binary tree.+module Data.RAVec.Tree (+    Tree (..),++    -- * Construction+    singleton,++    -- * Conversions+    toList,++    -- * Indexing+    (!),+    tabulate,+    leftmost,+    rightmost,++    -- * Folds+    foldMap,+    foldMap1,+    ifoldMap,+    ifoldMap1,+    foldr,+    ifoldr,+    foldr1Map,+    ifoldr1Map,+    foldl,+    ifoldl,+    length,++    -- * Mapping+    map,+    imap,+    traverse,+    itraverse,+#ifdef MIN_VERSION_semigroupoids+    traverse1,+    itraverse1,+#endif+    -- TODO: itraverse_,++    -- * Zipping+    zipWith,+    izipWith,+    repeat,++    -- * Universe+    universe,++    -- * QuickCheck+    liftArbitrary,+    liftShrink,++    ) where++import Prelude+       (Bool (..), Eq (..), Functor (..), Int, Ord (..), Show, id, seq,+       uncurry, ($), (*), (.))++import Control.Applicative (Applicative (..), (<$>))+import Control.DeepSeq     (NFData (..))+import Data.Hashable       (Hashable (..))+import Data.Monoid         (Monoid (..))+import Data.Nat            (Nat (..))+import Data.Semigroup      (Semigroup (..))+import Data.Typeable       (Typeable)+import Data.Wrd            (Wrd (..))++import qualified Data.Type.Nat as N++-- instances+import qualified Data.Foldable    as I (Foldable (..))+import qualified Data.Traversable as I (Traversable (..))+import qualified Test.QuickCheck  as QC++#ifdef MIN_VERSION_distributive+import qualified Data.Distributive as I (Distributive (..))++#ifdef MIN_VERSION_adjunctions+import qualified Data.Functor.Rep as I (Representable (..))+#endif+#endif++#ifdef MIN_VERSION_semigroupoids+import Data.Functor.Apply (Apply (..))++import qualified Data.Semigroup.Foldable    as I (Foldable1 (..))+import qualified Data.Semigroup.Traversable as I (Traversable1 (..))+#endif++-- $setup+-- >>> :set -XScopedTypeVariables+-- >>> import Data.Proxy (Proxy (..))+-- >>> import Prelude (Char, not, uncurry, flip)++-------------------------------------------------------------------------------+-- Data+-------------------------------------------------------------------------------++-- | Perfectly balanced binary tree of depth @n@, with @2 ^ n@ elements.+data Tree (n :: Nat) a where+    Leaf :: a -> Tree 'Z a+    Node :: Tree n a -> Tree n a -> Tree ('S n) a+  deriving (Typeable)++-------------------------------------------------------------------------------+-- Helpers+-------------------------------------------------------------------------------++goLeft :: (Wrd ('S n) -> a) -> Wrd n -> a+goLeft f xs = f (W0 xs)++goRight :: (Wrd ('S n) -> a) -> Wrd n -> a+goRight f xs = f (W1 xs)++-------------------------------------------------------------------------------+-- Instances+-------------------------------------------------------------------------------++deriving instance Eq a => Eq (Tree n a)+deriving instance Ord a => Ord (Tree n a)+deriving instance Show a => Show (Tree n a)++instance Functor (Tree n) where+    fmap = map++instance I.Foldable (Tree n) where+    foldMap = foldMap+    foldr   = foldr+    foldl   = foldl+#if MIN_VERSION_base(4,8,0)+    null _ = False+    toList = toList+    length = length+#endif++instance I.Traversable (Tree n) where+    traverse = traverse++#ifdef MIN_VERSION_semigroupoids+instance I.Foldable1 (Tree n) where+    foldMap1 = foldMap1++instance I.Traversable1 (Tree n) where+    traverse1 = traverse1+#endif++instance NFData a => NFData (Tree n a) where+    rnf (Leaf x)   = rnf x+    rnf (Node x y) = rnf x `seq` rnf y++instance Hashable a => Hashable (Tree n a) where+    hashWithSalt salt (Leaf x) = salt+        `hashWithSalt` x+    hashWithSalt salt (Node x y) = salt+        `hashWithSalt` x+        `hashWithSalt` y++instance N.SNatI n => Applicative (Tree n) where+    pure = repeat+    (<*>) = zipWith ($)+    x <* _ = x+    _ *> x = x+#if MIN_VERSION_base(4,10,0)+    liftA2 = zipWith+#endif++#ifdef MIN_VERSION_distributive+instance N.SNatI n => I.Distributive (Tree n) where+    distribute f = tabulate (\k -> fmap (! k) f)++#ifdef MIN_VERSION_adjunctions+instance N.SNatI n => I.Representable (Tree n) where+    type Rep (Tree n) = Wrd n++    tabulate = tabulate+    index    = (!)+#endif+#endif++instance Semigroup a => Semigroup (Tree n a) where+    Leaf x   <> Leaf y   = Leaf (x <> y)+    Node x y <> Node u v = Node (x <> u) (y <> v)++#ifdef MIN_VERSION_semigroupoids+instance Apply (Tree n) where+    (<.>)  = zipWith ($)+    _ .> x = x+    x <. _ = x+    liftF2 = zipWith+#endif++-------------------------------------------------------------------------------+-- Construction+-------------------------------------------------------------------------------++-- | 'Tree' of zero depth, with single element.+--+-- >>> singleton True+-- Leaf True+singleton :: a -> Tree 'Z a+singleton = Leaf++-------------------------------------------------------------------------------+-- Conversions+-------------------------------------------------------------------------------++-- | Convert 'Tree' to list.+--+-- >>> toList $ Node (Node (Leaf 'a') (Leaf 'b')) (Node (Leaf 'c') (Leaf 'd'))+-- "abcd"+toList :: Tree n a -> [a]+toList t = go t [] where+    go :: Tree n a -> [a] -> [a]+    go (Leaf x) = (x :)+    go (Node x y) = go x . go y++-------------------------------------------------------------------------------+-- Indexing+-------------------------------------------------------------------------------++-- | Indexing.+(!) :: Tree n a -> Wrd n -> a+(!) (Leaf x)   WE      = x+(!) (Node x _) (W0 is) = x ! is+(!) (Node _ y) (W1 is) = y ! is++tabulate :: forall n a. N.SNatI n => (Wrd n -> a) -> Tree n a+tabulate f = case N.snat :: N.SNat n of+    N.SZ -> Leaf (f WE)+    N.SS -> Node (tabulate (goLeft f)) (tabulate (goRight f))++leftmost :: Tree n a -> a+leftmost (Leaf a)   = a+leftmost (Node x _) = leftmost x++rightmost :: Tree n a -> a+rightmost (Leaf a)   = a+rightmost (Node _ y) = rightmost y++-------------------------------------------------------------------------------+-- Folds+-------------------------------------------------------------------------------++foldMap :: Monoid m => (a -> m) -> Tree n a -> m+foldMap f (Leaf x)   = f x+foldMap f (Node x y) = mappend (foldMap f x) (foldMap f y)++ifoldMap :: Monoid m => (Wrd n -> a -> m) -> Tree n a -> m+ifoldMap f (Leaf x)   = f WE x+ifoldMap f (Node x y) = mappend (ifoldMap (goLeft f) x) (ifoldMap (goRight f) y)++foldMap1 :: Semigroup s => (a -> s) -> Tree n a -> s+foldMap1 f (Leaf x)   = f x+foldMap1 f (Node x y) = foldMap1 f x <> foldMap1 f y++ifoldMap1 :: Semigroup s => (Wrd n -> a -> s) -> Tree n a -> s+ifoldMap1 f (Leaf x)   = f WE x+ifoldMap1 f (Node x y) = ifoldMap1 (goLeft f) x <> ifoldMap1 (goRight f) y++-- | >>> foldr (:) [] $ Node (Leaf True) (Leaf False)+-- [True,False]+foldr :: (a -> b -> b) -> b -> Tree n a -> b+foldr f z (Leaf x)   = f x z+foldr f z (Node x y) = foldr f (foldr f z y) x++ifoldr :: (Wrd n -> a -> b -> b) -> b -> Tree n a -> b+ifoldr f z (Leaf x)   = f WE x z+ifoldr f z (Node x y) = ifoldr (goLeft f) (ifoldr (goRight f) z y) x++foldr1Map :: (a -> b -> b) -> (a -> b) -> Tree n a -> b+foldr1Map _ z (Leaf x)   = z x+foldr1Map f z (Node x y) = foldr f (foldr1Map f z y) x++ifoldr1Map :: (Wrd n -> a -> b -> b) -> (Wrd n -> a -> b) -> Tree n a -> b+ifoldr1Map _ z (Leaf x) = z WE x+ifoldr1Map f z (Node x y) = ifoldr (goLeft f) (ifoldr1Map (goRight f) (goRight z) y) x++-- | >>> foldl (flip (:)) [] $ Node (Leaf True) (Leaf False)+-- [False,True]+foldl :: (b -> a -> b) -> b -> Tree n a -> b+foldl f z (Leaf x) = f z x+foldl f z (Node x y) = foldl f (foldl f z x) y++ifoldl :: (Wrd n -> b -> a -> b) -> b -> Tree n a -> b+ifoldl f z (Leaf x)   = f WE z x+ifoldl f z (Node x y) = ifoldl (goLeft f) (ifoldl (goRight f) z x) y++-- TODO: foldl++-- | >>> length (universe :: Tree N.Nat3 (Wrd N.Nat3))+-- 8+--+length :: Tree n a -> Int+length = go 1 where+    go :: Int -> Tree n a -> Int+    go !acc (Leaf _)   = acc+    go  acc (Node x _) = go (2 * acc) x++-------------------------------------------------------------------------------+-- Mapping+-------------------------------------------------------------------------------++-- | >>> map not $ Node (Leaf True) (Leaf False)+-- Node (Leaf False) (Leaf True)+map :: (a -> b) -> Tree n a -> Tree n b+map f (Leaf x)   = Leaf (f x)+map f (Node x y) = Node (map f x) (map f y)++-- | >>> imap (,) $ Node (Leaf True) (Leaf False)+-- Node (Leaf (0b0,True)) (Leaf (0b1,False))+imap :: (Wrd n -> a -> b) -> Tree n a -> Tree n b+imap f (Leaf x) = Leaf (f WE x)+imap f (Node x y) = Node (imap (goLeft f) x) (imap (goRight f) y)++traverse :: Applicative f => (a -> f b) -> Tree n a -> f (Tree n b)+traverse f (Leaf x)   = Leaf <$> f x+traverse f (Node x y) = Node <$> traverse f x <*> traverse f y++itraverse :: Applicative f => (Wrd n -> a -> f b) -> Tree n a -> f (Tree n b)+itraverse f (Leaf x)   = Leaf <$> f WE x+itraverse f (Node x y) = Node <$> itraverse (goLeft f) x <*> itraverse (goRight f) y++#ifdef MIN_VERSION_semigroupoids+traverse1 :: Apply f => (a -> f b) -> Tree n a -> f (Tree n b)+traverse1 f (Leaf x)   = Leaf <$> f x+traverse1 f (Node x y) = Node <$> traverse1 f x <.> traverse1 f y++itraverse1 :: Apply f => (Wrd n -> a -> f b) -> Tree n a -> f (Tree n b)+itraverse1 f (Leaf x)   = Leaf <$> f WE x+itraverse1 f (Node x y) = Node <$> itraverse1 (goLeft f) x <.> itraverse1 (goRight f) y+#endif++-------------------------------------------------------------------------------+-- Zipping+-------------------------------------------------------------------------------++-- | Zip two 'Vec's with a function.+zipWith ::  (a -> b -> c) -> Tree n a -> Tree n b -> Tree n c+zipWith f (Leaf x)   (Leaf y)   = Leaf (f x y)+zipWith f (Node x y) (Node u v) = Node (zipWith f x u) (zipWith f y v)++-- | Zip two 'Tree's. with a function that also takes the elements' indices.+izipWith :: (Wrd n -> a -> b -> c) -> Tree n a -> Tree n b -> Tree n c+izipWith f (Leaf x)   (Leaf y)   = Leaf (f WE x y)+izipWith f (Node x y) (Node u v) = Node (izipWith (goLeft f) x u) (izipWith (goRight f) y v)++-- | Repeat a value.+--+-- >>> repeat 'x' :: Tree N.Nat2 Char+-- Node (Node (Leaf 'x') (Leaf 'x')) (Node (Leaf 'x') (Leaf 'x'))+--+repeat :: N.SNatI n => a -> Tree n a+repeat x = N.induction1 (Leaf x) (\t -> Node t t)++-------------------------------------------------------------------------------+-- Universe+-------------------------------------------------------------------------------++-- | Get all @'Vec' n 'Bool'@ indices in @'Tree' n@.+--+-- >>> universe :: Tree N.Nat2 (Wrd N.Nat2)+-- Node (Node (Leaf 0b00) (Leaf 0b01)) (Node (Leaf 0b10) (Leaf 0b11))+--+universe :: N.SNatI n => Tree n (Wrd n)+universe = tabulate id++-------------------------------------------------------------------------------+-- QuickCheck+-------------------------------------------------------------------------------++instance N.SNatI n => QC.Arbitrary1 (Tree n) where+    liftArbitrary = liftArbitrary+    liftShrink    = liftShrink++liftArbitrary :: forall n a. N.SNatI n => QC.Gen a -> QC.Gen (Tree n a)+liftArbitrary arb = getArb $ N.induction1 (Arb (fmap Leaf arb)) step where+    step :: Arb m a -> Arb ('S m) a+    step (Arb rec) = Arb $ Node <$> rec <*> rec++newtype Arb n a = Arb { getArb :: QC.Gen (Tree n a) }++liftShrink :: forall n a. (a -> [a]) -> Tree n a -> [Tree n a]+liftShrink shr (Leaf x)   = Leaf <$> shr x+liftShrink shr (Node l r) = uncurry Node <$> QC.liftShrink2 rec rec (l, r) where+    rec = liftShrink shr++instance (N.SNatI n, QC.Arbitrary a) => QC.Arbitrary (Tree n a) where+    arbitrary = QC.arbitrary1+    shrink    = QC.shrink1++instance QC.CoArbitrary a => QC.CoArbitrary (Tree n a) where+    coarbitrary (Leaf x)   = QC.variant (0 :: Int) . QC.coarbitrary x+    coarbitrary (Node l r) = QC.variant (1 :: Int) . QC.coarbitrary (l, r)++instance (N.SNatI n, QC.Function a) => QC.Function (Tree n a) where+    function = case N.snat :: N.SNat n of+        N.SZ -> QC.functionMap (\(Leaf x) -> x)         Leaf+        N.SS -> QC.functionMap (\(Node l r ) -> (l, r)) (uncurry Node)