{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
-- | Expression for 'Bool'.
module Language.Symantic.Expr.Bool where

import Control.Monad
import qualified Data.Bool as Bool
import Data.Monoid
import qualified Data.Text as Text
import Prelude hiding ((&&), not, (||))

import Language.Symantic.Type
import Language.Symantic.Repr
import Language.Symantic.Expr.Root
import Language.Symantic.Expr.Error
import Language.Symantic.Expr.From
import Language.Symantic.Trans.Common

-- * Class 'Sym_Bool'
-- | Symantic.
class Sym_Bool repr where
	bool ::      Bool -> repr Bool
	not  :: repr Bool -> repr Bool
	(&&) :: repr Bool -> repr Bool -> repr Bool
	(||) :: repr Bool -> repr Bool -> repr Bool
	xor  :: repr Bool -> repr Bool -> repr Bool
	xor x y = (x || y) && not (x && y)
	
	default bool :: Trans t repr =>        Bool -> t repr Bool
	default not  :: Trans t repr => t repr Bool -> t repr Bool
	default (&&) :: Trans t repr => t repr Bool -> t repr Bool -> t repr Bool
	default (||) :: Trans t repr => t repr Bool -> t repr Bool -> t repr Bool
	
	bool = trans_lift . bool
	not  = trans_map1 not
	(&&) = trans_map2 (&&)
	(||) = trans_map2 (||)

infixr 2 ||
infixr 2 `xor`
infixr 3 &&

instance Sym_Bool Repr_Host where
	bool = Repr_Host
	not  = liftM Bool.not
	(&&) = liftM2 (Bool.&&)
	(||) = liftM2 (Bool.||)
instance Sym_Bool Repr_Text where
	bool a = Repr_Text $ \_p _v ->
		Text.pack (show a)
	not (Repr_Text x) =
		Repr_Text $ \p v ->
			let p' = Precedence 9 in
			paren p p' $ "not " <> x p' v
	(&&) = repr_text_infix "&&"    (Precedence 6)
	(||) = repr_text_infix "||"    (Precedence 5)
	xor  = repr_text_infix "`xor`" (Precedence 5)
instance
 ( Sym_Bool r1
 , Sym_Bool r2
 ) => Sym_Bool (Dup r1 r2) where
	bool x = bool x `Dup` bool x
	not  (x1 `Dup` x2)               = not  x1    `Dup` not  x2
	(&&) (x1 `Dup` x2) (y1 `Dup` y2) = (&&) x1 y1 `Dup` (&&) x2 y2
	(||) (x1 `Dup` x2) (y1 `Dup` y2) = (||) x1 y1 `Dup` (||) x2 y2
	xor  (x1 `Dup` x2) (y1 `Dup` y2) = xor  x1 y1 `Dup` xor  x2 y2

-- * Type 'Expr_Bool'
-- | Expression.
data Expr_Bool (root:: *)
type instance Root_of_Expr      (Expr_Bool root)      = root
type instance Type_of_Expr      (Expr_Bool root)      = Type_Bool
type instance Sym_of_Expr       (Expr_Bool root) repr = Sym_Bool repr
type instance Error_of_Expr ast (Expr_Bool root)      = No_Error_Expr