]> Git — Sourcephile - haskell/symantic-parser.git/blob - src/Symantic/Univariant/Trans.hs
add benchmarks
[haskell/symantic-parser.git] / src / Symantic / Univariant / Trans.hs
1 {-# LANGUAGE ConstraintKinds #-} -- For type class synonyms
2 {-# LANGUAGE DefaultSignatures #-} -- For adding Trans* constraints
3 module Symantic.Univariant.Trans where
4
5 -- TODO: move to symantic-univariant
6
7 import Data.Function ((.))
8 import Data.Kind (Type)
9
10 -- * Type family 'Output'
11 type family Output (repr :: Type -> Type) :: Type -> Type
12
13 -- * Class 'Trans'
14 -- | A 'trans'lation from an interpreter @(from)@ to an interpreter @(to)@.
15 class Trans from to where
16 trans :: from a -> to a
17
18 -- * Class 'BiTrans'
19 -- | Convenient type class synonym.
20 -- Note that this is not necessarily a bijective 'trans'lation,
21 -- a 'trans' being not necessarily injective nor surjective.
22 type BiTrans from to = (Trans from to, Trans to from)
23
24 -- ** Class 'Liftable'
25 -- | Convenient type class synonym for using 'Output'
26 type Liftable repr = Trans (Output repr) repr
27 lift :: forall repr a.
28 Liftable repr =>
29 Output repr a -> repr a
30 lift = trans @(Output repr)
31 {-# INLINE lift #-}
32
33 unlift :: forall repr a.
34 Trans repr (Output repr) =>
35 repr a -> Output repr a
36 unlift = trans @repr
37 {-# INLINE unlift #-}
38
39 -- ** Class 'Unliftable'
40 -- | Convenient type class synonym for using 'Output'
41 type Unliftable repr = Trans repr (Output repr)
42
43 -- * Class 'Trans1'
44 class Trans1 from to where
45 trans1 ::
46 (from a -> from b) ->
47 to a -> to b
48 default trans1 ::
49 BiTrans from to =>
50 (from a -> from b) ->
51 to a -> to b
52 trans1 f = trans . f . trans
53 {-# INLINE trans1 #-}
54
55 -- ** Class 'Liftable1'
56 -- | Convenient type class synonym for using 'Output'
57 type Liftable1 repr = Trans1 (Output repr) repr
58 lift1 :: forall repr a b.
59 Liftable1 repr =>
60 (Output repr a -> Output repr b) ->
61 repr a -> repr b
62 lift1 = trans1 @(Output repr)
63 {-# INLINE lift1 #-}
64
65 -- * Class 'Trans2'
66 class Trans2 from to where
67 trans2 ::
68 (from a -> from b -> from c) ->
69 to a -> to b -> to c
70 default trans2 ::
71 BiTrans from to =>
72 (from a -> from b -> from c) ->
73 to a -> to b -> to c
74 trans2 f a b = trans (f (trans a) (trans b))
75 {-# INLINE trans2 #-}
76
77 -- ** Class 'Liftable2'
78 -- | Convenient type class synonym for using 'Output'
79 type Liftable2 repr = Trans2 (Output repr) repr
80 lift2 :: forall repr a b c.
81 Liftable2 repr =>
82 (Output repr a -> Output repr b -> Output repr c) ->
83 repr a -> repr b -> repr c
84 lift2 = trans2 @(Output repr)
85 {-# INLINE lift2 #-}
86
87 -- * Class 'Trans3'
88 class Trans3 from to where
89 trans3 ::
90 (from a -> from b -> from c -> from d) ->
91 to a -> to b -> to c -> to d
92 default trans3 ::
93 BiTrans from to =>
94 (from a -> from b -> from c -> from d) ->
95 to a -> to b -> to c -> to d
96 trans3 f a b c = trans (f (trans a) (trans b) (trans c))
97 {-# INLINE trans3 #-}
98
99 -- ** Class 'Liftable3'
100 -- | Convenient type class synonym for using 'Output'
101 type Liftable3 repr = Trans3 (Output repr) repr
102 lift3 :: forall repr a b c d.
103 Liftable3 repr =>
104 (Output repr a -> Output repr b -> Output repr c -> Output repr d) ->
105 repr a -> repr b -> repr c -> repr d
106 lift3 = trans3 @(Output repr)
107 {-# INLINE lift3 #-}
108
109 -- * Type 'Any'
110 -- | A newtype to disambiguate the 'Trans' instance to any other interpreter when there is also one or more 'Trans's to other interpreters with a different interpretation than the generic one.
111 newtype Any repr a = Any { unAny :: repr a }
112 type instance Output (Any repr) = repr
113 instance Trans (Any repr) repr where
114 trans = unAny
115 instance Trans1 (Any repr) repr
116 instance Trans2 (Any repr) repr
117 instance Trans3 (Any repr) repr
118 instance Trans repr (Any repr) where
119 trans = Any
120 instance Trans1 repr (Any repr)
121 instance Trans2 repr (Any repr)
122 instance Trans3 repr (Any repr)