uds/uds.icl

   1 implementation module uds
   2
   3 import StdEnv
   4 import Data.Maybe
   5 import Data.Functor
   6 import Data.Func
   7 import Data.Either
   8 import Data.Tuple
   9 import Data.List
  10 import Control.Applicative
  11 import Control.Monad
  12 import Control.Monad.State
  13 import Control.Monad.Trans
  14 import qualified Data.Map
  15 import System.FilePath
  16
  17 import System.IO
  18 import System.Time
  19
  20 instance MonadFail Maybe where fail _ = Nothing
  21 instance MonadFail [] where fail _ = []
  22 instance MonadFail (Either a) | fromString a where fail s = Left $ fromString s
  23 instance MonadFail (StateT s m) | MonadFail m where fail s = liftT $ fail s
  24
  25 sds :: (sds m r w) -> SDS m r w | read sds & write sds & Monad m
  26 sds s = SDS s (pure ())
  27 instance read SDS where read (SDS sds _) = read sds
  28 instance write SDS where write w (SDS sds _) = write w sds
  29
  30 source :: (m r) (w -> m ()) -> Source m r w
  31 source read write = Source (ReadSource read) (WriteSource write)
  32
  33 constShare :: a -> ReadSource m a () | Monad m
  34 constShare a = ReadSource (pure a)
  35
  36 nullShare :: WriteSource m () a | Monad m
  37 nullShare = WriteSource (\_->pure ())
  38
  39 instance read ReadSource where read (ReadSource read) = read
  40 instance write WriteSource where write w (WriteSource write) = write w
  41 instance read Source where read (Source s _) = read s
  42 instance write Source where write w (Source _ s) = write w s
  43
  44 upd :: (r -> w) (v m r w) -> m w | TC r & TC w & read, write v & Monad m
  45 upd fun sds = read sds >>= \r
  46         # w = fun r
  47         = write w sds >>| pure w
  48
  49 timeStamp :: ReadSource IO Timestamp ()
  50 timeStamp = ReadSource $ withWorld time
  51
  52 par :: (r1 r2 -> m r) (w -> m (w1, w2)) (sdsl m r1 w1) (sdsr m r2 w2) -> Par sdsl sdsr m r w | TC r1 & TC r2 & TC w1 & TC w2
  53 par readl writel left right = Par {readl=readl,writel=writel,left=left,right=right}
  54
  55 (>*<) infixl 6 :: (sdsl m r1 w1) (sdsr m r2 w2) -> Par sdsl sdsr m (r1, r2) (w1, w2) | TC r1 & TC r2 & TC w1 & TC w2 & Monad m
  56 (>*<) l r = par (\x y->pure (x, y)) pure l r
  57
  58 instance read (Par sdsl sdsr) | read sdsl & read sdsr
  59 where
  60         read (Par {readl,left,right}) = join $ readl <$> read left <*> read right
  61 instance write (Par sdsl sdsr) | write sdsl & write sdsr
  62 where
  63         write w (Par {writel,left,right})
  64                 = writel w >>= \(w1, w2)->write w1 left >>| write w2 right
  65
  66 lens :: (r1 -> m r) (w r1 -> m w1) (sds m r1 w1) -> Lens sds m r w | TC r1 & TC w1
  67 lens mapr mapw lens = Lens {mapr=mapr,mapw=mapw,lens=lens}
  68
  69 instance read (Lens sds) | read sds
  70 where
  71         read (Lens {mapr,lens}) = read lens >>= mapr
  72 instance write (Lens sds) | read sds & write sds
  73 where
  74         write w (Lens {mapw,lens}) = read lens >>= mapw w >>= flip write lens
  75
  76 mapRead :: (r -> r`) (sds m r w) -> Lens sds m r` w | TC r` & TC r & TC w & Monad m
  77 mapRead f sds = lens (pure o f) (const o pure) sds
  78
  79 fromDynStore :: (sds m Dynamic Dynamic) -> Lens sds m r w | TC r & TC w & MonadFail m
  80 fromDynStore sds = lens
  81         (\r->case r of
  82                 (r :: r^) = pure r
  83                 _ = fail "type mismatch")
  84         (\w _->pure (dynamic w))
  85         sds
  86
  87 toDynStore :: (sds m r w) -> Lens sds m Dynamic Dynamic | TC r & TC w & MonadFail m
  88 toDynStore sds = lens
  89         (\r->pure (dynamic r))
  90         (\w _->case w of
  91                 (w :: w^) = pure w
  92                 _ = fail "type mismatch")
  93         sds
  94
  95 mapWrite :: (w` r -> m w) (sds m r w) -> Lens sds m r w` | TC r & TC w & TC w` & Monad m
  96 mapWrite f sds = lens pure f sds
  97
  98 indexedStore :: Int (sds m [a] [a]) -> Lens sds m a a | TC a & MonadFail m
  99 indexedStore idx sds = lens
 100         (\r->maybe (fail "out of range") pure (r !? idx))
 101         ((o) pure o updateAt idx)
 102 //      (\w->pure o updateAt idx w)
 103         sds
 104
 105 keyedStore :: k (sds m ('Data.Map'.Map k v) ('Data.Map'.Map k v)) -> Lens sds m v v | TC v & TC k & < k & MonadFail m
 106 keyedStore key sds = lens
 107         (maybe (fail "key not present") pure o 'Data.Map'.get key)
 108         ((o) pure o 'Data.Map'.put key)
 109 //      (\w->pure o 'Data.Map'.put key w)
 110         sds
 111
 112 select :: (sdsl m r1 w1) (r1 -> sdsr m r w) -> Select sdsl sdsr m r w | TC r1 & TC w1 & Monad m
 113 select select bind = Select {select=select,bind=bind,unused=pure ()}
 114
 115 instance read (Select sdsl sdsr) | read sdsl & read sdsr
 116 where
 117         read (Select {select,bind}) = read select >>= read o bind
 118 instance write (Select sdsl sdsr) | read sdsl & write sdsr
 119 where
 120         write w (Select {select,bind}) = read select >>= write w o bind
 121
 122 indexedSelect :: (sdsl m Int z) (sdsr m [a] [a]) -> Select sdsl (Lens sdsr) m a a | TC a & TC z & MonadFail m
 123 indexedSelect l r = select l $ flip indexedStore r
 124
 125 keyedSelect :: (sdsl m k z) (sdsr m ('Data.Map'.Map k v) ('Data.Map'.Map k v))
 126         -> Select sdsl (Lens sdsr) m v v | TC z & TC v & TC k & < k & MonadFail m
 127 keyedSelect l r = select l $ flip keyedStore r
 128
 129 //Start :: Either String ('Data.Map'.Map String Dynamic)
 130 //Start :: Either String (Int, 'Data.Map'.Map String Dynamic)
 131 //Start = runStateT t $ 'Data.Map'.singleton "blurp" (dynamic 38)
 132 //where
 133 //      t = write (42, "blurp") (astore "foo" >*< astore "bar")
 134 //      t = write 42 (astore "blurp")
 135 //              >>| read (astore "blurp")
 136
 137 //Start world = evalIO t world
 138 //where
 139 //      t = read (file "test.icl")
 140
 141 astore :: String -> Lens (Lens Source) (StateT ('Data.Map'.Map String Dynamic) m) a a | MonadFail m & TC a
 142 astore s = fromDynStore $ dstore s
 143
 144 dstore :: String -> Lens Source (StateT ('Data.Map'.Map String Dynamic) m) Dynamic Dynamic | MonadFail m
 145 dstore s = keyedStore s store
 146
 147 store :: (Source (StateT ('Data.Map'.Map String Dynamic) m) ('Data.Map'.Map String Dynamic) ('Data.Map'.Map String Dynamic)) | Monad m
 148 store = Source (ReadSource getState) (WriteSource put)
 149
 150 file :: FilePath -> Source IO String String
 151 file p = source (readFileM p) (writeFileM p)
 152
 153 Start = 42