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

   1 {-# LANGUAGE UndecidableInstances #-}
   2 {-# OPTIONS_GHC -fno-warn-orphans #-}
   3 {-# OPTIONS_GHC -fconstraint-solver-iterations=6 #-}
   4 -- | Symantic for 'Real'.
   5 module Language.Symantic.Lib.Real where
   6
   7 import Control.Monad (liftM)
   8 import Data.Proxy
   9 import Data.Ratio (Ratio)
  10 import Prelude (Real)
  11 import Prelude hiding (Real(..))
  12 import qualified Prelude
  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
  20 -- * Class 'Sym_Real'
  21 class Sym_Real term where
  22         toRational :: Real a => term a -> term Rational
  23         default toRational :: (Trans t term, Real a) => t term a -> t term Rational
  24         toRational = trans_map1 toRational
  25
  26 type instance Sym_of_Iface (Proxy Real) = Sym_Real
  27 type instance TyConsts_of_Iface (Proxy Real) = Proxy Real ': TyConsts_imported_by (Proxy Real)
  28 type instance TyConsts_imported_by (Proxy Real) =
  29  [ Proxy Ratio
  30  , Proxy Integer
  31  ]
  32
  33 instance Sym_Real HostI where
  34         toRational = liftM  Prelude.toRational
  35 instance Sym_Real TextI where
  36         toRational = textI1 "toRational"
  37 instance (Sym_Real r1, Sym_Real r2) => Sym_Real (DupI r1 r2) where
  38         toRational = dupI1 @Sym_Real toRational
  39
  40 instance
  41  ( Read_TyNameR TyName cs rs
  42  , Inj_TyConst cs Real
  43  ) => Read_TyNameR TyName cs (Proxy Real ': rs) where
  44         read_TyNameR _cs (TyName "Real") k = k (ty @Real)
  45         read_TyNameR _rs raw k = read_TyNameR (Proxy @rs) raw k
  46 instance Show_TyConst cs => Show_TyConst (Proxy Real ': cs) where
  47         show_TyConst TyConstZ{} = "Real"
  48         show_TyConst (TyConstS c) = show_TyConst c
  49
  50 instance Proj_TyConC cs (Proxy Real)
  51 data instance TokenT meta (ts::[*]) (Proxy Real)
  52  =  Token_Term_Real (EToken meta ts)
  53 deriving instance (Eq meta, Eq_Token meta ts) => Eq (TokenT meta ts (Proxy Real))
  54 deriving instance (Show meta, Show_Token meta ts) => Show (TokenT meta ts (Proxy Real))
  55
  56 instance -- CompileI
  57  ( Read_TyName TyName cs
  58  , Inj_TyConst cs Real
  59  , Inj_TyConsts cs (TyConsts_imported_by (Proxy Real))
  60  , Proj_TyCon cs
  61  , Compile cs is
  62  ) => CompileI cs is (Proxy Real) where
  63         compileI tok ctx k =
  64                 case tok of
  65                  Token_Term_Real tok_a ->
  66                         -- toRational :: a -> Rational
  67                         compileO tok_a ctx $ \ty_a (TermO a) ->
  68                         check_TyCon (At (Just tok_a) (ty @Real :$ ty_a)) $ \TyCon ->
  69                         k (ty @Ratio :$ ty @Integer) $ TermO $
  70                          \c -> toRational (a c)
  71 instance -- TokenizeT
  72  Inj_Token meta ts Real =>
  73  TokenizeT meta ts (Proxy Real) where
  74         tokenizeT _t = mempty
  75          { tokenizers_infix = tokenizeTMod []
  76                  [ tokenize1 "toRational" infixN5 Token_Term_Real
  77                  ]
  78          }
  79 instance Gram_Term_AtomsT meta ts (Proxy Real) g