diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,7 @@ +# Changelog for focuslist + +## Unreleased changes + +## v0.1.0.0 + +- Initial release. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Dennis Gosnell (c) 2018 + +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 Author name here 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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,79 @@ +FocusList +========= + +[![Build Status](https://secure.travis-ci.org/cdepillabout/focuslist.svg)](http://travis-ci.org/cdepillabout/focuslist) +[![Hackage](https://img.shields.io/hackage/v/focuslist.svg)](https://hackage.haskell.org/package/focuslist) +[![Stackage LTS](http://stackage.org/package/focuslist/badge/lts)](http://stackage.org/lts/package/focuslist) +[![Stackage Nightly](http://stackage.org/package/focuslist/badge/nightly)](http://stackage.org/nightly/package/focuslist) +[![BSD3 license](https://img.shields.io/badge/license-BSD3-blue.svg)](./LICENSE) + +A `FocusList` is a sequence of elements which has one element as its `Focus`. It +supports quick insertion and indexing by its implementation with +[`Seq`](http://hackage.haskell.org/package/containers-0.6.0.1/docs/Data-Sequence.html#t:Seq). + +## Example + +Here is a short example of using `FocusList`. + +```haskell +module Main where + +import Data.FocusList + ( Focus(Focus), FocusList, appendFL, fromListFL, getFocusItemFL, prependFL + , singletonFL + ) +import Data.Foldable (toList) + +-- | Create a new 'FocusList' from a list. You must set the 'Focus' of the new +-- 'FocusList'. The 'Focus' is counting from zero, so the @goat@ element should +-- have the 'Focus'. +-- +-- If you try to specify a 'Focus' out of range from the input list, +-- 'fromListFL' will return 'Nothing'. +myFocusList :: Maybe (FocusList String) +myFocusList = fromListFL (Focus 2) ["hello", "bye", "goat", "dog"] + +-- | You can get the focused element from an existing 'FocusList' +-- +-- If the 'FocusList' is empty, this returns 'Nothing'. +myFocusElement :: FocusList String -> Maybe String +myFocusElement focuslist = getFocusItemFL focuslist + +-- | You can append to either side of a 'FocusList'. +-- +-- 'singletonFL' creates a 'FocusList' with a single element. +-- That single element will have the 'Focus'. +-- +-- 'myFocusListAppended' will have a value of +-- @FocusList (Focus 1) ["bye", "hello", "foobar"]@ +myFocusListAppended :: FocusList String +myFocusListAppended = + prependFL "bye" (appendFL (singletonFL "hello") "foobar") + +-- | 'FocusList' is an instance of 'Functor' and 'Foldable', so you can use +-- functions like 'fmap' and 'toList' on a 'FocusList'. +fmapAndConvertToList :: FocusList Int -> [String] +fmapAndConvertToList focuslist = toList (fmap show focuslist) + +main :: IO () +main = do + putStrLn "myFocusList:" + print myFocusList + + putStrLn "\nmyFocusListAppended:" + print myFocusListAppended + + putStrLn "\nmyFocusElement myFocusListAppended:" + print (myFocusElement myFocusListAppended) + + putStrLn "\nfmap length myFocusListAppended:" + print (fmap length myFocusListAppended) + + putStrLn "\nfmapAndConvertToList (fmap length myFocusListAppended):" + print (fmapAndConvertToList (fmap length myFocusListAppended)) +``` + +## Maintainers + +- [Grendel-Grendel-Grendel](https://github.com/Grendel-Grendel-Grendel) +- [cdepillabout](https://github.com/cdepillabout) diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,40 @@ +-- This file comes from cabal-doctest: +-- https://github.com/phadej/cabal-doctest/blob/master/simple-example +-- +-- It is needed so that doctest can be run with the same options as the modules +-- are compiled with. + +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -Wall #-} + +module Main (main) where + +#ifndef MIN_VERSION_cabal_doctest +#define MIN_VERSION_cabal_doctest(x,y,z) 0 +#endif + +#if MIN_VERSION_cabal_doctest(1,0,0) + +import Distribution.Extra.Doctest ( defaultMainWithDoctests ) +main :: IO () +main = defaultMainWithDoctests "focuslist-doctests" + +#else + +#ifdef MIN_VERSION_Cabal +-- If the macro is defined, we have new cabal-install, +-- but for some reason we don't have cabal-doctest in package-db +-- +-- Probably we are running cabal sdist, when otherwise using new-build +-- workflow +#warning You are configuring this package without cabal-doctest installed. \ + The doctests test-suite will not work as a result. \ + To fix this, install cabal-doctest before configuring. +#endif + +import Distribution.Simple + +main :: IO () +main = defaultMain + +#endif diff --git a/focuslist.cabal b/focuslist.cabal new file mode 100644 --- /dev/null +++ b/focuslist.cabal @@ -0,0 +1,103 @@ +name: focuslist +version: 0.1.0.0 +synopsis: Lists with a focused element +description: Please see . +homepage: https://github.com/cdepillabout/focuslist +license: BSD3 +license-file: LICENSE +author: Dennis Gosnell and Grendel-Grendel-Grendel +maintainer: cdep.illabout@gmail.com +copyright: 2017-2018 Dennis Gosnell +category: Text +build-type: Custom +cabal-version: 1.12 +extra-source-files: README.md + , CHANGELOG.md + +custom-setup + setup-depends: base + , Cabal + , cabal-doctest >=1.0.2 && <1.1 + +-- This flag builds the example from the README.md file. It is only used for +-- testing. It should be enabled for CI. +flag buildreadme + description: Build the example from the README.md file. This + is normally only used for testing. + default: False + +library + hs-source-dirs: src + exposed-modules: Data.FocusList + build-depends: base >= 4.7 && < 5 + , containers + , lens + , mono-traversable + , QuickCheck + default-language: Haskell2010 + ghc-options: -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates + +test-suite focuslist-doctests + type: exitcode-stdio-1.0 + main-is: DocTest.hs + -- other-modules: Build_doctests + hs-source-dirs: test + build-depends: base + , doctest + , QuickCheck + , template-haskell + default-language: Haskell2010 + ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N + +test-suite focuslist-test + type: exitcode-stdio-1.0 + main-is: Test.hs + hs-source-dirs: test + other-modules: Test.FocusList + , Test.FocusList.Invariants + build-depends: base + , focuslist + , genvalidity-containers + , genvalidity-hspec + , hedgehog + , lens + , QuickCheck + , tasty + , tasty-hedgehog + , tasty-hspec + default-language: Haskell2010 + ghc-options: -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -threaded -rtsopts -with-rtsopts=-N + +executable focuslist-readme + main-is: README.lhs + hs-source-dirs: test/readme + build-depends: base + , focuslist + , markdown-unlit + ghc-options: -pgmL markdown-unlit + default-language: Haskell2010 + + if flag(buildreadme) + buildable: True + else + buildable: False + + +source-repository head + type: git + location: https://github.com/cdepillabout/focuslist/ + +-- benchmark termonad-bench +-- type: exitcode-stdio-1.0 +-- main-is: Bench.hs +-- hs-source-dirs: bench +-- build-depends: base +-- , criterion +-- , termonad +-- default-language: Haskell2010 +-- ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N + +source-repository head + type: git + location: git@github.com:cdepillabout/focuslist.git + diff --git a/src/Data/FocusList.hs b/src/Data/FocusList.hs new file mode 100644 --- /dev/null +++ b/src/Data/FocusList.hs @@ -0,0 +1,1207 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} + +module Data.FocusList + ( + -- * FocusList + FocusList(FocusList, focusListFocus, focusList) + -- ** Conversions + , fromListFL + , fromFoldableFL + , toSeqFL + -- ** Query + , lengthFL + , isEmptyFL + , getFocusItemFL + , lookupFL + , indexOfFL + , findFL + -- *** Query 'Focus' + , hasFocusFL + , getFocusFL + -- ** Manipulate + , prependFL + , appendFL + , appendSetFocusFL + , insertFL + , removeFL + , deleteFL + , moveFromToFL + , intersperseFL + , reverseFL + -- *** Manipulate 'Focus' + , setFocusFL + , updateFocusFL + -- ** Sort + , sortByFL + -- ** Construction + , emptyFL + , singletonFL + -- ** Unsafe Functions + , unsafeFromListFL + , unsafeGetFocusFL + , unsafeGetFocusItemFL + -- ** Invariants + , invariantFL + -- ** Testing + , genValidFL + -- ** Optics + -- | These optics allow you to get/set the internal state of a 'FocusList'. + -- You should make sure not to directly set the internal state of a + -- 'FocusList' unless you are sure that the invariants for the 'FocusList' + -- are protected. See 'invariantFL'. + , lensFocusListFocus + , lensFocusList + -- * Focus + , Focus(Focus, NoFocus) + , hasFocus + , getFocus + , maybeToFocus + , foldFocus + -- ** Optics + , _Focus + , _NoFocus + -- ** Unsafe Functions + , unsafeGetFocus + ) where + +import Prelude hiding (reverse) + +import Control.Lens (Prism', (^.), (.~), (-~), makeLensesFor, prism') +import Data.Foldable (toList) +import Data.Function ((&)) +import Data.MonoTraversable + (Element, GrowingAppend, MonoFoldable, MonoFunctor, MonoTraversable, olength) +import qualified Data.Sequence as Sequence +import Data.Sequence + (Seq((:<|), Empty), (<|), deleteAt, elemIndexL, insertAt, singleton) +import Data.Sequences + (Index, SemiSequence, cons, find, intersperse, reverse, snoc, sortBy) +import GHC.Exts (fromList) +import GHC.Generics (Generic) +import Test.QuickCheck + ( Arbitrary, Arbitrary1, CoArbitrary, Gen, arbitrary, arbitrary1, choose + , frequency, liftArbitrary + ) +import Text.Show (Show(showsPrec), ShowS, showParen, showString) + +-- $setup +-- >>> :set -XFlexibleContexts +-- >>> :set -XScopedTypeVariables +-- >>> import Data.Maybe (isJust) + +-- | A 'Focus' for the 'FocusList'. +-- +-- The 'Focus' is either 'NoFocus' (if the 'Focuslist' is empty), or 'Focus' +-- 'Int' to represent focusing on a specific element of the 'FocusList'. +data Focus = Focus {-# UNPACK #-} !Int | NoFocus deriving (Eq, Generic, Read, Show) + +-- | 'NoFocus' is always less than 'Focus'. +-- +-- prop> NoFocus < Focus a +-- +-- The ordering of 'Focus' depends on the ordering of the integer contained +-- inside. +-- +-- prop> (a < b) ==> (Focus a < Focus b) +instance Ord Focus where + compare :: Focus -> Focus -> Ordering + compare NoFocus NoFocus = EQ + compare NoFocus (Focus _) = LT + compare (Focus _) NoFocus = GT + compare (Focus a) (Focus b) = compare a b + +instance CoArbitrary Focus + +instance Arbitrary Focus where + arbitrary = frequency [(1, pure NoFocus), (3, fmap Focus arbitrary)] + +-- | A fold function for 'Focus'. +-- +-- This is similar to 'maybe' for 'Maybe'. +-- +-- >>> foldFocus "empty" (\i -> "focus at " <> show i) (Focus 3) +-- "focus at 3" +-- +-- >>> foldFocus Nothing Just NoFocus +-- Nothing +-- +-- prop> foldFocus NoFocus Focus focus == focus +foldFocus :: b -> (Int -> b) -> Focus -> b +foldFocus b _ NoFocus = b +foldFocus _ f (Focus i) = f i + +-- | A 'Prism'' for focusing on the 'Focus' constructor in a 'Focus' data type. +_Focus :: Prism' Focus Int +_Focus = prism' Focus (foldFocus Nothing Just) + +-- | A 'Prism'' for focusing on the 'NoFocus' constructor in a 'Focus' data type. +_NoFocus :: Prism' Focus () +_NoFocus = prism' (const NoFocus) (foldFocus (Just ()) (const Nothing)) + +-- | Returns 'True' if a 'Focus' exists, and 'False' if not. +-- +-- >>> hasFocus (Focus 0) +-- True +-- +-- >>> hasFocus NoFocus +-- False +-- +-- /complexity/: @O(1)@ +hasFocus :: Focus -> Bool +hasFocus NoFocus = False +hasFocus (Focus _) = True + +-- | Get the focus index from a 'Focus'. +-- +-- >>> getFocus (Focus 3) +-- Just 3 +-- +-- >>> getFocus NoFocus +-- Nothing +-- +-- /complexity/: @O(1)@ +getFocus :: Focus -> Maybe Int +getFocus NoFocus = Nothing +getFocus (Focus i) = Just i + +-- | Convert a 'Maybe' 'Int' to a 'Focus'. +-- +-- >>> maybeToFocus (Just 100) +-- Focus 100 +-- +-- >>> maybeToFocus Nothing +-- NoFocus +-- +-- 'maybeToFocus' and 'getFocus' witness an isomorphism. +-- +-- prop> focus == maybeToFocus (getFocus focus) +-- +-- prop> maybeInt == getFocus (maybeToFocus maybeInt) +-- +-- /complexity/: @O(1)@ +maybeToFocus :: Maybe Int -> Focus +maybeToFocus Nothing = NoFocus +maybeToFocus (Just i) = Focus i + +-- | Unsafely get the focus index from a 'Focus'. +-- +-- Returns an error if 'NoFocus'. +-- +-- >>> unsafeGetFocus (Focus 50) +-- 50 +-- +-- >>> unsafeGetFocus NoFocus +-- *** Exception: ... +-- ... +-- +-- /complexity/: @O(1)@ +unsafeGetFocus :: Focus -> Int +unsafeGetFocus NoFocus = error "unsafeGetFocus: NoFocus" +unsafeGetFocus (Focus i) = i + +-- | A list with a given element having the 'Focus'. +-- +-- 'FocusList' has some invariants that must be protected. You should not use +-- the 'FocusList' constructor or the 'focusListFocus' or 'focusList' +-- accessors. +-- +-- Implemented under the hood as a 'Seq'. +data FocusList a = FocusList + { focusListFocus :: !Focus + , focusList :: !(Seq a) + } deriving (Eq, Functor, Generic) + +$(makeLensesFor + [ ("focusListFocus", "lensFocusListFocus") + , ("focusList", "lensFocusList") + ] + ''FocusList + ) + +instance Foldable FocusList where + foldr f b (FocusList _ fls) = foldr f b fls + + length = lengthFL + +instance Traversable FocusList where + traverse :: Applicative f => (a -> f b) -> FocusList a -> f (FocusList b) + traverse f (FocusList focus fls) = FocusList focus <$> traverse f fls + +type instance Element (FocusList a) = a + +instance MonoFunctor (FocusList a) + +instance MonoFoldable (FocusList a) where + olength = lengthFL + +instance MonoTraversable (FocusList a) + +instance GrowingAppend (FocusList a) + +instance SemiSequence (FocusList a) where + type Index (FocusList a) = Int + + intersperse = intersperseFL + + reverse = reverseFL + + find = findFL + + sortBy = sortByFL + + cons = prependFL + + snoc = appendFL + +-- | Given a 'Gen' for @a@, generate a valid 'FocusList'. +genValidFL :: forall a. Gen a -> Gen (FocusList a) +genValidFL genA = do + newFL <- genFL + if invariantFL newFL + then pure newFL + else error "genValidFL generated an invalid FocusList! This should never happen!" + where + genFL :: Gen (FocusList a) + genFL = do + arbList <- liftArbitrary genA + case arbList of + [] -> pure emptyFL + (_:_) -> do + let listLen = length arbList + len <- choose (0, listLen - 1) + pure $ unsafeFromListFL (Focus len) arbList + +instance Arbitrary1 FocusList where + liftArbitrary = genValidFL + +instance Arbitrary a => Arbitrary (FocusList a) where + arbitrary = arbitrary1 + +instance CoArbitrary a => CoArbitrary (FocusList a) + +instance Show a => Show (FocusList a) where + showsPrec :: Int -> FocusList a -> ShowS + showsPrec d FocusList{..} = + showParen (d > 10) $ + showString "FocusList " . + showsPrec 11 focusListFocus . + showString " " . + showsPrec 11 (toList focusList) + +-- | Get the underlying 'Seq' in a 'FocusList'. +-- +-- /complexity/: @O(1)@ +toSeqFL :: FocusList a -> Seq a +toSeqFL FocusList{focusList = fls} = fls + +-- | Return the length of a 'FocusList'. +-- +-- >>> let Just fl = fromListFL (Focus 2) ["hello", "bye", "parrot"] +-- >>> lengthFL fl +-- 3 +-- +-- /complexity/: @O(1)@ +lengthFL :: FocusList a -> Int +lengthFL = length . focusList + +-- | This is an invariant that the 'FocusList' must always protect. +-- +-- The functions in this module should generally protect this invariant. If +-- they do not, it is generally a bug. +-- +-- The invariants are as follows: +-- +-- - The 'Focus' in a 'FocusList' can never be negative. +-- +-- - If there is a 'Focus', then it actually exists in +-- the 'FocusList'. +-- +-- - There needs to be a 'Focus' if the length of the +-- 'FocusList' is greater than 0. +-- +-- /complexity/: @O(log n)@, where @n@ is the length of the 'FocusList'. +invariantFL :: FocusList a -> Bool +invariantFL fl = + invariantFocusNotNeg && + invariantFocusInMap && + invariantFocusIfLenGT0 + where + -- This makes sure that the 'Focus' in a 'FocusList' can never be negative. + invariantFocusNotNeg :: Bool + invariantFocusNotNeg = + case fl ^. lensFocusListFocus of + NoFocus -> True + Focus i -> i >= 0 + + -- | This makes sure that if there is a 'Focus', then it actually exists in + -- the 'FocusList'. + invariantFocusInMap :: Bool + invariantFocusInMap = + case fl ^. lensFocusListFocus of + NoFocus -> length (fl ^. lensFocusList) == 0 + Focus i -> + case Sequence.lookup i (fl ^. lensFocusList) of + Nothing -> False + Just _ -> True + + -- | This makes sure that there needs to be a 'Focus' if the length of the + -- 'FocusList' is greater than 0. + invariantFocusIfLenGT0 :: Bool + invariantFocusIfLenGT0 = + let len = lengthFL fl + focus = fl ^. lensFocusListFocus + in + case focus of + Focus _ -> len /= 0 + NoFocus -> len == 0 + +-- | Unsafely create a 'FocusList'. This does not check that the focus +-- actually exists in the list. This is an internal function and should +-- generally not be used. It is only safe to use if you ALREADY know +-- the 'Focus' is within the list. +-- +-- Instead, you should generally use 'fromListFL'. +-- +-- The following is an example of using 'unsafeFromListFL' correctly. +-- +-- >>> unsafeFromListFL (Focus 1) [0..2] +-- FocusList (Focus 1) [0,1,2] +-- +-- >>> unsafeFromListFL NoFocus [] +-- FocusList NoFocus [] +-- +-- 'unsafeFromListFL' can also be used uncorrectly. The following is an +-- example of 'unsafeFromListFL' allowing you to create a 'FocusList' that does +-- not pass 'invariantFL'. +-- +-- >>> unsafeFromListFL (Focus 100) [0..2] +-- FocusList (Focus 100) [0,1,2] +-- +-- If 'fromListFL' returns a 'Just' 'FocusList', then 'unsafeFromListFL' should +-- return the same 'FocusList'. +-- +-- /complexity/: @O(n)@ where @n@ is the length of the input list. +unsafeFromListFL :: Focus -> [a] -> FocusList a +unsafeFromListFL focus list = + FocusList + { focusListFocus = focus + , focusList = fromList list + } + +-- | Safely create a 'FocusList' from a list. +-- +-- >>> fromListFL (Focus 1) ["cat","dog","goat"] +-- Just (FocusList (Focus 1) ["cat","dog","goat"]) +-- +-- >>> fromListFL NoFocus [] +-- Just (FocusList NoFocus []) +-- +-- If the 'Focus' is out of range for the list, then 'Nothing' will be returned. +-- +-- >>> fromListFL (Focus (-1)) ["cat","dog","goat"] +-- Nothing +-- +-- >>> fromListFL (Focus 3) ["cat","dog","goat"] +-- Nothing +-- +-- >>> fromListFL NoFocus ["cat","dog","goat"] +-- Nothing +-- +-- /complexity/: @O(n)@ where @n@ is the length of the input list. +fromListFL :: Focus -> [a] -> Maybe (FocusList a) +fromListFL NoFocus [] = Just emptyFL +fromListFL _ [] = Nothing +fromListFL NoFocus (_:_) = Nothing +fromListFL (Focus i) list = + let len = length list + in + if i < 0 || i >= len + then Nothing + else + Just $ + FocusList + { focusListFocus = Focus i + , focusList = fromList list + } + +-- | Create a 'FocusList' from any 'Foldable' container. +-- +-- This just calls 'toList' on the 'Foldable', and then passes the result to +-- 'fromListFL'. +-- +-- prop> fromFoldableFL foc (foldable :: Data.Sequence.Seq Int) == fromListFL foc (toList foldable) +-- +-- /complexity/: @O(n)@ where @n@ is the length of the 'Foldable' +fromFoldableFL :: Foldable f => Focus -> f a -> Maybe (FocusList a) +fromFoldableFL foc as = fromListFL foc (toList as) + +-- | Create a 'FocusList' with a single element. +-- +-- >>> singletonFL "hello" +-- FocusList (Focus 0) ["hello"] +-- +-- /complexity/: @O(1)@ +singletonFL :: a -> FocusList a +singletonFL a = + FocusList + { focusListFocus = Focus 0 + , focusList = singleton a + } + +-- | Create an empty 'FocusList' without a 'Focus'. +-- +-- >>> emptyFL +-- FocusList NoFocus [] +-- +-- /complexity/: @O(1)@ +emptyFL :: FocusList a +emptyFL = + FocusList + { focusListFocus = NoFocus + , focusList = mempty + } + +-- | Return 'True' if the 'FocusList' is empty. +-- +-- >>> isEmptyFL emptyFL +-- True +-- +-- >>> isEmptyFL $ singletonFL "hello" +-- False +-- +-- Any 'FocusList' with a 'Focus' should never be empty. +-- +-- prop> hasFocusFL fl ==> not (isEmptyFL fl) +-- +-- The opposite is also true. +-- +-- /complexity/: @O(1)@ +isEmptyFL :: FocusList a -> Bool +isEmptyFL fl = (lengthFL fl) == 0 + +-- | Append a value to the end of a 'FocusList'. +-- +-- This can be thought of as a \"snoc\" operation. +-- +-- >>> appendFL emptyFL "hello" +-- FocusList (Focus 0) ["hello"] +-- +-- >>> appendFL (singletonFL "hello") "bye" +-- FocusList (Focus 0) ["hello","bye"] +-- +-- Appending a value to an empty 'FocusList' is the same as using 'singletonFL'. +-- +-- prop> appendFL emptyFL a == singletonFL a +-- +-- /complexity/: @O(log n)@ where @n@ is the length of the 'FocusList'. +appendFL :: FocusList a -> a -> FocusList a +appendFL fl a = + if isEmptyFL fl + then singletonFL a + else insertFL (length $ focusList fl) a fl + +-- | A combination of 'appendFL' and 'setFocusFL'. +-- +-- >>> let Just fl = fromListFL (Focus 1) ["hello", "bye", "tree"] +-- >>> appendSetFocusFL fl "pie" +-- FocusList (Focus 3) ["hello","bye","tree","pie"] +-- +-- The 'Focus' will always be updated after calling 'appendSetFocusFL'. +-- +-- prop> getFocusFL (appendSetFocusFL fl a) > getFocusFL fl +-- +-- /complexity/: @O(log n)@ where @n@ is the length of the 'FocusList'. +appendSetFocusFL :: FocusList a -> a -> FocusList a +appendSetFocusFL fl a = + let oldLen = length $ focusList fl + in + case setFocusFL oldLen (appendFL fl a) of + Nothing -> error "Internal error with setting the focus. This should never happen." + Just newFL -> newFL + +-- | Prepend a value to a 'FocusList'. +-- +-- This can be thought of as a \"cons\" operation. +-- +-- >>> prependFL "hello" emptyFL +-- FocusList (Focus 0) ["hello"] +-- +-- The focus will be updated when prepending: +-- +-- >>> prependFL "bye" (singletonFL "hello") +-- FocusList (Focus 1) ["bye","hello"] +-- +-- Prepending to a 'FocusList' will always update the 'Focus': +-- +-- prop> getFocusFL fl < getFocusFL (prependFL a fl) +-- +-- /complexity/: @O(1)@ +prependFL :: a -> FocusList a -> FocusList a +prependFL a fl@FocusList{ focusListFocus = focus, focusList = fls} = + case focus of + NoFocus -> singletonFL a + Focus i -> + fl + { focusListFocus = Focus (i+1) + , focusList = a <| fls + } + +-- | Unsafely get the 'Focus' from a 'FocusList'. If the 'Focus' is +-- 'NoFocus', this function returns 'error'. +-- +-- This function is only safe if you already have knowledge that +-- the 'FocusList' has a 'Focus'. +-- +-- Generally, 'getFocusFL' should be used instead of this function. +-- +-- >>> let Just fl = fromListFL (Focus 1) [0..9] +-- >>> unsafeGetFocusFL fl +-- 1 +-- +-- >>> unsafeGetFocusFL emptyFL +-- *** Exception: ... +-- ... +-- +-- /complexity/: @O(1)@ +unsafeGetFocusFL :: FocusList a -> Int +unsafeGetFocusFL fl = + let focus = fl ^. lensFocusListFocus + in + case focus of + NoFocus -> error "unsafeGetFocusFL: the focus list doesn't have a focus" + Focus i -> i + +-- | Return 'True' if the 'Focus' in a 'FocusList' exists. +-- +-- Return 'False' if the 'Focus' in a 'FocusList' is 'NoFocus'. +-- +-- >>> hasFocusFL $ singletonFL "hello" +-- True +-- +-- >>> hasFocusFL emptyFL +-- False +-- +-- /complexity/: @O(1)@ +hasFocusFL :: FocusList a -> Bool +hasFocusFL = hasFocus . getFocusFL + +-- | Get the 'Focus' from a 'FocusList'. +-- +-- >>> getFocusFL $ singletonFL "hello" +-- Focus 0 +-- +-- >>> let Just fl = fromListFL (Focus 3) [0..9] +-- >>> getFocusFL fl +-- Focus 3 +-- +-- >>> getFocusFL emptyFL +-- NoFocus +-- +-- /complexity/: @O(1)@ +getFocusFL :: FocusList a -> Focus +getFocusFL FocusList{focusListFocus} = focusListFocus + +-- | Unsafely get the value of the 'Focus' from a 'FocusList'. If the 'Focus' is +-- 'NoFocus', this function returns 'error'. +-- +-- This function is only safe if you already have knowledge that the 'FocusList' +-- has a 'Focus'. +-- +-- Generally, 'getFocusItemFL' should be used instead of this function. +-- +-- >>> let Just fl = fromListFL (Focus 0) ['a'..'c'] +-- >>> unsafeGetFocusItemFL fl +-- 'a' +-- +-- >>> unsafeGetFocusFL emptyFL +-- *** Exception: ... +-- ... +-- +-- /complexity/: @O(log(min(i, n - i)))@ where @i@ is the 'Focus', and @n@ +-- is the length of the 'FocusList'. +unsafeGetFocusItemFL :: FocusList a -> a +unsafeGetFocusItemFL fl = + let focus = fl ^. lensFocusListFocus + in + case focus of + NoFocus -> error "unsafeGetFocusItemFL: the focus list doesn't have a focus" + Focus i -> + let fls = fl ^. lensFocusList + in + case Sequence.lookup i fls of + Nothing -> + error $ + "unsafeGetFocusItemFL: internal error, i (" <> + show i <> + ") doesnt exist in sequence" + Just a -> a + +-- | Get the item the 'FocusList' is focusing on. Return 'Nothing' if the +-- 'FocusList' is empty. +-- +-- >>> let Just fl = fromListFL (Focus 0) ['a'..'c'] +-- >>> getFocusItemFL fl +-- Just 'a' +-- +-- >>> getFocusItemFL emptyFL +-- Nothing +-- +-- This will always return 'Just' if there is a 'Focus'. +-- +-- prop> hasFocusFL fl ==> isJust (getFocusItemFL fl) +-- +-- /complexity/: @O(log(min(i, n - i)))@ where @i@ is the 'Focus', and @n@ +-- is the length of the 'FocusList'. +getFocusItemFL :: FocusList a -> Maybe a +getFocusItemFL fl = + let focus = fl ^. lensFocusListFocus + in + case focus of + NoFocus -> Nothing + Focus i -> + let fls = fl ^. lensFocusList + in + case Sequence.lookup i fls of + Nothing -> + error $ + "getFocusItemFL: internal error, i (" <> + show i <> + ") doesnt exist in sequence" + Just a -> Just a + +-- | Lookup the element at the specified index, counting from 0. +-- +-- >>> let Just fl = fromListFL (Focus 0) ['a'..'c'] +-- >>> lookupFL 0 fl +-- Just 'a' +-- +-- Returns 'Nothing' if the index is out of bounds. +-- +-- >>> let Just fl = fromListFL (Focus 0) ['a'..'c'] +-- >>> lookupFL 100 fl +-- Nothing +-- >>> lookupFL (-1) fl +-- Nothing +-- +-- Always returns 'Nothing' if the 'FocusList' is empty. +-- +-- prop> lookupFL i emptyFL == Nothing +-- +-- /complexity/: @O(log(min(i, n - i)))@ where @i@ is the index you want to look up, and @n@ +-- is the length of the 'FocusList'. +lookupFL + :: Int -- ^ Index to lookup. + -> FocusList a + -> Maybe a +lookupFL i fl = Sequence.lookup i (fl ^. lensFocusList) + +-- | Insert a new value into the 'FocusList'. The 'Focus' of the list is +-- changed appropriately. +-- +-- Inserting an element into an empty 'FocusList' will set the 'Focus' on +-- that element. +-- +-- >>> insertFL 0 "hello" emptyFL +-- FocusList (Focus 0) ["hello"] +-- +-- The 'Focus' will not be changed if you insert a new element after the +-- current 'Focus'. +-- +-- >>> insertFL 1 "hello" (singletonFL "bye") +-- FocusList (Focus 0) ["bye","hello"] +-- +-- The 'Focus' will be bumped up by one if you insert a new element before +-- the current 'Focus'. +-- +-- >>> insertFL 0 "hello" (singletonFL "bye") +-- FocusList (Focus 1) ["hello","bye"] +-- +-- Behaves like @Data.Sequence.'Data.Sequence.insertAt'@. If the index is out of bounds, it will be +-- inserted at the nearest available index +-- +-- >>> insertFL 100 "hello" emptyFL +-- FocusList (Focus 0) ["hello"] +-- +-- >>> insertFL 100 "bye" (singletonFL "hello") +-- FocusList (Focus 0) ["hello","bye"] +-- +-- >>> insertFL (-1) "bye" (singletonFL "hello") +-- FocusList (Focus 1) ["bye","hello"] +-- +-- /complexity/: @O(log(min(i, n - i)))@ where @i@ is the index you want to insert at, and @n@ +-- is the length of the 'FocusList'. +insertFL + :: Int -- ^ The index at which to insert the new element. + -> a -- ^ The new element. + -> FocusList a + -> FocusList a +insertFL _ a FocusList {focusListFocus = NoFocus} = singletonFL a +insertFL i a fl@FocusList{focusListFocus = Focus focus, focusList = fls} = + if i > focus + then + fl + { focusList = insertAt i a fls + } + else + fl + { focusList = insertAt i a fls + , focusListFocus = Focus $ focus + 1 + } + +-- | Remove an element from a 'FocusList'. +-- +-- If the element to remove is not the 'Focus', then update the 'Focus' +-- accordingly. +-- +-- For example, if the 'Focus' is on index 1, and we have removed index 2, then +-- the focus is not affected, so it is not changed. +-- +-- >>> let focusList = unsafeFromListFL (Focus 1) ["cat","goat","dog","hello"] +-- >>> removeFL 2 focusList +-- Just (FocusList (Focus 1) ["cat","goat","hello"]) +-- +-- If the 'Focus' is on index 2 and we have removed index 1, then the 'Focus' +-- will be moved back one element to set to index 1. +-- +-- >>> let focusList = unsafeFromListFL (Focus 2) ["cat","goat","dog","hello"] +-- >>> removeFL 1 focusList +-- Just (FocusList (Focus 1) ["cat","dog","hello"]) +-- +-- If we remove the 'Focus', then the next item is set to have the 'Focus'. +-- +-- >>> let focusList = unsafeFromListFL (Focus 0) ["cat","goat","dog","hello"] +-- >>> removeFL 0 focusList +-- Just (FocusList (Focus 0) ["goat","dog","hello"]) +-- +-- If the element to remove is the only element in the list, then the 'Focus' +-- will be set to 'NoFocus'. +-- +-- >>> let focusList = unsafeFromListFL (Focus 0) ["hello"] +-- >>> removeFL 0 focusList +-- Just (FocusList NoFocus []) +-- +-- If the 'Int' for the index to remove is either less than 0 or greater then +-- the length of the list, then 'Nothing' is returned. +-- +-- >>> let focusList = unsafeFromListFL (Focus 0) ["hello"] +-- >>> removeFL (-1) focusList +-- Nothing +-- +-- >>> let focusList = unsafeFromListFL (Focus 1) ["hello","bye","cat"] +-- >>> removeFL 3 focusList +-- Nothing +-- +-- If the 'FocusList' passed in is 'Empty', then 'Nothing' is returned. +-- +-- >>> removeFL 0 emptyFL +-- Nothing +-- +-- /complexity/: @O(log(min(i, n - i)))@ where @i@ is index of the element to remove, and @n@ +-- is the length of the 'FocusList'. +removeFL + :: Int -- ^ Index of the element to remove from the 'FocusList'. + -> FocusList a -- ^ The 'FocusList' to remove an element from. + -> Maybe (FocusList a) +removeFL i fl@FocusList{focusList = fls} + | i < 0 || i >= (lengthFL fl) || isEmptyFL fl = + -- Return Nothing if the removal position is out of bounds. + Nothing + | lengthFL fl == 1 = + -- Return an empty focus list if there is currently only one element + Just emptyFL + | otherwise = + let newFL = fl {focusList = deleteAt i fls} + focus = unsafeGetFocusFL fl + in + if focus >= i && focus /= 0 + then Just $ newFL & lensFocusListFocus . _Focus -~ 1 + else Just newFL + +-- | Find the index of the first element in the 'FocusList'. +-- +-- >>> let Just fl = fromListFL (Focus 1) ["hello", "bye", "tree"] +-- >>> indexOfFL "hello" fl +-- Just 0 +-- +-- If more than one element exists, then return the index of the first one. +-- +-- >>> let Just fl = fromListFL (Focus 1) ["dog", "cat", "cat"] +-- >>> indexOfFL "cat" fl +-- Just 1 +-- +-- If the element doesn't exist, then return 'Nothing' +-- +-- >>> let Just fl = fromListFL (Focus 1) ["foo", "bar", "baz"] +-- >>> indexOfFL "hogehoge" fl +-- Nothing +indexOfFL :: Eq a => a -> FocusList a -> Maybe Int +indexOfFL a FocusList{focusList = fls} = + elemIndexL a fls + +-- | Delete an element from a 'FocusList'. +-- +-- >>> let Just fl = fromListFL (Focus 0) ["hello", "bye", "tree"] +-- >>> deleteFL "bye" fl +-- FocusList (Focus 0) ["hello","tree"] +-- +-- The focus will be updated if an item before it is deleted. +-- +-- >>> let Just fl = fromListFL (Focus 1) ["hello", "bye", "tree"] +-- >>> deleteFL "hello" fl +-- FocusList (Focus 0) ["bye","tree"] +-- +-- If there are multiple matching elements in the 'FocusList', remove them all. +-- +-- >>> let Just fl = fromListFL (Focus 0) ["hello", "bye", "bye"] +-- >>> deleteFL "bye" fl +-- FocusList (Focus 0) ["hello"] +-- +-- If there are no matching elements, return the original 'FocusList'. +-- +-- >>> let Just fl = fromListFL (Focus 2) ["hello", "good", "bye"] +-- >>> deleteFL "frog" fl +-- FocusList (Focus 2) ["hello","good","bye"] +deleteFL + :: forall a. + (Eq a) + => a + -> FocusList a + -> FocusList a +deleteFL item = go + where + go :: FocusList a -> FocusList a + go fl = + let maybeIndex = indexOfFL item fl + in + case maybeIndex of + Nothing -> fl + Just i -> + let maybeNewFL = removeFL i fl + in + case maybeNewFL of + Nothing -> fl + Just newFL -> go newFL + +-- | Set the 'Focus' for a 'FocusList'. +-- +-- This is just like 'updateFocusFL', but doesn't return the newly focused item. +-- +-- prop> setFocusFL i fl == fmap snd (updateFocusFL i fl) +-- +-- /complexity/: @O(1)@ +setFocusFL :: Int -> FocusList a -> Maybe (FocusList a) +setFocusFL i fl + -- Can't set a 'Focus' for an empty 'FocusList'. + | isEmptyFL fl = Nothing + | otherwise = + let len = lengthFL fl + in + if i < 0 || i >= len + then Nothing + else Just $ fl & lensFocusListFocus . _Focus .~ i + +-- | Update the 'Focus' for a 'FocusList' and get the new focused element. +-- +-- >>> updateFocusFL 1 =<< fromListFL (Focus 2) ["hello","bye","dog","cat"] +-- Just ("bye",FocusList (Focus 1) ["hello","bye","dog","cat"]) +-- +-- If the 'FocusList' is empty, then return 'Nothing'. +-- +-- >>> updateFocusFL 1 emptyFL +-- Nothing +-- +-- If the new focus is less than 0, or greater than or equal to the length of +-- the 'FocusList', then return 'Nothing'. +-- +-- >>> updateFocusFL (-1) =<< fromListFL (Focus 2) ["hello","bye","dog","cat"] +-- Nothing +-- +-- >>> updateFocusFL 4 =<< fromListFL (Focus 2) ["hello","bye","dog","cat"] +-- Nothing +-- +-- /complexity/: @O(log(min(i, n - i)))@ where @i@ is the new index to put the 'Focus' on, +-- and @n@ -- is the length of the 'FocusList'. +updateFocusFL + :: Int -- ^ The new index to put the 'Focus' on. + -> FocusList a + -> Maybe (a, FocusList a) + -- ^ A tuple of the new element that gets the 'Focus', and the new + -- 'FocusList'. +updateFocusFL i fl + | isEmptyFL fl = Nothing + | otherwise = + let len = lengthFL fl + in + if i < 0 || i >= len + then Nothing + else + let newFL = fl & lensFocusListFocus . _Focus .~ i + in Just (unsafeGetFocusItemFL newFL, newFL) + +-- | Find a value in a 'FocusList'. Similar to @Data.List.'Data.List.find'@. +-- +-- >>> let Just fl = fromListFL (Focus 1) ["hello", "bye", "tree"] +-- >>> findFL (\a -> a == "hello") fl +-- Just "hello" +-- +-- This will only find the first value. +-- +-- >>> let Just fl = fromListFL (Focus 0) ["hello", "bye", "bye"] +-- >>> findFL (\a -> a == "bye") fl +-- Just "bye" +-- +-- If no values match the comparison, this will return 'Nothing'. +-- +-- >>> let Just fl = fromListFL (Focus 1) ["hello", "bye", "parrot"] +-- >>> findFL (\a -> a == "ball") fl +-- Nothing +-- +-- /complexity/: @O(n)@ where @n@ is the length of the 'FocusList'. +findFL :: (a -> Bool) -> FocusList a -> Maybe (a) +findFL p fl = + let fls = fl ^. lensFocusList + in find p fls + +-- | Move an existing item in a 'FocusList' to a new index. +-- +-- The 'Focus' gets updated appropriately when moving items. +-- +-- >>> let Just fl = fromListFL (Focus 1) ["hello", "bye", "parrot"] +-- >>> moveFromToFL 0 1 fl +-- Just (FocusList (Focus 0) ["bye","hello","parrot"]) +-- +-- The 'Focus' may not get updated if it is not involved. +-- +-- >>> let Just fl = fromListFL (Focus 0) ["hello", "bye", "parrot"] +-- >>> moveFromToFL 1 2 fl +-- Just (FocusList (Focus 0) ["hello","parrot","bye"]) +-- +-- If the element with the 'Focus' is moved, then the 'Focus' will be updated +-- appropriately. +-- +-- >>> let Just fl = fromListFL (Focus 2) ["hello", "bye", "parrot"] +-- >>> moveFromToFL 2 0 fl +-- Just (FocusList (Focus 0) ["parrot","hello","bye"]) +-- +-- If the index of the item to move is out bounds, then 'Nothing' will be returned. +-- +-- >>> let Just fl = fromListFL (Focus 2) ["hello", "bye", "parrot"] +-- >>> moveFromToFL 3 0 fl +-- Nothing +-- +-- If the new index is out of bounds, then 'Nothing' wil be returned. +-- +-- >>> let Just fl = fromListFL (Focus 2) ["hello", "bye", "parrot"] +-- >>> moveFromToFL 1 (-1) fl +-- Nothing +-- +-- /complexity/: @O(log n)@ where @n@ is the length of the 'FocusList'. +moveFromToFL + :: Show a + => Int -- ^ Index of the item to move. + -> Int -- ^ New index for the item. + -> FocusList a + -> Maybe (FocusList a) +moveFromToFL oldPos newPos fl + | oldPos < 0 || oldPos >= length fl = Nothing + | newPos < 0 || newPos >= length fl = Nothing + | otherwise = + let oldFocus = fl ^. lensFocusListFocus + in + case lookupFL oldPos fl of + Nothing -> error "moveFromToFL should have been able to lookup the item" + Just item -> + case removeFL oldPos fl of + Nothing -> error "moveFromToFL should have been able to remove old position" + Just flAfterRemove -> + let flAfterInsert = insertFL newPos item flAfterRemove in + if Focus oldPos == oldFocus + then + case setFocusFL newPos flAfterInsert of + Nothing -> error "moveFromToFL should have been able to reset the focus" + Just flWithUpdatedFocus -> Just flWithUpdatedFocus + else Just flAfterInsert + +-- | Intersperse a new element between existing elements in the 'FocusList'. +-- +-- >>> let Just fl = fromListFL (Focus 0) ["hello", "bye", "cat"] +-- >>> intersperseFL "foo" fl +-- FocusList (Focus 0) ["hello","foo","bye","foo","cat"] +-- +-- The 'Focus' is updated accordingly. +-- +-- >>> let Just fl = fromListFL (Focus 2) ["hello", "bye", "cat", "goat"] +-- >>> intersperseFL "foo" fl +-- FocusList (Focus 4) ["hello","foo","bye","foo","cat","foo","goat"] +-- +-- The item with the 'Focus' should never change after calling 'intersperseFL'. +-- +-- prop> getFocusItemFL (fl :: FocusList Int) == getFocusItemFL (intersperseFL a fl) +-- +-- 'intersperseFL' should not have any effect on a 'FocusList' with less than +-- two items. +-- +-- prop> emptyFL == intersperseFL x emptyFL +-- prop> singletonFL a == intersperseFL x (singletonFL a) +-- +-- /complexity/: @O(n)@ where @n@ is the length of the 'FocusList'. +intersperseFL :: a -> FocusList a -> FocusList a +intersperseFL _ FocusList{focusListFocus = NoFocus} = emptyFL +intersperseFL a FocusList{focusList = fls, focusListFocus = Focus foc} = + let newFLS = intersperse a fls + in + FocusList + { focusList = newFLS + , focusListFocus = Focus (foc * 2) + } + +-- | Reverse a 'FocusList'. The 'Focus' is updated accordingly. +-- +-- >>> let Just fl = fromListFL (Focus 0) ["hello", "bye", "cat"] +-- >>> reverseFL fl +-- FocusList (Focus 2) ["cat","bye","hello"] +-- +-- >>> let Just fl = fromListFL (Focus 2) ["hello", "bye", "cat", "goat"] +-- >>> reverseFL fl +-- FocusList (Focus 1) ["goat","cat","bye","hello"] +-- +-- The item with the 'Focus' should never change after calling 'intersperseFL'. +-- +-- prop> getFocusItemFL (fl :: FocusList Int) == getFocusItemFL (reverseFL fl) +-- +-- Reversing twice should not change anything. +-- +-- prop> (fl :: FocusList Int) == reverseFL (reverseFL fl) +-- +-- Reversing empty lists and single lists should not do anything. +-- +-- prop> emptyFL == reverseFL emptyFL +-- prop> singletonFL a == reverseFL (singletonFL a) +-- +-- /complexity/: @O(n)@ where @n@ is the length of the 'FocusList'. +reverseFL :: FocusList a -> FocusList a +reverseFL FocusList{focusListFocus = NoFocus} = emptyFL +reverseFL FocusList{focusList = fls, focusListFocus = Focus foc} = + let newFLS = reverse fls + newFLSLen = length newFLS + in + FocusList + { focusList = newFLS + , focusListFocus = Focus (newFLSLen - foc - 1) + } + +-- | Sort a 'FocusList'. +-- +-- The 'Focus' will stay with the element that has the 'Focus'. +-- +-- >>> let Just fl = fromListFL (Focus 2) ["b", "c", "a"] +-- >>> sortByFL compare fl +-- FocusList (Focus 0) ["a","b","c"] +-- +-- Nothing will happen if you try to sort an empty 'FocusList', or a +-- 'FocusList' with only one element. +-- +-- prop> emptyFL == sortByFL compare emptyFL +-- prop> singletonFL a == sortByFL compare (singletonFL a) +-- +-- The element with the 'Focus' should be the same before and after sorting. +-- +-- prop> getFocusItemFL (fl :: FocusList Int) == getFocusItemFL (sortByFL compare fl) +-- +-- Sorting a 'FocusList' and getting the underlying 'Seq' should be the same as +-- getting the underlying 'Seq' and then sorting it. +-- +-- prop> toSeqFL (sortByFL compare (fl :: FocusList Int)) == sortBy compare (toSeqFL fl) +-- +-- __WARNING__: The computational complexity for this is very bad. It should be +-- able to be done in @O(n * log n)@, but the current implementation is +-- @O(n^2)@ (or worse), where @n@ is the length of the 'FocusList'. This +-- function could be implemented the same way +-- @Data.Sequence.'Data.Sequence.sortBy'@ is implemented. However, a small +-- change needs to be added to that function to keep track of the 'Focus' in +-- the 'FocusList' and make sure it gets updated properly. If you're +-- interested in fixing this, please send a PR. +sortByFL + :: forall a + . (a -> a -> Ordering) -- ^ The function to use to compare elements. + -> FocusList a + -> FocusList a +sortByFL _ FocusList{focusListFocus = NoFocus} = emptyFL +sortByFL cmpFunc FocusList{focusList = fls, focusListFocus = Focus foc} = + let (res, maybeNewFoc) = go fls (Just foc) + in + case maybeNewFoc of + Nothing -> error "sortByFL: A sequence should never lose its focus." + Just newFoc -> + FocusList + { focusList = res + , focusListFocus = Focus newFoc + } + where + go + :: Seq a -- ^ The sequence that needs to be sorted. + -> Maybe Int + -- ^ Whether or not we are tracking a 'Focus' that needs to be updated. + -> (Seq a, Maybe Int) + -- Trying to sort an empty sequence with a 'Focus'. This should never happen. + go Empty (Just _) = + error "sortByFL: go: this should never happen, sort empty with focus." + -- Trying to sort an empty sequence. + go Empty Nothing = (Empty, Nothing) + -- Trying to sort a non-empty sequence with no focus. + go (a :<| as) Nothing = + let res = go as Nothing + in + case res of + (_, Just _) -> error "sortByFL: go: this should never happen, no focus case" + (Empty, Nothing) -> (a :<| Empty, Nothing) + (b :<| bs, Nothing) -> + case cmpFunc a b of + LT -> (a :<| b :<| bs, Nothing) + EQ -> (a :<| b :<| bs, Nothing) + GT -> (b :<| fst (go (a :<| bs) Nothing), Nothing) + -- Trying to sort a non-empty sequence with the top element having the focus. + go (a :<| as) (Just 0) = + let res = go as Nothing + in + case res of + (_, Just _) -> error "sortByFL: go: this should never happen, top elem has focus case" + (Empty, Nothing) -> (a :<| Empty, Just 0) + (b :<| bs, Nothing) -> + case cmpFunc a b of + LT -> (a :<| b :<| bs, Just 0) + EQ -> (a :<| b :<| bs, Just 0) + GT -> + let (newSeq, maybeNewFoc) = go (a :<| bs) (Just 0) + in + case maybeNewFoc of + Nothing -> error "sortByFL: go: this should never happen, lost the focus" + Just newFoc -> (b :<| newSeq, Just (newFoc + 1)) + -- Trying to sort a non-empty sequence where some element other than the + -- top element has the focus. + go (a :<| as) (Just n) = + let res = go as (Just (n - 1)) + in + case res of + (_, Nothing) -> error "sortByFL: go: this should never happen, no focus" + (Empty, Just _) -> error "sortByFL: go: this should never happen, focus but no elems" + (b :<| bs, Just newFoc) -> + case cmpFunc a b of + LT -> (a :<| b :<| bs, Just (newFoc + 1)) + EQ -> (a :<| b :<| bs, Just (newFoc + 1)) + GT -> + case newFoc of + 0 -> (b :<| fst (go (a :<| bs) Nothing), Just 0) + gt0 -> + let (newSeq, maybeNewFoc') = go (a :<| bs) (Just gt0) + in + case maybeNewFoc' of + Nothing -> error "sortByFL: go: this should never happen, lost the focus again" + Just newFoc' -> (b :<| newSeq, Just (newFoc' + 1)) diff --git a/test/DocTest.hs b/test/DocTest.hs new file mode 100644 --- /dev/null +++ b/test/DocTest.hs @@ -0,0 +1,12 @@ + +module Main where + +import Build_doctests (flags, pkgs, module_sources) +import Test.DocTest (doctest) + +main :: IO () +main = do + doctest args + where + args :: [String] + args = flags ++ pkgs ++ module_sources diff --git a/test/Test.hs b/test/Test.hs new file mode 100644 --- /dev/null +++ b/test/Test.hs @@ -0,0 +1,20 @@ + +module Main where + +import Test.Tasty (TestTree, defaultMain, testGroup) + +import Test.FocusList (focusListTestsIO) + +main :: IO () +main = do + tests <- testsIO + defaultMain tests + +testsIO :: IO TestTree +testsIO = do + focusListTests <- focusListTestsIO + pure $ + testGroup + "tests" + [ focusListTests + ] diff --git a/test/Test/FocusList.hs b/test/Test/FocusList.hs new file mode 100644 --- /dev/null +++ b/test/Test/FocusList.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE TypeApplications #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Test.FocusList where + +import Data.GenValidity.Sequence () +import Test.QuickCheck (Gen) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.Hedgehog (testProperty) +import Test.Tasty.Hspec (Spec, testSpec) +import Test.Validity (GenInvalid, GenUnchecked, GenValid(genValid), Validity(validate), check, eqSpec, genValidSpec) + +import Data.FocusList (Focus, FocusList, genValidFL, invariantFL) + +import Test.FocusList.Invariants (testInvariantsInFocusList) + +instance GenUnchecked Focus + +instance GenUnchecked a => GenUnchecked (FocusList a) + +instance Validity (FocusList a) where + validate fl = check (invariantFL fl) "the FocusList has been constructed correctly" + +instance GenValid a => GenValid (FocusList a) where + genValid :: Gen (FocusList a) + genValid = genValidFL genValid + +instance GenInvalid a => GenInvalid (FocusList a) + +focusListTestsIO :: IO TestTree +focusListTestsIO = do + specs <- testSpec "validity tests" validitySpec + pure $ + testGroup + "FocusList" + [ testProperty "invariants in FocusList" testInvariantsInFocusList + , specs + ] + +validitySpec :: Spec +validitySpec = do + eqSpec @(FocusList String) + genValidSpec @(FocusList String) diff --git a/test/Test/FocusList/Invariants.hs b/test/Test/FocusList/Invariants.hs new file mode 100644 --- /dev/null +++ b/test/Test/FocusList/Invariants.hs @@ -0,0 +1,129 @@ + +module Test.FocusList.Invariants where + +import Data.Maybe (catMaybes) +import Hedgehog + ( Gen + , Property + , PropertyT + , annotate + , annotateShow + , failure + , forAll + , property + , success + ) +import Hedgehog.Gen (alphaNum, choice, int, string) +import Hedgehog.Range (constant, linear) + +import Data.FocusList + ( FocusList + , deleteFL + , emptyFL + , insertFL + , invariantFL + , isEmptyFL + , lengthFL + , lookupFL + , removeFL + ) + +testInvariantsInFocusList :: Property +testInvariantsInFocusList = + property $ do + numOfActions <- forAll $ int (linear 1 200) + let initialState = emptyFL + let strGen = string (constant 0 25) alphaNum + -- traceM "----------------------------------" + -- traceM $ "starting bar, numOfActions: " <> show numOfActions + runActions numOfActions strGen initialState + +data Action a + = InsertFL Int a + | RemoveFL Int + | DeleteFL a + deriving (Eq, Show) + +genInsertFL :: Gen a -> FocusList a -> Maybe (Gen (Action a)) +genInsertFL valGen fl + | isEmptyFL fl = Just $ do + val <- valGen + pure $ InsertFL 0 val + | otherwise = Just $ do + let len = lengthFL fl + key <- int $ constant 0 len + val <- valGen + pure $ InsertFL key val + +genRemoveFL :: FocusList a -> Maybe (Gen (Action a)) +genRemoveFL fl + | isEmptyFL fl = Nothing + | otherwise = Just $ do + let len = lengthFL fl + keyToRemove <- int $ constant 0 (len - 1) + pure $ RemoveFL keyToRemove + +genDeleteFL :: Show a => FocusList a -> Maybe (Gen (Action a)) +genDeleteFL fl + | isEmptyFL fl = Nothing + | otherwise = Just $ do + let len = lengthFL fl + keyForItemToDelete <- int $ constant 0 (len - 1) + let maybeItemToDelete = lookupFL keyForItemToDelete fl + case maybeItemToDelete of + Nothing -> + let msg = + "Could not find item in focuslist even though " <> + "it should be there." <> + "\nkey: " <> + show keyForItemToDelete <> + "\nfocus list: " <> + show fl + in error msg + Just item -> pure $ DeleteFL item + +generateAction :: Show a => Gen a -> FocusList a -> Gen (Action a) +generateAction valGen fl = do + let generators = + catMaybes + [ genInsertFL valGen fl + , genRemoveFL fl + , genDeleteFL fl + ] + case generators of + [] -> + let msg = + "No generators available for fl:\n" <> + show fl + in error msg + _ -> do + choice generators + +performAction :: Eq a => FocusList a -> Action a -> Maybe (FocusList a) +performAction fl (InsertFL key val) = Just $ insertFL key val fl +performAction fl (RemoveFL keyToRemove) = removeFL keyToRemove fl +performAction fl (DeleteFL valToDelete) = Just $ deleteFL valToDelete fl + +runActions :: (Eq a, Monad m, Show a) => Int -> Gen a -> FocusList a -> PropertyT m () +runActions i valGen startingFL + | i <= 0 = success + | otherwise = do + action <- forAll $ generateAction valGen startingFL + -- traceM $ "runActions, startingFL: " <> show startingFL + -- traceM $ "runActions, action: " <> show action + let maybeEndingFL = performAction startingFL action + case maybeEndingFL of + Nothing -> do + annotate "Failed to perform action." + annotateShow startingFL + annotateShow action + failure + Just endingFL -> + if invariantFL endingFL + then runActions (i - 1) valGen endingFL + else do + annotate "Ending FocusList failed invariants." + annotateShow startingFL + annotateShow action + annotateShow endingFL + failure diff --git a/test/readme/README.lhs b/test/readme/README.lhs new file mode 100644 --- /dev/null +++ b/test/readme/README.lhs @@ -0,0 +1,79 @@ +FocusList +========= + +[![Build Status](https://secure.travis-ci.org/cdepillabout/focuslist.svg)](http://travis-ci.org/cdepillabout/focuslist) +[![Hackage](https://img.shields.io/hackage/v/focuslist.svg)](https://hackage.haskell.org/package/focuslist) +[![Stackage LTS](http://stackage.org/package/focuslist/badge/lts)](http://stackage.org/lts/package/focuslist) +[![Stackage Nightly](http://stackage.org/package/focuslist/badge/nightly)](http://stackage.org/nightly/package/focuslist) +[![BSD3 license](https://img.shields.io/badge/license-BSD3-blue.svg)](./LICENSE) + +A `FocusList` is a sequence of elements which has one element as its `Focus`. It +supports quick insertion and indexing by its implementation with +[`Seq`](http://hackage.haskell.org/package/containers-0.6.0.1/docs/Data-Sequence.html#t:Seq). + +## Example + +Here is a short example of using `FocusList`. + +```haskell +module Main where + +import Data.FocusList + ( Focus(Focus), FocusList, appendFL, fromListFL, getFocusItemFL, prependFL + , singletonFL + ) +import Data.Foldable (toList) + +-- | Create a new 'FocusList' from a list. You must set the 'Focus' of the new +-- 'FocusList'. The 'Focus' is counting from zero, so the @goat@ element should +-- have the 'Focus'. +-- +-- If you try to specify a 'Focus' out of range from the input list, +-- 'fromListFL' will return 'Nothing'. +myFocusList :: Maybe (FocusList String) +myFocusList = fromListFL (Focus 2) ["hello", "bye", "goat", "dog"] + +-- | You can get the focused element from an existing 'FocusList' +-- +-- If the 'FocusList' is empty, this returns 'Nothing'. +myFocusElement :: FocusList String -> Maybe String +myFocusElement focuslist = getFocusItemFL focuslist + +-- | You can append to either side of a 'FocusList'. +-- +-- 'singletonFL' creates a 'FocusList' with a single element. +-- That single element will have the 'Focus'. +-- +-- 'myFocusListAppended' will have a value of +-- @FocusList (Focus 1) ["bye", "hello", "foobar"]@ +myFocusListAppended :: FocusList String +myFocusListAppended = + prependFL "bye" (appendFL (singletonFL "hello") "foobar") + +-- | 'FocusList' is an instance of 'Functor' and 'Foldable', so you can use +-- functions like 'fmap' and 'toList' on a 'FocusList'. +fmapAndConvertToList :: FocusList Int -> [String] +fmapAndConvertToList focuslist = toList (fmap show focuslist) + +main :: IO () +main = do + putStrLn "myFocusList:" + print myFocusList + + putStrLn "\nmyFocusListAppended:" + print myFocusListAppended + + putStrLn "\nmyFocusElement myFocusListAppended:" + print (myFocusElement myFocusListAppended) + + putStrLn "\nfmap length myFocusListAppended:" + print (fmap length myFocusListAppended) + + putStrLn "\nfmapAndConvertToList (fmap length myFocusListAppended):" + print (fmapAndConvertToList (fmap length myFocusListAppended)) +``` + +## Maintainers + +- [Grendel-Grendel-Grendel](https://github.com/Grendel-Grendel-Grendel) +- [cdepillabout](https://github.com/cdepillabout)