Language/Symantic/Expr/Num.hs

   1 {-# LANGUAGE DefaultSignatures #-}
   2 {-# LANGUAGE FlexibleContexts #-}
   3 {-# LANGUAGE OverloadedStrings #-}
   4 {-# LANGUAGE ScopedTypeVariables #-}
   5 {-# LANGUAGE TypeFamilies #-}
   6 {-# LANGUAGE TypeOperators #-}
   7 -- | Expression for 'Num'.
   8 module Language.Symantic.Expr.Num where
   9
  10 import Control.Monad
  11 import Prelude hiding (Num(..))
  12 import Prelude (Num)
  13 import qualified Prelude
  14
  15 import Language.Symantic.Type
  16 import Language.Symantic.Repr
  17 import Language.Symantic.Expr.Root
  18 import Language.Symantic.Expr.Error
  19 import Language.Symantic.Expr.From
  20 import Language.Symantic.Trans.Common
  21
  22 -- * Class 'Sym_Num'
  23 -- | Symantic.
  24 class Sym_Num repr where
  25         abs    :: Num n => repr n -> repr n
  26         negate :: Num n => repr n -> repr n
  27         (+)    :: Num n => repr n -> repr n -> repr n
  28         (-)    :: Num n => repr n -> repr n -> repr n
  29         (*)    :: Num n => repr n -> repr n -> repr n
  30
  31         default abs    :: (Trans t repr, Num n) => t repr n -> t repr n
  32         default negate :: (Trans t repr, Num n) => t repr n -> t repr n
  33         default (+)    :: (Trans t repr, Num n) => t repr n -> t repr n -> t repr n
  34         default (-)    :: (Trans t repr, Num n) => t repr n -> t repr n -> t repr n
  35         default (*)    :: (Trans t repr, Num n) => t repr n -> t repr n -> t repr n
  36
  37         abs    = trans_map1 abs
  38         negate = trans_map1 negate
  39         (+)    = trans_map2 (+)
  40         (-)    = trans_map2 (-)
  41         (*)    = trans_map2 (*)
  42
  43 infixl 6 +
  44 infixl 6 -
  45 infixl 7 *
  46
  47 instance Sym_Num Repr_Host where
  48         abs    = liftM Prelude.abs
  49         negate = liftM Prelude.negate
  50         (+)    = liftM2 (Prelude.+)
  51         (-)    = liftM2 (Prelude.-)
  52         (*)    = liftM2 (Prelude.*)
  53 instance Sym_Num Repr_Text where
  54         abs    = repr_text_app1 "abs"
  55         negate = repr_text_app1 "negate"
  56         (+)    = repr_text_infix "+" (Precedence 6)
  57         (-)    = repr_text_infix "-" (Precedence 6)
  58         (*)    = repr_text_infix "-" (Precedence 7)
  59 instance
  60  ( Sym_Num r1
  61  , Sym_Num r2
  62  ) => Sym_Num (Repr_Dup r1 r2) where
  63         abs    (x1 `Repr_Dup` x2)                    = abs x1    `Repr_Dup` abs x2
  64         negate (x1 `Repr_Dup` x2)                    = negate x1 `Repr_Dup` negate x2
  65         (+)    (x1 `Repr_Dup` x2) (y1 `Repr_Dup` y2) = (+) x1 y1 `Repr_Dup` (+) x2 y2
  66         (-)    (x1 `Repr_Dup` x2) (y1 `Repr_Dup` y2) = (-) x1 y1 `Repr_Dup` (-) x2 y2
  67         (*)    (x1 `Repr_Dup` x2) (y1 `Repr_Dup` y2) = (*) x1 y1 `Repr_Dup` (*) x2 y2
  68
  69 -- * Type 'Expr_Num'
  70 -- | Expression.
  71 data Expr_Num (root:: *)
  72 type instance Root_of_Expr      (Expr_Num root)      = root
  73 type instance Type_of_Expr      (Expr_Num root)      = No_Type
  74 type instance Sym_of_Expr       (Expr_Num root) repr = Sym_Num repr
  75 type instance Error_of_Expr ast (Expr_Num root)      = No_Error_Expr