ral-optics (empty) → 0.1

raw patch · 10 files changed

+433/−0 lines, 10 filesdep +basedep +bindep +fin

Dependencies added: base, bin, fin, optics-core, ral

Files

ChangeLog.md +5/−0
LICENSE +17/−0
ral-optics.cabal +51/−0
src/Data/RAList/NonEmpty/Optics.hs +45/−0
src/Data/RAList/NonEmpty/Optics/Internal.hs +41/−0
src/Data/RAList/Optics.hs +48/−0
src/Data/RAVec/NonEmpty/Optics.hs +73/−0
src/Data/RAVec/NonEmpty/Optics/Internal.hs +29/−0
src/Data/RAVec/Optics.hs +60/−0
src/Data/RAVec/Tree/Optics.hs +64/−0

+ 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>.

+ ral-optics.cabal view

@@ -0,0 +1,51 @@+cabal-version:      2.2+name:               ral-optics+version:            0.1+synopsis:           Length-indexed random access lists: optics utilities.+category:           Data, Dependent Types, Singletons, Optics+description:+  This package provides [optics](https://hackage.haskell.org/package/optics) and instances+  for data types in [ral](https://hackage.haskell.org/package/ral) package.++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 ==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-optics++library+  default-language: Haskell2010+  hs-source-dirs:   src+  ghc-options:      -Wall -fprint-explicit-kinds+  exposed-modules:+    Data.RAList.NonEmpty.Optics+    Data.RAList.Optics+    Data.RAVec.NonEmpty.Optics+    Data.RAVec.Optics+    Data.RAVec.Tree.Optics++  other-modules:+    Data.RAList.NonEmpty.Optics.Internal+    Data.RAVec.NonEmpty.Optics.Internal++  build-depends:+    , base         >=4.9   && <4.14+    , bin          ^>=0.1+    , fin          ^>=0.1.1+    , optics-core  ^>=0.2+    , ral          ^>=0.1++-- dump-core+-- if impl(ghc >= 8.0)+--  build-depends: dump-core+--  ghc-options: -fplugin=DumpCore -fplugin-opt DumpCore:core-html

+ src/Data/RAList/NonEmpty/Optics.hs view

@@ -0,0 +1,45 @@+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes            #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE TypeFamilies          #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Data.RAList.NonEmpty.Optics (+    -- * Indexing+    ix,+    ) where++import Prelude (Int)++import qualified Optics.Core as L++import Data.RAList.NonEmpty+import Data.RAList.NonEmpty.Optics.Internal++-------------------------------------------------------------------------------+-- Indexing+-------------------------------------------------------------------------------++ix :: Int -> L.AffineTraversal' (NERAList a) a+ix i = L.atraversalVL (ixVL i)++-------------------------------------------------------------------------------+-- Instances+-------------------------------------------------------------------------------++instance L.FunctorWithIndex Int NERAList where+    imap = imap++instance L.FoldableWithIndex Int NERAList where+    ifoldMap = ifoldMap++instance L.TraversableWithIndex Int NERAList where+    itraverse = itraverse++instance L.Each Int (NERAList a) (NERAList b) a b++type instance L.Index (NERAList a)   = Int+type instance L.IxValue (NERAList a) = a++instance L.Ixed (NERAList a) where+    ix = ix

+ src/Data/RAList/NonEmpty/Optics/Internal.hs view

@@ -0,0 +1,41 @@+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes            #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE TypeFamilies          #-}+module Data.RAList.NonEmpty.Optics.Internal where++import Control.Applicative ((<$>))+import Prelude+       (Functor (..), Int, Num (..), Ord (..), div, otherwise)++import qualified Data.RAList.Tree as Tr++import Data.RAList.NonEmpty++type LensLikeVL f s t a b = (a -> f b) -> s -> f t+type LensLikeVL' f s a = LensLikeVL f s s a a++ixVL :: forall f a. Functor f => Int -> (forall x. x -> f x) -> LensLikeVL' f (NERAList a) a+ixVL i0 point f (NE xs) = NE <$> go 1 i0 xs where+    go :: forall t. TreeIx t => Int -> Int -> NERAList' t a -> f (NERAList' t a)+    go s i (Last  t)   = Last <$> treeIx s i point f t+    go s i (Cons0   r) = Cons0 <$> go (s + s) i r+    go s i (Cons1 t r)+        | i < s     = (`Cons1` r) <$> treeIx s i point f t+        | otherwise = (t `Cons1`) <$> go (s + s) (i - s) r++class TreeIx t where+    treeIx :: Functor f => Int -> Int -> (forall x. x -> f x) -> (a -> f a) -> t a -> f (t a)++instance TreeIx Tr.Leaf where+    treeIx _ 0 _     f (Tr.Lf x) = Tr.Lf <$> f x+    treeIx _ _ point _ leaf      = point leaf++instance TreeIx t => TreeIx (Tr.Node t) where+    treeIx s i point f node@(Tr.Nd x y)+        | i < s2    = (`Tr.Nd` y) <$> treeIx s2 i        point f x+        | i < s     = (x `Tr.Nd`) <$> treeIx s2 (i - s2) point f x+        | otherwise = point node+      where+        s2 = s `div` 2

+ src/Data/RAList/Optics.hs view

@@ -0,0 +1,48 @@+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes            #-}+{-# LANGUAGE TypeFamilies          #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Data.RAList.Optics (+    -- * Indexing+    ix,+    ) where++import Prelude (Int, Functor (..))++import qualified Optics.Core as L+import qualified Data.RAList.NonEmpty.Optics.Internal as NE++import Data.RAList++-------------------------------------------------------------------------------+-- Indexing+-------------------------------------------------------------------------------++ix :: Int -> L.AffineTraversal' (RAList a) a+ix i = L.atraversalVL (ixVL i)++ixVL :: forall f a. Functor f => Int -> (forall x. x -> f x) -> NE.LensLikeVL' f (RAList a) a+ixVL _ point _ Empty        = point Empty+ixVL i point f (NonEmpty x) = fmap NonEmpty (NE.ixVL i point f x)++-------------------------------------------------------------------------------+-- Instances+-------------------------------------------------------------------------------++instance L.FunctorWithIndex Int RAList where+    imap = imap++instance L.FoldableWithIndex Int RAList where+    ifoldMap = ifoldMap++instance L.TraversableWithIndex Int RAList where+    itraverse = itraverse++instance L.Each Int (RAList a) (RAList b) a b++type instance L.Index (RAList a)   = Int+type instance L.IxValue (RAList a) = a++instance L.Ixed (RAList a) where+    ix = ix

+ src/Data/RAVec/NonEmpty/Optics.hs view

@@ -0,0 +1,73 @@+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies          #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Data.RAVec.NonEmpty.Optics (+    -- * Indexing+    ix, ix',+    ) where++import Data.BinP.PosP (PosP (..), PosP' (..))+import Prelude ()++import qualified Optics.Core as L++import Data.RAVec.NonEmpty+import Data.RAVec.NonEmpty.Optics.Internal++-- $setup+-- >>> import Optics.Core (set)+-- >>> import Prelude+-- >>> import qualified Data.Type.Bin as B++-------------------------------------------------------------------------------+-- Indexing+-------------------------------------------------------------------------------++ix :: PosP b -> L.Lens' (NERAVec b a) a+ix i = L.lensVL (ixVL i)++ix' :: PosP' n b -> L.Lens' (NERAVec' n b a) a+ix' i = L.lensVL (ixVL' i)++-------------------------------------------------------------------------------+-- Instances+-------------------------------------------------------------------------------++instance L.FunctorWithIndex (PosP b) (NERAVec b) where+    imap = imap++instance L.FunctorWithIndex (PosP' n b) (NERAVec' n b) where+    imap = imap'++instance L.FoldableWithIndex (PosP b) (NERAVec b) where+    ifoldMap = ifoldMap+    ifoldr   = ifoldr++instance L.FoldableWithIndex (PosP' n b) (NERAVec' n b) where+    ifoldMap = ifoldMap'+    ifoldr   = ifoldr'++instance L.TraversableWithIndex (PosP b) (NERAVec b) where+    itraverse = itraverse++instance L.TraversableWithIndex (PosP' n b) (NERAVec' n b) where+    itraverse = itraverse'++instance L.Each (PosP n) (NERAVec n a) (NERAVec n b) a b where++instance L.Each (PosP' n m) (NERAVec' n m a) (NERAVec' n m b) a b where++type instance L.Index   (NERAVec b a) = PosP b+type instance L.IxValue (NERAVec b a) = a++type instance L.Index   (NERAVec' n b a) = PosP' n b+type instance L.IxValue (NERAVec' n b a) = a++instance L.Ixed (NERAVec b a) where+    type IxKind (NERAVec b a) = L.A_Lens+    ix = ix++instance L.Ixed (NERAVec' n b a) where+    type IxKind (NERAVec' n b a) = L.A_Lens+    ix = ix'

+ src/Data/RAVec/NonEmpty/Optics/Internal.hs view

@@ -0,0 +1,29 @@+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies          #-}+module Data.RAVec.NonEmpty.Optics.Internal where++import Control.Applicative ((<$>))+import Data.BinP.PosP      (PosP (..), PosP' (..))+import Data.RAVec.Tree     (Tree (..))+import Data.Wrd            (Wrd (..))+import Prelude             (Functor)++import Data.RAVec.NonEmpty++type LensLikeVL f s t a b = (a -> f b) -> s -> f t+type LensLikeVL' f s a = LensLikeVL f s s a a++ixVL :: Functor f => PosP b -> LensLikeVL' f (NERAVec b a) a+ixVL (PosP i) f (NE xs) = NE <$> ixVL' i f xs++ixVL' :: Functor f => PosP' n b -> LensLikeVL' f (NERAVec' n b a) a+ixVL' (AtEnd i)  f (Last  t)   = Last <$> treeIxVL i f t+ixVL' (There0 i) f (Cons0   r) = Cons0 <$> ixVL' i f r+ixVL' (There1 i) f (Cons1 t r) = (t `Cons1`) <$> ixVL' i f r+ixVL' (Here i)   f (Cons1 t r) = (`Cons1` r) <$> treeIxVL i f t++treeIxVL :: Functor f => Wrd n -> LensLikeVL' f (Tree n a) a+treeIxVL WE      f (Leaf x)   = Leaf <$> f x+treeIxVL (W0 is) f (Node x y) = (`Node` y) <$> treeIxVL is f x+treeIxVL (W1 is) f (Node x y) = (x `Node`) <$> treeIxVL is f y

+ src/Data/RAVec/Optics.hs view

@@ -0,0 +1,60 @@+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies          #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Data.RAVec.Optics (+    -- * Indexing+    ix,+    ) where++import Control.Applicative        ((<$>))+import Data.Bin.Pos               (Pos (..))+import Data.RAVec.NonEmpty.Optics ()++import qualified Data.RAVec.NonEmpty.Optics.Internal as NE+import qualified Optics.Core                         as L++import Data.RAVec++-- $setup+-- >>> import Optics.Core (set)+-- >>> import Prelude+-- >>> import qualified Data.Type.Bin as B++-------------------------------------------------------------------------------+-- Indexing+-------------------------------------------------------------------------------++-- | Index lens.+--+-- >>> let Just ral = fromList "xyz" :: Maybe (RAVec B.Bin3 Char)+-- >>> set (ix maxBound) 'Z' ral+-- NonEmpty (NE (Cons1 (Leaf 'x') (Last (Node (Leaf 'y') (Leaf 'Z')))))+ix :: Pos b -> L.Lens' (RAVec b a) a+ix i = L.lensVL (ixVL i)++ixVL :: Functor f => Pos b -> NE.LensLikeVL' f (RAVec b a) a+ixVL (Pos n) f (NonEmpty x) = NonEmpty <$> NE.ixVL n f x++-------------------------------------------------------------------------------+-- Instances+-------------------------------------------------------------------------------++instance L.FunctorWithIndex (Pos b) (RAVec b) where+    imap = imap++instance L.FoldableWithIndex (Pos b) (RAVec b) where+    ifoldMap = ifoldMap+    ifoldr   = ifoldr++instance L.TraversableWithIndex (Pos b) (RAVec b) where+    itraverse = itraverse++instance L.Each (Pos n) (RAVec n a) (RAVec n b) a b where++type instance L.Index   (RAVec n a) = Pos n+type instance L.IxValue (RAVec n a) = a++instance L.Ixed (RAVec b a) where+    type IxKind (RAVec b a) = L.A_Lens+    ix = ix

+ src/Data/RAVec/Tree/Optics.hs view

@@ -0,0 +1,64 @@+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies          #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Data.RAVec.Tree.Optics (+    -- * Indexing+    ix,+    ) where++import Control.Applicative ((<$>))+import Data.Wrd            (Wrd (..))+import Prelude             (Functor)++import qualified Optics.Core as L++import Data.RAVec.Tree++-- $setup+-- >>> import Optics.Core (set)+-- >>> import Prelude++type LensLikeVL f s t a b = (a -> f b) -> s -> f t+type LensLikeVL' f s a = LensLikeVL f s s a a++-------------------------------------------------------------------------------+-- Indexing+-------------------------------------------------------------------------------++-- | Index lens.+--+-- >>> let tree = Node (Node (Leaf 'a') (Leaf 'b')) (Node (Leaf 'c') (Leaf 'd'))+-- >>> set (ix (W1 $ W0 WE)) 'z' tree+-- Node (Node (Leaf 'a') (Leaf 'b')) (Node (Leaf 'z') (Leaf 'd'))+--+ix :: Wrd n -> L.Lens' (Tree n a) a+ix i = L.lensVL (ixVL i)++ixVL :: Functor f => Wrd n -> LensLikeVL' f (Tree n a) a+ixVL WE      f (Leaf x)   = Leaf <$> f x+ixVL (W0 is) f (Node x y) = (`Node` y) <$> ixVL is f x+ixVL (W1 is) f (Node x y) = (x `Node`) <$> ixVL is f y++-------------------------------------------------------------------------------+-- Instances+-------------------------------------------------------------------------------++instance L.FunctorWithIndex (Wrd n) (Tree n) where+    imap = imap++instance L.FoldableWithIndex (Wrd n) (Tree n) where+    ifoldMap = ifoldMap+    ifoldr   = ifoldr++instance L.TraversableWithIndex (Wrd n) (Tree n) where+    itraverse = itraverse++instance L.Each (Wrd n) (Tree n a) (Tree n b) a b where++type instance L.Index (Tree n a)   = Wrd n+type instance L.IxValue (Tree n a) = a++instance L.Ixed (Tree n a) where+    type IxKind (Tree n a) = L.A_Lens+    ix = ix