diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,5 @@ +# Version history for ral + +## 0.1 + +- First version. Released on an unsuspecting world. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,17 @@ +SPDX-License-Identifier: GPL-2.0-or-later + +Copyright (c) 2019 Oleg Grenrus + + 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 . diff --git a/ral-lens.cabal b/ral-lens.cabal new file mode 100644 --- /dev/null +++ b/ral-lens.cabal @@ -0,0 +1,54 @@ +cabal-version: 2.2 +name: ral-lens +version: 0.1 +synopsis: Length-indexed random access lists: lens utilities. +category: Data, Dependent Types, Singletons, Lens +description: + This package provides [lenses](https://hackage.haskell.org/package/lens) 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 +maintainer: Oleg.Grenrus +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-lens + +library + default-language: Haskell2010 + hs-source-dirs: src + ghc-options: -Wall -fprint-explicit-kinds + exposed-modules: + Data.RAList.Lens + Data.RAList.NonEmpty.Lens + Data.RAVec.Lens + Data.RAVec.NonEmpty.Lens + Data.RAVec.Tree.Lens + + build-depends: + , base >=4.7 && <4.14 + , bin ^>=0.1 + , fin ^>=0.1.1 + , lens >=4.16 && <4.19 + , ral ^>=0.1 + +-- dump-core +-- if impl(ghc >= 8.0) +-- build-depends: dump-core +-- ghc-options: -fplugin=DumpCore -fplugin-opt DumpCore:core-html diff --git a/src/Data/RAList/Lens.hs b/src/Data/RAList/Lens.hs new file mode 100644 --- /dev/null +++ b/src/Data/RAList/Lens.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Data.RAList.Lens ( + -- * Indexing + ix, + ) where + +import Control.Applicative (Applicative (..), (<$>)) +import Prelude (Int) + +import qualified Control.Lens as L +import qualified Data.RAList.NonEmpty.Lens as NE + +import Data.RAList + +------------------------------------------------------------------------------- +-- Indexing +------------------------------------------------------------------------------- + +ix :: forall f a. Applicative f => Int -> L.LensLike' f (RAList a) a +ix _ _ Empty = pure Empty +ix i f (NonEmpty xs) = NonEmpty <$> NE.ix i f xs + +------------------------------------------------------------------------------- +-- 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 (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 diff --git a/src/Data/RAList/NonEmpty/Lens.hs b/src/Data/RAList/NonEmpty/Lens.hs new file mode 100644 --- /dev/null +++ b/src/Data/RAList/NonEmpty/Lens.hs @@ -0,0 +1,67 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Data.RAList.NonEmpty.Lens ( + -- * Indexing + ix, + ) where + +import Control.Applicative (Applicative (pure), (<$>)) +import Prelude (Int, Num (..), Ord (..), div, otherwise) + +import qualified Control.Lens as L +import qualified Data.RAList.Tree as Tr + +import Data.RAList.NonEmpty + +------------------------------------------------------------------------------- +-- Indexing +------------------------------------------------------------------------------- + +ix :: forall f a. Applicative f => Int -> L.LensLike' f (NERAList a) a +ix i0 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 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 f t + | otherwise = (t `Cons1`) <$> go (s + s) (i - s) r + +class TreeIx t where + treeIx :: Applicative f => Int -> Int -> (a -> f a) -> t a -> f (t a) + +instance TreeIx Tr.Leaf where + treeIx _ 0 f (Tr.Lf x) = Tr.Lf <$> f x + treeIx _ _ _ leaf = pure leaf + +instance TreeIx t => TreeIx (Tr.Node t) where + treeIx s i f node@(Tr.Nd x y) + | i < s2 = (`Tr.Nd` y) <$> treeIx s2 i f x + | i < s = (x `Tr.Nd`) <$> treeIx s2 (i - s2) f x + | otherwise = pure node + where + s2 = s `div` 2 + +------------------------------------------------------------------------------- +-- 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 (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 diff --git a/src/Data/RAVec/Lens.hs b/src/Data/RAVec/Lens.hs new file mode 100644 --- /dev/null +++ b/src/Data/RAVec/Lens.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Data.RAVec.Lens ( + -- * Indexing + ix, + ) where + +import Control.Applicative ((<$>)) +import Data.Bin.Pos (Pos (..)) +import Prelude () + +import qualified Control.Lens as L +import qualified Data.RAVec.NonEmpty.Lens as NE + +import Data.RAVec + +-- $setup +-- >>> import Control.Lens ((^.), (&), (.~), (^?), (#)) +-- >>> import Prelude +-- >>> import qualified Data.Type.Bin as B + +------------------------------------------------------------------------------- +-- Indexing +------------------------------------------------------------------------------- + +-- | Index lens. +-- +-- >>> let Just ral = fromList "xyz" :: Maybe (RAVec B.Bin3 Char) +-- >>> ral & ix maxBound .~ 'Z' +-- NonEmpty (NE (Cons1 (Leaf 'x') (Last (Node (Leaf 'y') (Leaf 'Z'))))) +ix :: Pos b -> L.Lens' (RAVec b a) a +ix (Pos n) f (NonEmpty x) = NonEmpty <$> NE.ix 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 (RAVec n a) (RAVec n b) a b where + each = traverse + +type instance L.Index (RAVec n a) = Pos n +type instance L.IxValue (RAVec n a) = a + +instance L.Ixed (RAVec b a) where + ix = ix diff --git a/src/Data/RAVec/NonEmpty/Lens.hs b/src/Data/RAVec/NonEmpty/Lens.hs new file mode 100644 --- /dev/null +++ b/src/Data/RAVec/NonEmpty/Lens.hs @@ -0,0 +1,78 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Data.RAVec.NonEmpty.Lens ( + -- * Indexing + ix, ix', + ) where + +import Control.Applicative ((<$>)) +import Data.BinP.PosP (PosP (..), PosP' (..)) +import Prelude () + +import qualified Control.Lens as L +import qualified Data.RAVec.Tree.Lens as Tree + +import Data.RAVec.NonEmpty + +-- $setup +-- >>> import Control.Lens ((^.), (&), (.~), (^?), (#)) +-- >>> import Prelude +-- >>> import qualified Data.Type.Bin as B + +------------------------------------------------------------------------------- +-- Indexing +------------------------------------------------------------------------------- + +ix :: PosP b -> L.Lens' (NERAVec b a) a +ix (PosP i) f (NE xs) = NE <$> ix' i f xs + +ix' :: PosP' n b -> L.Lens' (NERAVec' n b a) a +ix' (AtEnd i) f (Last t) = Last <$> Tree.ix i f t +ix' (There0 i) f (Cons0 r) = Cons0 <$> ix' i f r +ix' (There1 i) f (Cons1 t r) = (t `Cons1`) <$> ix' i f r +ix' (Here i) f (Cons1 t r) = (`Cons1` r) <$> Tree.ix i f t + +------------------------------------------------------------------------------- +-- 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 (NERAVec n a) (NERAVec n b) a b where + each = traverse + +instance L.Each (NERAVec' n m a) (NERAVec' n m b) a b where + each = traverse' + +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 + ix = ix + +instance L.Ixed (NERAVec' n b a) where + ix = ix' diff --git a/src/Data/RAVec/Tree/Lens.hs b/src/Data/RAVec/Tree/Lens.hs new file mode 100644 --- /dev/null +++ b/src/Data/RAVec/Tree/Lens.hs @@ -0,0 +1,59 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Data.RAVec.Tree.Lens ( + -- * Indexing + ix, + ) where + +import Prelude () +import Control.Applicative ((<$>)) +import Data.Wrd (Wrd (..)) + +import qualified Control.Lens as L + +import Data.RAVec.Tree + +-- $setup +-- >>> import Control.Lens ((^.), (&), (.~), (^?), (#)) +-- >>> import Prelude + +------------------------------------------------------------------------------- +-- Indexing +------------------------------------------------------------------------------- + +-- | Index lens. +-- +-- >>> let tree = Node (Node (Leaf 'a') (Leaf 'b')) (Node (Leaf 'c') (Leaf 'd')) +-- >>> tree & ix (W1 $ W0 WE) .~ 'z' +-- Node (Node (Leaf 'a') (Leaf 'b')) (Node (Leaf 'z') (Leaf 'd')) +-- +ix :: Wrd n -> L.Lens' (Tree n a) a +ix WE f (Leaf x) = Leaf <$> f x +ix (W0 is) f (Node x y) = (`Node` y) <$> ix is f x +ix (W1 is) f (Node x y) = (x `Node`) <$> ix 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 + ifoldl = ifoldl + +instance L.TraversableWithIndex (Wrd n) (Tree n) where + itraverse = itraverse + +instance L.Each (Tree n a) (Tree n b) a b + +type instance L.Index (Tree n a) = Wrd n +type instance L.IxValue (Tree n a) = a + +instance L.Ixed (Tree n a) where + ix = ix