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 Data.Proxy
  14 import qualified Data.Text as Text
  15 import Prelude hiding ((&&), not, (||))
  16
  17 import Language.Symantic.Type
  18 import Language.Symantic.Repr
  19 import Language.Symantic.Expr.Root
  20 import Language.Symantic.Expr.Error
  21 import Language.Symantic.Expr.From
  22 import Language.Symantic.Trans.Common
  23
  24 -- * Class 'Sym_Bool'
  25 -- | Symantic.
  26 class Sym_Bool repr where
  27         bool ::      Bool -> repr Bool
  28         not  :: repr Bool -> repr Bool
  29         (&&) :: repr Bool -> repr Bool -> repr Bool
  30         (||) :: repr Bool -> repr Bool -> repr Bool
  31         xor  :: repr Bool -> repr Bool -> repr Bool
  32         xor x y = (x || y) && not (x && y)
  33
  34         default bool :: Trans t repr =>        Bool -> t repr Bool
  35         default not  :: Trans t repr => t repr Bool -> t repr Bool
  36         default (&&) :: Trans t repr => t repr Bool -> t repr Bool -> t repr Bool
  37         default (||) :: Trans t repr => t repr Bool -> t repr Bool -> t repr Bool
  38
  39         bool = trans_lift . bool
  40         not  = trans_map1 not
  41         (&&) = trans_map2 (&&)
  42         (||) = trans_map2 (||)
  43
  44 infixr 2 ||
  45 infixr 2 `xor`
  46 infixr 3 &&
  47
  48 instance Sym_Bool Repr_Host where
  49         bool = Repr_Host
  50         not  = liftM Bool.not
  51         (&&) = liftM2 (Bool.&&)
  52         (||) = liftM2 (Bool.||)
  53 instance Sym_Bool Repr_Text where
  54         bool a = Repr_Text $ \_p _v ->
  55                 Text.pack (show a)
  56         not (Repr_Text x) =
  57                 Repr_Text $ \p v ->
  58                         let p' = Precedence 9 in
  59                         paren p p' $ "not " <> x p' v
  60         (&&) = repr_text_infix "&&"    (Precedence 6)
  61         (||) = repr_text_infix "||"    (Precedence 5)
  62         xor  = repr_text_infix "`xor`" (Precedence 5)
  63 instance (Sym_Bool r1, Sym_Bool r2) => Sym_Bool (Repr_Dup r1 r2) where
  64         bool x = bool x `Repr_Dup` bool x
  65         not  = repr_dup1 sym_Bool not
  66         (&&) = repr_dup2 sym_Bool (&&)
  67         (||) = repr_dup2 sym_Bool (||)
  68         xor  = repr_dup2 sym_Bool xor
  69
  70 sym_Bool :: Proxy Sym_Bool
  71 sym_Bool = Proxy
  72
  73 -- * Type 'Expr_Bool'
  74 -- | Expression.
  75 data Expr_Bool (root:: *)
  76 type instance Root_of_Expr      (Expr_Bool root)      = root
  77 type instance Type_of_Expr      (Expr_Bool root)      = Type_Bool
  78 type instance Sym_of_Expr       (Expr_Bool root) repr = Sym_Bool repr
  79 type instance Error_of_Expr ast (Expr_Bool root)      = No_Error_Expr