github/semantic
1
1
Fork 0
mirror of https://github.com/github/semantic.git synced 2024-12-21 13:51:44 +03:00
Code Issues Projects Releases Wiki Activity

Define a fromListWith constructor.

Browse Source
This commit is contained in:
Rob Rix 2017-08-31 22:56:18 -04:00
parent f1b406fc16
commit aede0519c5
1 changed files with 12 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
src/Data/Syntax/Assignment/Table/Array.hs
View File

@ -1,11 +1,16 @@
module Data.Syntax.Assignment.Table.Array module Data.Syntax.Assignment.Table.Array
( Table(tableAddresses) ( Table(tableAddresses)
, singleton , singleton
, fromListWith
) where ) where
import Control.Arrow ((&&&))
import Data.Array import Data.Array
import Data.Foldable (toList) import Data.Foldable (toList)
import Data.Functor.Classes import Data.Functor.Classes
import Data.List.NonEmpty (NonEmpty(..))
import Data.Semigroup (Max(..), Min(..), sconcat)
import GHC.Stack
data Table i a = Table { tableAddresses :: [i], tableBranches :: Array i (Maybe a) } data Table i a = Table { tableAddresses :: [i], tableBranches :: Array i (Maybe a) }
deriving (Foldable, Functor, Traversable) deriving (Foldable, Functor, Traversable)
@ -13,6 +18,13 @@ data Table i a = Table { tableAddresses :: [i], tableBranches :: Array i (Maybe
singleton :: Ix i => i -> a -> Table i a singleton :: Ix i => i -> a -> Table i a
singleton i a = Table [i] (listArray (i, i) [Just a]) singleton i a = Table [i] (listArray (i, i) [Just a])
fromListWith :: (HasCallStack, Ix i) => (a -> a -> a) -> [(i, a)] -> Table i a
fromListWith _ [] = error "fromList: empty list of associations"
fromListWith with assocs@(a:as) = Table (fst <$> assocs) (accumArray merge Nothing (getMin mn, getMax mx) assocs)
where (mn, mx) = sconcat ((Min &&& Max) . fst <$> a:|as)
merge Nothing b = Just b
merge (Just a) b = Just (with a b)
instance (Ix i, Show i) => Show1 (Table i) where instance (Ix i, Show i) => Show1 (Table i) where
liftShowsPrec spA slA d Table{..} = showsBinaryWith showsPrec (const (liftShowList spA slA)) "Table" d tableAddresses (tableAddresses >>= \ addr -> (,) addr <$> toList (tableBranches ! addr)) liftShowsPrec spA slA d Table{..} = showsBinaryWith showsPrec (const (liftShowList spA slA)) "Table" d tableAddresses (tableAddresses >>= \ addr -> (,) addr <$> toList (tableBranches ! addr))