cli/Hcompta/Trans/Bool/Const.hs

   1 {-# LANGUAGE ExistentialQuantification #-}
   2 {-# LANGUAGE FlexibleInstances #-}
   3 {-# LANGUAGE MultiParamTypeClasses #-}
   4 {-# LANGUAGE NoImplicitPrelude #-}
   5 {-# OPTIONS_GHC -fno-warn-tabs #-}
   6
   7 module Hcompta.Trans.Bool.Const where
   8
   9 import Data.Bool
  10 import Data.Function (($))
  11 import Data.Text.Buildable (Buildable(..))
  12 import Text.Show (Show)
  13
  14 import Hcompta.Expr.Trans
  15 import Hcompta.Expr.Lit
  16 import Hcompta.Expr.Bool
  17
  18 -- * Type 'Trans_Bool_Const'
  19
  20 -- * Annotation to propagate constants.
  21 data Trans_Bool_Const repr h
  22  =   Trans_Bool_Const_Unk (repr h)
  23  |   (Buildable h, Show h)
  24   => Trans_Bool_Const_Lit h
  25
  26 instance Expr_Lit repr => Trans Trans_Bool_Const repr where
  27         trans_lift = Trans_Bool_Const_Unk
  28         trans_apply (Trans_Bool_Const_Unk x) = x
  29         trans_apply (Trans_Bool_Const_Lit x) = lit x
  30
  31 trans_bool_const
  32  :: (Expr_Bool repr, Expr_Lit repr)
  33  => Trans_Bool_Const repr h
  34  ->                  repr h
  35 trans_bool_const = trans_apply
  36
  37 instance Expr_Lit repr => Expr_Lit (Trans_Bool_Const repr) where
  38         lit = Trans_Bool_Const_Lit
  39 instance Expr_Bool repr => Expr_Bool (Trans_Bool_Const repr) where
  40         and (Trans_Bool_Const_Lit True) y   = y
  41         and (Trans_Bool_Const_Lit False) _y = Trans_Bool_Const_Lit False
  42         and x (Trans_Bool_Const_Lit True)   = x
  43         and _x (Trans_Bool_Const_Lit False) = Trans_Bool_Const_Lit False
  44         and (Trans_Bool_Const_Unk x)
  45             (Trans_Bool_Const_Unk y)
  46          =   Trans_Bool_Const_Unk $ and x y
  47
  48         or (Trans_Bool_Const_Lit False) y = y
  49         or (Trans_Bool_Const_Lit True) _y = Trans_Bool_Const_Lit True
  50         or x (Trans_Bool_Const_Lit False) = x
  51         or _x (Trans_Bool_Const_Lit True) = Trans_Bool_Const_Lit True
  52         or (Trans_Bool_Const_Unk x)
  53            (Trans_Bool_Const_Unk y)
  54          =  Trans_Bool_Const_Unk $ or x y
  55
  56         neg (Trans_Bool_Const_Unk e) = Trans_Bool_Const_Unk $ neg e
  57         neg (Trans_Bool_Const_Lit x) = Trans_Bool_Const_Lit $ not x