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.Decimal (Decimal)
   8 -- import Control.Applicative (Applicative(..))
   9 import Data.Eq (Eq)
  10 import Data.Function (($), (.))
  11 import Data.Functor ((<$>))
  12 import Data.Maybe (Maybe(..))
  13 import Data.Ord (Ord)
  14 import Data.Proxy
  15 -- import Data.Semigroup ((<>))
  16 import Data.Type.Equality ((:~:)(Refl))
  17 import Prelude (Enum, Real)
  18 -- import Text.Read (read)
  19 import Text.Show (Show(..))
  20 import qualified Data.Text as Text
  21 import qualified Language.Symantic.Typing as Sym
  22 import qualified Language.Symantic.Lib as Sym
  23
  24 import Hcompta (Addable, Negable)
  25 import Hcompta.LCC.Amount
  26 import Hcompta.LCC.Read
  27
  28 import Language.Symantic.Parsing
  29 import Language.Symantic.Typing
  30 import Language.Symantic.Compiling
  31 import Language.Symantic.Interpreting
  32 import Language.Symantic.Transforming.Trans
  33
  34 -- * Class 'Sym_Quantity'
  35 class Sym_Quantity term where
  36         quantity :: Quantity -> term Quantity
  37         default quantity :: Trans t term => Quantity -> t term Quantity
  38         quantity = trans_lift . quantity
  39
  40 type instance Sym_of_Iface (Proxy Quantity) = Sym_Quantity
  41 type instance TyConsts_of_Iface (Proxy Quantity) = Proxy Quantity ': TyConsts_imported_by (Proxy Quantity)
  42 type instance TyConsts_imported_by (Proxy Quantity) =
  43  [ Proxy Addable
  44  , Proxy Negable
  45  , Proxy Enum
  46  , Proxy Eq
  47  -- , Proxy Fractional
  48  -- , Proxy Num
  49  , Proxy Ord
  50  , Proxy Real
  51  -- , Proxy RealFrac
  52  , Proxy Show
  53  ]
  54
  55 instance Sym_Quantity HostI where
  56         quantity = HostI
  57 instance Sym_Quantity TextI where
  58         quantity a = TextI $ \_p _v ->
  59                 Text.pack (show a)
  60 instance (Sym_Quantity r1, Sym_Quantity r2) => Sym_Quantity (DupI r1 r2) where
  61         quantity x = quantity x `DupI` quantity x
  62
  63 instance
  64  ( Read_TyNameR TyName cs rs
  65  , Inj_TyConst cs Quantity
  66  ) => Read_TyNameR TyName cs (Proxy Quantity ': rs) where
  67         read_TyNameR _cs (TyName "Quantity") k = k (ty @Quantity)
  68         read_TyNameR _rs raw k = read_TyNameR (Proxy @rs) raw k
  69 instance Show_TyConst cs => Show_TyConst (Proxy Quantity ': cs) where
  70         show_TyConst TyConstZ{} = "Quantity"
  71         show_TyConst (TyConstS c) = show_TyConst c
  72
  73 instance Proj_TyFamC cs Sym.TyFam_MonoElement Quantity
  74
  75 instance -- Proj_TyConC
  76  ( Proj_TyConst cs Quantity
  77  , Proj_TyConsts cs (TyConsts_imported_by (Proxy Quantity))
  78  ) => Proj_TyConC cs (Proxy Quantity) where
  79         proj_TyConC _ (TyConst q :$ TyConst c)
  80          | Just Refl <- eq_skind (kind_of_TyConst c) SKiType
  81          , Just Refl <- proj_TyConst c (Proxy @Quantity)
  82          = case () of
  83                  _ | Just Refl <- proj_TyConst q (Proxy @Addable)    -> Just TyCon
  84                    | Just Refl <- proj_TyConst q (Proxy @Negable)    -> Just TyCon
  85                    | Just Refl <- proj_TyConst q (Proxy @Enum)       -> Just TyCon
  86                    | Just Refl <- proj_TyConst q (Proxy @Eq)         -> Just TyCon
  87                    {- | Just Refl <- proj_TyConst q (Proxy @Fractional) -> Just TyCon -}
  88                    {- | Just Refl <- proj_TyConst q (Proxy @Num)        -> Just TyCon -}
  89                    | Just Refl <- proj_TyConst q (Proxy @Ord)        -> Just TyCon
  90                    | Just Refl <- proj_TyConst q (Proxy @Real)       -> Just TyCon
  91                    {- | Just Refl <- proj_TyConst q (Proxy @RealFrac)   -> Just TyCon -}
  92                    | Just Refl <- proj_TyConst q (Proxy @Show)       -> Just TyCon
  93                  _ -> Nothing
  94         proj_TyConC _c _q = Nothing
  95 data instance TokenT meta (ts::[*]) (Proxy Quantity)
  96  = Token_Term_Quantity Quantity
  97 deriving instance Eq_Token meta ts => Eq (TokenT meta ts (Proxy Quantity))
  98 deriving instance Show_Token meta ts => Show (TokenT meta ts (Proxy Quantity))
  99 instance -- CompileI
 100  Inj_TyConst cs Quantity =>
 101  CompileI cs is (Proxy Quantity) where
 102         compileI tok _ctx k =
 103                 case tok of
 104                  Token_Term_Quantity i -> k (ty @Quantity) $ TermO $ \_c -> quantity i
 105 instance -- TokenizeT
 106  -- Inj_Token meta ts Quantity =>
 107  TokenizeT meta ts (Proxy Quantity)
 108 instance -- Gram_Term_AtomsT
 109  ( Alt g
 110  , Alter g
 111  , Gram_Rule g
 112  , Gram_Lexer g
 113  , Gram_Meta meta g
 114  , Gram_Amount g
 115  , Inj_Token meta ts Quantity
 116  ) => Gram_Term_AtomsT meta ts (Proxy Quantity) g where
 117         gs_term_atomsT _t =
 118          [ rule "term_quantity" $
 119                 lexeme $ metaG $
 120                 (\(qty, _sty) meta -> ProTok $ inj_EToken meta $ Token_Term_Quantity qty)
 121                  <$> g_quantity
 122                  -- <$> some (choice $ char <$> ['0'..'9'])
 123                  -- <*> option [] ((:) <$> char '.' <*> some (choice $ char <$> ['0'..'9']))
 124          ]