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