eternal 0.0.9 → 0.1.0

raw patch · 12 files changed

+164/−130 lines, 12 filesdep +base-unicode-symbols

Dependencies added: base-unicode-symbols

Files

eternal.cabal +3/−1
src/Control/Eternal/Algorithms/NaturalSort.hs +21/−19
src/Control/Eternal/Reactive.hs +74/−74
src/Control/Eternal/String.hs +4/−3
src/Control/Eternal/Syntax.hs +7/−0
src/Control/Eternal/Syntax/Lift.hs +5/−4
src/Control/Eternal/Syntax/Logic.hs +4/−3
src/Control/Eternal/Syntax/Operators.hs +6/−5
src/Control/Eternal/Syntax/Unicode.hs +13/−0
src/Control/Eternal/System/Exec.hs +11/−9
src/Control/Eternal/System/FileSystem.hs +9/−6
src/Control/Eternal/System/HTTP.hs +7/−6

eternal.cabal view

@@ -1,6 +1,6 @@ name:       eternal
 category:   Control
-version:    0.0.9
+version:    0.1.0
 author:        Heather Cynede
 maintainer:    Heather Cynede <Cynede@Gentoo.org>
 license: BSD3
@@ -26,6 +26,7 @@     Control.Eternal.Reactive
     
     Control.Eternal.Syntax.Operators
+    Control.Eternal.Syntax.Unicode
     Control.Eternal.Syntax.Lift
     Control.Eternal.Syntax.Logic
     
@@ -49,3 +50,4 @@     , transformers
     , utf8-string
     , bytestring
+    , base-unicode-symbols

src/Control/Eternal/Algorithms/NaturalSort.hs view

@@ -1,3 +1,4 @@+{-# LANGUAGE UnicodeSyntax #-}
 module Control.Eternal.Algorithms.NaturalSort
   ( nSort
   ) where
@@ -5,25 +6,26 @@ import Data.List
 import Data.Char
 
-nSort   ::  [String] -> [String]
+import Control.Eternal.Syntax
+
+nSort   ::  [String] → [String]
 nSort s =   if all allFloat s then    
-                let { readFloat = read :: String -> Float } 
-                in  (map show . sortBy compare . map readFloat) s
-            else    
-                sortBy natComp s
-    where allFloat  =   all (\x -> isDigit x || '.' == 'x')
+                let { readFloat = read :: String → Float } 
+                in  (map show ∘ sortBy compare ∘ map readFloat) s
+            else sortBy natComp s
+    where allFloat = all (\x → isDigit x ∨ '.' ≡ 'x')
 
-natComp                                 ::  String -> String -> Ordering
-natComp [] []                           =   EQ
-natComp [] _                            =   LT
-natComp _ []                            =   GT
+natComp ::  String → String → Ordering
+natComp [] []                       = EQ
+natComp [] _                        = LT
+natComp _ []                        = GT
 natComp xxs@(x:xs) yys@(y:ys)
-    | noDigit x && noDigit y && x == y  =   natComp xs ys
-    | noDigit x || noDigit y            =   compare x y
-    | nx == ny                          =   natComp rx ry
-    | otherwise                         =   compare nx ny
-    where   (nx,rx)     =   getNumber xxs
-            (ny,ry)     =   getNumber yys
-            noDigit     =   not . isDigit
-            getNumber s =   let { digits = takeWhile isDigit s }
-                            in (read digits :: Integer, drop (length digits) s)
+    | noDigit x ∧ noDigit y ∧ x ≡ y = natComp xs ys
+    | noDigit x ∨ noDigit y         = compare x y
+    | nx == ny                      = natComp rx ry
+    | otherwise                     = compare nx ny
+    where   (nx,rx)     = getNumber xxs
+            (ny,ry)     = getNumber yys
+            noDigit     = not ∘ isDigit
+            getNumber s = let { digits = takeWhile isDigit s }
+                          in (read digits :: Integer, drop (length digits) s)

src/Control/Eternal/Reactive.hs view

@@ -1,74 +1,74 @@-{-# LANGUAGE RankNTypes, GADTs, ScopedTypeVariables, LambdaCase #-}--module Control.Eternal.Reactive -	( Action-	, Request-	, reactiveObjectIO-    , Sink-    , pauseIO-    , reactiveIO-	) where---- |--- Module: Control.Eternal.Reactive--- Copyright: Andy Gill (??-2008), Heather Cynede (2014)--- License: BSD3--- |--import Control.Concurrent.Chan-import Control.Concurrent-import Control.Exception as Ex---- An action is an IO-based change to an explicit state-type Action s    = s -> IO s	 -- only state change-type Request s a = s -> IO (s,a) -- state change + reply to be passed back to caller---- Choices:---   * do the Requests see the failure---   * Actions do not see anything---   * -data Msg s = Act (Action s)-           | forall a . Req (Request s a) (MVar a)-           | Done (MVar ())--reactiveObjectIO-    :: forall state object. state-    -> (    ThreadId -            -> (forall r. Request state r -> IO r) 	-- requests-            -> (Action state -> IO ()) 	            -- actions-            -> IO ()				                -- done-            -> object-       ) -> IO object-reactiveObjectIO state mkObject = do-    chan <- newChan-    let dispatch st = -         readChan chan >>= \case Act act     -> do state1 <- act st-                                                   dispatch $! state1-                                 Req req box -> do (state1,ret) <- req st-                                                   putMVar box ret-                                                   dispatch $! state1-                                 Done box    -> do putMVar box ()-                                                   return ()-        requestit :: forall r. Request state r -> IO r-        requestit fun = do ret <- newEmptyMVar-                           writeChan chan $ Req fun ret-                           takeMVar ret -- wait-        actionit act = writeChan chan $ Act act-        doneit = do ret <- newEmptyMVar-                    writeChan chan $ Done ret-                    takeMVar ret -- wait-    pid <- forkIO $ dispatch state-    return (mkObject pid requestit actionit doneit)--type Sink a = a -> IO ()---- This turns a reactive style call into a pausing IO call.-pauseIO :: (a -> Sink b -> IO ()) -> a -> IO b-pauseIO fn a = do var <- newEmptyMVar-                  forkIO $ do fn a (\ b -> putMVar var b)-                  takeMVar var---- This turns a pausing IO call into a reactive style call.-reactiveIO :: (a -> IO b) -> a -> Sink b -> IO ()-reactiveIO fn a sinkB = do forkIO $ sinkB =<< fn a-                           return ()+{-# LANGUAGE RankNTypes, GADTs, ScopedTypeVariables, LambdaCase, UnicodeSyntax #-}
+
+module Control.Eternal.Reactive 
+    ( Action
+    , Request
+    , reactiveObjectIO
+    , Sink
+    , pauseIO
+    , reactiveIO
+    ) where
+
+-- |
+-- Module: Control.Eternal.Reactive
+-- Copyright: Andy Gill (??-2008), Heather Cynede (2014-??)
+-- License: BSD3
+-- |
+
+import Control.Concurrent.Chan
+import Control.Concurrent
+import Control.Exception as Ex
+
+-- An action is an IO-based change to an explicit state
+type Action s    = s → IO s     -- only state change
+type Request s a = s → IO (s,a) -- state change + reply to be passed back to caller
+
+-- Choices:
+--   * do the Requests see the failure
+--   * Actions do not see anything
+--   * 
+data Msg s = Act (Action s)
+           | ∀ a . Req (Request s a) (MVar a)
+           | Done (MVar ())
+
+reactiveObjectIO
+    :: ∀ state object. state
+    → ( ThreadId 
+            → (∀ r. Request state r → IO r)     -- requests
+            → (Action state → IO ())             -- actions
+            → IO ()                                -- done
+            → object
+       ) → IO object
+reactiveObjectIO state mkObject = do
+    chan ← newChan
+    let dispatch st = 
+         readChan chan >>= \case Act act     → do state1 ← act st
+                                                  dispatch $! state1
+                                 Req req box → do (state1,ret) ← req st
+                                                  putMVar box ret
+                                                  dispatch $! state1
+                                 Done box    → do putMVar box ()
+                                                  return ()
+        requestit :: ∀ r. Request state r → IO r
+        requestit fun = do ret ← newEmptyMVar
+                           writeChan chan $ Req fun ret
+                           takeMVar ret -- wait
+        actionit act = writeChan chan $ Act act
+        doneit = do ret ← newEmptyMVar
+                    writeChan chan $ Done ret
+                    takeMVar ret -- wait
+    pid ← forkIO $ dispatch state
+    return (mkObject pid requestit actionit doneit)
+
+type Sink a = a → IO ()
+
+-- This turns a reactive style call into a pausing IO call.
+pauseIO :: (a → Sink b → IO ()) → a → IO b
+pauseIO fn a = do var ← newEmptyMVar
+                  forkIO $ do fn a (\ b → putMVar var b)
+                  takeMVar var
+
+-- This turns a pausing IO call into a reactive style call.
+reactiveIO :: (a → IO b) → a → Sink b → IO ()
+reactiveIO fn a sinkB = do forkIO $ sinkB =<< fn a
+                           return ()

src/Control/Eternal/String.hs view

@@ -1,15 +1,16 @@+{-# LANGUAGE UnicodeSyntax #-}
 module Control.Eternal.String
   ( trim
   ) where
 
 import Data.Char (isSpace)
 
-trim :: String -> String
+trim :: String → String
 trim xs = dropSpaceTail "" $ dropWhile isSpace xs
 
-dropSpaceTail :: String -> String -> String
+dropSpaceTail :: String → String → String
 dropSpaceTail maybeStuff "" = ""
 dropSpaceTail maybeStuff (x:xs)
-        | isSpace x = dropSpaceTail (x:maybeStuff) xs
+        | isSpace x       = dropSpaceTail (x:maybeStuff) xs
         | null maybeStuff = x : dropSpaceTail "" xs
         | otherwise       = reverse maybeStuff ++ x : dropSpaceTail "" xs

src/Control/Eternal/Syntax.hs view

@@ -1,9 +1,16 @@ module Control.Eternal.Syntax
   ( module Control.Eternal.Syntax.Operators
+  , module Control.Eternal.Syntax.Unicode
   , module Control.Eternal.Syntax.Lift
   , module Control.Eternal.Syntax.Logic
+  , module Prelude.Unicode
+  , module Control.Monad.Unicode
   ) where
 
 import Control.Eternal.Syntax.Operators
+import Control.Eternal.Syntax.Unicode
 import Control.Eternal.Syntax.Lift
 import Control.Eternal.Syntax.Logic
+
+import Prelude.Unicode -- base-unicode-symbols
+import Control.Monad.Unicode

src/Control/Eternal/Syntax/Lift.hs view

@@ -1,3 +1,4 @@+{-# LANGUAGE UnicodeSyntax #-}
 module Control.Eternal.Syntax.Lift
   ( liftM_
   , liftM2_
@@ -7,14 +8,14 @@ 
 import Control.Monad
 
-liftM_ :: Monad m => (a1 -> m a) -> m a1 -> m a
+liftM_ :: Monad m ⇒ (a1 → m a) → m a1 → m a
 liftM_ a1 r = join ( liftM a1 r )
 
-liftM2_ :: Monad m => (a1 -> a2 -> m a) -> m a1 -> m a2 -> m a
+liftM2_ :: Monad m ⇒ (a1 → a2 → m a) → m a1 → m a2 → m a
 liftM2_ a1 a2 r = join ( liftM2 a1 a2 r )
 
-liftM3_ :: Monad m => (a1 -> a2 -> a3 -> m a) -> m a1 -> m a2 -> m a3 -> m a
+liftM3_ :: Monad m ⇒ (a1 → a2 → a3 → m a) → m a1 → m a2 → m a3 → m a
 liftM3_ a1 a2 a3 r = join ( liftM3 a1 a2 a3 r )
 
-liftM4_ :: Monad m => (a1 -> a2 -> a3 -> a4 -> m a) -> m a1 -> m a2 -> m a3 -> m a4 -> m a
+liftM4_ :: Monad m ⇒ (a1 → a2 → a3 → a4 → m a) → m a1 → m a2 → m a3 → m a4 → m a
 liftM4_ a1 a2 a3 a4 r = join ( liftM4 a1 a2 a3 a4 r )

src/Control/Eternal/Syntax/Logic.hs view

@@ -1,3 +1,4 @@+{-# LANGUAGE UnicodeSyntax #-}
 module Control.Eternal.Syntax.Logic
   ( ifSo
   , ifNot
@@ -5,8 +6,8 @@ 
 import Control.Monad (when, unless)
 
-ifSo :: IO () -> Bool -> IO ()
+ifSo :: IO () → Bool → IO ()
 ifSo = flip when
 
-ifNot :: IO () -> Bool -> IO ()
-ifNot = flip unless+ifNot :: IO () → Bool → IO ()
+ifNot = flip unless

src/Control/Eternal/Syntax/Operators.hs view

@@ -1,3 +1,4 @@+{-# LANGUAGE UnicodeSyntax #-}
 module Control.Eternal.Syntax.Operators
   ( (<|)
   , (|>)
@@ -7,16 +8,16 @@ 
 infixl 2 <|, |>
 
-(<|) :: (a -> b) -> a -> b
+(<|) :: (α → β) → α → β
 f <| a = f a
 
-(|>) :: a -> (a -> b) -> b
+(|>) :: α → (α → β) → β
 a |> f = f a
 
 infixl 7 <<|, |>>
 
-(<<|) :: (a -> b) -> a -> b
+(<<|) :: (α → β) → α → β
 f <<| a = f a
 
-(|>>) :: a -> (a -> b) -> b
-a |>> f = f a+(|>>) :: α → (α → β) → β
+a |>> f = f a

+ src/Control/Eternal/Syntax/Unicode.hs view

@@ -0,0 +1,13 @@+{-# LANGUAGE UnicodeSyntax #-}
+module Control.Eternal.Syntax.Unicode
+  ( (⊳)
+  , (⊲)
+  ) where
+
+infixl 2 ⊳, ⊲
+
+(⊳) :: α → (α → β) → β
+a ⊳ f = f a
+
+(⊲) :: (α → β) → α → β
+f ⊲ a = f a

src/Control/Eternal/System/Exec.hs view

@@ -1,15 +1,17 @@+{-# LANGUAGE UnicodeSyntax #-}
 module Control.Eternal.System.Exec
-  ( exec,
-    exc,
+  ( exec
+  , exc
   ) where
 
 import System.Directory (setCurrentDirectory)
-import System.Process (runCommand, waitForProcess)
+import System.Process (waitForProcess)
+import System.Cmd (system)
 
-exec :: [Char] -> IO()
-exec args = do
-    pid <- runCommand args
-    waitForProcess pid >> return ()
+import Control.Eternal.Syntax
 
-exc :: [Char] -> [Char] -> IO()
-exc path args = setCurrentDirectory path >> exec args+exec :: String → IO()
+exec args = system args ≫ return ()
+
+exc :: String → String → IO()
+exc path args = setCurrentDirectory path ≫ exec args

src/Control/Eternal/System/FileSystem.hs view

@@ -1,3 +1,4 @@+{-# LANGUAGE UnicodeSyntax #-}
 module Control.Eternal.System.FileSystem
   ( copyDir
   ) where
@@ -7,13 +8,15 @@ 
 import System.FilePath((</>))
 
-copyDir ::  FilePath -> FilePath -> IO ()
+import Control.Eternal.Syntax
+
+copyDir :: FilePath → FilePath → IO ()
 copyDir src dst = do
     createDirectory dst
-    content <- getDirectoryContents src
-    let xs = filter (`notElem` [".", ".."]) content
-    forM_ xs $ \name -> let srcPath = src </> name
-                            dstPath = dst </> name
-        in doesDirectoryExist srcPath >>= \dirExist ->
+    content ← getDirectoryContents src
+    let xs = filter (∉ [".", ".."]) content
+    forM_ xs $ \name → let srcPath = src </> name
+                           dstPath = dst </> name
+        in doesDirectoryExist srcPath >>= \dirExist →
             if dirExist then copyDir srcPath dstPath
                         else copyFile srcPath dstPath

src/Control/Eternal/System/HTTP.hs view

@@ -1,3 +1,4 @@+{-# LANGUAGE UnicodeSyntax #-}
 module Control.Eternal.System.HTTP
   ( getHTTP
   , download
@@ -15,16 +16,16 @@ 
 import Control.Monad.IO.Class (liftIO)
 
-getHTTP :: [Char] -> IO String
+getHTTP :: [Char] → IO String
 getHTTP url = withSocketsDo
     $ simpleHttp url
-        >>= \bs -> return $ S.decode $ L.unpack bs
+        >>= \bs → return $ S.decode $ L.unpack bs
 
-download :: String -> String -> IO()
+download :: String → String → IO()
 download url filename = withSocketsDo $ do
-    irequest <- liftIO $ parseUrl url
-    withManager $ \manager -> do
+    irequest ← liftIO $ parseUrl url
+    withManager $ \manager → do
         let request = irequest
              { method = methodGet }
-        response <- http request manager
+        response ← http request manager
         responseBody response C.$$+- sinkFile filename