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 ClassInstancesFor Quantity where
  40         proveConstraintFor _c (TyApp _ (TyConst _ _ q) c)
  41          | Just HRefl <- proj_ConstKiTy @(K Quantity) @Quantity c
  42          = case () of
  43                  _ | Just Refl <- proj_Const @Addable q    -> Just Dict
  44                    | Just Refl <- proj_Const @Negable q    -> Just Dict
  45                    | Just Refl <- proj_Const @Subable q    -> Just Dict
  46                    | Just Refl <- proj_Const @Enum q       -> Just Dict
  47                    | Just Refl <- proj_Const @Eq q         -> Just Dict
  48                    -- | Just Refl <- proj_Const @Fractional q -> Just Dict
  49                    | Just Refl <- proj_Const @Num q        -> Just Dict
  50                    | Just Refl <- proj_Const @Ord q        -> Just Dict
  51                    | Just Refl <- proj_Const @Real q       -> Just Dict
  52                    -- | Just Refl <- proj_Const @RealFrac q   -> Just Dict
  53                    | Just Refl <- proj_Const @Show q       -> Just Dict
  54                  _ -> Nothing
  55         proveConstraintFor _c _q = Nothing
  56 instance TypeInstancesFor Quantity
  57 instance -- Gram_Term_AtomsFor
  58  ( Gram_Alt g
  59  , Gram_Rule g
  60  , Sym.Gram_Comment g
  61  , Gram_Source src g
  62  , Gram_Amount g
  63  , SymInj ss Quantity
  64  , Source src
  65  ) => Gram_Term_AtomsFor src ss g Quantity where
  66         g_term_atomsFor =
  67          [ rule "teQuantity" $
  68                 lexeme $ source $
  69                 (\(qty, _sty) src -> BinTree0 $ Token_Term $ TermAVT $ (`setSource` src) $ teQuantity qty)
  70                  <$> g_quantity
  71                  -- <$> some (choice $ char <$> ['0'..'9'])
  72                  -- <*> option [] ((:) <$> char '.' <*> some (choice $ char <$> ['0'..'9']))
  73          ]
  74 instance (Source src, SymInj ss Quantity) => ModuleFor src ss Quantity where
  75         moduleFor = ["Quantity"] `moduleWhere`
  76          [
  77          ]
  78
  79 tyQuantity :: Source src => LenInj vs => Type src vs Quantity
  80 tyQuantity = tyConst @(K Quantity) @Quantity
  81
  82 teQuantity :: Source src => SymInj ss Quantity => Quantity -> Term src ss ts '[] (() #> Quantity)
  83 teQuantity a = Term noConstraint tyQuantity $ teSym @Quantity $ quantity a