]> Git — Sourcephile - haskell/symantic-parser.git/blob - src/Symantic/Univariant/Trans.hs
test: save
[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, a 'trans' being not necessarily injective nor surjective.
21 type BiTrans from to = (Trans from to, Trans to from)
22
23 -- ** Class 'Liftable'
24 -- | Convenient type class synonym for using 'Output'
25 type Liftable repr = Trans (Output repr) repr
26 lift :: forall repr a.
27 Liftable repr =>
28 Output repr a -> repr a
29 lift = trans @(Output repr)
30 {-# INLINE lift #-}
31
32 unlift :: forall repr a.
33 Trans repr (Output repr) =>
34 repr a -> Output repr a
35 unlift = trans @repr
36 {-# INLINE unlift #-}
37
38 -- ** Class 'Unliftable'
39 -- | Convenient type class synonym for using 'Output'
40 type Unliftable repr = Trans repr (Output repr)
41
42 -- * Class 'Trans1'
43 class Trans1 from to where
44 trans1 ::
45 (from a -> from b) ->
46 to a -> to b
47 default trans1 ::
48 BiTrans from to =>
49 (from a -> from b) ->
50 to a -> to b
51 trans1 f = trans . f . trans
52 {-# INLINE trans1 #-}
53
54 -- ** Class 'Liftable1'
55 -- | Convenient type class synonym for using 'Output'
56 type Liftable1 repr = Trans1 (Output repr) repr
57 lift1 :: forall repr a b.
58 Liftable1 repr =>
59 (Output repr a -> Output repr b) ->
60 repr a -> repr b
61 lift1 = trans1 @(Output repr)
62 {-# INLINE lift1 #-}
63
64 -- * Class 'Trans2'
65 class Trans2 from to where
66 trans2 ::
67 (from a -> from b -> from c) ->
68 to a -> to b -> to c
69 default trans2 ::
70 BiTrans from to =>
71 (from a -> from b -> from c) ->
72 to a -> to b -> to c
73 trans2 f a b = trans (f (trans a) (trans b))
74 {-# INLINE trans2 #-}
75
76 -- ** Class 'Liftable2'
77 -- | Convenient type class synonym for using 'Output'
78 type Liftable2 repr = Trans2 (Output repr) repr
79 lift2 :: forall repr a b c.
80 Liftable2 repr =>
81 (Output repr a -> Output repr b -> Output repr c) ->
82 repr a -> repr b -> repr c
83 lift2 = trans2 @(Output repr)
84 {-# INLINE lift2 #-}
85
86 -- * Class 'Trans3'
87 class Trans3 from to where
88 trans3 ::
89 (from a -> from b -> from c -> from d) ->
90 to a -> to b -> to c -> to d
91 default trans3 ::
92 BiTrans from to =>
93 (from a -> from b -> from c -> from d) ->
94 to a -> to b -> to c -> to d
95 trans3 f a b c = trans (f (trans a) (trans b) (trans c))
96 {-# INLINE trans3 #-}
97
98 -- ** Class 'Liftable3'
99 -- | Convenient type class synonym for using 'Output'
100 type Liftable3 repr = Trans3 (Output repr) repr
101 lift3 :: forall repr a b c d.
102 Liftable3 repr =>
103 (Output repr a -> Output repr b -> Output repr c -> Output repr d) ->
104 repr a -> repr b -> repr c -> repr d
105 lift3 = trans3 @(Output repr)
106 {-# INLINE lift3 #-}
107
108 -- * Type 'Any'
109 -- | 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.
110 newtype Any repr a = Any { unAny :: repr a }
111 type instance Output (Any repr) = repr
112 instance Trans (Any repr) repr where
113 trans = unAny
114 instance Trans1 (Any repr) repr
115 instance Trans2 (Any repr) repr
116 instance Trans3 (Any repr) repr
117 instance Trans repr (Any repr) where
118 trans = Any
119 instance Trans1 repr (Any repr)
120 instance Trans2 repr (Any repr)
121 instance Trans3 repr (Any repr)