Key.hs

module UHC.Light.Compiler.CHR.Key
( Key (..) )
where
import UHC.Light.Compiler.Base.Common
import UHC.Util.TreeTrie
import UHC.Util.Pretty
import UHC.Util.Utils
import UHC.Util.CHR.Key
import UHC.Light.Compiler.Ty
import UHC.Light.Compiler.Ty.Pretty
import UHC.Util.Serialize
import Control.Monad




{-# LINE 33 "src/ehc/CHR/Key.chs" #-}
data Key
  = Key_HNm     !HsName         -- type constant, its name
  | Key_UID     !UID            -- type variable, its id, used with TKK_Partial
  | Key_Str     !String         -- arbitrary string
  | Key_TyQu    !TyQu           -- quantified type, used with TKK_Partial
  | Key_Ty      !Ty             -- catchall for the rest, used with TKK_Partial
  deriving ( Eq, Ord
           , Typeable
           )

{-# LINE 57 "src/ehc/CHR/Key.chs" #-}
instance Show Key where
  show (Key_HNm  n) = "H:" ++ show n
  show (Key_UID  n) = "U:" ++ show n
  show (Key_Str  n) = "S:" ++ n
  show (Key_TyQu n) = "Q:" ++ show n
  show (Key_Ty   n) = "T:" ++ show n

{-# LINE 71 "src/ehc/CHR/Key.chs" #-}
instance PP Key where
  pp (Key_HNm  n) = "H:" >|< n
  pp (Key_UID  n) = "U:" >|< n
  pp (Key_Str  n) = "S:" >|< n
  pp (Key_TyQu n) = "Q:" >|< show n
  pp (Key_Ty   n) = "T:" >|< n

{-# LINE 138 "src/ehc/CHR/Key.chs" #-}
type instance TrTrKey x = TTKey x

instance TTKeyable x => TreeTrieKeyable x where
  toTreeTrieKey = toTTKey

{-# LINE 149 "src/ehc/CHR/Key.chs" #-}
instance Serialize Key where
  sput (Key_HNm  a) = sputWord8 0 >> sput a
  sput (Key_UID  a) = sputWord8 1 >> sput a
  sput (Key_Str  a) = sputWord8 2 >> sput a
  sput (Key_TyQu a) = sputWord8 3 >> sput a
  sput (Key_Ty   a) = sputWord8 4 >> sput a
  sget = do
    t <- sgetWord8
    case t of
      0 -> liftM  Key_HNm  sget
      1 -> liftM  Key_UID  sget
      2 -> liftM  Key_Str  sget
      3 -> liftM  Key_TyQu sget
      4 -> liftM  Key_Ty   sget