Language/Symantic/Repr/Host.hs

   1 {-# LANGUAGE FlexibleContexts #-}
   2 {-# LANGUAGE FlexibleInstances #-}
   3 {-# LANGUAGE MultiParamTypeClasses #-}
   4 {-# LANGUAGE ScopedTypeVariables #-}
   5 {-# LANGUAGE Rank2Types #-}
   6 {-# LANGUAGE TypeFamilies #-}
   7 {-# LANGUAGE UndecidableInstances #-}
   8 -- | Interpreter to compute a host-term.
   9 module Language.Symantic.Repr.Host where
  10
  11 import Control.Applicative as Applicative
  12 import Control.Monad as Monad
  13 import Data.Foldable as Foldable
  14 import Data.Functor as Functor
  15 import Data.Monoid as Monoid
  16 import Data.Traversable as Traversable
  17 import qualified Data.Tuple as Tuple
  18 import qualified Data.Bool as Bool
  19 import qualified Data.List as List
  20 import qualified Data.Map.Strict as Map
  21 import qualified Data.Maybe as Maybe
  22 import qualified System.IO as IO
  23
  24 -- import Language.Symantic.Type
  25 import Language.Symantic.Expr hiding (Sym_Monad(..))
  26 import qualified Language.Symantic.Expr as Expr
  27
  28 -- * Type 'Repr_Host'
  29
  30 -- | Interpreter's data.
  31 newtype Repr_Host h = Repr_Host { unRepr_Host :: h }
  32 instance Functor Repr_Host where
  33         fmap f (Repr_Host a) = Repr_Host (f a)
  34 instance Applicative Repr_Host where
  35         pure = Repr_Host
  36         (Repr_Host f) <*> (Repr_Host a) = Repr_Host (f a)
  37 instance Monad Repr_Host where
  38         return = Repr_Host
  39         (Repr_Host a) >>= f = f a
  40
  41 -- | Interpreter.
  42 host_from_expr :: Repr_Host h -> h
  43 host_from_expr = unRepr_Host
  44
  45 instance Sym_Lambda Repr_Host where
  46         ($$)  = (Applicative.<*>)
  47         lam f = Repr_Host (unRepr_Host . f . Repr_Host)
  48 instance Sym_Bool Repr_Host where
  49         bool = Repr_Host
  50         not  = liftM Bool.not
  51         (&&) = liftM2 (Prelude.&&)
  52         (||) = liftM2 (Prelude.||)
  53 instance Sym_Int Repr_Host where
  54         int = Repr_Host
  55 instance Sym_Integer Repr_Host where
  56         integer = Repr_Host
  57 instance Sym_Num Repr_Host where
  58         abs    = liftM Prelude.abs
  59         negate = liftM Prelude.negate
  60         (+)    = liftM2 (Prelude.+)
  61         (-)    = liftM2 (Prelude.-)
  62         (*)    = liftM2 (Prelude.*)
  63 instance Sym_Integral Repr_Host where
  64         quot      = liftM2 Prelude.quot
  65         rem       = liftM2 Prelude.rem
  66         div       = liftM2 Prelude.div
  67         mod       = liftM2 Prelude.mod
  68         quotRem   = liftM2 Prelude.quotRem
  69         divMod    = liftM2 Prelude.divMod
  70         toInteger = liftM  Prelude.toInteger
  71 instance Sym_Text Repr_Host where
  72         text = Repr_Host
  73 instance Sym_Maybe Repr_Host where
  74         nothing = Repr_Host Nothing
  75         just    = liftM Just
  76         maybe   = liftM3 Maybe.maybe
  77 instance Sym_IO Repr_Host where
  78         io_hClose   = liftM IO.hClose
  79         io_openFile = liftM2 IO.openFile
  80 instance Sym_If Repr_Host where
  81         if_ (Repr_Host b) ok ko = if b then ok else ko
  82 instance Sym_When Repr_Host where
  83         when (Repr_Host b) = Monad.when b
  84 instance Sym_Eq Repr_Host where
  85         (==) = liftM2 (Prelude.==)
  86 instance Sym_Ord Repr_Host where
  87         compare = liftM2 Prelude.compare
  88 instance Sym_List Repr_Host where
  89         list_empty   = return []
  90         list_cons    = liftM2 (:)
  91         list         = sequence
  92         list_filter  = liftM2 List.filter
  93         list_zipWith = liftM3 List.zipWith
  94         list_reverse = liftM  List.reverse
  95 instance Sym_Tuple2 Repr_Host where
  96         tuple2 = liftM2 (,)
  97         fst    = liftM  Tuple.fst
  98         snd    = liftM  Tuple.snd
  99 instance Sym_Map Repr_Host where
 100         map_from_list    = liftM  Map.fromList
 101         mapWithKey       = liftM2 Map.mapWithKey
 102         map_lookup       = liftM2 Map.lookup
 103         map_keys         = liftM  Map.keys
 104         map_member       = liftM2 Map.member
 105         map_insert       = liftM3 Map.insert
 106         map_delete       = liftM2 Map.delete
 107         map_difference   = liftM2 Map.difference
 108         map_foldrWithKey = liftM3 Map.foldrWithKey
 109 instance Sym_Functor Repr_Host where
 110         fmap = liftM2 (Functor.<$>)
 111 instance Expr.Sym_Monad Repr_Host where
 112         return = liftM Monad.return
 113         (>>=)  = Monad.liftM2 (Monad.>>=)
 114 instance Sym_Either Repr_Host where
 115         right = liftM Right
 116         left  = liftM Left
 117 instance Sym_Monoid Repr_Host where
 118         mempty  = Repr_Host Monoid.mempty
 119         mappend = liftM2 Monoid.mappend
 120 instance Sym_Foldable Repr_Host where
 121         foldMap = liftM2 Foldable.foldMap
 122         null    = liftM Foldable.null
 123         length  = liftM Foldable.length
 124         minimum = liftM Foldable.minimum
 125         maximum = liftM Foldable.maximum
 126         elem    = liftM2 Foldable.elem
 127 instance Sym_Applicative Repr_Host where
 128         pure  = liftM Applicative.pure
 129         (<*>) = liftM2 (Applicative.<*>)
 130 instance Sym_Traversable Repr_Host where
 131         traverse = liftM2 Traversable.traverse