Language/Symantic/Repr/Dup.hs

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