lcc/Hcompta/LCC/Sym/Subable.hs

   1 {-# LANGUAGE UndecidableInstances #-}
   2 {-# OPTIONS_GHC -fno-warn-orphans #-}
   3 -- | Symantic for 'Subable'.
   4 module Hcompta.LCC.Sym.Subable where
   5
   6 import Control.Monad (liftM2)
   7 import Data.Eq (Eq)
   8 import Data.Function (($))
   9 import Data.Maybe (Maybe(..))
  10 import Data.Monoid (Monoid(..))
  11 import Data.Proxy
  12 import Text.Show (Show)
  13 import qualified Prelude ()
  14
  15 import Hcompta.Quantity
  16 import Language.Symantic
  17 import Language.Symantic.Lib.Lambda
  18
  19 -- * Class 'Sym_Subable'
  20 class Sym_Subable term where
  21         (-) :: Subable n => term n -> term n -> term n; infixl 6 -
  22         default (-) :: (Trans t term, Subable n) => t term n -> t term n -> t term n
  23         (-) = trans_map2 (-)
  24
  25 type instance Sym_of_Iface (Proxy Subable) = Sym_Subable
  26 type instance TyConsts_of_Iface (Proxy Subable) = Proxy Subable ': TyConsts_imported_by (Proxy Subable)
  27 type instance TyConsts_imported_by (Proxy Subable) = '[]
  28
  29 instance Sym_Subable HostI where
  30         (-) = liftM2 quantity_sub
  31 instance Sym_Subable TextI where
  32         (-) = textI_infix "+" (infixB L 6)
  33 instance (Sym_Subable r1, Sym_Subable r2) => Sym_Subable (DupI r1 r2) where
  34         (-) = dupI2 @Sym_Subable (-)
  35
  36 instance
  37  ( Read_TyNameR TyName cs rs
  38  , Inj_TyConst cs Subable
  39  ) => Read_TyNameR TyName cs (Proxy Subable ': rs) where
  40         read_TyNameR _cs (TyName "Subable") k = k (ty @Subable)
  41         read_TyNameR _rs raw k = read_TyNameR (Proxy @rs) raw k
  42 instance Show_TyConst cs => Show_TyConst (Proxy Subable ': cs) where
  43         show_TyConst TyConstZ{} = "Subable"
  44         show_TyConst (TyConstS c) = show_TyConst c
  45
  46 instance Proj_TyConC cs (Proxy Subable)
  47 data instance TokenT meta (ts::[*]) (Proxy Subable)
  48  = Token_Term_Subable_add (EToken meta ts)
  49 deriving instance (Eq meta, Eq_Token meta ts) => Eq (TokenT meta ts (Proxy Subable))
  50 deriving instance (Show meta, Show_Token meta ts) => Show (TokenT meta ts (Proxy Subable))
  51 instance -- CompileI
  52  ( Inj_TyConst cs Subable
  53  , Inj_TyConst cs (->)
  54  , Proj_TyCon  cs
  55  , Compile cs is
  56  ) => CompileI cs is (Proxy Subable) where
  57         compileI tok ctx k =
  58                 case tok of
  59                  Token_Term_Subable_add tok_a -> op2_from tok_a (-)
  60                 where
  61                 op2_from tok_a
  62                  (op::forall term a. (Sym_Subable term, Subable a)
  63                          => term a -> term a -> term a) =
  64                  -- (-) :: Subable a => a -> a -> a
  65                         compileO tok_a ctx $ \ty_a (TermO a) ->
  66                         check_TyCon (At (Just tok_a) (ty @Subable :$ ty_a)) $ \TyCon ->
  67                         k (ty_a ~> ty_a) $ TermO $
  68                          \c -> lam $ \y -> op (a c) y
  69 instance -- TokenizeT
  70  Inj_Token meta ts Subable =>
  71  TokenizeT meta ts (Proxy Subable) where
  72         tokenizeT _t = mempty
  73          { tokenizers_infix = tokenizeTMod []
  74                  [ tokenize1 "-" (infixL 6) Token_Term_Subable_add
  75                  ]
  76          }
  77 instance Gram_Term_AtomsT meta ts (Proxy Subable) g