lcc/Hcompta/LCC/Sym/Addable.hs

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