lcc/Hcompta/LCC/Sym/Quantity.hs

   1 {-# LANGUAGE UndecidableInstances #-}
   2 {-# OPTIONS_GHC -fno-warn-orphans #-}
   3 {-# OPTIONS_GHC -fconstraint-solver-iterations=7 #-}
   4 -- | Symantic for 'Quantity'.
   5 module Hcompta.LCC.Sym.Quantity where
   6
   7 import Data.Eq (Eq)
   8 import Data.Function (($), (.))
   9 import Data.Functor ((<$>))
  10 import Data.Maybe (Maybe(..))
  11 import Data.Ord (Ord)
  12 import Data.Type.Equality ((:~:)(Refl))
  13 import Prelude (Enum, Num, Real)
  14 import Text.Show (Show(..))
  15 import qualified Data.Text as Text
  16
  17 import Hcompta (Addable, Negable, Subable)
  18 import Hcompta.LCC.Amount
  19 import Hcompta.LCC.Grammar
  20
  21 import Language.Symantic.Grammar as Sym
  22 import Language.Symantic
  23 import Language.Symantic.Lib ()
  24
  25 -- * Class 'Sym_Quantity'
  26 type instance Sym (Proxy Quantity) = Sym_Quantity
  27 class Sym_Quantity term where
  28         quantity :: Quantity -> term Quantity
  29         default quantity :: Sym_Quantity (UnT term) => Trans term => Quantity -> term Quantity
  30         quantity = trans . quantity
  31
  32 instance Sym_Quantity Eval where
  33         quantity = Eval
  34 instance Sym_Quantity View where
  35         quantity a = View $ \_p _v -> Text.pack (show a)
  36 instance (Sym_Quantity r1, Sym_Quantity r2) => Sym_Quantity (Dup r1 r2) where
  37         quantity x = quantity x `Dup` quantity x
  38 instance (Sym_Quantity term, Sym_Lambda term) => Sym_Quantity (BetaT term)
  39
  40 instance ClassInstancesFor Quantity where
  41         proveConstraintFor _c (TyApp _ (TyConst _ _ q) c)
  42          | Just HRefl <- proj_ConstKiTy @(K Quantity) @Quantity c
  43          = case () of
  44                  _ | Just Refl <- proj_Const @Addable q    -> Just Dict
  45                    | Just Refl <- proj_Const @Negable q    -> Just Dict
  46                    | Just Refl <- proj_Const @Subable q    -> Just Dict
  47                    | Just Refl <- proj_Const @Enum q       -> Just Dict
  48                    | Just Refl <- proj_Const @Eq q         -> Just Dict
  49                    -- | Just Refl <- proj_Const @Fractional q -> Just Dict
  50                    | Just Refl <- proj_Const @Num q        -> Just Dict
  51                    | Just Refl <- proj_Const @Ord q        -> Just Dict
  52                    | Just Refl <- proj_Const @Real q       -> Just Dict
  53                    -- | Just Refl <- proj_Const @RealFrac q   -> Just Dict
  54                    | Just Refl <- proj_Const @Show q       -> Just Dict
  55                  _ -> Nothing
  56         proveConstraintFor _c _q = Nothing
  57 instance TypeInstancesFor Quantity
  58 instance -- Gram_Term_AtomsFor
  59  ( Gram_Alt g
  60  , Gram_Rule g
  61  , Sym.Gram_Comment g
  62  , Gram_Amount g
  63  , Gram_Source src g
  64  , Inj_Sym ss Quantity
  65  , Source src
  66  ) => Gram_Term_AtomsFor src ss g Quantity where
  67         g_term_atomsFor =
  68          [ rule "teQuantity" $
  69                 lexeme $ g_source $
  70                 (\(qty, _sty) src -> BinTree0 $ Token_Term $ TermAVT $ (`setSource` src) $ teQuantity qty)
  71                  <$> g_quantity
  72                  -- <$> some (choice $ char <$> ['0'..'9'])
  73                  -- <*> option [] ((:) <$> char '.' <*> some (choice $ char <$> ['0'..'9']))
  74          ]
  75 instance (Source src, Inj_Sym ss Quantity) => ModuleFor src ss Quantity where
  76         moduleFor = ["Quantity"] `moduleWhere`
  77          [
  78          ]
  79
  80 tyQuantity :: Source src => Inj_Len vs => Type src vs Quantity
  81 tyQuantity = tyConst @(K Quantity) @Quantity
  82
  83 teQuantity :: Source src => Inj_Sym ss Quantity => Quantity -> Term src ss ts '[] (() #> Quantity)
  84 teQuantity a = Term noConstraint tyQuantity $ teSym @Quantity $ quantity a