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         abs    = liftM Prelude.abs
  56         negate = liftM Prelude.negate
  57         (+)    = liftM2 (Prelude.+)
  58         (-)    = liftM2 (Prelude.-)
  59         (*)    = liftM2 (Prelude.*)
  60         mod    = liftM2 Prelude.mod
  61 instance Sym_Text Repr_Host where
  62         text = Repr_Host
  63 instance Sym_Maybe Repr_Host where
  64         nothing = Repr_Host Nothing
  65         just    = liftM Just
  66         maybe   = liftM3 Maybe.maybe
  67 instance Sym_IO Repr_Host where
  68         io_hClose   = liftM IO.hClose
  69         io_openFile = liftM2 IO.openFile
  70 instance Sym_If Repr_Host where
  71         if_ (Repr_Host b) ok ko = if b then ok else ko
  72 instance Sym_When Repr_Host where
  73         when (Repr_Host b) = Monad.when b
  74 instance Sym_Eq Repr_Host where
  75         (==) = liftM2 (Prelude.==)
  76 instance Sym_Ord Repr_Host where
  77         compare = liftM2 Prelude.compare
  78 instance Sym_List Repr_Host where
  79         list_empty   = return []
  80         list_cons    = liftM2 (:)
  81         list         = sequence
  82         list_filter  = liftM2 List.filter
  83         list_zipWith = liftM3 List.zipWith
  84         list_reverse = liftM  List.reverse
  85 instance Sym_Tuple2 Repr_Host where
  86         tuple2 = liftM2 (,)
  87         fst    = liftM  Tuple.fst
  88         snd    = liftM  Tuple.snd
  89 instance Sym_Map Repr_Host where
  90         map_from_list    = liftM  Map.fromList
  91         mapWithKey       = liftM2 Map.mapWithKey
  92         map_lookup       = liftM2 Map.lookup
  93         map_keys         = liftM  Map.keys
  94         map_member       = liftM2 Map.member
  95         map_insert       = liftM3 Map.insert
  96         map_delete       = liftM2 Map.delete
  97         map_difference   = liftM2 Map.difference
  98         map_foldrWithKey = liftM3 Map.foldrWithKey
  99 instance Sym_Functor Repr_Host where
 100         fmap = liftM2 (Functor.<$>)
 101 instance Expr.Sym_Monad Repr_Host where
 102         return = liftM Monad.return
 103         (>>=)  = Monad.liftM2 (Monad.>>=)
 104 instance Sym_Either Repr_Host where
 105         right = liftM Right
 106         left  = liftM Left
 107 instance Sym_Monoid Repr_Host where
 108         mempty  = Repr_Host Monoid.mempty
 109         mappend = liftM2 Monoid.mappend
 110 instance Sym_Foldable Repr_Host where
 111         foldMap = liftM2 Foldable.foldMap
 112         null    = liftM Foldable.null
 113         length  = liftM Foldable.length
 114         minimum = liftM Foldable.minimum
 115         maximum = liftM Foldable.maximum
 116         elem    = liftM2 Foldable.elem
 117 instance Sym_Applicative Repr_Host where
 118         pure  = liftM Applicative.pure
 119         (<*>) = liftM2 (Applicative.<*>)
 120 instance Sym_Traversable Repr_Host where
 121         traverse = liftM2 Traversable.traverse