Language/Symantic/Expr/Bool.hs

   1 {-# LANGUAGE DefaultSignatures #-}
   2 {-# LANGUAGE FlexibleContexts #-}
   3 {-# LANGUAGE OverloadedStrings #-}
   4 {-# LANGUAGE ScopedTypeVariables #-}
   5 {-# LANGUAGE TypeFamilies #-}
   6 {-# LANGUAGE TypeOperators #-}
   7 -- | Expression for 'Bool'.
   8 module Language.Symantic.Expr.Bool where
   9
  10 import Control.Monad
  11 import qualified Data.Bool as Bool
  12 import Data.Monoid
  13 import qualified Data.Text as Text
  14 import Prelude hiding ((&&), not, (||))
  15
  16 import Language.Symantic.Type
  17 import Language.Symantic.Repr
  18 import Language.Symantic.Expr.Root
  19 import Language.Symantic.Expr.Error
  20 import Language.Symantic.Expr.From
  21 import Language.Symantic.Trans.Common
  22
  23 -- * Class 'Sym_Bool'
  24 -- | Symantic.
  25 class Sym_Bool repr where
  26         bool ::      Bool -> repr Bool
  27         not  :: repr Bool -> repr Bool
  28         (&&) :: repr Bool -> repr Bool -> repr Bool
  29         (||) :: repr Bool -> repr Bool -> repr Bool
  30         xor  :: repr Bool -> repr Bool -> repr Bool
  31         xor x y = (x || y) && not (x && y)
  32
  33         default bool :: Trans t repr =>        Bool -> t repr Bool
  34         default not  :: Trans t repr => t repr Bool -> t repr Bool
  35         default (&&) :: Trans t repr => t repr Bool -> t repr Bool -> t repr Bool
  36         default (||) :: Trans t repr => t repr Bool -> t repr Bool -> t repr Bool
  37         bool = trans_lift . bool
  38         not  = trans_map1 not
  39         (&&) = trans_map2 (&&)
  40         (||) = trans_map2 (||)
  41 infixr 2 ||
  42 infixr 2 `xor`
  43 infixr 3 &&
  44 instance Sym_Bool Repr_Host where
  45         bool = Repr_Host
  46         not  = liftM Bool.not
  47         (&&) = liftM2 (Bool.&&)
  48         (||) = liftM2 (Bool.||)
  49 instance Sym_Bool Repr_Text where
  50         bool a = Repr_Text $ \_p _v ->
  51                 Text.pack (show a)
  52         not (Repr_Text x) =
  53                 Repr_Text $ \p v ->
  54                         let p' = precedence_Not in
  55                         paren p p' $ "!" <> x p' v
  56         (&&) (Repr_Text x) (Repr_Text y) =
  57                 Repr_Text $ \p v ->
  58                         let p' = precedence_And in
  59                         paren p p' $ x p' v <> " && " <> y p' v
  60         (||) (Repr_Text x) (Repr_Text y) =
  61                 Repr_Text $ \p v ->
  62                         let p' = precedence_Or in
  63                         paren p p'  $ x p' v <> " || " <> y p' v
  64         xor (Repr_Text x) (Repr_Text y) =
  65                 Repr_Text $ \p v ->
  66                         let p' = precedence_Xor in
  67                         paren p p'  $ "xor " <> x p' v <> " " <> y p' v
  68 instance
  69  ( Sym_Bool r1
  70  , Sym_Bool r2
  71  ) => Sym_Bool (Dup r1 r2) where
  72         bool x = bool x `Dup` bool x
  73         not  (x1 `Dup` x2)               = not  x1    `Dup` not  x2
  74         (&&) (x1 `Dup` x2) (y1 `Dup` y2) = (&&) x1 y1 `Dup` (&&) x2 y2
  75         (||) (x1 `Dup` x2) (y1 `Dup` y2) = (||) x1 y1 `Dup` (||) x2 y2
  76         xor  (x1 `Dup` x2) (y1 `Dup` y2) = xor  x1 y1 `Dup` xor  x2 y2
  77
  78 -- * Type 'Expr_Bool'
  79 -- | Expression.
  80 data Expr_Bool (root:: *)
  81 type instance Root_of_Expr      (Expr_Bool root)      = root
  82 type instance Type_of_Expr      (Expr_Bool root)      = Type_Bool
  83 type instance Sym_of_Expr       (Expr_Bool root) repr = Sym_Bool repr
  84 type instance Error_of_Expr ast (Expr_Bool root)      = No_Error_Expr