module Yhc.Core.Annotation (
CoreAnnotations,
CoreAnnotable (..),
CoreProperty (..),
addAnnotation,
getAnnotation,
combineAnnotations) where
import Data.Maybe
import qualified Data.Map as M
import qualified Data.List as L
import Yhc.Core
type CoreAnnotations = M.Map String (M.Map String String)
class CoreAnnotable a where
toAnnotationKey :: a -> String
class CoreProperty p where
toAnnString :: p -> String
fromAnnString :: (Monad m) => String -> m p
addAnnotation :: (CoreAnnotable a, CoreProperty p)
=> a
-> (String, p)
-> CoreAnnotations
-> CoreAnnotations
addAnnotation a (n, p) b =
let ak = toAnnotationKey a
aa = M.findWithDefault M.empty ak b
ps = toAnnString p
aa' = M.insert n ps aa
in M.insert ak aa' b
getAnnotation :: (CoreAnnotable a, CoreProperty p)
=> a
-> String
-> CoreAnnotations
-> Maybe p
getAnnotation a n b = do
let ak = toAnnotationKey a
aa <- M.lookup ak b
ps <- M.lookup n aa
p <- fromAnnString ps
return p
combineAnnotations :: CoreAnnotations -> CoreAnnotations -> CoreAnnotations
combineAnnotations l r =
let flkup = flip M.lookup
lkeys = M.keys l
rkeys = M.keys r
ikeys = L.intersect lkeys rkeys
lnodup = lkeys L.\\ ikeys
rnodup = rkeys L.\\ ikeys
lanno = concat $ map (maybeToList . flkup l) lnodup
ranno = concat $ map (maybeToList . flkup r) rnodup
ilanno = concat $ map (maybeToList . flkup l) ikeys
iranno = concat $ map (maybeToList . flkup r) ikeys
imps = zipWith M.union ilanno iranno
in M.fromList (zip lnodup lanno ++ zip rnodup ranno ++ zip ikeys imps)