]> Git — Sourcephile - haskell/symantic.git/blob - Language/Symantic/Repr/Dup.hs
fix (->) by removing inline/val/lazy
[haskell/symantic.git] / Language / Symantic / Repr / Dup.hs
1 {-# LANGUAGE FlexibleContexts #-}
2 {-# LANGUAGE FlexibleInstances #-}
3 {-# LANGUAGE MultiParamTypeClasses #-}
4 {-# LANGUAGE NoImplicitPrelude #-}
5 {-# LANGUAGE TypeFamilies #-}
6 {-# LANGUAGE UndecidableInstances #-}
7 -- | Interpreter to duplicate the representation of an expression
8 -- in order to evaluate it with different interpreters.
9 --
10 -- NOTE: this is a more verbose, less clear,
11 -- and maybe less efficient alternative
12 -- to maintaining the universal polymorphism of @repr@ at parsing time
13 -- as done with 'Forall_Repr_with_Context';
14 -- it is mainly here for the sake of curiosity.
15 module Language.Symantic.Repr.Dup where
16
17 import Data.Foldable (foldr)
18
19 import Language.Symantic.Expr
20
21 -- | Interpreter's data.
22 data Dup repr1 repr2 a
23 = Dup
24 { dup1 :: repr1 a
25 , dup2 :: repr2 a
26 }
27
28 instance -- Sym_Bool
29 ( Sym_Bool r1
30 , Sym_Bool r2
31 ) => Sym_Bool (Dup r1 r2) where
32 bool x = bool x `Dup` bool x
33 not (x1 `Dup` x2) = not x1 `Dup` not x2
34 (&&) (x1 `Dup` x2) (y1 `Dup` y2) = (&&) x1 y1 `Dup` (&&) x2 y2
35 (||) (x1 `Dup` x2) (y1 `Dup` y2) = (||) x1 y1 `Dup` (||) x2 y2
36 xor (x1 `Dup` x2) (y1 `Dup` y2) = xor x1 y1 `Dup` xor x2 y2
37 instance -- Sym_Int
38 ( Sym_Int r1
39 , Sym_Int r2
40 ) => Sym_Int (Dup r1 r2) where
41 int x = int x `Dup` int x
42 abs (x1 `Dup` x2) = abs x1 `Dup` abs x2
43 negate (x1 `Dup` x2) = negate x1 `Dup` negate x2
44 (+) (x1 `Dup` x2) (y1 `Dup` y2) = (+) x1 y1 `Dup` (+) x2 y2
45 (-) (x1 `Dup` x2) (y1 `Dup` y2) = (-) x1 y1 `Dup` (-) x2 y2
46 (*) (x1 `Dup` x2) (y1 `Dup` y2) = (*) x1 y1 `Dup` (*) x2 y2
47 mod (x1 `Dup` x2) (y1 `Dup` y2) = mod x1 y1 `Dup` mod x2 y2
48 instance -- Sym_Eq
49 ( Sym_Eq r1
50 , Sym_Eq r2
51 ) => Sym_Eq (Dup r1 r2) where
52 (==) (x1 `Dup` x2) (y1 `Dup` y2) = (==) x1 y1 `Dup` (==) x2 y2
53 instance -- Sym_Ord
54 ( Sym_Ord r1
55 , Sym_Ord r2
56 ) => Sym_Ord (Dup r1 r2) where
57 compare (x1 `Dup` x2) (y1 `Dup` y2) =
58 compare x1 y1 `Dup` compare x2 y2
59 instance -- Sym_If
60 ( Sym_If r1
61 , Sym_If r2
62 ) => Sym_If (Dup r1 r2) where
63 if_ (c1 `Dup` c2) (ok1 `Dup` ok2) (ko1 `Dup` ko2) =
64 if_ c1 ok1 ko1 `Dup` if_ c2 ok2 ko2
65 instance -- Sym_When
66 ( Sym_When r1
67 , Sym_When r2
68 ) => Sym_When (Dup r1 r2) where
69 when (c1 `Dup` c2) (ok1 `Dup` ok2) =
70 when c1 ok1 `Dup` when c2 ok2
71 instance -- Sym_List
72 ( Sym_List r1
73 , Sym_List r2
74 ) => Sym_List (Dup r1 r2) where
75 list_empty = list_empty `Dup` list_empty
76 list_cons (a1 `Dup` a2) (l1 `Dup` l2) = list_cons a1 l1 `Dup` list_cons a2 l2
77 list l =
78 let (l1, l2) =
79 foldr (\(x1 `Dup` x2) (xs1, xs2) ->
80 (x1:xs1, x2:xs2)) ([], []) l in
81 list l1 `Dup` list l2
82 list_filter (f1 `Dup` f2) (l1 `Dup` l2) =
83 list_filter f1 l1 `Dup` list_filter f2 l2
84 instance -- Sym_Maybe
85 ( Sym_Maybe r1
86 , Sym_Maybe r2
87 ) => Sym_Maybe (Dup r1 r2) where
88 nothing = nothing `Dup` nothing
89 just (a1 `Dup` a2) = just a1 `Dup` just a2
90 maybe (m1 `Dup` m2) (n1 `Dup` n2) (j1 `Dup` j2) =
91 maybe m1 n1 j1 `Dup`
92 maybe m2 n2 j2
93 instance -- Sym_Lambda
94 ( Sym_Lambda r1
95 , Sym_Lambda r2
96 ) => Sym_Lambda (Dup r1 r2) where
97 ($$) (f1 `Dup` f2) (x1 `Dup` x2) = ($$) f1 x1 `Dup` ($$) f2 x2
98 lam f = dup1 (lam f) `Dup` dup2 (lam f)
99 instance -- Sym_Tuple2
100 ( Sym_Tuple2 r1
101 , Sym_Tuple2 r2
102 ) => Sym_Tuple2 (Dup r1 r2) where
103 tuple2 (a1 `Dup` a2) (b1 `Dup` b2) =
104 tuple2 a1 b1 `Dup` tuple2 a2 b2
105 instance -- Sym_Map
106 ( Sym_Map r1
107 , Sym_Map r2
108 ) => Sym_Map (Dup r1 r2) where
109 map_from_list (l1 `Dup` l2) =
110 map_from_list l1 `Dup` map_from_list l2
111 mapWithKey (f1 `Dup` f2) (m1 `Dup` m2) =
112 mapWithKey f1 m1 `Dup` mapWithKey f2 m2
113 instance -- Sym_Functor
114 ( Sym_Functor r1
115 , Sym_Functor r2
116 ) => Sym_Functor (Dup r1 r2) where
117 fmap (f1 `Dup` f2) (m1 `Dup` m2) =
118 fmap f1 m1 `Dup` fmap f2 m2
119 instance -- Sym_Applicative
120 ( Sym_Applicative r1
121 , Sym_Applicative r2
122 ) => Sym_Applicative (Dup r1 r2) where
123 pure (a1 `Dup` a2) =
124 pure a1 `Dup` pure a2
125 (<*>) (f1 `Dup` f2) (m1 `Dup` m2) =
126 (<*>) f1 m1 `Dup` (<*>) f2 m2
127 instance -- Sym_Traversable
128 ( Sym_Traversable r1
129 , Sym_Traversable r2
130 ) => Sym_Traversable (Dup r1 r2) where
131 traverse (f1 `Dup` f2) (m1 `Dup` m2) =
132 traverse f1 m1 `Dup` traverse f2 m2
133 instance -- Sym_Monad
134 ( Sym_Monad r1
135 , Sym_Monad r2
136 ) => Sym_Monad (Dup r1 r2) where
137 return (a1 `Dup` a2) =
138 return a1 `Dup` return a2
139 (>>=) (m1 `Dup` m2) (f1 `Dup` f2) =
140 (>>=) m1 f1 `Dup` (>>=) m2 f2