diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,7 @@ +# Changelog for rg + +## Unreleased changes + + * 1.0.0.0: first release + * 1.1.0.0: add RgText, BE derivation + - 1.2.0.0: first public release diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Chris Dornan (c) 2019 + +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 Chris Dornan 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,3 @@ +# rg + +A package for dynamic/unbounded Haskell enumerations. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/rg.cabal b/rg.cabal new file mode 100644 --- /dev/null +++ b/rg.cabal @@ -0,0 +1,67 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.31.1. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: 527175fcfe23d40d0a87e869a4613c10ea692ae5c67e26c181bae7d7f71687ee + +name: rg +version: 1.2.0.0 +synopsis: A dynamic/unbounded alternative to Bounded Enum +description: Please see the README on GitHub at +category: Types +homepage: https://github.com/cdornan/rg#readme +bug-reports: https://github.com/cdornan/rg/issues +author: Chris Dornan +maintainer: chris.dornan@irisconnect.co.uk +copyright: 2019 Chris Dornan +license: BSD3 +license-file: LICENSE +build-type: Simple +extra-source-files: + README.md + ChangeLog.md + +source-repository head + type: git + location: https://github.com/cdornan/rg + +library + exposed-modules: + Data.Rg + other-modules: + Paths_rg + hs-source-dirs: + src + ghc-options: -Wall -Wcompat + build-depends: + array + , base >=4.10 && <5 + , fmt >=0.4.0.0 + , possibly + , text + , unordered-containers + , vector + default-language: Haskell2010 + +test-suite nike-test + type: exitcode-stdio-1.0 + main-is: test.hs + other-modules: + Paths_rg + hs-source-dirs: + test + ghc-options: -Wall -Wcompat -with-rtsopts "-T -N -qg -qb -H1024m -I0" -threaded -rtsopts + build-depends: + array + , base >=4.10 && <5 + , fmt >=0.4.0.0 + , possibly + , rg + , tasty + , tasty-hunit + , text + , unordered-containers + , vector + default-language: Haskell2010 diff --git a/src/Data/Rg.hs b/src/Data/Rg.hs new file mode 100644 --- /dev/null +++ b/src/Data/Rg.hs @@ -0,0 +1,162 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module Data.Rg + ( Rg(..) + , RgText(..) + , BE(..) + , Range + , newStartOfRangeFromList + , newStartOfRangeFromVector + , extractRange + ) where + +import Data.Array +import qualified Data.HashMap.Strict as HM +import Data.Maybe +import Data.Possibly +import qualified Data.Text as T +import qualified Data.Vector as V +import Fmt + + +-- | Rg acts a bit like a Bounded Enum, but the size of the enumeration +-- can be dynamically determined from each value in the type (see 'sizeRg') +class Rg rg where + -- | the number of values in the enumeration; sizeRg sz > 0 + sizeRg :: rg -> Int + + -- | the nth item in the enumeration (first is 0) + toRg :: rg -> Int -> Maybe rg + + -- | place in the enumation (first is 0) + fromRg :: rg -> Int + + -- | first item in the enumeration + minRg :: rg -> rg + minRg = fromMaybe oops . flip toRg 0 + where + oops = error "minRg: no minimum value in range" + + -- | last item in the enumeration + maxRg :: rg -> rg + maxRg rg = fromMaybe oops $ toRg rg n + where + n = sizeRg rg - 1 + oops = error "maxRg: no maximum value in range" + + -- | next item in the enumeration (Nothing if already last) + succRg :: rg -> Maybe rg + succRg rg = toRg rg $ fromRg rg + 1 + + -- | previous item in the enumeration (Nothing if already first) + predRg :: rg -> Maybe rg + predRg rg = toRg rg $ fromRg rg - 1 + + -- | list given items in the enumeration + allListRg :: rg -> [rg] + allListRg rg = listRg rg [0..] + + -- | list given items in the enumeration, stopping as soon as an index is + -- out of range + listRg :: rg -> [Int] -> [rg] + listRg rg is = catMaybes $ takeWhile isJust [ toRg rg i | i<-is ] + + -- | list given items in the enumeration as a 'V.Vector' + allVectorRg :: rg -> [rg] + allVectorRg rg = listRg rg [0..] + + -- | list the items in the enumeration as a 'V.Vector', stopping as soon as an + -- index is out of range + vectorRg :: rg -> [Int] -> V.Vector rg + vectorRg rg is = V.fromList $ listRg rg is + + +------------------------------------------------------------------------------- +-- class RgText +------------------------------------------------------------------------------- + +-- | a class in which we can build things and parse them from 'T.Text' +class (Rg e, Buildable e, Eq e, Ord e, Show e) => RgText e where + parseRgText :: e -> T.Text -> Possibly e + parseRgText e txt = maybe (Left msg) Right $ HM.lookup txt $ hashmap_t e + where + msg = "parseRgText: enumeration not recognised: "++show txt + + +------------------------------------------------------------------------------- +-- newtype BE +------------------------------------------------------------------------------- + +-- | a @newtype@ wrapper used for deriving 'Rg' instances from 'Bounded' 'Enum' +newtype BE a = BE { _BE :: a } + deriving (Eq,Ord,Bounded,Enum,Show) + +instance (Bounded i,Enum i) => Rg (BE i) where + sizeRg be = (1 +) $ fromEnum $ maxBound `asTypeOf` _BE be + + toRg be i = case 0 <= i && i < sizeRg be of + True -> Just $ BE $ toEnum i + False -> Nothing + + fromRg = fromEnum . _BE + + +------------------------------------------------------------------------------- +-- data Range +------------------------------------------------------------------------------- + +-- | used to generate 'Rg' values from lists of things +data Range a = + Range + { _rg_size :: Int -- ^ number of items in enumeration (derivable from Array) + , _rg_elem :: Int -- ^ position in the enumeration of this element + , _rg_array :: Array Int a -- ^ all of the elements of the enumeration + } + deriving (Show) + +instance Rg (Range a) where + sizeRg = _rg_size + toRg rg i = case 0 <= i && i < _rg_size rg of + False -> Nothing + True -> Just rg { _rg_elem = i } + fromRg = _rg_elem + +-- | generating a 'Range' from a list +newStartOfRangeFromList :: [a] -> Range a +newStartOfRangeFromList xs = + Range + { _rg_size = sz + , _rg_elem = 0 + , _rg_array = listArray (0,sz-1) xs + } + where + sz = length xs + +-- | generating a 'Range' from a 'V.Vector' +newStartOfRangeFromVector :: V.Vector a -> Range a +newStartOfRangeFromVector v = + Range + { _rg_size = sz + , _rg_elem = 0 + , _rg_array = listArray (0,sz-1) $ V.toList v + } + where + sz = V.length v + +-- | extracting the thing +extractRange :: Range a -> a +extractRange Range{..} = _rg_array ! _rg_elem + + +------------------------------------------------------------------------------- +-- hashmap_t +------------------------------------------------------------------------------- + +-- | 'T.Text' 'HM.HashMap' based on 'renderEnumText' representation +hashmap_t :: RgText e => e -> HM.HashMap T.Text e +hashmap_t x = HM.fromList + [ (fmt $ build c,c) + | c <- allListRg x + ] diff --git a/test/test.hs b/test/test.hs new file mode 100644 --- /dev/null +++ b/test/test.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Main (main) where + +import Data.Rg +import Fmt +import Test.Tasty +import Test.Tasty.HUnit + + +main :: IO () +main = defaultMain $ + testGroup "rg" $ + [ testGroup "Range" + [ testCase "sizeRg" $ 10 @=? sizeRg tst + , testCase "allListRg" $ [10,9..1] @=? map extractRange (allListRg tst) + , testCase "predRg" $ Nothing @=? (extractRange <$> predRg tst) + , testCase "predRg . maxRg" $ Just 2 @=? (extractRange <$> predRg (maxRg tst)) + , testCase "succRg" $ Just 9 @=? (extractRange <$> succRg tst) + , testCase "extractRange" $ 10 @=? extractRange tst + , testCase "minRg" $ 10 @=? extractRange (minRg tst) + , testCase "maxRg" $ 1 @=? extractRange (maxRg tst) + , testCase "extractRange" $ 1 @=? extractRange (maxRg tst) + , testCase "fromRg" $ 0 @=? fromRg tst + , testCase "minRg" $ 0 @=? fromRg (minRg tst) + , testCase "maxRg" $ 9 @=? fromRg (maxRg tst) + , testCase "toRg" $ Just 5 @=? (fromRg <$> toRg tst 5) + ] + , testGroup "BE" + [ testCase "sizeRg True" $ 2 @=? sizeRg (BE True ) + , testCase "sizeRg False" $ 2 @=? sizeRg (BE False) + , testCase "toRg 0" $ Just (BE False) @=? toRg (BE False) 0 + , testCase "toRg 1" $ Just (BE True ) @=? toRg (BE False) 1 + , testCase "toRg 3" $ Nothing @=? toRg (BE False) 2 + , testCase "allListRg" $ [BE False,BE True] @=? allListRg (BE False) + , testCase "fromRg False" $ 0 @=? fromRg (BE False) + , testCase "fromRg True" $ 1 @=? fromRg (BE True ) + ] + , testGroup "RgText" + [ testCase "TRUE" $ Right (BE True ) @=? parseRgText (BE False) "TRUE" + , testCase "FALSE" $ Right (BE False) @=? parseRgText (BE True ) "FALSE" + , testCase "true" $ Left msg @=? parseRgText (BE False) "false" + ] + ] + where + tst :: Range Int + tst = newStartOfRangeFromList [10,9..1] + + msg :: String + msg = "parseRgText: enumeration not recognised: \"false\"" + +instance RgText (BE Bool) + +instance Buildable (BE Bool) where + build (BE True) = "TRUE" + build (BE False) = "FALSE"