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

import Control.Applicative (Applicative(..))
import Data.Eq (Eq)
import Data.Function (($), (.), id)
import Data.Functor (Functor(..), (<$>))
import Data.Maybe (Maybe(..))
import Text.Show (Show(..))
import qualified Data.MonoTraversable as MT
import qualified Data.NonNull as NonNull
import qualified Data.Text as Text
import qualified Prelude ()

import Language.Symantic.Grammar
import Language.Symantic hiding (Name)
import Language.Symantic.Lib (Element)

import Hcompta.LCC.Account
import Hcompta.LCC.Name

-- * Class 'Sym_Account'
type instance Sym (Proxy Account) = Sym_Account
class Sym_Account term where
	account :: Account -> term Account
	default account :: Sym_Account (UnT term) => Trans term => Account -> term Account
	account = trans . account

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

instance ClassInstancesFor Account where
	proveConstraintFor _c (TyApp _ (TyConst _ _ q) c)
	 | Just HRefl <- proj_ConstKiTy @(K Account) @Account c
	 = case () of
		 _ | Just Refl <- proj_Const @Eq   q -> Just Dict
		   | Just Refl <- proj_Const @Show q -> Just Dict
		 _ -> Nothing
	proveConstraintFor _c _q = Nothing
instance TypeInstancesFor Account where
	expandFamFor _c len f (c `TypesS` TypesZ)
	 | Just HRefl <- proj_ConstKi @_ @Element f
	 , Just HRefl <- proj_ConstKiTy @_ @Account c
	 = Just $ tyConstLen @(K (MT.Element Account)) @(MT.Element Account) len
	expandFamFor _c _len _fam _as = Nothing
instance -- Gram_Term_AtomsFor
 ( Gram_Alt g
 , Gram_Rule g
 , Gram_Comment g
 , Gram_Source src g
 , Inj_Sym ss Account
 ) => Gram_Term_AtomsFor src ss g Account where
	g_term_atomsFor =
	 [ rule "term_account" $
		lexeme $ g_source $
		(\a src -> BinTree0 $ Token_Term $ TermAVT $ (`setSource` src) $ teAccount a)
		 <$> g_account
	 ]
		where
		g_account :: CF g Account
		g_account =
			Account . NonNull.impureNonNull
			 <$> some (id <$ char '/' <*> g_account_section)
		g_account_section :: CF g Account_Section
		g_account_section =
			Name . Text.pack
			 <$> some (choice $ unicat <$> [Unicat_Letter])
instance (Source src, Inj_Sym ss Account) => ModuleFor src ss Account where
	moduleFor = ["Account"] `moduleWhere`
	 [
	 ]

tyAccount :: Source src => Inj_Len vs => Type src vs Account
tyAccount = tyConst @(K Account) @Account

teAccount :: Source src => Inj_Sym ss Account => Account -> Term src ss ts '[] (() #> Account)
teAccount a = Term noConstraint tyAccount $ teSym @Account $ account a

-- * Class 'Sym_Name'
type instance Sym (Proxy Name) = Sym_Name
class Sym_Name (term:: * -> *) where

instance Sym_Name Eval where
instance Sym_Name View where
instance (Sym_Name r1, Sym_Name r2) => Sym_Name (Dup r1 r2) where

instance ClassInstancesFor Name where
	proveConstraintFor _c (TyApp _ (TyConst _ _ q) c)
	 | Just HRefl <- proj_ConstKiTy @(K Name) @Name c
	 = case () of
		 _ | Just Refl <- proj_Const @Eq   q -> Just Dict
		   | Just Refl <- proj_Const @Show q -> Just Dict
		 _ -> Nothing
	proveConstraintFor _c _q = Nothing
instance TypeInstancesFor Name where
	expandFamFor _c len f (c `TypesS` TypesZ)
	 | Just HRefl <- proj_ConstKi @_ @Element f
	 , Just HRefl <- proj_ConstKiTy @_ @Name c
	 = Just $ tyConstLen @(K (MT.Element Name)) @(MT.Element Name) len
	expandFamFor _c _len _fam _as = Nothing
instance Gram_Term_AtomsFor src ss g Name
instance (Source src, Inj_Sym ss Name) => ModuleFor src ss Name where
	moduleFor = ["Name"] `moduleWhere`
	 [
	 ]