{-# LANGUAGE DeriveFoldable #-}{-# LANGUAGE DeriveFunctor #-}{-# LANGUAGE DeriveTraversable #-}{-# LANGUAGE TypeFamilies #-}{-# LANGUAGE GeneralizedNewtypeDeriving #-}moduleHoopl.Label(Label ,LabelMap ,LabelSet ,FactBase ,lookupFact ,mkHooplLabel )whereimportGhcPrelude importOutputable -- TODO: This should really just use GHC's Unique and Uniq{Set,FM}importHoopl.Collections importUnique (Uniquable (..))importTrieMap ------------------------------------------------------------------------------- Label-----------------------------------------------------------------------------newtypeLabel =Label {lblToUnique ::Int}deriving(Eq,Ord)mkHooplLabel::Int->Label mkHooplLabel =Label instanceShowLabel whereshow (Label n )="L"++shown instanceUniquable Label wheregetUnique label=getUnique (lblToUniquelabel)instanceOutputable Label whereppr label=ppr (getUnique label)------------------------------------------------------------------------------- LabelSetnewtypeLabelSet =LS UniqueSet deriving(Eq,Ord,Show,Monoid,Semigroup)instanceIsSet LabelSet wheretypeElemOfLabelSet =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 setFilter f (LS s )=LS (setFilter (f .mkHooplLabel )s )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 setElems (LS s )=mapmkHooplLabel (setElems s )setFromList ks =LS (setFromList (maplblToUniqueks ))------------------------------------------------------------------------------- LabelMapnewtypeLabelMap v =LM (UniqueMap v )deriving(Eq,Ord,Show,Functor,Foldable,Traversable)instanceIsMap LabelMap wheretypeKeyOfLabelMap =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 )mapAlter f (Label k )(LM m )=LM (mapAlter f k m )mapAdjust f (Label k )(LM m )=LM (mapAdjust f k m )mapUnion (LM x )(LM y )=LM (mapUnion x y )mapUnionWithKey f (LM x )(LM y )=LM (mapUnionWithKey (f .mkHooplLabel )x y )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 )mapMapWithKey f (LM m )=LM (mapMapWithKey (f .mkHooplLabel )m )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 mapFoldMapWithKey f (LM m )=mapFoldMapWithKey (\k v ->f (mkHooplLabel k )v )m mapFilter f (LM m )=LM (mapFilter f m )mapFilterWithKey f (LM m )=LM (mapFilterWithKey (f .mkHooplLabel )m )mapElems (LM m )=mapElems m mapKeys (LM m )=mapmkHooplLabel (mapKeys m )mapToList (LM m )=[(mkHooplLabel k ,v )|(k ,v )<-mapToList m ]mapFromList assocs =LM (mapFromList [(lblToUniquek ,v )|(k ,v )<-assocs ])mapFromListWith f assocs =LM (mapFromListWith f [(lblToUniquek ,v )|(k ,v )<-assocs ])------------------------------------------------------------------------------- InstancesinstanceOutputable LabelSet whereppr =ppr .setElems instanceOutputable a =>Outputable (LabelMap a )whereppr =ppr .mapToList instanceTrieMap LabelMap wheretypeKeyLabelMap =Label emptyTM =mapEmpty lookupTM k m =mapLookup k m alterTM k f m =mapAlter f k m foldTM k m z =mapFoldr k z m mapTM f m =mapMap f m ------------------------------------------------------------------------------- FactBasetypeFactBase f =LabelMap f lookupFact::Label ->FactBase f ->Maybef lookupFact =mapLookup