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.Bool as Bool
  18 import qualified Data.List as List
  19 import qualified Data.Map.Strict as Map
  20 import qualified Data.Maybe as Maybe
  21 import qualified System.IO as IO
  22
  23 -- import Language.Symantic.Type
  24 import Language.Symantic.Expr hiding (Sym_Monad(..))
  25 import qualified Language.Symantic.Expr as Expr
  26
  27 -- * Type 'Repr_Host'
  28
  29 -- | Interpreter's data.
  30 newtype Repr_Host h = Repr_Host { unRepr_Host :: h }
  31 instance Functor Repr_Host where
  32         fmap f (Repr_Host a) = Repr_Host (f a)
  33 instance Applicative Repr_Host where
  34         pure = Repr_Host
  35         (Repr_Host f) <*> (Repr_Host a) = Repr_Host (f a)
  36 instance Monad Repr_Host where
  37         return = Repr_Host
  38         (Repr_Host a) >>= f = f a
  39
  40 -- | Interpreter.
  41 host_from_expr :: Repr_Host h -> h
  42 host_from_expr = unRepr_Host
  43
  44 instance Sym_Lambda Repr_Host where
  45         ($$)  = (Applicative.<*>)
  46         lam f = Repr_Host (unRepr_Host . f . Repr_Host)
  47 instance Sym_Bool Repr_Host where
  48         bool = Repr_Host
  49         not  = liftM Bool.not
  50         (&&) = liftM2 (Prelude.&&)
  51         (||) = liftM2 (Prelude.||)
  52 instance Sym_Int Repr_Host where
  53         int    = Repr_Host
  54         abs    = liftM Prelude.abs
  55         negate = liftM Prelude.negate
  56         (+)    = liftM2 (Prelude.+)
  57         (-)    = liftM2 (Prelude.-)
  58         (*)    = liftM2 (Prelude.*)
  59         mod    = liftM2 Prelude.mod
  60 instance Sym_Text Repr_Host where
  61         text = Repr_Host
  62 instance Sym_Maybe Repr_Host where
  63         nothing = Repr_Host Nothing
  64         just    = liftM Just
  65         maybe   = liftM3 Maybe.maybe
  66 instance Sym_IO Repr_Host where
  67         io_hClose   = liftM IO.hClose
  68         io_openFile = liftM2 IO.openFile
  69 instance Sym_If Repr_Host where
  70         if_ (Repr_Host b) ok ko = if b then ok else ko
  71 instance Sym_When Repr_Host where
  72         when (Repr_Host b) = Monad.when b
  73 instance Sym_Eq Repr_Host where
  74         (==) = liftM2 (Prelude.==)
  75 instance Sym_Ord Repr_Host where
  76         compare = liftM2 Prelude.compare
  77 instance Sym_List Repr_Host where
  78         list_empty  = return []
  79         list_cons   = liftM2 (:)
  80         list        = sequence
  81         list_filter = liftM2 List.filter
  82 instance Sym_Tuple2 Repr_Host where
  83         tuple2 = liftM2 (,)
  84 instance Sym_Map Repr_Host where
  85         map_from_list = liftM Map.fromList
  86         mapWithKey    = liftM2 Map.mapWithKey
  87 instance Sym_Functor Repr_Host where
  88         fmap = liftM2 (Functor.<$>)
  89 instance Expr.Sym_Monad Repr_Host where
  90         return = liftM Monad.return
  91         (>>=)  = Monad.liftM2 (Monad.>>=)
  92 instance Sym_Either Repr_Host where
  93         right = liftM Right
  94         left  = liftM Left
  95 instance Sym_Monoid Repr_Host where
  96         mempty  = Repr_Host Monoid.mempty
  97         mappend = liftM2 Monoid.mappend
  98 instance Sym_Foldable Repr_Host where
  99         foldMap = liftM2 Foldable.foldMap
 100         null    = liftM Foldable.null
 101         length  = liftM Foldable.length
 102         minimum = liftM Foldable.minimum
 103         maximum = liftM Foldable.maximum
 104         elem    = liftM2 Foldable.elem
 105 instance Sym_Applicative Repr_Host where
 106         pure  = liftM Applicative.pure
 107         (<*>) = liftM2 (Applicative.<*>)
 108 instance Sym_Traversable Repr_Host where
 109         traverse = liftM2 Traversable.traverse