packages feed

forbidden-fruit (empty) → 0.1.0

raw patch · 18 files changed

+1577/−0 lines, 18 filesdep +basedep +control-monad-loopdep +hashablesetup-changed

Dependencies added: base, control-monad-loop, hashable, hashtables, hspec, primitive, transformers, transformers-base, vector

Files

+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2014, Yu Fukuzawa++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Yu Fukuzawa nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ forbidden-fruit.cabal view
@@ -0,0 +1,55 @@+name:                forbidden-fruit+version:             0.1.0+synopsis:            A library accelerates imperative style programming.+description:         A library accelerates imperative style programming.+license:             BSD3+license-file:        LICENSE+author:              Yu Fukuzawa+maintainer:          minpou.primer@gmail.com+category:            Control+build-type:          Simple+homepage:            http://github.com/minpou/forbidden-fruit+cabal-version:       >=1.10++library+  exposed-modules:     +                       Control.Imperative+                       Control.Imperative.Operators+                       Control.Imperative.Var+                       Control.Imperative.Var.Class+                       Control.Imperative.Vector+                       Control.Imperative.Vector.Dynamic+                       Control.Imperative.Vector.Static+                       Control.Imperative.Hash+                       Control.Imperative.Hash.Class+                       Control.Imperative.Zoom+                       Data.Nat+  other-modules:       Control.Imperative.Internal+                       Control.Imperative.Vector.Base+                       Data.Vector.Dynamic+  build-depends:       base >=4.7 && <5+                     , transformers >=0.2.2.1 && <0.5+                     , control-monad-loop ==0.1+                     , hashtables >=1.1.2.1 && <1.3+                     , hashable >=1.2.1.0 && <1.3+                     , vector >=0.10.9.0 && <0.11+                     , primitive >=0.5.2.1+                     , transformers-base >=0.4 && <0.5+  ghc-options:         -Wall -O2+  hs-source-dirs:      src+  default-language:    Haskell2010++Test-Suite test+  type:                exitcode-stdio-1.0+  ghc-options:         -O2 -Wall+  main-is:             Spec.hs+  hs-source-dirs:      src, test+  default-language:    Haskell2010+  build-depends:       base -any+                     , hspec >=0.2.0+                     , transformers+                     , control-monad-loop+                     , hashtables+                     , hashable+                     , vector+                     , primitive
+ src/Control/Imperative.hs view
@@ -0,0 +1,84 @@+-----------------------------------------------------------+-- |+-- Module      : Control.Imperative+-- Copyright   : (C) 2015, Yu Fukuzawa+-- License     : BSD3+-- Maintainer  : minpou.primer@email.com+-- Stability   : experimental+-- Portability : portable+--+-----------------------------------------------------------++{-# LANGUAGE ConstraintKinds  #-}+{-# LANGUAGE FlexibleContexts #-}++module Control.Imperative+( var+, val+, ref+, assign+, (=:)+, MonadImperative+, BaseEff+, Indexable(..)+  -- * Control Structures+, whenR+, unlessR+, ifR+, whileR+, untilR+, doWhileR+  -- * Types+, Ref+, Size(..)+, dim1+, dim2+, dim3+  -- * Re-exports+, module Control.Monad.Trans.Loop+, module Control.Monad.Base+) where++import           Control.Monad.Base+import           Control.Imperative.Hash        (MonadHash)+import           Control.Imperative.Operators+import           Control.Imperative.Internal+import           Control.Imperative.Var         (MonadVar, var)+import           Control.Imperative.Vector.Base+import           Control.Monad+import           Control.Monad.Trans.Loop++-- | Useful constraint synonym.+type MonadImperative m = (MonadVar m, MonadVector m, MonadHash m)++-- | A when statement for 'Ref'.+whenR :: MonadBase (BaseEff m) m => Ref (BaseEff m) Bool -> m () -> m ()+whenR v m = ref v >>= flip when m+{-# INLINE whenR #-}++-- | A unless statement for 'Ref'.+unlessR :: MonadBase (BaseEff m) m => Ref (BaseEff m) Bool -> m () -> m ()+unlessR v = whenR (notR v)+{-# INLINE unlessR #-}++-- | A if statement for 'Ref'+ifR :: MonadBase (BaseEff m) m => Ref (BaseEff m) Bool -> m a -> m a -> m a+ifR v t f = do+  b <- ref v+  if b then t else f+{-# INLINE ifR #-}++-- | A while loop statement for 'Ref'.+whileR :: MonadBase (BaseEff m) m => Ref (BaseEff m) Bool -> LoopT c () m c -> m ()+whileR v = while (ref v)+{-# INLINE whileR #-}++-- | A until loop statement for 'Ref'.+untilR :: MonadBase (BaseEff m) m => Ref (BaseEff m) Bool -> LoopT c () m c -> m ()+untilR v = while (ref (notR v))+{-# INLINE untilR #-}++-- | A do-while loop statement for 'Ref'.+doWhileR :: MonadBase (BaseEff m) m => LoopT a a m a -> Ref (BaseEff m) Bool -> m a+doWhileR m v = doWhile m (ref v)+{-# INLINE doWhileR #-}
+ src/Control/Imperative/Hash.hs view
@@ -0,0 +1,89 @@+-----------------------------------------------------------+-- |+-- Module      : Control.Imperative.Hash+-- Copyright   : (C) 2015, Yu Fukuzawa+-- License     : BSD3+-- Maintainer  : minpou.primer@email.com+-- Stability   : experimental+-- Portability : portable+--+-----------------------------------------------------------++{-# LANGUAGE ConstraintKinds     #-}+{-# LANGUAGE DataKinds           #-}+{-# LANGUAGE FlexibleContexts    #-}+{-# LANGUAGE FlexibleInstances   #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies        #-}+{-# LANGUAGE TypeOperators       #-}++module Control.Imperative.Hash+( -- $doc++  -- * Types+  HashTable+, MonadHash+, HashKey+  -- * Operations+, new+, newSized+, delete+, fromList+, toList+) where++import           Control.Imperative.Hash.Class+import           Control.Imperative.Internal+import           Control.Monad                 (liftM)+import           Control.Monad.Base++-- $doc+-- A mutable hashtable.+--+-- There are two basic operation exported from the "Control.Imperative" module.+--+-- [@ref@] /O(1)/. lookup the value of a hashtable at the given key.+-- [@assign@] /O(1)/. insert the value at the given key.++newtype HashTable m k v = H (HashEntity m k v)++instance (HashKey k, MHash m) => Indexable (HashTable m k v) where+  type Element (HashTable m k v) = Ref m v+  type IndexType (HashTable m k v) = k+  (H h) ! k = Ref+    { get = unsafeLookupHash h k+    , set = insertHash h k+    }+  {-# INLINE (!) #-}++-- | Useful constraint synonym for hashtable operations.+type MonadHash m = (MonadBase (BaseEff m) m, MHash (BaseEff m))++-- | /O(1)/. Create an empty hashtable with a given size.+new+  :: MonadHash m+  => m (HashTable (BaseEff m) k v)+new = newSized 2+{-# INLINE new #-}++-- | /O(1)/. Create an empty hashtable with a given size.+newSized+  :: MonadHash m+  => Int -- initial size+  -> m (HashTable (BaseEff m) k v)+newSized size = liftBase $ liftM H $ newSizedHash size+{-# INLINE newSized #-}++-- | /O(n)/ worst case, /O(1)/ amortized. Delete key-value mapping in a hashtable.+delete :: (HashKey k, MonadHash m) => HashTable (BaseEff m) k v -> k -> m ()+delete (H h) k = liftBase $ deleteHash h k+{-# INLINE delete #-}+-- | /O(n)/. Create a hashtable from an associative list.+fromList :: (HashKey k, MonadHash m) => [(k, v)] -> m (HashTable (BaseEff m) k v)+fromList as = liftBase $ liftM H $ fromListHash as+{-# INLINE fromList #-}++-- | /O(n)/. Convert the hashtable to a nested associative list.+toList :: (HashKey k, MonadHash m) => HashTable (BaseEff m) k v -> m [(k, v)]+toList (H h) = liftBase $ toListHash h+{-# INLINE toList #-}
+ src/Control/Imperative/Hash/Class.hs view
@@ -0,0 +1,75 @@+-----------------------------------------------------------+-- |+-- Module      : Control.Imperative.Hash.Class+-- Copyright   : (C) 2015, Yu Fukuzawa+-- License     : BSD3+-- Maintainer  : minpou.primer@email.com+-- Stability   : experimental+-- Portability : portable+--+-----------------------------------------------------------++{-# LANGUAGE FlexibleInstances    #-}+{-# LANGUAGE TypeFamilies         #-}+{-# LANGUAGE UndecidableInstances #-}++module Control.Imperative.Hash.Class+( -- * Class+  MHash(..)+, HashKey+) where+import           Control.Applicative+import           Control.Monad.ST+import           Data.Hashable+import qualified Data.HashTable.Class     as HC+import qualified Data.HashTable.IO        as HIO+import qualified Data.HashTable.ST.Basic as HST+import           Data.Maybe++class (Eq k, Hashable k) => HashKey k+instance (Eq k, Hashable k) => HashKey k++-- | Base class for mutable hashtables.+class Monad m => MHash m where+  type HashEntity m :: * -> * -> *+  newSizedHash :: Int -> m (HashEntity m k v)+  unsafeLookupHash :: HashKey k => HashEntity m k v -> k -> m v+  lookupHash :: HashKey k => HashEntity m k v -> k -> m (Maybe v)+  insertHash :: HashKey k => HashEntity m k v -> k -> v -> m ()+  deleteHash :: HashKey k => HashEntity m k v -> k -> m ()+  fromListHash :: HashKey k => [(k, v)] -> m (HashEntity m k v)+  toListHash :: HashKey k => HashEntity m k v -> m [(k, v)]++instance MHash IO where+  type HashEntity IO = HST.HashTable RealWorld+  newSizedHash = HIO.newSized+  {-# INLINE newSizedHash #-}+  unsafeLookupHash h k = fromJust <$> HIO.lookup h k+  {-# INLINE unsafeLookupHash #-}+  lookupHash = HIO.lookup+  {-# INLINE lookupHash #-}+  insertHash = HIO.insert+  {-# INLINE insertHash #-}+  deleteHash = HIO.delete+  {-# INLINE deleteHash #-}+  fromListHash = HIO.fromList+  {-# INLINE fromListHash #-}+  toListHash = HIO.toList+  {-# INLINE toListHash #-}++instance MHash (ST s) where+  type HashEntity (ST s) = HST.HashTable s+  newSizedHash = HST.newSized+  {-# INLINE newSizedHash #-}+  unsafeLookupHash h k = fromJust <$> HST.lookup h k+  {-# INLINE unsafeLookupHash #-}+  lookupHash = HST.lookup+  {-# INLINE lookupHash #-}+  insertHash = HST.insert+  {-# INLINE insertHash #-}+  deleteHash = HST.delete+  {-# INLINE deleteHash #-}+  fromListHash = HC.fromList+  {-# INLINE fromListHash #-}+  toListHash = HC.toList+  {-# INLINE toListHash #-}
+ src/Control/Imperative/Internal.hs view
@@ -0,0 +1,164 @@+-----------------------------------------------------------+-- |+-- Module      : Control.Imperative.Internal+-- Copyright   : (C) 2015, Yu Fukuzawa+-- License     : BSD3+-- Maintainer  : minpou.primer@email.com+-- Stability   : experimental+-- Portability : portable+--+-----------------------------------------------------------++{-# LANGUAGE BangPatterns          #-}+{-# LANGUAGE CPP                   #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies          #-}++module Control.Imperative.Internal where+import           Control.Monad+import           Control.Monad.Base+import qualified Control.Monad.ST                  as Strict+import qualified Control.Monad.ST.Lazy             as Lazy+import           Control.Monad.Trans.Cont          (ContT)+import           Control.Monad.Trans.Identity      (IdentityT)+import           Control.Monad.Trans.List          (ListT)+import           Control.Monad.Trans.Loop          (LoopT)+import           Control.Monad.Trans.Maybe         (MaybeT)+import           Control.Monad.Trans.Reader        (ReaderT)+import qualified Control.Monad.Trans.RWS.Lazy      as Lazy+import qualified Control.Monad.Trans.RWS.Strict    as Strict+import qualified Control.Monad.Trans.State.Lazy    as Lazy+import qualified Control.Monad.Trans.State.Strict  as Strict+import qualified Control.Monad.Trans.Writer.Lazy   as Lazy+import qualified Control.Monad.Trans.Writer.Strict as Strict+import           Data.Functor.Identity+import           Data.Monoid+import           GHC.Exts++#ifndef MIN_VERSION_transformers+#define MIN_VERSION_transformers(x,y,z) 1+#endif++#if MIN_VERSION_transformers(0,4,0)+import           Control.Monad.Trans.Except        (ExceptT)+#else+import           Control.Monad.Trans.Error         (Error, ErrorT)+#endif++type family BaseEff (m :: * -> *) :: * -> *+type instance BaseEff [] = []+type instance BaseEff IO = IO+type instance BaseEff Maybe = Maybe+type instance BaseEff Identity = Identity+type instance BaseEff (ListT m)	= BaseEff m+type instance BaseEff (MaybeT m) = BaseEff m+type instance BaseEff (IdentityT m)	= BaseEff m+#if MIN_VERSION_transformers(0,4,0)+type instance BaseEff (ExceptT e m)	= BaseEff m+#else+type instance BaseEff (ErrorT e m)	= BaseEff m+#endif+type instance BaseEff (Lazy.WriterT w m)	= BaseEff m+type instance BaseEff (Strict.WriterT w m)	= BaseEff m+type instance BaseEff (ContT r m)	  = BaseEff m+type instance BaseEff (Lazy.StateT s m)	= BaseEff m+type instance BaseEff (Strict.StateT s m)	= BaseEff m+type instance BaseEff (ReaderT r m)	= BaseEff m+type instance BaseEff (Lazy.RWST r w s m) = BaseEff m+type instance BaseEff (Strict.RWST r w s m)	= BaseEff m+type instance BaseEff (Either e) = Either e+type instance BaseEff (Lazy.ST s) = Lazy.ST s+type instance BaseEff (Strict.ST s) = Strict.ST s+type instance BaseEff (LoopT c e m) = BaseEff m++-- | A reference type in the specified monad.+data Ref m a = Ref+  { get :: m a+  , set :: a -> m ()+  }++-- | Get a stored value from the 'Ref'.+ref :: (MonadBase (BaseEff m) m) => Ref (BaseEff m) a -> m a+ref r = liftBase $ get r+{-# INLINE ref #-}++-- | Assign a value to the 'Ref'.+assign :: MonadBase (BaseEff m) m => Ref (BaseEff m) a -> a -> m ()+assign r !x = liftBase $ set r x+{-# INLINE assign #-}++-- | Apply a function to a stored value without rewriting original one.+liftOp :: Monad m => (a -> b) -> Ref m a -> Ref m b+liftOp f r = expr $ liftM f $ get r+{-# INLINE liftOp #-}++-- | Apply a binary function to two 'Ref's.+liftOp2 :: Monad m => (a -> b -> c) -> Ref m a -> Ref m b -> Ref m c+liftOp2 f r s = expr $ liftM2 f (get r) (get s)+{-# INLINE liftOp2 #-}++-- | Wrap a value inside an immutable 'Ref'.+val :: Monad m => a -> Ref m a+val x = Ref+  { get = return x+  , set = const $ return ()+  }+{-# INLINE val #-}++expr :: Monad m => m a -> Ref m a+expr m = Ref+  { get = m+  , set = const $ return ()+  }+{-# INLINE expr #-}++instance (Num a, Monad m) => Num (Ref m a) where+  (+) = liftOp2 (+)+  (-) = liftOp2 (-)+  (*) = liftOp2 (*)+  negate = liftOp negate+  abs = liftOp abs+  signum = liftOp signum+  fromInteger = val . fromInteger++instance (Fractional a, Monad m) => Fractional (Ref m a) where+  (/) = liftOp2 (/)+  recip = liftOp recip+  fromRational = val . fromRational++instance (Floating a, Monad m) => Floating (Ref m a) where+  pi = val pi+  exp = liftOp exp+  sqrt = liftOp sqrt+  log= liftOp log+  (**) = liftOp2 (**)+  logBase = liftOp2 logBase+  sin = liftOp sin+  tan = liftOp tan+  cos = liftOp cos+  asin = liftOp asin+  atan = liftOp atan+  acos = liftOp acos+  sinh = liftOp sinh+  cosh = liftOp cosh+  tanh = liftOp tanh+  asinh = liftOp asinh+  acosh = liftOp acosh+  atanh = liftOp atanh++instance (Monoid w, Monad m) => Monoid (Ref m w) where+  mempty = val mempty+  mappend = liftOp2 mappend++instance (IsString a, Monad m) => IsString (Ref m a) where+  fromString = val . fromString++-- | Indexing for array-like.+class Indexable v where+  type Element v+  type IndexType v+  (!) :: v -> IndexType v -> Element v++infixl 9 !
+ src/Control/Imperative/Operators.hs view
@@ -0,0 +1,184 @@+-----------------------------------------------------------+-- |+-- Module      : Control.Imperative.Operators+-- Copyright   : (C) 2015, Yu Fukuzawa+-- License     : BSD3+-- Maintainer  : minpou.primer@email.com+-- Stability   : experimental+-- Portability : portable+--+-----------------------------------------------------------++{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE GADTs                 #-}+{-# LANGUAGE MultiParamTypeClasses #-}+module Control.Imperative.Operators+( -- * Operators+  liftOp+, liftOp2+, (~$), (~*)+  -- *** Binary Operation+, (/.), (%.), (^.), (&&.), (||.)+, (==.), (/=.), (>=.), (<=.), (>.), (<.), notR, (&.), (|.), xorR, complR, (<<.), (>>.)+  -- *** Assignment Operators+, assignModify+, (=:), (+=:), (-=:), (*=:), (/=:), (%=:), (^=:), (//=:), (**=:), (<>=:)+, (&&=:), (||=:), (&=:), (|=:), (<<=:), (>>=:)+, (<~), (<&~)+) where+import           Control.Imperative.Internal+import           Control.Monad.Base+import           Data.Bits+import           Data.Monoid++-- | Alias for 'liftOp'.+(~$) :: Monad m => (a -> b) -> Ref m a -> Ref m b+(~$) = liftOp+{-# INLINE (~$) #-}++-- | Analogous to (\<*\>) for Applicative.+(~*) :: Monad m => Ref m (a -> b) -> Ref m a -> Ref m b+(~*) = liftOp2 ($)+{-# INLINE (~*) #-}++infixl 4 ~$, ~*++(/.), (%.) :: Monad m => Integral a => Ref m a -> Ref m a -> Ref m a+(/.) = liftOp2 div+{-# INLINE (/.) #-}+(%.) = liftOp2 mod+{-# INLINE (%.) #-}++infixl 7 /., %.++(^.) :: (Num a, Integral b, Monad m) => Ref m a -> Ref m b -> Ref m a+(^.) = liftOp2 (^)+{-# INLINE (^.) #-}++infixr 8 ^.++(&&.), (||.) :: Monad m => Ref m Bool -> Ref m Bool -> Ref m Bool+(&&.) = liftOp2 (&&)+{-# INLINE (&&.) #-}+(||.) = liftOp2 (||)+{-# INLINE (||.) #-}++infixr 3 &&.+infixr 2 ||.++(==.), (/=.), (>=.), (<=.), (<.), (>.) :: (Ord a, Monad m) => Ref m a -> Ref m a -> Ref m Bool+(==.) = liftOp2 (==)+{-# INLINE (==.) #-}+(/=.) = liftOp2 (/=)+{-# INLINE (/=.) #-}+(>=.) = liftOp2 (>=)+{-# INLINE (>=.) #-}+(<=.) = liftOp2 (<=)+{-# INLINE (<=.) #-}+(>.)  = liftOp2 (>)+{-# INLINE (>.) #-}+(<.)  = liftOp2 (<)+{-# INLINE (<.) #-}++infixl 4 ==., /=., >=., <=., <., >.++notR :: Monad m => Ref m Bool -> Ref m Bool+notR = liftOp not+{-# INLINE notR #-}++(&.), (|.), xorR :: (Bits a, Monad m) => Ref m a -> Ref m a -> Ref m a+(&.) = liftOp2 (.&.)+{-# INLINE (&.) #-}+(|.) = liftOp2 (.|.)+{-# INLINE (|.) #-}+xorR = liftOp2 xor+{-# INLINE xorR #-}++infixl 7 &.+infixl 5 |.++(<<.), (>>.) :: (Bits a, Monad m) => Ref m a -> Ref m Int -> Ref m a+(<<.) = liftOp2 shiftL+{-# INLINE (<<.) #-}+(>>.) = liftOp2 shiftR+{-# INLINE (>>.) #-}++infixl 5 <<., >>.++complR :: (Bits a, Monad m) => Ref m a -> Ref m a+complR = liftOp complement+{-# INLINE complR #-}++-- | Modify the value of mutable 'Ref' with another 'Ref'.+assignModify :: MonadBase (BaseEff m) m => (a -> b -> a) -> Ref (BaseEff m) a -> Ref (BaseEff m) b -> m ()+assignModify f v w = ref (liftOp2 f v w) >>= assign v+{-# INLINE assignModify #-}++-- | An assignment operator.+(=:) :: MonadBase (BaseEff m) m => Ref (BaseEff m) a -> Ref (BaseEff m) a -> m ()+(=:) v w = ref w >>= assign v+{-# INLINE (=:) #-}++(+=:), (-=:), (*=:) :: (Num a, MonadBase (BaseEff m) m) => Ref (BaseEff m) a -> Ref (BaseEff m) a -> m ()+(+=:) = assignModify (+)+{-# INLINE (+=:) #-}+(-=:) = assignModify (-)+{-# INLINE (-=:) #-}+(*=:) = assignModify (*)+{-# INLINE (*=:) #-}++(/=:), (%=:) :: (Integral a, MonadBase (BaseEff m) m) => Ref (BaseEff m) a -> Ref (BaseEff m) a -> m ()+(/=:) = assignModify div+{-# INLINE (/=:) #-}+(%=:) = assignModify mod+{-# INLINE (%=:) #-}++(^=:) :: (Num a, Integral b, MonadBase (BaseEff m) m) => Ref (BaseEff m) a -> Ref (BaseEff m) b -> m ()+(^=:) = assignModify (^)+{-# INLINE (^=:) #-}++(//=:) :: (Fractional a, MonadBase (BaseEff m) m) => Ref (BaseEff m) a -> Ref (BaseEff m) a -> m ()+(//=:) = assignModify (/)+{-# INLINE (//=:) #-}++(**=:) :: (Floating a, MonadBase (BaseEff m) m) => Ref (BaseEff m) a -> Ref (BaseEff m) a -> m ()+(**=:) = assignModify (**)+{-# INLINE (**=:) #-}++(&=:), (|=:) :: (Bits a, MonadBase (BaseEff m) m) => Ref (BaseEff m) a -> Ref (BaseEff m) a -> m ()+(&=:) = assignModify (.&.)+{-# INLINE (&=:) #-}+(|=:) = assignModify (.|.)+{-# INLINE (|=:) #-}++(<<=:), (>>=:) :: (Bits a, MonadBase (BaseEff m) m) => Ref (BaseEff m) a -> Ref (BaseEff m) Int -> m ()+(<<=:) = assignModify shiftL+{-# INLINE (<<=:) #-}+(>>=:) = assignModify shiftR+{-# INLINE (>>=:) #-}++(<>=:) :: (Monoid a, MonadBase (BaseEff m) m) => Ref (BaseEff m) a -> Ref (BaseEff m) a -> m ()+(<>=:) = assignModify (<>)+{-# INLINE (<>=:) #-}++(&&=:), (||=:) :: MonadBase (BaseEff m) m => Ref (BaseEff m) Bool -> Ref (BaseEff m) Bool -> m ()+(&&=:) = assignModify (&&)+{-# INLINE (&&=:) #-}+(||=:) = assignModify (||)+{-# INLINE (||=:) #-}++-- | Run a monadic action, and assign the result of it to the mutable 'Ref'.+(<~) :: MonadBase (BaseEff m) m => Ref (BaseEff m) a -> m a -> m ()+v <~ m = m >>= assign v+{-# INLINE (<~) #-}++-- | Modify the mutable 'Ref' with an endomorphism.+(<&~) :: MonadBase (BaseEff m) m => Ref (BaseEff m) a -> (a -> a) -> m ()+v <&~ f = ref v >>= assign v . f+{-# INLINE (<&~) #-}++infix 2 =:, +=:, -=:, *=:, %=:, /=:, ^=:, //=:, **=:+infix 2 &&=:, ||=:, &=:, |=:, <<=:, >>=:, <>=:+infixr 2 <~+infix 2 <&~
+ src/Control/Imperative/Var.hs view
@@ -0,0 +1,38 @@+-----------------------------------------------------------+-- |+-- Module      : Control.Imperative.Var+-- Copyright   : (C) 2015, Yu Fukuzawa+-- License     : BSD3+-- Maintainer  : minpou.primer@email.com+-- Stability   : experimental+-- Portability : portable+--+-----------------------------------------------------------++{-# LANGUAGE ConstraintKinds       #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies          #-}++module Control.Imperative.Var+( MonadVar+, var+) where++import           Control.Imperative.Internal+import           Control.Imperative.Var.Class+import           Control.Monad.Base++-- | Useful constraint synonym for variable operation.+type MonadVar m = (MonadBase (BaseEff m) m, MVar (BaseEff m))++-- | Create a new mutable variable.+var :: MonadVar m => a -> m (Ref (BaseEff m) a)+var x = do+  v <- liftBase $ newVar x+  return Ref+    { get = readVar v+    , set = writeVar v+    }+{-# INLINE var #-}
+ src/Control/Imperative/Var/Class.hs view
@@ -0,0 +1,46 @@+-----------------------------------------------------------+-- |+-- Module      : Control.Imperative.Var.Class+-- Copyright   : (C) 2015, Yu Fukuzawa+-- License     : BSD3+-- Maintainer  : minpou.primer@email.com+-- Stability   : experimental+-- Portability : portable+--+-----------------------------------------------------------++{-# LANGUAGE TypeFamilies #-}++module Control.Imperative.Var.Class+( -- * Class+  MVar(..)+) where++import           Control.Monad.ST+import           Data.IORef+import           Data.STRef++-- | Base class for mutable variables.+class Monad m => MVar m where+  type VarEntity m :: * -> *+  newVar :: a -> m (VarEntity m a)+  readVar  :: VarEntity m a -> m a+  writeVar :: VarEntity m a -> a -> m ()++instance MVar IO where+  type VarEntity IO = IORef+  newVar = newIORef+  {-# INLINE newVar #-}+  readVar = readIORef+  {-# INLINE readVar #-}+  writeVar = writeIORef+  {-# INLINE writeVar #-}++instance MVar (ST s) where+  type VarEntity (ST s) = STRef s+  newVar = newSTRef+  {-# INLINE newVar #-}+  readVar = readSTRef+  {-# INLINE readVar #-}+  writeVar = writeSTRef+  {-# INLINE writeVar #-}
+ src/Control/Imperative/Vector.hs view
@@ -0,0 +1,15 @@+-----------------------------------------------------------+-- |+-- Module      : Control.Imperative.Vector+-- Copyright   : (C) 2015, Yu Fukuzawa+-- License     : BSD3+-- Maintainer  : minpou.primer@email.com+-- Stability   : experimental+-- Portability : portable+--+-----------------------------------------------------------++module Control.Imperative.Vector+( module Control.Imperative.Vector.Dynamic+) where+import           Control.Imperative.Vector.Dynamic
+ src/Control/Imperative/Vector/Base.hs view
@@ -0,0 +1,85 @@+-----------------------------------------------------------+-- |+-- Module      : Control.Imperative.Vector.Base+-- Copyright   : (C) 2015, Yu Fukuzawa+-- License     : BSD3+-- Maintainer  : minpou.primer@email.com+-- Stability   : experimental+-- Portability : portable+--+-----------------------------------------------------------++{-# LANGUAGE ConstraintKinds   #-}+{-# LANGUAGE DataKinds         #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs             #-}+{-# LANGUAGE TypeFamilies      #-}+{-# LANGUAGE TypeOperators     #-}++module Control.Imperative.Vector.Base+( VectorEntity+, MonadVector+, VectorElem+, NestedList+, Dim(..)+, dim1+, dim2+, dim3+, Size(..)+) where++import           Control.Imperative.Internal+import           Control.Monad.Base+import           Control.Monad.Primitive     (PrimMonad)+import           Data.Int+import           Data.Nat+import qualified Data.Vector.Generic.Mutable as GMV+import qualified Data.Vector.Mutable         as MV+import qualified Data.Vector.Unboxed         as UV+import           Data.Word++-- | Useful constraint synonym for vector operations.+type MonadVector m = (MonadBase (BaseEff m) m, PrimMonad (BaseEff m))++-- | Specialized 'Proxy' type.+data Dim (n :: Nat) = Dim++dim1 :: Dim (S Z)+dim1 = Dim++dim2 :: Dim (S (S Z))+dim2 = Dim++dim3 :: Dim (S (S (S Z)))+dim3 = Dim++type VectorElem a = GMV.MVector (VectorEntity a) a++type family NestedList (n :: Nat) a where+  NestedList Z a = a+  NestedList (S n) a = [NestedList n a]++type family VectorEntity a :: * -> * -> * where+  VectorEntity Bool   = UV.MVector+  VectorEntity Char	  = UV.MVector+  VectorEntity Double = UV.MVector+  VectorEntity Float	= UV.MVector+  VectorEntity Int	  = UV.MVector+  VectorEntity Int8	  = UV.MVector+  VectorEntity Int16	= UV.MVector+  VectorEntity Int32	= UV.MVector+  VectorEntity Int64	= UV.MVector+  VectorEntity Word	  = UV.MVector+  VectorEntity Word8	= UV.MVector+  VectorEntity Word16 = UV.MVector+  VectorEntity Word32 = UV.MVector+  VectorEntity Word64 = UV.MVector+  VectorEntity ()	    = UV.MVector+  VectorEntity a	    = MV.MVector++-- | A sized-list type for specify the size of array.+data Size (n :: Nat) where+  One  :: Size Z+  (:*:) :: {-# UNPACK #-} !Int -> Size n -> Size (S n)++infixr 5 :*:
+ src/Control/Imperative/Vector/Dynamic.hs view
@@ -0,0 +1,237 @@+-----------------------------------------------------------+-- |+-- Module      : Control.Imperative.Vector.Dynamic+-- Copyright   : (C) 2015, Yu Fukuzawa+-- License     : BSD3+-- Maintainer  : minpou.primer@email.com+-- Stability   : experimental+-- Portability : portable+--+-----------------------------------------------------------++{-# LANGUAGE ConstraintKinds           #-}+{-# LANGUAGE DataKinds                 #-}+{-# LANGUAGE FlexibleContexts          #-}+{-# LANGUAGE FlexibleInstances         #-}+{-# LANGUAGE FunctionalDependencies    #-}+{-# LANGUAGE GADTs                     #-}+{-# LANGUAGE MultiParamTypeClasses     #-}+{-# LANGUAGE ScopedTypeVariables       #-}+{-# LANGUAGE TypeFamilies              #-}+{-# LANGUAGE TypeOperators             #-}+{-# LANGUAGE UndecidableInstances      #-}++module Control.Imperative.Vector.Dynamic+( -- $doc++  -- * Types+  Vector+, MonadVector+, VectorElem+, VectorEntity+, HasVector+, Item+, NestedList+, Size(..)+, Dim(..)+, dim1+, dim2+, dim3+  -- * Operations+, new+, newSized+, newSized'+, Control.Imperative.Vector.Dynamic.length+, size+, fromList+, toList+, push+, pop+, unshift+, shift+) where+import           Control.Imperative.Internal+import           Control.Imperative.Vector.Base+import           Control.Monad                  (liftM)+import qualified Control.Monad                  as M+import           Control.Monad.Base+import           Control.Monad.Primitive        (PrimMonad)+import           Data.Nat+import           Data.Vector.Dynamic++-- $doc+-- An efficient array which has three features.+--+-- * Automatic switching unboxed and boxed arrays.+-- * Multi-dimension support+-- * Dynamically resizing+--+-- There are two basic operation exported from the "Control.Imperative" module.+--+-- [@ref@] /O(1)/. return the element of a vector at the given index.+-- [@assign@] /O(1)/ amortized. replace the element at the given index.+--+newtype Vector m n a = V (MultiDim m n a)++class Monad m => HasVector s v m | s -> v, s -> m where+  getVector :: s -> m v++instance Monad m => HasVector (Vector m n a) (Vector m n a) m where+  getVector = return+  {-# INLINE getVector #-}++instance Monad m => HasVector (Ref m (Vector m n a)) (Vector m n a) m where+  getVector = get+  {-# INLINE getVector #-}++data MultiDim m (n :: Nat) a where+  D1 :: DynamicVector m a -> MultiDim m (S Z) a+  DN :: DynamicVector m (MultiDim m (S n) a) -> MultiDim m (S (S n)) a++instance (VectorElem a, PrimMonad m) => Indexable (Vector m (S Z) a) where+  type Element (Vector m (S Z) a)   = Ref m a+  type IndexType (Vector m (S Z) a) = Int+  (!) (V (D1 v)) i = Ref+    { get = readDyn v i +    , set = writeDyn v i+    }+  {-# INLINE (!) #-}++instance PrimMonad m => Indexable (Vector m (S (S n)) a) where+  type Element (Vector m (S (S n)) a) = Ref m (Vector m (S n) a)+  type IndexType (Vector m (S (S n)) a) = Int+  (!) (V (DN v)) i = Ref+    { get = liftM V $ readDyn v i+    , set = \(V w) -> writeDyn v i w+    }+  {-# INLINE (!) #-}++instance (VectorElem a, PrimMonad m) => Indexable (Ref m (Vector m (S Z) a)) where+  type Element (Ref m (Vector m (S Z) a)) = Ref m a+  type IndexType (Ref m (Vector m (S Z) a)) = Int+  r ! i = Ref+    { get = get r >>= \(V (D1 v)) -> readDyn v i+    , set = \x -> get r >>= \(V (D1 v)) -> writeDyn v i x+    }+  {-# INLINE (!) #-}++instance PrimMonad m => Indexable (Ref m (Vector m (S (S n)) a)) where+  type Element (Ref m (Vector m (S (S n)) a)) = Ref m (Vector m (S n) a)+  type IndexType (Ref m (Vector m (S (S n)) a)) = Int+  r ! i = Ref+    { get = get r >>= \(V (DN v)) -> liftM V $ readDyn v i+    , set = \(V w) -> get r >>= \(V (DN v)) -> writeDyn v i w+    }+  {-# INLINE (!) #-}++-- | /O(1)/. Create an empty vector.+new+  :: (VectorElem a, MonadVector m, SingNat (S n))+  => proxy (S n) -- ^ dimension+  -> m (Vector (BaseEff m) (S n) a)+new (_ :: proxy (S n)) = liftBase $ liftM V $ case (singNat :: SNat (S n)) of+  SS SZ -> M.liftM D1 $ newDyn 0+  SS (SS _) -> M.liftM DN $ newDyn 0+{-# INLINE new #-}++-- | /O(n)/. Create a vector of the given length.+newSized :: (VectorElem a, MonadVector m) => Size (S n) -> m (Vector (BaseEff m) (S n) a)+newSized = liftBase . liftM V . go+  where+    go :: (VectorElem a, PrimMonad m) => Size (S n) -> m (MultiDim m (S n) a)+    go (n :*: One) = liftM D1 $ newDyn n+    go (n :*: r@(_ :*: _)) = do+      v <- newDyn n+      M.forM_ [0..n-1] $ \i -> do+        w <- go r+        writeDyn v i w+      return $ DN v+{-# INLINE newSized #-}++-- | /O(n)/. Create a vector filled with an initial value.+newSized' :: (VectorElem a, MonadVector m) => Size (S n) -> a -> m (Vector (BaseEff m) (S n) a)+newSized' r = liftBase . liftM V . go r+  where+    go :: (VectorElem a, PrimMonad m) => Size (S n) -> a -> m (MultiDim m (S n) a)+    go (n :*: One) x = liftM D1 $ newDyn' n x+    go (n :*: rest@(_ :*: _)) x = do+      v <- newDyn n+      M.forM_ [0..n-1] $ \i -> do+        w <- go rest x+        writeDyn v i w+      return $ DN v+{-# INLINE newSized' #-}++-- | /O(n)/. Build a vector from a nested list.+fromList+  :: (VectorElem a, MonadVector m, SingNat (S d))+  => proxy (S d) -- ^ dimension+  -> NestedList (S d) a -- ^ nested list+  -> m (Vector (BaseEff m) (S d) a)+fromList (_ :: proxy (S d)) = liftBase . liftM V . go (singNat :: SNat (S d))+  where+    go :: (PrimMonad f, VectorElem b) => SNat (S n) -> NestedList (S n) b -> f (MultiDim f (S n) b)+    go (SS SZ) xs = do+      v <- newDyn 0+      M.forM_ xs $ \x -> pushDyn v x+      return (D1 v)+    go (SS n@(SS _)) xs = do+      v <- newDyn 0+      M.forM_ xs $ \ys -> do+        w <- go n ys+        pushDyn v w+      return (DN v)+{-# INLINE fromList #-}++-- | /O(n)/. Convert the vector to a nested list.+toList :: (VectorElem a, HasVector s (Vector (BaseEff m) (S n) a) (BaseEff m), MonadVector m) => s -> m (NestedList (S n) a)+toList s = liftBase $ getVector s >>= \(V dv) -> go dv+  where+    go :: (VectorElem a, PrimMonad m) => MultiDim m n a -> m (NestedList n a)+    go (D1 v) = toListDyn v+    go (DN v) = toListDyn v >>= M.mapM go+{-# INLINE toList #-}++-- | Short alias for 'length'.+size :: (VectorElem a, HasVector s (Vector (BaseEff m) (S n) a) (BaseEff m), MonadVector m) => s -> m Int+size s = liftBase $ getVector s >>= \(V dv) -> case dv of+  D1 v -> sizeDyn v+  DN v -> sizeDyn v+{-# INLINE size #-}++-- | /O(1)/. The number of elements in the vector.+length :: (VectorElem a, HasVector s (Vector (BaseEff m) (S n) a) (BaseEff m), MonadVector m) => s -> m Int+length = size+{-# INLINE length #-}++type family Item a where+  Item (Vector m (S Z) a) = a+  Item (Vector m (S (S n)) a) = Vector m (S n) a++-- | /O(1)/. Add a value to the rear of a vector.+push :: (VectorElem a, HasVector s (Vector (BaseEff m) (S n) a) (BaseEff m), MonadVector m) => s -> Item (Vector (BaseEff m) (S n) a) -> m ()+push s x = liftBase $ getVector s >>= \(V dv) -> case dv of+  D1 v -> pushDyn v x+  DN v -> let (V w) = x in pushDyn v w+{-# INLINE push #-}++-- | /O(1)/. Extract a value from the rear of a vector.+pop :: (VectorElem a, HasVector s (Vector (BaseEff m) (S n) a) (BaseEff m), MonadVector m) => s -> m (Item (Vector (BaseEff m) (S n) a))+pop s = liftBase $ getVector s >>= \(V dv) -> case dv of+  D1 v -> popDyn v+  DN v -> liftM V $ popDyn v+{-# INLINE pop #-}++-- | /O(1)/. Add a value to the front of a vector.+unshift :: (VectorElem a, HasVector s (Vector (BaseEff m) (S n) a) (BaseEff m), MonadVector m) => s -> Item (Vector (BaseEff m) (S n) a) -> m ()+unshift s x = liftBase $ getVector s >>= \(V dv) -> case dv of+  D1 v -> unshiftDyn v x+  DN v -> let (V w) = x in unshiftDyn v w+{-# INLINE unshift #-}++-- | /O(1)/. Extract a value from the front of a vector.+shift :: (VectorElem a, HasVector s (Vector (BaseEff m) (S n) a) (BaseEff m), MonadVector m) => s -> m (Item (Vector (BaseEff m) (S n) a))+shift s = liftBase $ getVector s >>= \(V dv) -> case dv of+  D1 v -> shiftDyn v+  DN v -> liftM V $ shiftDyn v+{-# INLINE shift #-}
+ src/Control/Imperative/Vector/Static.hs view
@@ -0,0 +1,189 @@+-------------------------------------------------------------+-- |+-- Module      : Control.Imperative.Vector.Static+-- Copyright   : (C) 2015, Yu Fukuzawa+-- License     : BSD3+-- Maintainer  : minpou.primer@email.com+-- Stability   : experimental+-- Portability : portable+--+-----------------------------------------------------------++{-# LANGUAGE ConstraintKinds           #-}+{-# LANGUAGE DataKinds                 #-}+{-# LANGUAGE FlexibleContexts          #-}+{-# LANGUAGE FlexibleInstances         #-}+{-# LANGUAGE FunctionalDependencies    #-}+{-# LANGUAGE GADTs                     #-}+{-# LANGUAGE MultiParamTypeClasses     #-}+{-# LANGUAGE ScopedTypeVariables       #-}+{-# LANGUAGE TypeFamilies              #-}+{-# LANGUAGE TypeOperators             #-}+{-# LANGUAGE UndecidableInstances      #-}++module Control.Imperative.Vector.Static+( -- $doc++  -- * Types+  Vector+, MonadVector+, VectorElem+, VectorEntity+, HasVector+, NestedList+, Size(..)+, Dim(..)+, dim1+, dim2+, dim3+  -- * Operations+, newSized+, newSized'+, Control.Imperative.Vector.Static.length+, size+, fromListN+, toList+) where+import           Control.Imperative.Internal+import           Control.Imperative.Vector.Base+import           Control.Monad                  (liftM)+import qualified Control.Monad                  as M+import           Control.Monad.Base+import           Control.Monad.Primitive        (PrimMonad, PrimState)+import           Data.Nat+import qualified Data.Vector.Generic.Mutable    as GMV+import qualified Data.Vector.Mutable            as MV++-- $doc+-- An efficient array which has two features.+--+-- * Automatic switching unboxed and boxed arrays.+-- * Multi-dimension support+--+-- There are two basic operation exported from the "Control.Imperative" module.+--+-- [@ref@] /O(1)/. return the element of a vector at the given index.+-- [@assign@] /O(1)/. replace the element at the given index.++newtype Vector m n a = V (MultiDim m n a)++class Monad m => HasVector s v m | s -> v, s -> m where+  getVector :: s -> m v++instance Monad m => HasVector (Vector m n a) (Vector m n a) m where+  getVector = return+  {-# INLINE getVector #-}++instance Monad m => HasVector (Ref m (Vector m n a)) (Vector m n a) m where+  getVector = get+  {-# INLINE getVector #-}++data MultiDim m (n :: Nat) a where+  D1 :: VectorEntity a (PrimState m) a -> MultiDim m (S Z) a+  DN :: MV.MVector (PrimState m) (MultiDim m (S n) a) -> MultiDim m (S (S n)) a++instance (VectorElem a, PrimMonad m) => Indexable (Vector m (S Z) a) where+  type Element (Vector m (S Z) a)   = Ref m a+  type IndexType (Vector m (S Z) a) = Int+  (!) (V (D1 v)) i = Ref+    { get = GMV.read v i+    , set = GMV.write v i+    }+  {-# INLINE (!) #-}++instance PrimMonad m => Indexable (Vector m (S (S n)) a) where+  type Element (Vector m (S (S n)) a) = Ref m (Vector m (S n) a)+  type IndexType (Vector m (S (S n)) a) = Int+  (!) (V (DN v)) i = Ref+    { get = liftM V $ MV.read v i+    , set = \(V w) -> MV.write v i w+    }+  {-# INLINE (!) #-}++instance (VectorElem a, PrimMonad m) => Indexable (Ref m (Vector m (S Z) a)) where+  type Element (Ref m (Vector m (S Z) a)) = Ref m a+  type IndexType (Ref m (Vector m (S Z) a)) = Int+  r ! i = Ref+    { get = get r >>= \(V (D1 v)) -> GMV.read v i+    , set = \x -> get r >>= \(V (D1 v)) -> GMV.write v i x+    }+  {-# INLINE (!) #-}++instance PrimMonad m => Indexable (Ref m (Vector m (S (S n)) a)) where+  type Element (Ref m (Vector m (S (S n)) a)) = Ref m (Vector m (S n) a)+  type IndexType (Ref m (Vector m (S (S n)) a)) = Int+  r ! i = Ref+    { get = get r >>= \(V (DN v)) -> liftM V $ MV.read v i+    , set = \(V w) -> get r >>= \(V (DN v)) -> MV.write v i w+    }+  {-# INLINE (!) #-}++-- | /O(n)/. Create a vector of the given length.+newSized :: (VectorElem a, MonadVector m) => Size (S n) -> m (Vector (BaseEff m) (S n) a)+newSized = liftBase . liftM V . go+  where+    go :: (VectorElem a, PrimMonad m) => Size (S n) -> m (MultiDim m (S n) a)+    go (n :*: One) = liftM D1 $ GMV.new n+    go (n :*: r@(_ :*: _)) = do+      v <- MV.new n+      M.forM_ [0..n-1] $ \i -> do+        w <- go r+        GMV.write v i w+      return $ DN v+{-# INLINE newSized #-}++-- | /O(n)/. Create a vector filled with an initial value.+newSized' :: (VectorElem a, MonadVector m) => Size (S n) -> a -> m (Vector (BaseEff m) (S n) a)+newSized' r = liftBase . liftM V . go r+  where+    go :: (VectorElem a, PrimMonad m) => Size (S n) -> a -> m (MultiDim m (S n) a)+    go (n :*: One) x = liftM D1 $ GMV.replicate n x+    go (n :*: rest@(_ :*: _)) x = do+      v <- MV.new n+      M.forM_ [0..n-1] $ \i -> do+        w <- go rest x+        GMV.write v i w+      return $ DN v+{-# INLINE newSized' #-}++-- | Short alias for 'length'.+size :: (VectorElem a, HasVector s (Vector (BaseEff m) (S n) a) (BaseEff m), MonadVector m) => s -> m Int+size s = liftBase $ getVector s >>= \(V dv) -> return $ case dv of+  D1 v -> GMV.length v+  DN v -> MV.length v+{-# INLINE size #-}++-- | /O(1)/. The number of elements in the vector.+length :: (VectorElem a, HasVector s (Vector (BaseEff m) (S n) a) (BaseEff m), MonadVector m) => s -> m Int+length = size+{-# INLINE length #-}++-- | /O(n)/. Build a vector from a nested list.+fromListN+  :: (VectorElem a, MonadVector m)+  => Size (S n) -- ^ sizes of vector+  -> NestedList (S n) a -- ^ nested list+  -> m (Vector (BaseEff m) (S n) a)+fromListN r = liftBase . liftM V . go r+  where+    go :: (VectorElem a, PrimMonad m) => Size (S n) -> NestedList (S n) a -> m (MultiDim m (S n) a)+    go (n :*: One) xs = do+      v <- GMV.new n+      M.forM_ (zip [0..n-1] xs) $ \(i, x) -> GMV.write v i x+      return $ D1 v+    go (n :*: rest@(_ :*: _)) xs = do+      v <- GMV.new n+      M.forM_ (zip [0..n-1] xs) $ \(i, ys) -> do+        w <- go rest ys+        GMV.write v i w+      return $ DN v+{-# INLINE fromListN #-}++-- | /O(n)/. Convert the vector to a nested list.+toList :: (VectorElem a, HasVector s (Vector (BaseEff m) (S n) a) (BaseEff m), MonadVector m) => s -> m (NestedList (S n) a)+toList s = liftBase $ getVector s >>= \(V dv) -> go dv+  where+    go :: (VectorElem a, PrimMonad m) => MultiDim m n a -> m (NestedList n a)+    go (D1 v) = M.forM [0..GMV.length v-1] (GMV.read v)+    go (DN v) = M.forM [0..MV.length v-1] (MV.read v) >>= M.mapM go+{-# INLINE toList #-}
+ src/Control/Imperative/Zoom.hs view
@@ -0,0 +1,43 @@+-------------------------------------------------------------+-- |+-- Module      : Control.Imperative.Zoom+-- Copyright   : (C) 2015, Yu Fukuzawa+-- License     : BSD3+-- Maintainer  : minpou.primer@email.com+-- Stability   : experimental+-- Portability : portable+--+-----------------------------------------------------------++{-# LANGUAGE FlexibleInstances         #-}+{-# LANGUAGE RankNTypes                #-}+module Control.Imperative.Zoom+( zoomR+, Traversal'+)+where+import           Control.Applicative    (Applicative, Const (..))+import           Control.Imperative.Internal+import           Control.Monad+import           Data.Functor.Identity  (Identity (..))+import           Data.Maybe             (fromMaybe)+import           Data.Monoid            (First (..))++-- | See <http://hackage.haskell.org/package/lens/docs/Control-Lens-Traversal.html>.+type Traversal' s a = Applicative f => (a -> f a) -> s -> f s++unsafePreview :: Traversal' s a -> s -> a+unsafePreview l s = fromMaybe (error "empty value") $ getFirst $ getConst $ l (Const . First . Just) s+{-# INLINE unsafePreview #-}++set' :: Traversal' s a -> a -> s -> s+set' l x = runIdentity . l (const (Identity x))+{-# INLINE set' #-}++-- | Zoom in on stored value in the 'Ref'.+zoomR :: Monad m => Traversal' s a -> Ref m s -> Ref m a+zoomR l r = Ref+  { get = liftM (unsafePreview l) $ get r+  , set = \x -> get r >>= \s -> let t = set' l x s in t `seq` set r t+  }+{-# INLINE zoomR #-}
+ src/Data/Nat.hs view
@@ -0,0 +1,49 @@+-------------------------------------------------------------+-- |+-- Module      : Data.Nat+-- Copyright   : (C) 2015, Yu Fukuzawa+-- License     : BSD3+-- Maintainer  : minpou.primer@email.com+-- Stability   : experimental+-- Portability : portable+--+-----------------------------------------------------------++{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE GADTs                 #-}+{-# LANGUAGE KindSignatures        #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE TypeOperators         #-}++module Data.Nat where++data Nat = Z | S Nat++data SNat (n :: Nat) where+  SZ :: SNat Z+  SS :: SNat n -> SNat (S n)++class SingNat (n :: Nat) where+  singNat :: SNat n++instance SingNat Z where+  singNat = SZ+  {-# INLINE singNat #-}++instance SingNat n => SingNat (S n) where+  singNat = SS singNat+  {-# INLINE singNat #-}++type family (:+:) (n :: Nat) (m :: Nat) where+  Z :+: n = n+  S n :+: m = S (n :+: m)++type family (:-:) (n :: Nat) (m :: Nat) where+  n :-: Z = n+  S n :-: S m = n :-: m++class (:<=) (n :: Nat) (m :: Nat) where+instance (:<=) Z n+instance (n :<= m) => (:<=) (S n) (S m)
+ src/Data/Vector/Dynamic.hs view
@@ -0,0 +1,191 @@+{-# OPTIONS_GHC -w #-}+{-# LANGUAGE BangPatterns          #-}+{-# LANGUAGE ConstraintKinds       #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NamedFieldPuns        #-}+{-# LANGUAGE TypeFamilies          #-}+module Data.Vector.Dynamic+( DynamicVector+, newDyn+, newDyn'+, readDyn+, writeDyn+, pushDyn+, popDyn+, shiftDyn+, unshiftDyn+, sizeDyn+, toListDyn+) where+import           Control.Imperative.Vector.Base (VectorElem, VectorEntity)+import           Control.Monad+import           Control.Monad.Primitive        (PrimMonad, PrimState)+import           Data.Bits+import           Data.Int+import           Data.Primitive.MutVar+import qualified Data.Vector.Generic.Mutable    as GMV+import qualified Data.Vector.Mutable            as MV+import qualified Data.Vector.Unboxed            as UV+import           Data.Word++data DynamicVector m a = Dynamic+  { logSizeVar :: MutVar (PrimState m) Int+  , frontVar   :: MutVar (PrimState m) Int+  , rearVar    :: MutVar (PrimState m) Int+  , vecVar     :: MutVar (PrimState m) (VectorEntity a (PrimState m) a)+  }++toPow2 :: Int -> Int+toPow2 n+  | n <= 0 = 1+  | otherwise = go (n-1) 1+    where+      go 0 !c = c+      go n !c = go (shiftR n 1) (shiftL c 1)+{-# INLINE toPow2 #-}++newDyn :: (PrimMonad m, VectorElem a) => Int -> m (DynamicVector m a)+newDyn logSize = liftM4 Dynamic+  (newMutVar logSize)+  (newMutVar 0)+  (newMutVar (max 0 (logSize-1)))+  (GMV.unsafeNew (toPow2 logSize) >>= newMutVar)+{-# INLINE newDyn #-}++newDyn' :: (PrimMonad m, VectorElem a) => Int -> a -> m (DynamicVector m a)+newDyn' logSize x = do+  d@(Dynamic {vecVar}) <- newDyn logSize+  v <- readMutVar vecVar+  w <- GMV.replicate logSize x+  unsafeMemCopy 0 v 0 (max 0 logSize) w+  return d+{-# INLINE newDyn' #-}++unsafeMemCopy+  :: (PrimMonad m, GMV.MVector v a)+  => Int -- dst offset+  -> v (PrimState m) a -- dst+  -> Int -- src offset+  -> Int -- length+  -> v (PrimState m) a -- src+  -> m ()+unsafeMemCopy i dst j n src = do+  let sdst = GMV.unsafeSlice i n dst+      ssrc = GMV.unsafeSlice j n src+  GMV.unsafeCopy sdst ssrc+{-# INLINE unsafeMemCopy #-}++readDyn :: (PrimMonad m, VectorElem a) => DynamicVector m a -> Int -> m a+readDyn d@(Dynamic {logSizeVar, frontVar, rearVar, vecVar}) logIndex = do+  logSize  <- readMutVar logSizeVar+  when (logSize <= logIndex || logIndex < 0) $+    error $ "index out of bounds " ++ show (logIndex, logSize)+  phyIndex <- log2phy d logIndex+  vec <- readMutVar vecVar+  GMV.unsafeRead vec phyIndex+{-# INLINE readDyn #-}++log2phy :: (PrimMonad m, VectorElem a) => DynamicVector m a -> Int -> m Int+log2phy (Dynamic {frontVar, vecVar}) i = do+  front <- readMutVar frontVar+  vec   <- readMutVar vecVar+  let realCap = GMV.length vec+  return $ (front + i) .&. (realCap - 1)+{-# INLINE log2phy #-}++writeDyn :: (PrimMonad m, VectorElem a) => DynamicVector m a -> Int -> a -> m ()+writeDyn d@(Dynamic {logSizeVar, rearVar, vecVar}) logIndex x = do+  logSize <- readMutVar logSizeVar+  when (logIndex < 0) $+    error $ "index out of bounds " ++ show (logIndex, logSize)+  when (logSize <= logIndex) $ do+    resizeDyn d (logIndex + 1)+    log2phy d logIndex >>= writeMutVar rearVar+  phyIndex <- log2phy d logIndex+  vec <- readMutVar vecVar+  GMV.unsafeWrite vec phyIndex x+{-# INLINE writeDyn #-}++resizeDyn :: (PrimMonad m, VectorElem a) => DynamicVector m a -> Int -> m ()+resizeDyn (Dynamic {logSizeVar, frontVar, rearVar, vecVar}) newLogSize = do+  vec <- readMutVar vecVar+  let realCap = GMV.length vec+  when (realCap < newLogSize) $ do+    let newRealCap = until (newLogSize <=) (*2) realCap+        diff = newRealCap - realCap+    front <- readMutVar frontVar+    rear <- readMutVar rearVar+    newVec <- if front > rear+      then do+        let n = realCap - front+        nv <- GMV.unsafeNew newRealCap+        unsafeMemCopy 0 nv 0 (rear+1) vec+        unsafeMemCopy (front + diff) nv front n vec+        writeMutVar frontVar (front + diff)+        return nv+      else GMV.unsafeGrow vec diff+    writeMutVar vecVar newVec+  writeMutVar logSizeVar newLogSize+{-# INLINE resizeDyn #-}++pushDyn :: (PrimMonad m, VectorElem a) => DynamicVector m a -> a -> m ()+pushDyn d@(Dynamic {logSizeVar, rearVar}) x = do+  logSize <- readMutVar logSizeVar+  writeDyn d logSize x+{-# INLINE pushDyn #-}++popDyn :: (PrimMonad m, VectorElem a) => DynamicVector m a -> m a+popDyn d@(Dynamic {logSizeVar, frontVar, rearVar}) = do+  logSize <- readMutVar logSizeVar+  when (logSize < 1) $ error "Couldn't pop on an empty vector"+  x <- readDyn d (logSize-1)+  when (logSize > 1) $+    log2phy d (logSize-2) >>= writeMutVar rearVar+  modifyMutVar' logSizeVar pred+  return x+{-# INLINE popDyn #-}++shiftDyn :: (PrimMonad m, VectorElem a) => DynamicVector m a -> m a+shiftDyn d@(Dynamic {logSizeVar, frontVar, rearVar, vecVar}) = do+  logSize <- readMutVar logSizeVar+  when (logSize < 1) $ error "Couldn't shift on an empty vector"+  x <- readDyn d 0+  when (logSize > 1) $+    log2phy d 1 >>= writeMutVar frontVar+  modifyMutVar' logSizeVar pred+  return x+{-# INLINE shiftDyn #-}++unshiftDyn :: (PrimMonad m, VectorElem a) => DynamicVector m a -> a -> m ()+unshiftDyn d@(Dynamic {logSizeVar, frontVar, rearVar, vecVar}) x = do+  logSize <- readMutVar logSizeVar+  realCap <- liftM GMV.length $ readMutVar vecVar+  if logSize == realCap+    then resizeDyn d (logSize+1)+    else modifyMutVar' logSizeVar succ+  phyNewHead <- log2phy d (-1)+  vec <- readMutVar vecVar+  GMV.unsafeWrite vec phyNewHead x+  writeMutVar frontVar phyNewHead+  when (logSize==0) $ writeMutVar rearVar phyNewHead+{-# INLINE unshiftDyn #-}++toListDyn :: (PrimMonad m, VectorElem a) => DynamicVector m a -> m [a]+toListDyn (Dynamic {logSizeVar, frontVar, rearVar, vecVar}) = do+  logSize <- readMutVar logSizeVar+  if logSize == 0+    then return []+    else do+      front <- readMutVar frontVar+      rear <- readMutVar rearVar+      vec  <- readMutVar vecVar+      let realCap = GMV.length vec+          indicies = if front <= rear then [front..rear] else [front..realCap-1] ++ [0..rear]+      forM indicies $ GMV.unsafeRead vec+{-# INLINE toListDyn #-}++sizeDyn :: PrimMonad m => DynamicVector m a -> m Int+sizeDyn (Dynamic {logSizeVar}) = readMutVar logSizeVar+{-# INLINE sizeDyn #-}
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}