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

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