never executed always true always false

    1 module HelVM.HelIO.Collections.MapList where
    2 
    3 import           HelVM.HelIO.Containers.LLIndexSafe
    4 import           HelVM.HelIO.Containers.LLInsertDef
    5 import           HelVM.HelIO.Control.Safe
    6 
    7 import           Control.Monad.Extra
    8 
    9 import           Data.Default
   10 
   11 import qualified Data.IntMap                        as IntMap
   12 import qualified Data.List.Index                    as List
   13 import qualified Data.ListLike                      as LL
   14 import qualified GHC.Exts                           as I (IsList (..))
   15 import qualified Text.Show
   16 
   17 -- | Construction
   18 mapListEmpty :: MapList a
   19 mapListEmpty = mapListFromList []
   20 
   21 mapListFromList :: [a] -> MapList a
   22 mapListFromList = fromIndexedList <$> List.indexed
   23 
   24 fromIndexedList :: IndexedList a -> MapList a
   25 fromIndexedList = fromIntMap <$> IntMap.fromList
   26 
   27 fromIntMap :: IntMap a -> MapList a
   28 fromIntMap = MapList
   29 
   30 -- | DeConstruction
   31 mapListToList :: Default a => MapList a -> [a]
   32 mapListToList = listFromDescList <$> toDescList
   33 
   34 toDescList :: MapList a -> IndexedList a
   35 toDescList = IntMap.toDescList <$> unMapList
   36 
   37 -- | Internal function
   38 listFromDescList :: Default a => IndexedList a -> [a]
   39 listFromDescList = loop act <$> ([] , ) where
   40   act :: Default a => AccWithIndexedList a -> Either (AccWithIndexedList a) [a]
   41   act (acc , []                        ) = Right acc
   42   act (acc , [(i , v)]                 ) = Right $ consDef i $ v : acc
   43   act (acc , (i1 , v1) : (i2 , v2) : l ) = Left (consDef (i1 - i2 - 1) $ v1 : acc , (i2 , v2) : l)
   44 
   45 consDef :: Default a => Key -> [a] -> [a]
   46 consDef i l = (check <$> compare i) 0 where
   47   check LT = error "MapList.consDef index is negative"
   48   check EQ = l
   49   check GT = consDef (i - 1) (def : l)
   50 
   51 -- | Types
   52 type AccWithIndexedList a = ([a] , IndexedList a)
   53 type Key = IntMap.Key
   54 type IndexedList a = [(Key , a)]
   55 type MapString = MapList Char
   56 
   57 newtype MapList a = MapList {unMapList :: IntMap a}
   58   deriving stock (Eq , Ord, Read)
   59   deriving newtype (Semigroup , Monoid)
   60 
   61 -- | Standard instances
   62 instance (Default a , Show a) => Show (MapList a) where
   63   show = show <$> I.toList
   64 
   65 instance IsString MapString where
   66   fromString = mapListFromList
   67 
   68 instance Default a => IsList (MapList a) where
   69   type (Item (MapList a)) = a
   70   toList      = mapListToList
   71   fromList    = mapListFromList
   72   fromListN n = mapListFromList <$> fromListN n
   73 
   74 -- | ListLike instances
   75 instance Default a => LL.FoldableLL (MapList a) a where
   76   foldl f b = IntMap.foldl f b <$> unMapList
   77   foldr f b = IntMap.foldr f b <$> unMapList
   78 
   79 -- | My instances
   80 instance {-# OVERLAPPING #-} IndexSafe (MapList a) a where
   81   findWithDefault e i = IntMap.findWithDefault e i <$> unMapList
   82   findMaybe    = mapListFindMaybe
   83   indexMaybe   = mapListIndexMaybe
   84   findSafe   i = liftMaybeOrError "MapList.findSafe: index is not correct" <$> mapListFindMaybe i
   85   indexSafe  l = liftMaybeOrError "MapList.LLIndexSafe: index is not correct" <$> mapListIndexMaybe l
   86 
   87 instance InsertDef (MapList a) a where
   88   insertDef i e = fromIntMap <$> IntMap.insert i e <$> unMapList
   89 
   90 -- | Internal functions
   91 mapListFindMaybe :: Key -> MapList a -> Maybe a
   92 mapListFindMaybe  i   = IntMap.lookup i <$> unMapList
   93 
   94 mapListIndexMaybe :: MapList a -> Key -> Maybe a
   95 mapListIndexMaybe l i = unMapList l IntMap.!? i