Label.hs 3.83 KB
Newer Older
1 2 3 4 5 6 7 8 9 10
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE TypeFamilies #-}
module Hoopl.Label
    ( Label
    , LabelMap
    , LabelSet
    , FactBase
    , lookupFact
Michal Terepeta's avatar
Michal Terepeta committed
11
    , mkHooplLabel
12 13
    ) where

14 15
import GhcPrelude

16 17 18
import Outputable

-- TODO: This should really just use GHC's Unique and Uniq{Set,FM}
Michal Terepeta's avatar
Michal Terepeta committed
19
import Hoopl.Collections
20 21 22 23 24 25 26

import Unique (Uniquable(..))

-----------------------------------------------------------------------------
--              Label
-----------------------------------------------------------------------------

Michal Terepeta's avatar
Michal Terepeta committed
27
newtype Label = Label { lblToUnique :: Int }
28 29
  deriving (Eq, Ord)

Michal Terepeta's avatar
Michal Terepeta committed
30 31
mkHooplLabel :: Int -> Label
mkHooplLabel = Label
32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63

instance Show Label where
  show (Label n) = "L" ++ show n

instance Uniquable Label where
  getUnique label = getUnique (lblToUnique label)

instance Outputable Label where
  ppr label = ppr (getUnique label)

-----------------------------------------------------------------------------
-- LabelSet

newtype LabelSet = LS UniqueSet deriving (Eq, Ord, Show)

instance IsSet LabelSet where
  type ElemOf LabelSet = Label

  setNull (LS s) = setNull s
  setSize (LS s) = setSize s
  setMember (Label k) (LS s) = setMember k s

  setEmpty = LS setEmpty
  setSingleton (Label k) = LS (setSingleton k)
  setInsert (Label k) (LS s) = LS (setInsert k s)
  setDelete (Label k) (LS s) = LS (setDelete k s)

  setUnion (LS x) (LS y) = LS (setUnion x y)
  setDifference (LS x) (LS y) = LS (setDifference x y)
  setIntersection (LS x) (LS y) = LS (setIntersection x y)
  setIsSubsetOf (LS x) (LS y) = setIsSubsetOf x y

64 65
  setFoldl k z (LS s) = setFoldl (\a v -> k a (mkHooplLabel v)) z s
  setFoldr k z (LS s) = setFoldr (\v a -> k (mkHooplLabel v) a) z s
66

Michal Terepeta's avatar
Michal Terepeta committed
67
  setElems (LS s) = map mkHooplLabel (setElems s)
68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91
  setFromList ks = LS (setFromList (map lblToUnique ks))

-----------------------------------------------------------------------------
-- LabelMap

newtype LabelMap v = LM (UniqueMap v)
  deriving (Eq, Ord, Show, Functor, Foldable, Traversable)

instance IsMap LabelMap where
  type KeyOf LabelMap = Label

  mapNull (LM m) = mapNull m
  mapSize (LM m) = mapSize m
  mapMember (Label k) (LM m) = mapMember k m
  mapLookup (Label k) (LM m) = mapLookup k m
  mapFindWithDefault def (Label k) (LM m) = mapFindWithDefault def k m

  mapEmpty = LM mapEmpty
  mapSingleton (Label k) v = LM (mapSingleton k v)
  mapInsert (Label k) v (LM m) = LM (mapInsert k v m)
  mapInsertWith f (Label k) v (LM m) = LM (mapInsertWith f k v m)
  mapDelete (Label k) (LM m) = LM (mapDelete k m)

  mapUnion (LM x) (LM y) = LM (mapUnion x y)
Michal Terepeta's avatar
Michal Terepeta committed
92
  mapUnionWithKey f (LM x) (LM y) = LM (mapUnionWithKey (f . mkHooplLabel) x y)
93 94 95 96 97
  mapDifference (LM x) (LM y) = LM (mapDifference x y)
  mapIntersection (LM x) (LM y) = LM (mapIntersection x y)
  mapIsSubmapOf (LM x) (LM y) = mapIsSubmapOf x y

  mapMap f (LM m) = LM (mapMap f m)
Michal Terepeta's avatar
Michal Terepeta committed
98
  mapMapWithKey f (LM m) = LM (mapMapWithKey (f . mkHooplLabel) m)
99 100 101 102
  mapFoldl k z (LM m) = mapFoldl k z m
  mapFoldr k z (LM m) = mapFoldr k z m
  mapFoldlWithKey k z (LM m) =
      mapFoldlWithKey (\a v -> k a (mkHooplLabel v)) z m
103 104 105
  mapFilter f (LM m) = LM (mapFilter f m)

  mapElems (LM m) = mapElems m
Michal Terepeta's avatar
Michal Terepeta committed
106 107
  mapKeys (LM m) = map mkHooplLabel (mapKeys m)
  mapToList (LM m) = [(mkHooplLabel k, v) | (k, v) <- mapToList m]
108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126
  mapFromList assocs = LM (mapFromList [(lblToUnique k, v) | (k, v) <- assocs])
  mapFromListWith f assocs = LM (mapFromListWith f [(lblToUnique k, v) | (k, v) <- assocs])

-----------------------------------------------------------------------------
-- Instances

instance Outputable LabelSet where
  ppr = ppr . setElems

instance Outputable a => Outputable (LabelMap a) where
  ppr = ppr . mapToList

-----------------------------------------------------------------------------
-- FactBase

type FactBase f = LabelMap f

lookupFact :: Label -> FactBase f -> Maybe f
lookupFact = mapLookup