lcc/Hcompta/LCC/Sym/Quantity.hs

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