symantic-lib/Language/Symantic/Lib/Semigroup.hs

   1 {-# LANGUAGE UndecidableInstances #-}
   2 {-# OPTIONS_GHC -fno-warn-orphans #-}
   3 -- | Symantic for 'Semigroup'.
   4 module Language.Symantic.Lib.Semigroup where
   5
   6 import Data.Semigroup (Semigroup)
   7 import qualified Data.Semigroup as Semigroup
   8
   9 import Language.Symantic
  10 import Language.Symantic.Lib.Function (a0, b1)
  11 import Language.Symantic.Lib.Integral (tyIntegral)
  12
  13 -- * Class 'Sym_Semigroup'
  14 type instance Sym Semigroup = Sym_Semigroup
  15 class Sym_Semigroup term where
  16         (<>)   :: Semigroup a => term a -> term a -> term a
  17         stimes :: (Semigroup a, Integral b) => term b -> term a -> term a
  18         -- sconcat :: NonEmpty a -> a
  19         default (<>)   :: Sym_Semigroup (UnT term) => Trans term => Semigroup a => term a -> term a -> term a
  20         default stimes :: Sym_Semigroup (UnT term) => Trans term => Semigroup a => Integral b => term b -> term a -> term a
  21         (<>)   = trans2 (<>)
  22         stimes = trans2 stimes
  23
  24 -- Interpreting
  25 instance Sym_Semigroup Eval where
  26         (<>)   = eval2 (Semigroup.<>)
  27         stimes = eval2 Semigroup.stimes
  28 instance Sym_Semigroup View where
  29         (<>)   = viewInfix "-" (infixR 6)
  30         stimes = view2 "stimes"
  31 instance (Sym_Semigroup r1, Sym_Semigroup r2) => Sym_Semigroup (Dup r1 r2) where
  32         (<>)   = dup2 @Sym_Semigroup (<>)
  33         stimes = dup2 @Sym_Semigroup stimes
  34
  35 -- Transforming
  36 instance (Sym_Semigroup term, Sym_Lambda term) => Sym_Semigroup (BetaT term)
  37
  38 -- Typing
  39 instance FixityOf Semigroup
  40 instance ClassInstancesFor Semigroup
  41 instance TypeInstancesFor Semigroup
  42
  43 -- Compiling
  44 instance Gram_Term_AtomsFor src ss g Semigroup
  45 instance (Source src, Inj_Sym ss Semigroup) => ModuleFor src ss Semigroup where
  46         moduleFor = ["Semigroup"] `moduleWhere`
  47          [ "<>" `withInfixR` 6 := teSemigroup_sappend
  48          , "stimes" := teSemigroup_stimes
  49          ]
  50
  51 -- ** 'Type's
  52 tySemigroup :: Source src => Type src vs a -> Type src vs (Semigroup a)
  53 tySemigroup a = tyConstLen @(K Semigroup) @Semigroup (lenVars a) `tyApp` a
  54
  55 -- ** 'Term's
  56 teSemigroup_sappend :: TermDef Semigroup '[Proxy a] (Semigroup a #> (a -> a -> a))
  57 teSemigroup_sappend = Term (tySemigroup a0) (a0 ~> a0 ~> a0) $ teSym @Semigroup $ lam2 (<>)
  58
  59 teSemigroup_stimes :: TermDef Semigroup '[Proxy a, Proxy b] (Semigroup a # Integral b #> (b -> a -> a))
  60 teSemigroup_stimes = Term (tySemigroup a0 # tyIntegral b1) (b1 ~> a0 ~> a0) $ teSym @Semigroup $ lam2 stimes