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 instance -- Sym_Integer
  43  ( Sym_Integer r1
  44  , Sym_Integer r2
  45  ) => Sym_Integer (Dup r1 r2) where
  46         integer x = integer x `Dup` integer x
  47 instance -- Sym_Num
  48  ( Sym_Num r1
  49  , Sym_Num r2
  50  ) => Sym_Num (Dup r1 r2) where
  51         abs    (x1 `Dup` x2)               = abs x1    `Dup` abs x2
  52         negate (x1 `Dup` x2)               = negate x1 `Dup` negate x2
  53         (+)    (x1 `Dup` x2) (y1 `Dup` y2) = (+) x1 y1 `Dup` (+) x2 y2
  54         (-)    (x1 `Dup` x2) (y1 `Dup` y2) = (-) x1 y1 `Dup` (-) x2 y2
  55         (*)    (x1 `Dup` x2) (y1 `Dup` y2) = (*) x1 y1 `Dup` (*) x2 y2
  56 instance -- Sym_Integral
  57  ( Sym_Integral r1
  58  , Sym_Integral r2
  59  ) => Sym_Integral (Dup r1 r2) where
  60         quot      (x1 `Dup` x2) (y1 `Dup` y2) = quot      x1 y1 `Dup` quot      x2 y2
  61         div       (x1 `Dup` x2) (y1 `Dup` y2) = div       x1 y1 `Dup` div       x2 y2
  62         rem       (x1 `Dup` x2) (y1 `Dup` y2) = rem       x1 y1 `Dup` rem       x2 y2
  63         mod       (x1 `Dup` x2) (y1 `Dup` y2) = mod       x1 y1 `Dup` mod       x2 y2
  64         quotRem   (x1 `Dup` x2) (y1 `Dup` y2) = quotRem   x1 y1 `Dup` quotRem   x2 y2
  65         divMod    (x1 `Dup` x2) (y1 `Dup` y2) = divMod    x1 y1 `Dup` divMod    x2 y2
  66         toInteger (x1 `Dup` x2)               = toInteger x1    `Dup` toInteger x2
  67 instance -- Sym_Eq
  68  ( Sym_Eq r1
  69  , Sym_Eq r2
  70  ) => Sym_Eq (Dup r1 r2) where
  71         (==) (x1 `Dup` x2) (y1 `Dup` y2) = (==) x1 y1 `Dup` (==) x2 y2
  72 instance -- Sym_Ord
  73  ( Sym_Ord r1
  74  , Sym_Ord r2
  75  ) => Sym_Ord (Dup r1 r2) where
  76         compare (x1 `Dup` x2) (y1 `Dup` y2) =
  77                 compare x1 y1 `Dup` compare x2 y2
  78 instance -- Sym_If
  79  ( Sym_If r1
  80  , Sym_If r2
  81  ) => Sym_If (Dup r1 r2) where
  82         if_ (c1 `Dup` c2) (ok1 `Dup` ok2) (ko1 `Dup` ko2) =
  83                 if_ c1 ok1 ko1 `Dup` if_ c2 ok2 ko2
  84 instance -- Sym_When
  85  ( Sym_When r1
  86  , Sym_When r2
  87  ) => Sym_When (Dup r1 r2) where
  88         when (c1 `Dup` c2) (ok1 `Dup` ok2) =
  89                 when c1 ok1 `Dup` when c2 ok2
  90 instance -- Sym_List
  91  ( Sym_List r1
  92  , Sym_List r2
  93  ) => Sym_List (Dup r1 r2) where
  94         list_empty = list_empty `Dup` list_empty
  95         list_cons (a1 `Dup` a2) (l1 `Dup` l2) = list_cons a1 l1 `Dup` list_cons a2 l2
  96         list l =
  97                 let (l1, l2) =
  98                         foldr (\(x1 `Dup` x2) (xs1, xs2) ->
  99                                 (x1:xs1, x2:xs2)) ([], []) l in
 100                 list l1 `Dup` list l2
 101         list_filter (f1 `Dup` f2) (l1 `Dup` l2) =
 102                 list_filter f1 l1 `Dup` list_filter f2 l2
 103         list_zipWith (f1 `Dup` f2) (la1 `Dup` la2) (lb1 `Dup` lb2) =
 104                 list_zipWith f1 la1 lb1 `Dup` list_zipWith f2 la2 lb2
 105         list_reverse (l1 `Dup` l2) =
 106                 list_reverse l1 `Dup` list_reverse l2
 107 instance -- Sym_Maybe
 108  ( Sym_Maybe r1
 109  , Sym_Maybe r2
 110  ) => Sym_Maybe (Dup r1 r2) where
 111         nothing = nothing `Dup` nothing
 112         just (a1 `Dup` a2) = just a1 `Dup` just a2
 113         maybe (m1 `Dup` m2) (n1 `Dup` n2) (j1 `Dup` j2) =
 114                 maybe m1 n1 j1 `Dup`
 115                 maybe m2 n2 j2
 116 instance -- Sym_Lambda
 117  ( Sym_Lambda r1
 118  , Sym_Lambda r2
 119  ) => Sym_Lambda (Dup r1 r2) where
 120         ($$) (f1 `Dup` f2) (x1 `Dup` x2) = ($$) f1 x1 `Dup` ($$) f2 x2
 121         lam f = dup1 (lam f) `Dup` dup2 (lam f)
 122 instance -- Sym_Tuple2
 123  ( Sym_Tuple2 r1
 124  , Sym_Tuple2 r2
 125  ) => Sym_Tuple2 (Dup r1 r2) where
 126         tuple2 (a1 `Dup` a2) (b1 `Dup` b2) =
 127                 tuple2 a1 b1 `Dup` tuple2 a2 b2
 128         fst (t1 `Dup` t2) = fst t1 `Dup` fst t2
 129         snd (t1 `Dup` t2) = snd t1 `Dup` snd t2
 130 instance -- Sym_Map
 131  ( Sym_Map r1
 132  , Sym_Map r2
 133  ) => Sym_Map (Dup r1 r2) where
 134         map_from_list (l1 `Dup` l2) =
 135                 map_from_list l1 `Dup` map_from_list l2
 136         mapWithKey (f1 `Dup` f2) (m1 `Dup` m2) =
 137                 mapWithKey f1 m1 `Dup` mapWithKey f2 m2
 138         map_lookup (k1 `Dup` k2) (m1 `Dup` m2) =
 139                 map_lookup k1 m1 `Dup` map_lookup k2 m2
 140         map_keys (m1 `Dup` m2) =
 141                 map_keys m1 `Dup` map_keys m2
 142         map_member (k1 `Dup` k2) (m1 `Dup` m2) =
 143                 map_member k1 m1 `Dup` map_member k2 m2
 144         map_insert (k1 `Dup` k2) (a1 `Dup` a2) (m1 `Dup` m2) =
 145                 map_insert k1 a1 m1 `Dup` map_insert k2 a2 m2
 146         map_delete (k1 `Dup` k2) (m1 `Dup` m2) =
 147                 map_delete k1 m1 `Dup` map_delete k2 m2
 148         map_difference (ma1 `Dup` ma2) (mb1 `Dup` mb2) =
 149                 map_difference ma1 mb1 `Dup` map_difference ma2 mb2
 150         map_foldrWithKey (f1 `Dup` f2) (b1 `Dup` b2) (m1 `Dup` m2) =
 151                 map_foldrWithKey f1 b1 m1 `Dup` map_foldrWithKey f2 b2 m2
 152 instance -- Sym_Functor
 153  ( Sym_Functor r1
 154  , Sym_Functor r2
 155  ) => Sym_Functor (Dup r1 r2) where
 156         fmap (f1 `Dup` f2) (m1 `Dup` m2) =
 157                 fmap f1 m1 `Dup` fmap f2 m2
 158 instance -- Sym_Applicative
 159  ( Sym_Applicative r1
 160  , Sym_Applicative r2
 161  ) => Sym_Applicative (Dup r1 r2) where
 162         pure (a1 `Dup` a2) =
 163                 pure a1 `Dup` pure a2
 164         (<*>) (f1 `Dup` f2) (m1 `Dup` m2) =
 165                 (<*>) f1 m1 `Dup` (<*>) f2 m2
 166 instance -- Sym_Traversable
 167  ( Sym_Traversable r1
 168  , Sym_Traversable r2
 169  ) => Sym_Traversable (Dup r1 r2) where
 170         traverse (f1 `Dup` f2) (m1 `Dup` m2) =
 171                 traverse f1 m1 `Dup` traverse f2 m2
 172 instance -- Sym_Monad
 173  ( Sym_Monad r1
 174  , Sym_Monad r2
 175  ) => Sym_Monad (Dup r1 r2) where
 176         return (a1 `Dup` a2) =
 177                 return a1 `Dup` return a2
 178         (>>=) (m1 `Dup` m2) (f1 `Dup` f2) =
 179                 (>>=) m1 f1 `Dup` (>>=) m2 f2