]> Git — Sourcephile - haskell/symantic.git/blob - symantic-lib/Language/Symantic/Lib/Monoid.hs
Support GHC-8.4.3.
[haskell/symantic.git] / 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