old/iot/test.icl

   1 module test
   2
   3 import StdEnv
   4
   5 import Data.Func
   6 import Data.Either
   7 import Data.Functor
   8 import Data.Functor.Identity
   9 import Data.Tuple
  10 import Data.Error
  11 import Control.Applicative
  12 import Control.Monad
  13 import Control.Monad.State
  14 import Control.Monad.Identity
  15
  16 import System.File
  17
  18 :: ErrorT e m a = ErrorT (m (Either e a))
  19
  20 runErrorT (ErrorT m) = m
  21
  22 instance Functor (ErrorT e m) | Functor m
  23 where
  24         fmap f a = ErrorT $ fmap (fmap f) $ runErrorT a
  25
  26 instance Applicative (ErrorT e m) | Functor m & Monad m
  27 where
  28         pure a = ErrorT $ pure $ Right a
  29         (<*>) f v = ErrorT $ runErrorT f
  30                 >>= \mf->case mf of
  31                         Left e = pure $ Left e
  32                         Right k = runErrorT v
  33                                 >>= \mv->case mv of
  34                                         Left e = pure (Left e)
  35                                         Right x = pure $ Right $ k x
  36
  37 instance Monad (ErrorT e m) | Monad m
  38 where
  39         bind m k = ErrorT $ runErrorT m
  40                 >>= \a->case a of
  41                         Left l = pure $ Left l
  42                         Right r = runErrorT (k r)
  43
  44 :: IOT m a = IOT (*World -> *(m a, *World))
  45
  46 runIOT (IOT f) = f
  47
  48 instance Functor (IOT m) | Functor m
  49 where
  50         fmap f a = IOT \w->appFst (fmap f) $ runIOT a w
  51 //instance Applicative (IOT m) | Applicative m
  52 //where
  53 //      pure a = IOT $ tuple $ pure a
  54 //      (<*>) f v = IOT \w->
  55 //              case runIOT f w of
  56 //                      (Left e, w) = (Left e, w)
  57 //                      (Right ff, w) = case runIOT v w of
  58 //                              (Left e, w) = (Left e, w)
  59 //                              (Right fv, w) = (Right (ff fv), w)
  60
  61
  62 //liftIOT :: (*World -> *(MaybeError e a, *World)) -> ErrorT e (StateT *World Identity) String
  63 //liftIOT f = ErrorT $ StateT \w->case f w of
  64 //      (Ok a, w`) = pure (pure a, w`)
  65
  66 liftIO :: (*World -> *(a, *World)) -> State *World a
  67 liftIO f = state f
  68
  69 Start = 42//liftIOT (readFile "/opt/clean/etc/IDEEnvs")