Language/Symantic/Trans/Bool/Const.hs

   1 {-# LANGUAGE FlexibleInstances #-}
   2 {-# LANGUAGE GADTs #-}
   3 {-# LANGUAGE MultiParamTypeClasses #-}
   4
   5 -- | Transformer propagating boolean constants.
   6 module Language.Symantic.Trans.Bool.Const where
   7
   8 import qualified Data.Bool as Bool
   9 import Prelude hiding ((&&), not, (||))
  10
  11 import Language.Symantic.Trans.Common
  12 import Language.Symantic.Expr.Bool
  13
  14 -- * Type 'Trans_Bool_Const'
  15
  16 -- | Annotation.
  17 data Trans_Bool_Const repr h where
  18         Trans_Bool_Const_Unknown :: repr h -> Trans_Bool_Const repr h
  19         Trans_Bool_Const_Known   :: 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_Unknown
  25         trans_apply (Trans_Bool_Const_Unknown x) = x
  26         trans_apply (Trans_Bool_Const_Known   x) = bool x
  27
  28 instance
  29  Sym_Bool repr =>
  30  Sym_Bool (Trans_Bool_Const repr) where
  31         bool = Trans_Bool_Const_Known
  32
  33         not (Trans_Bool_Const_Unknown e) = Trans_Bool_Const_Unknown $ not e
  34         not (Trans_Bool_Const_Known   x) = Trans_Bool_Const_Known $ Bool.not x
  35
  36         (&&) (Trans_Bool_Const_Known True) y   = y
  37         (&&) (Trans_Bool_Const_Known False) _y = Trans_Bool_Const_Known False
  38         (&&) x  (Trans_Bool_Const_Known True)  = x
  39         (&&) _x (Trans_Bool_Const_Known False) = Trans_Bool_Const_Known False
  40         (&&) (Trans_Bool_Const_Unknown x)
  41              (Trans_Bool_Const_Unknown y)
  42          =   Trans_Bool_Const_Unknown $ (&&) x y
  43
  44         (||) (Trans_Bool_Const_Known False) y = y
  45         (||) (Trans_Bool_Const_Known True) _y = Trans_Bool_Const_Known True
  46         (||) x (Trans_Bool_Const_Known False) = x
  47         (||) _x (Trans_Bool_Const_Known True) = Trans_Bool_Const_Known True
  48         (||) (Trans_Bool_Const_Unknown x)
  49              (Trans_Bool_Const_Unknown y)
  50          =  Trans_Bool_Const_Unknown $ (||) 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