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

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