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