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 NameTyOf Semigroup where
  40         nameTyOf _c = ["Semigroup"] `Mod` "Semigroup"
  41 instance FixityOf Semigroup
  42 instance ClassInstancesFor Semigroup
  43 instance TypeInstancesFor Semigroup
  44
  45 -- Compiling
  46 instance Gram_Term_AtomsFor src ss g Semigroup
  47 instance (Source src, SymInj ss Semigroup) => ModuleFor src ss Semigroup where
  48         moduleFor = ["Semigroup"] `moduleWhere`
  49          [ "<>" `withInfixR` 6 := teSemigroup_sappend
  50          , "stimes" := teSemigroup_stimes
  51          ]
  52
  53 -- ** 'Type's
  54 tySemigroup :: Source src => Type src vs a -> Type src vs (Semigroup a)
  55 tySemigroup a = tyConstLen @(K Semigroup) @Semigroup (lenVars a) `tyApp` a
  56
  57 -- ** 'Term's
  58 teSemigroup_sappend :: TermDef Semigroup '[Proxy a] (Semigroup a #> (a -> a -> a))
  59 teSemigroup_sappend = Term (tySemigroup a0) (a0 ~> a0 ~> a0) $ teSym @Semigroup $ lam2 (<>)
  60
  61 teSemigroup_stimes :: TermDef Semigroup '[Proxy a, Proxy b] (Semigroup a # Integral b #> (b -> a -> a))
  62 teSemigroup_stimes = Term (tySemigroup a0 # tyIntegral b1) (b1 ~> a0 ~> a0) $ teSym @Semigroup $ lam2 stimes