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 instance -- Sym_List_Lam
  83  ( Sym_List_Lam lam r1
  84  , Sym_List_Lam lam r2
  85  ) => Sym_List_Lam lam (Dup r1 r2) where
  86         list_filter (f1 `Dup` f2) (l1 `Dup` l2) =
  87                 list_filter f1 l1 `Dup` list_filter f2 l2
  88 instance -- Sym_Maybe
  89  ( Sym_Maybe r1
  90  , Sym_Maybe r2
  91  ) => Sym_Maybe (Dup r1 r2) where
  92         nothing = nothing `Dup` nothing
  93         just (a1 `Dup` a2) = just a1 `Dup` just a2
  94 instance -- Sym_Maybe_Lam
  95  ( Sym_Maybe_Lam lam r1
  96  , Sym_Maybe_Lam lam r2
  97  ) => Sym_Maybe_Lam lam (Dup r1 r2) where
  98         maybe (m1 `Dup` m2) (n1 `Dup` n2) (j1 `Dup` j2) =
  99                 maybe m1 n1 j1 `Dup`
 100                 maybe m2 n2 j2
 101 type instance Lambda_from_Repr (Dup r1 r2) = Lambda_from_Repr r1
 102 instance -- Sym_Lambda_App
 103  ( Sym_Lambda_App lam r1
 104  , Sym_Lambda_App lam r2
 105  ) => Sym_Lambda_App lam (Dup r1 r2) where
 106         app (f1 `Dup` f2) (x1 `Dup` x2) = app f1 x1 `Dup` app f2 x2
 107 instance -- Sym_Lambda_Inline
 108  ( Sym_Lambda_Inline lam r1
 109  , Sym_Lambda_Inline lam r2
 110  ) => Sym_Lambda_Inline lam (Dup r1 r2) where
 111         inline f = dup1 (inline f) `Dup` dup2 (inline f)
 112 instance -- Sym_Lambda_Val
 113  ( Sym_Lambda_Val lam r1
 114  , Sym_Lambda_Val lam r2
 115  ) => Sym_Lambda_Val lam (Dup r1 r2) where
 116         val f = dup1 (val f) `Dup` dup2 (val f)
 117 instance -- Sym_Lambda_Lazy
 118  ( Sym_Lambda_Lazy lam r1
 119  , Sym_Lambda_Lazy lam r2
 120  ) => Sym_Lambda_Lazy lam (Dup r1 r2) where
 121         lazy f = dup1 (lazy f) `Dup` dup2 (lazy 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 instance -- Sym_Map
 129  ( Sym_Map r1
 130  , Sym_Map r2
 131  ) => Sym_Map (Dup r1 r2) where
 132         map_from_list (l1 `Dup` l2) =
 133                 map_from_list l1 `Dup` map_from_list l2
 134 instance -- Sym_Map_Lam
 135  ( Sym_Map_Lam lam r1
 136  , Sym_Map_Lam lam r2
 137  ) => Sym_Map_Lam lam (Dup r1 r2) where
 138         map_map (f1 `Dup` f2) (m1 `Dup` m2) =
 139                 map_map f1 m1 `Dup` map_map f2 m2
 140 instance -- Sym_Functor
 141  ( Sym_Functor lam r1
 142  , Sym_Functor lam r2
 143  ) => Sym_Functor lam (Dup r1 r2) where
 144         fmap (f1 `Dup` f2) (m1 `Dup` m2) =
 145                 fmap f1 m1 `Dup` fmap f2 m2
 146 instance -- Sym_Applicative
 147  ( Sym_Applicative r1
 148  , Sym_Applicative r2
 149  , Sym_Applicative_Lam (Lambda_from_Repr r1) (Dup r1 r2)
 150  ) => Sym_Applicative (Dup r1 r2) where
 151         pure (a1 `Dup` a2) =
 152                 pure a1 `Dup` pure a2
 153 instance -- Sym_Applicative_Lam
 154  ( Sym_Applicative_Lam lam r1
 155  , Sym_Applicative_Lam lam r2
 156  ) => Sym_Applicative_Lam lam (Dup r1 r2) where
 157         (<*>) (f1 `Dup` f2) (m1 `Dup` m2) =
 158                 (<*>) f1 m1 `Dup` (<*>) f2 m2
 159 instance -- Sym_Traversable
 160  ( Sym_Traversable lam r1
 161  , Sym_Traversable lam r2
 162  , lam ~ Lambda_from_Repr r1
 163  ) => Sym_Traversable lam (Dup r1 r2) where
 164         traverse (f1 `Dup` f2) (m1 `Dup` m2) =
 165                 traverse f1 m1 `Dup` traverse f2 m2
 166 instance -- Sym_Monad
 167  ( Sym_Monad_Lam lam r1
 168  , Sym_Monad_Lam lam r2
 169  , lam ~ Lambda_from_Repr r1
 170  ) => Sym_Monad_Lam lam (Dup r1 r2) where
 171         (>>=) (m1 `Dup` m2) (f1 `Dup` f2) =
 172                 (>>=) m1 f1 `Dup` (>>=) m2 f2