lcc/Hcompta/LCC/Sym/Unit.hs

   1 {-# LANGUAGE UndecidableInstances #-}
   2 {-# OPTIONS_GHC -fno-warn-orphans #-}
   3 -- | Symantic for 'Unit'.
   4 module Hcompta.LCC.Sym.Unit where
   5
   6 import Data.Eq (Eq)
   7 import Data.Function (($), (.))
   8 import Data.Maybe (Maybe(..))
   9 import Data.Ord (Ord)
  10 import Data.Type.Equality ((:~:)(Refl))
  11 import Text.Show (Show(..))
  12 import qualified Language.Symantic.Typing as Sym
  13
  14 import Language.Symantic
  15
  16 import Hcompta.LCC.Amount
  17
  18 -- * Class 'Sym_Unit'
  19 type instance Sym Unit = Sym_Unit
  20 class Sym_Unit term where
  21         unit :: Unit -> term Unit
  22         default unit :: Sym_Unit (UnT term) => Trans term => Unit -> term Unit
  23         unit = trans . unit
  24
  25 instance Sym_Unit Eval where
  26         unit = Eval
  27 instance Sym_Unit View where
  28         unit (Unit u) = View $ \_p _v -> u
  29 instance (Sym_Unit r1, Sym_Unit r2) => Sym_Unit (Dup r1 r2) where
  30         unit x = unit x `Dup` unit x
  31 instance (Sym_Unit term, Sym_Lambda term) => Sym_Unit (BetaT term)
  32
  33 instance ClassInstancesFor Unit where
  34         proveConstraintFor _c (TyApp _ (TyConst _ _ q) c)
  35          | Just HRefl <- proj_ConstKiTy @(K Unit) @Unit c
  36          = case () of
  37                  _ | Just Refl <- proj_Const @Eq   q -> Just Dict
  38                    | Just Refl <- proj_Const @Ord  q -> Just Dict
  39                    | Just Refl <- proj_Const @Show q -> Just Dict
  40                  _ -> Nothing
  41         proveConstraintFor _c _q = Nothing
  42 instance TypeInstancesFor Unit
  43 instance Gram_Term_AtomsFor src ss g Unit
  44 instance (Source src, SymInj ss Unit) => ModuleFor src ss Unit where
  45         moduleFor = ["Unit"] `moduleWhere`
  46          [
  47          ]
  48
  49 tyUnit :: Source src => LenInj vs => Type src vs Unit
  50 tyUnit = tyConst @(K Unit) @Unit
  51
  52 teUnit :: Source src => SymInj ss Unit => Unit -> Term src ss ts '[] (() #> Unit)
  53 teUnit a = Term noConstraint tyUnit $ teSym @Unit $ unit a