]> Git — Sourcephile - haskell/symantic.git/blob - Language/Symantic/Expr/Bool.hs
Repr_Dup helpers
[haskell/symantic.git] / 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