{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
-- | Symantic for 'Quantity'.
module Hcompta.LCC.Sym.Quantity where

import Data.Eq (Eq)
import Data.Function (($), (.))
import Data.Functor ((<$>))
import Data.Maybe (Maybe(..))
import Data.Ord (Ord)
import Data.Type.Equality ((:~:)(Refl))
import Prelude (Enum, Num, Real)
import Text.Show (Show(..))
import qualified Data.Text as Text

import Hcompta (Addable, Negable, Subable)
import Hcompta.LCC.Amount
import Hcompta.LCC.Grammar

import Language.Symantic.Grammar as Sym
import Language.Symantic
import Language.Symantic.Lib ()

-- * Class 'Sym_Quantity'
type instance Sym Quantity = Sym_Quantity
class Sym_Quantity term where
	quantity :: Quantity -> term Quantity
	default quantity :: Sym_Quantity (UnT term) => Trans term => Quantity -> term Quantity
	quantity = trans . quantity

instance Sym_Quantity Eval where
	quantity = Eval
instance Sym_Quantity View where
	quantity a = View $ \_p _v -> Text.pack (show a)
instance (Sym_Quantity r1, Sym_Quantity r2) => Sym_Quantity (Dup r1 r2) where
	quantity x = quantity x `Dup` quantity x
instance (Sym_Quantity term, Sym_Lambda term) => Sym_Quantity (BetaT term)

instance ClassInstancesFor Quantity where
	proveConstraintFor _c (TyApp _ (TyConst _ _ q) c)
	 | Just HRefl <- proj_ConstKiTy @(K Quantity) @Quantity c
	 = case () of
		 _ | Just Refl <- proj_Const @Addable q    -> Just Dict
		   | Just Refl <- proj_Const @Negable q    -> Just Dict
		   | Just Refl <- proj_Const @Subable q    -> Just Dict
		   | Just Refl <- proj_Const @Enum q       -> Just Dict
		   | Just Refl <- proj_Const @Eq q         -> Just Dict
		   -- | Just Refl <- proj_Const @Fractional q -> Just Dict
		   | Just Refl <- proj_Const @Num q        -> Just Dict
		   | Just Refl <- proj_Const @Ord q        -> Just Dict
		   | Just Refl <- proj_Const @Real q       -> Just Dict
		   -- | Just Refl <- proj_Const @RealFrac q   -> Just Dict
		   | Just Refl <- proj_Const @Show q       -> Just Dict
		 _ -> Nothing
	proveConstraintFor _c _q = Nothing
instance TypeInstancesFor Quantity
instance -- Gram_Term_AtomsFor
 ( Gram_Alt g
 , Gram_Rule g
 , Sym.Gram_Comment g
 , Gram_Source src g
 , Gram_Amount g
 , SymInj ss Quantity
 , Source src
 ) => Gram_Term_AtomsFor src ss g Quantity where
	g_term_atomsFor =
	 [ rule "teQuantity" $
		lexeme $ source $
		(\(qty, _sty) src -> BinTree0 $ Token_Term $ TermAVT $ (`setSource` src) $ teQuantity qty)
		 <$> g_quantity
		 -- <$> some (choice $ char <$> ['0'..'9'])
		 -- <*> option [] ((:) <$> char '.' <*> some (choice $ char <$> ['0'..'9']))
	 ]
instance (Source src, SymInj ss Quantity) => ModuleFor src ss Quantity where
	moduleFor = ["Quantity"] `moduleWhere`
	 [
	 ]

tyQuantity :: Source src => LenInj vs => Type src vs Quantity
tyQuantity = tyConst @(K Quantity) @Quantity

teQuantity :: Source src => SymInj ss Quantity => Quantity -> Term src ss ts '[] (() #> Quantity)
teQuantity a = Term noConstraint tyQuantity $ teSym @Quantity $ quantity a