symantic-lib/Language/Symantic/Lib/Num.hs

   1 {-# LANGUAGE UndecidableInstances #-}
   2 {-# OPTIONS_GHC -fno-warn-orphans #-}
   3 -- | Symantic for 'Num'.
   4 module Language.Symantic.Lib.Num where
   5
   6 import Control.Monad (liftM, liftM2)
   7 import qualified Data.Function as Fun
   8 import Data.Proxy
   9 import Data.Type.Equality ((:~:)(Refl))
  10 import qualified Prelude
  11 import Prelude hiding (Num(..))
  12 import Prelude (Num)
  13
  14 import Language.Symantic.Parsing
  15 import Language.Symantic.Typing
  16 import Language.Symantic.Compiling
  17 import Language.Symantic.Interpreting
  18 import Language.Symantic.Transforming
  19 import Language.Symantic.Lib.Lambda
  20
  21 -- * Class 'Sym_Num'
  22 class Sym_Num term where
  23         abs         :: Num n => term n -> term n
  24         negate      :: Num n => term n -> term n
  25         signum      :: Num n => term n -> term n
  26         (+)         :: Num n => term n -> term n -> term n
  27         (-)         :: Num n => term n -> term n -> term n
  28         (*)         :: Num n => term n -> term n -> term n
  29         fromInteger :: Num n => term Integer -> term n
  30
  31         default abs         :: (Trans t term, Num n) => t term n -> t term n
  32         default negate      :: (Trans t term, Num n) => t term n -> t term n
  33         default signum      :: (Trans t term, Num n) => t term n -> t term n
  34         default (+)         :: (Trans t term, Num n) => t term n -> t term n -> t term n
  35         default (-)         :: (Trans t term, Num n) => t term n -> t term n -> t term n
  36         default (*)         :: (Trans t term, Num n) => t term n -> t term n -> t term n
  37         default fromInteger :: (Trans t term, Num n) => t term Integer -> t term n
  38
  39         abs         = trans_map1 abs
  40         negate      = trans_map1 negate
  41         signum      = trans_map1 signum
  42         (+)         = trans_map2 (+)
  43         (-)         = trans_map2 (-)
  44         (*)         = trans_map2 (*)
  45         fromInteger = trans_map1 fromInteger
  46
  47 infixl 6 +
  48 infixl 6 -
  49 infixl 7 *
  50
  51 type instance Sym_of_Iface (Proxy Num) = Sym_Num
  52 type instance TyConsts_of_Iface (Proxy Num) = Proxy Num ': TyConsts_imported_by Num
  53 type instance TyConsts_imported_by Num =
  54  '[ Proxy Integer
  55  ]
  56
  57 instance Sym_Num HostI where
  58         abs         = liftM Prelude.abs
  59         negate      = liftM Prelude.negate
  60         signum      = liftM Prelude.signum
  61         (+)         = liftM2 (Prelude.+)
  62         (-)         = liftM2 (Prelude.-)
  63         (*)         = liftM2 (Prelude.*)
  64         fromInteger = liftM Prelude.fromInteger
  65 instance Sym_Num TextI where
  66         abs         = textI1 "abs"
  67         negate      = textI1 "negate"
  68         signum      = textI1 "signum"
  69         (+)         = textI_infix "+" (infixB L 6)
  70         (-)         = textI_infix "-" (infixL 6)
  71         (*)         = textI_infix "*" (infixB L 7)
  72         fromInteger = textI1 "fromInteger"
  73 instance (Sym_Num r1, Sym_Num r2) => Sym_Num (DupI r1 r2) where
  74         abs         = dupI1 (Proxy @Sym_Num) abs
  75         negate      = dupI1 (Proxy @Sym_Num) negate
  76         signum      = dupI1 (Proxy @Sym_Num) signum
  77         (+)         = dupI2 (Proxy @Sym_Num) (+)
  78         (-)         = dupI2 (Proxy @Sym_Num) (-)
  79         (*)         = dupI2 (Proxy @Sym_Num) (*)
  80         fromInteger = dupI1 (Proxy @Sym_Num) fromInteger
  81
  82 instance
  83  ( Read_TyNameR TyName cs rs
  84  , Inj_TyConst cs Num
  85  ) => Read_TyNameR TyName cs (Proxy Num ': rs) where
  86         read_TyNameR _cs (TyName "Num") k = k (ty @Num)
  87         read_TyNameR _rs raw k = read_TyNameR (Proxy @rs) raw k
  88 instance Show_TyConst cs => Show_TyConst (Proxy Num ': cs) where
  89         show_TyConst TyConstZ{} = "Num"
  90         show_TyConst (TyConstS c) = show_TyConst c
  91
  92 instance Proj_TyConC cs (Proxy Num)
  93 data instance TokenT meta (ts::[*]) (Proxy Num)
  94  = Token_Term_Num_abs         (EToken meta ts)
  95  | Token_Term_Num_negate      (EToken meta ts)
  96  | Token_Term_Num_signum      (EToken meta ts)
  97  | Token_Term_Num_add         (EToken meta ts)
  98  | Token_Term_Num_sub         (EToken meta ts)
  99  | Token_Term_Num_mul         (EToken meta ts)
 100  | Token_Term_Num_fromInteger (EToken meta '[Proxy Token_Type])
 101 deriving instance (Eq meta, Eq_Token meta ts) => Eq (TokenT meta ts (Proxy Num))
 102 deriving instance (Show meta, Show_Token meta ts) => Show (TokenT meta ts (Proxy Num))
 103 instance -- CompileI
 104  ( Read_TyName TyName (TyConsts_of_Ifaces is)
 105  , Inj_TyConst (TyConsts_of_Ifaces is) Num
 106  , Inj_TyConst (TyConsts_of_Ifaces is) (->)
 107  , Inj_TyConst (TyConsts_of_Ifaces is) Integer
 108  , Proj_TyCon  (TyConsts_of_Ifaces is)
 109  , Compile is
 110  ) => CompileI is (Proxy Num) where
 111         compileI tok ctx k =
 112                 case tok of
 113                  Token_Term_Num_abs    tok_a -> op1_from tok_a abs
 114                  Token_Term_Num_negate tok_a -> op1_from tok_a negate
 115                  Token_Term_Num_signum tok_a -> op1_from tok_a signum
 116                  Token_Term_Num_add    tok_a -> op2_from tok_a (+)
 117                  Token_Term_Num_sub    tok_a -> op2_from tok_a (-)
 118                  Token_Term_Num_mul    tok_a -> op2_from tok_a (*)
 119                  Token_Term_Num_fromInteger tok_ty_a ->
 120                         -- fromInteger :: Num a => Integer -> a
 121                         compile_Type tok_ty_a $ \(ty_a::Type (TyConsts_of_Ifaces is) a) ->
 122                         check_Kind
 123                          (At Nothing SKiType)
 124                          (At (Just tok_ty_a) $ kind_of ty_a) $ \Refl ->
 125                         check_TyCon (At (Just tok_ty_a) (ty @Num :$ ty_a)) $ \TyCon ->
 126                         k (ty @Integer ~> ty_a) $ TermO $
 127                                 Fun.const $ lam fromInteger
 128                 where
 129                 op1_from tok_a
 130                  (op::forall term a. (Sym_Num term, Num a)
 131                          => term a -> term a) =
 132                  -- abs    :: Num a => a -> a
 133                  -- negate :: Num a => a -> a
 134                  -- signum :: Num a => a -> a
 135                         compileO tok_a ctx $ \ty_a (TermO x) ->
 136                         check_TyCon (At (Just tok_a) (ty @Num :$ ty_a)) $ \TyCon ->
 137                         k ty_a $ TermO $
 138                          \c -> op (x c)
 139                 op2_from tok_a
 140                  (op::forall term a. (Sym_Num term, Num a)
 141                          => term a -> term a -> term a) =
 142                  -- (+) :: Num a => a -> a -> a
 143                  -- (-) :: Num a => a -> a -> a
 144                  -- (*) :: Num a => a -> a -> a
 145                         compileO tok_a ctx $ \ty_a (TermO x) ->
 146                         check_TyCon (At (Just tok_a) (ty @Num :$ ty_a)) $ \TyCon ->
 147                         k (ty_a ~> ty_a) $ TermO $
 148                          \c -> lam $ \y -> op (x c) y
 149 instance -- TokenizeT
 150  Inj_Token meta ts Num =>
 151  TokenizeT meta ts (Proxy Num) where
 152         tokenizeT _t = mempty
 153          { tokenizers_infix = tokenizeTMod []
 154                  [ tokenize1 "abs"    infixN5 Token_Term_Num_abs
 155                  , tokenize1 "negate" infixN5 Token_Term_Num_negate
 156                  , tokenize1 "signum" infixN5 Token_Term_Num_signum
 157                  , tokenize1 "+" (infixB L 6) Token_Term_Num_add
 158                  , tokenize1 "-" (infixL 6) Token_Term_Num_sub
 159                  , tokenize1 "*" (infixB L 7) Token_Term_Num_mul
 160                  , (Term_Name "fromInteger",) Term_ProTok
 161                          { term_protok = \meta -> ProTokPi $ \a ->
 162                                 ProTok $ inj_EToken meta $ Token_Term_Num_fromInteger a
 163                          , term_fixity = infixN5
 164                          }
 165                  ]
 166          , tokenizers_prefix = tokenizeTMod []
 167                  [ tokenize1 "-"   (Prefix 10) Token_Term_Num_negate
 168                  ]
 169          }
 170 instance Gram_Term_AtomsT meta ts (Proxy Num) g