Language/LOL/Symantic/Trans/Bool/Const.hs

   1 {-# LANGUAGE FlexibleInstances #-}
   2 {-# LANGUAGE GADTs #-}
   3 {-# LANGUAGE MultiParamTypeClasses #-}
   4
   5 module Language.LOL.Symantic.Trans.Bool.Const where
   6
   7 import qualified Data.Bool as Bool
   8 import Prelude hiding (and, not, or)
   9
  10 import Language.LOL.Symantic.Trans.Common
  11 import Language.LOL.Symantic.Expr.Bool
  12
  13 -- * Type 'Trans_Bool_Const'
  14
  15 -- | Annotation to propagate constants.
  16 data Trans_Bool_Const repr h where
  17         Trans_Bool_Const_Unk :: repr h -> Trans_Bool_Const repr h
  18         Trans_Bool_Const_Lit :: Bool   -> Trans_Bool_Const repr Bool
  19
  20 instance
  21  Sym_Bool repr =>
  22  Trans Trans_Bool_Const repr where
  23         trans_lift = Trans_Bool_Const_Unk
  24         trans_apply (Trans_Bool_Const_Unk x) = x
  25         trans_apply (Trans_Bool_Const_Lit x) = bool x
  26
  27 instance
  28  Sym_Bool repr =>
  29  Sym_Bool (Trans_Bool_Const repr) where
  30         bool = Trans_Bool_Const_Lit
  31
  32         not (Trans_Bool_Const_Unk e) = Trans_Bool_Const_Unk $ not e
  33         not (Trans_Bool_Const_Lit x) = Trans_Bool_Const_Lit $ Bool.not x
  34
  35         and (Trans_Bool_Const_Lit True) y   = y
  36         and (Trans_Bool_Const_Lit False) _y = Trans_Bool_Const_Lit False
  37         and x  (Trans_Bool_Const_Lit True)  = x
  38         and _x (Trans_Bool_Const_Lit False) = Trans_Bool_Const_Lit False
  39         and (Trans_Bool_Const_Unk x)
  40             (Trans_Bool_Const_Unk y)
  41          =   Trans_Bool_Const_Unk $ and x y
  42
  43         or (Trans_Bool_Const_Lit False) y = y
  44         or (Trans_Bool_Const_Lit True) _y = Trans_Bool_Const_Lit True
  45         or x (Trans_Bool_Const_Lit False) = x
  46         or _x (Trans_Bool_Const_Lit True) = Trans_Bool_Const_Lit True
  47         or (Trans_Bool_Const_Unk x)
  48            (Trans_Bool_Const_Unk y)
  49          =  Trans_Bool_Const_Unk $ or x y
  50
  51 trans_bool_const
  52  :: Sym_Bool repr
  53  => Trans_Bool_Const repr h -> repr h
  54 trans_bool_const = trans_apply