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 Data.Monoid
  12 import Prelude hiding ((+), (-), (*), abs, mod, negate)
  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         default abs    :: (Trans t repr, Num n) => t repr n -> t repr n
  31         default negate :: (Trans t repr, Num n) => t repr n -> t repr n
  32         default (+)    :: (Trans t repr, Num n) => t repr 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         abs    = trans_map1 abs
  36         negate = trans_map1 negate
  37         (+)    = trans_map2 (+)
  38         (-)    = trans_map2 (-)
  39         (*)    = trans_map2 (*)
  40 infixl 6 +
  41 infixl 6 -
  42 infixl 7 *
  43 instance Sym_Num Repr_Host where
  44         abs    = liftM Prelude.abs
  45         negate = liftM Prelude.negate
  46         (+)    = liftM2 (Prelude.+)
  47         (-)    = liftM2 (Prelude.-)
  48         (*)    = liftM2 (Prelude.*)
  49 instance Sym_Num Repr_Text where
  50         abs = repr_text_app1 "abs"
  51         negate (Repr_Text x) =
  52                 Repr_Text $ \p v ->
  53                         let p' = precedence_Neg in
  54                         paren p p' $ "-" <> x p' v
  55         (+) (Repr_Text x) (Repr_Text y) =
  56                 Repr_Text $ \p v ->
  57                         let p' = precedence_Add in
  58                         paren p p' $ x p' v <> " + " <> y p' v
  59         (-) (Repr_Text x) (Repr_Text y) =
  60                 Repr_Text $ \p v ->
  61                         let p' = precedence_Sub in
  62                         paren p p' $ x p' v <> " - " <> y p' v
  63         (*) (Repr_Text x) (Repr_Text y) =
  64                 Repr_Text $ \p v ->
  65                         let p' = precedence_Mul in
  66                         paren p p' $ x p' v <> " * " <> y p' v
  67 instance
  68  ( Sym_Num r1
  69  , Sym_Num r2
  70  ) => Sym_Num (Dup r1 r2) where
  71         abs    (x1 `Dup` x2)               = abs x1    `Dup` abs x2
  72         negate (x1 `Dup` x2)               = negate x1 `Dup` negate x2
  73         (+)    (x1 `Dup` x2) (y1 `Dup` y2) = (+) x1 y1 `Dup` (+) x2 y2
  74         (-)    (x1 `Dup` x2) (y1 `Dup` y2) = (-) x1 y1 `Dup` (-) x2 y2
  75         (*)    (x1 `Dup` x2) (y1 `Dup` y2) = (*) x1 y1 `Dup` (*) x2 y2
  76
  77 -- * Type 'Expr_Num'
  78 -- | Expression.
  79 data Expr_Num (root:: *)
  80 type instance Root_of_Expr      (Expr_Num root)      = root
  81 type instance Type_of_Expr      (Expr_Num root)      = No_Type
  82 type instance Sym_of_Expr       (Expr_Num root) repr = Sym_Num repr
  83 type instance Error_of_Expr ast (Expr_Num root)      = No_Error_Expr