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 Language.Symantic
   7 import Language.Symantic.Lib (a0)
   8
   9 import Hcompta.Quantity as H hiding ((-))
  10 import qualified Hcompta.Quantity as H
  11
  12 -- * Class 'Sym_Subable'
  13 type instance Sym Subable = Sym_Subable
  14 class Sym_Subable term where
  15         (-) :: Subable a => term a -> term a -> term a; infixl 6 -
  16         default (-) :: Sym_Subable (UnT term) => Trans term => Subable a => term a -> term a -> term a
  17         (-) = trans2 (-)
  18
  19 instance Sym_Subable Eval where
  20         (-) = eval2 (H.-)
  21 instance Sym_Subable View where
  22         (-) = viewInfix "-" (infixB SideL 6)
  23 instance (Sym_Subable r1, Sym_Subable r2) => Sym_Subable (Dup r1 r2) where
  24         (-) = dup2 @Sym_Subable (-)
  25 instance (Sym_Subable term, Sym_Lambda term) => Sym_Subable (BetaT term)
  26
  27 instance NameTyOf Subable where
  28         nameTyOf _c = ["LCC"] `Mod` "Subable"
  29 instance FixityOf Subable
  30 instance ClassInstancesFor Subable
  31 instance TypeInstancesFor Subable
  32 instance Gram_Term_AtomsFor src ss g Subable
  33 instance (Source src, SymInj ss Subable) => ModuleFor src ss Subable where
  34         moduleFor = ["LCC"] `moduleWhere`
  35          [ "-" `withInfixB` (SideL, 6) := teSubable_sub
  36          ]
  37
  38 tySubable :: Source src => Type src vs a -> Type src vs (Subable a)
  39 tySubable a = tyConstLen @(K Subable) @Subable (lenVars a) `tyApp` a
  40
  41 teSubable_sub :: TermDef Subable '[Proxy a] (Subable a #> (a -> a -> a))
  42 teSubable_sub = Term (tySubable a0) (a0 ~> a0 ~> a0) (teSym @Subable (lam2 (-)))