Language/Symantic/Expr/Bool.hs

   1 {-# LANGUAGE DefaultSignatures #-}
   2 {-# LANGUAGE FlexibleContexts #-}
   3 {-# LANGUAGE ScopedTypeVariables #-}
   4 {-# LANGUAGE TypeFamilies #-}
   5 {-# LANGUAGE TypeOperators #-}
   6 -- | Expression for 'Bool'.
   7 module Language.Symantic.Expr.Bool where
   8
   9 import Prelude hiding ((&&), not, (||))
  10
  11 import Language.Symantic.Type
  12 import Language.Symantic.Expr.Common
  13 import Language.Symantic.Repr.Dup
  14 import Language.Symantic.Trans.Common
  15
  16 -- * Class 'Sym_Bool'
  17 -- | Symantic.
  18 class Sym_Bool repr where
  19         bool ::      Bool -> repr Bool
  20         not  :: repr Bool -> repr Bool
  21         (&&) :: repr Bool -> repr Bool -> repr Bool
  22         (||) :: repr Bool -> repr Bool -> repr Bool
  23         xor  :: repr Bool -> repr Bool -> repr Bool
  24         xor x y = (x || y) && not (x && y)
  25
  26         default bool :: Trans t repr =>        Bool -> t repr Bool
  27         default not  :: Trans t repr => t repr Bool -> t repr Bool
  28         default (&&) :: Trans t repr => t repr Bool -> t repr Bool -> t repr Bool
  29         default (||) :: Trans t repr => t repr Bool -> t repr Bool -> t repr Bool
  30         bool = trans_lift . bool
  31         not  = trans_map1 not
  32         (&&) = trans_map2 (&&)
  33         (||) = trans_map2 (||)
  34 infixr 2 ||
  35 infixr 2 `xor`
  36 infixr 3 &&
  37
  38 instance -- Sym_Bool Dup
  39  ( Sym_Bool r1
  40  , Sym_Bool r2
  41  ) => Sym_Bool (Dup r1 r2) where
  42         bool x = bool x `Dup` bool x
  43         not  (x1 `Dup` x2)               = not  x1    `Dup` not  x2
  44         (&&) (x1 `Dup` x2) (y1 `Dup` y2) = (&&) x1 y1 `Dup` (&&) x2 y2
  45         (||) (x1 `Dup` x2) (y1 `Dup` y2) = (||) x1 y1 `Dup` (||) x2 y2
  46         xor  (x1 `Dup` x2) (y1 `Dup` y2) = xor  x1 y1 `Dup` xor  x2 y2
  47
  48 -- * Type 'Expr_Bool'
  49 -- | Expression.
  50 data Expr_Bool (root:: *)
  51 type instance Root_of_Expr      (Expr_Bool root)      = root
  52 type instance Type_of_Expr      (Expr_Bool root)      = Type_Bool
  53 type instance Sym_of_Expr       (Expr_Bool root) repr = Sym_Bool repr
  54 type instance Error_of_Expr ast (Expr_Bool root)      = No_Error_Expr