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

import Control.Monad
import Prelude hiding (Num(..))
import Prelude (Num)
import qualified Prelude

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_Num'
-- | Symantic.
class Sym_Num repr where
	abs    :: Num n => repr n -> repr n
	negate :: Num n => repr n -> repr n
	(+)    :: Num n => repr n -> repr n -> repr n
	(-)    :: Num n => repr n -> repr n -> repr n
	(*)    :: Num n => repr n -> repr n -> repr n
	
	default abs    :: (Trans t repr, Num n) => t repr n -> t repr n
	default negate :: (Trans t repr, Num n) => t repr n -> t repr n
	default (+)    :: (Trans t repr, Num n) => t repr n -> t repr n -> t repr n
	default (-)    :: (Trans t repr, Num n) => t repr n -> t repr n -> t repr n
	default (*)    :: (Trans t repr, Num n) => t repr n -> t repr n -> t repr n
	
	abs    = trans_map1 abs
	negate = trans_map1 negate
	(+)    = trans_map2 (+)
	(-)    = trans_map2 (-)
	(*)    = trans_map2 (*)

infixl 6 +
infixl 6 -
infixl 7 *

instance Sym_Num Repr_Host where
	abs    = liftM Prelude.abs
	negate = liftM Prelude.negate
	(+)    = liftM2 (Prelude.+)
	(-)    = liftM2 (Prelude.-)
	(*)    = liftM2 (Prelude.*)
instance Sym_Num Repr_Text where
	abs    = repr_text_app1 "abs"
	negate = repr_text_app1 "negate"
	(+)    = repr_text_infix "+" (Precedence 6)
	(-)    = repr_text_infix "-" (Precedence 6)
	(*)    = repr_text_infix "-" (Precedence 7)
instance
 ( Sym_Num r1
 , Sym_Num r2
 ) => Sym_Num (Dup r1 r2) where
	abs    (x1 `Dup` x2)               = abs x1    `Dup` abs x2
	negate (x1 `Dup` x2)               = negate x1 `Dup` negate x2
	(+)    (x1 `Dup` x2) (y1 `Dup` y2) = (+) x1 y1 `Dup` (+) x2 y2
	(-)    (x1 `Dup` x2) (y1 `Dup` y2) = (-) x1 y1 `Dup` (-) x2 y2
	(*)    (x1 `Dup` x2) (y1 `Dup` y2) = (*) x1 y1 `Dup` (*) x2 y2

-- * Type 'Expr_Num'
-- | Expression.
data Expr_Num (root:: *)
type instance Root_of_Expr      (Expr_Num root)      = root
type instance Type_of_Expr      (Expr_Num root)      = No_Type
type instance Sym_of_Expr       (Expr_Num root) repr = Sym_Num repr
type instance Error_of_Expr ast (Expr_Num root)      = No_Error_Expr