packages feed

SciFlow (empty) → 0.1.0

raw patch · 10 files changed

+352/−0 lines, 10 filesdep +basedep +bytestringdep +data-default-classsetup-changed

Dependencies added: base, bytestring, data-default-class, mtl, shelly, template-haskell, text, unordered-containers, yaml

Files

+ LICENSE view
@@ -0,0 +1,20 @@+Copyright (c) 2015 Kai Zhang++Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions:++The above copyright notice and this permission notice shall be included+in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ SciFlow.cabal view
@@ -0,0 +1,56 @@+-- Initial SciFlow.cabal generated by cabal init.  For further +-- documentation, see http://haskell.org/cabal/users-guide/++name:                SciFlow+version:             0.1.0+synopsis:            Scientific workflow management system+description:         SciFlow is to help programmers design complex workflows+                     with ease.+                     .+                     Feature includes: +                     .+                        1. Use "labeled" arrows to connect individual steps+                           and cache computational results.+                        2. Use monad and template haskell to automate the process+                           of building DAGs.++license:             MIT+license-file:        LICENSE+author:              Kai Zhang+maintainer:          kai@kzhang.org+copyright:           (c) 2015 Kai Zhang+category:            Control+build-type:          Simple+-- extra-source-files:  +cabal-version:       >=1.10++library+  exposed-modules:+    Scientific.Workflow+    Scientific.Workflow.Types+    Scientific.Workflow.Builder+    Scientific.Workflow.Builder.TH+    Scientific.Workflow.Serialization+    Scientific.Workflow.Serialization.Show+    Scientific.Workflow.Serialization.Yaml++--  other-modules:       ++  -- other-extensions:    +  build-depends:       +      base >=4.0 && <5.0+    , bytestring+    , data-default-class+    , mtl+    , shelly+    , text+    , template-haskell+    , unordered-containers >=0.2+    , yaml++  hs-source-dirs:      src+  default-language:    Haskell2010++source-repository  head+  type: git+  location: https://github.com/kaizhang/SciFlow.git
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ src/Scientific/Workflow.hs view
@@ -0,0 +1,28 @@+module Scientific.Workflow+    ( module Scientific.Workflow.Types+    , module Scientific.Workflow.Builder+    , module Scientific.Workflow.Builder.TH+    , module Scientific.Workflow.Serialization.Yaml+    , runWorkflow+    , mapA+    ) where++import Control.Arrow (Kleisli(..))+import Control.Monad.Reader (runReaderT, forM_)+import qualified Data.Text as T+import Shelly (mkdir_p, shelly, fromText)++import Scientific.Workflow.Builder+import Scientific.Workflow.Builder.TH+import Scientific.Workflow.Types+import Scientific.Workflow.Serialization.Yaml++runWorkflow :: [Workflow] -> WorkflowOpt -> IO ()+runWorkflow wfs opt = do+    shelly $ mkdir_p $ fromText $ T.pack $ _logDir opt+    forM_ wfs $ \(Workflow wf) -> do+        _ <- runReaderT (runProcessor wf ()) $ Config $ _logDir opt+        return ()++mapA :: Monad m => Kleisli m a b -> Kleisli m [a] [b]+mapA (Kleisli f) = Kleisli $ mapM f
+ src/Scientific/Workflow/Builder.hs view
@@ -0,0 +1,65 @@+module Scientific.Workflow.Builder where++import Control.Arrow (second)+import Control.Monad.State.Lazy (State, modify)+import qualified Data.HashMap.Strict as M+import qualified Data.Text as T+import Data.Tuple (swap)++data Unit = S String+          | L String String+          | L2 (String,String) String+          | L3 (String,String,String) String++data B = B+    { _nodes :: [(String, String, T.Text)]+    , _links :: [(String, Unit)]+    }++type Builder = State B++node :: String -> String -> T.Text -> Builder ()+node l f anno = modify $ \s -> s{_nodes = (l,f,anno) : _nodes s}++singleton :: String -> Builder ()+singleton t = modify $ \s -> s{_links = (t, S t) : _links s}++link :: String -> String -> Builder ()+link a t = modify $ \s -> s{_links = (t, L a t) : _links s}++(~>) :: String -> String -> Builder ()+(~>) = link++link2 :: (String, String) -> String -> Builder ()+link2 (a,b) t = modify $ \s -> s{_links = (t, L2 (a,b) t) : _links s}++link3 :: (String, String, String) -> String -> Builder ()+link3 (a,b,c) t = modify $ \s -> s{_links = (t, L3 (a,b,c) t) : _links s}++data Graph = Graph+    { _children :: M.HashMap String [String]+    , _parents :: M.HashMap String [String]+    , _vertice :: [String]+    }++children :: String -> Graph -> [String]+children x = M.lookupDefault [] x . _children++parents :: String -> Graph -> [String]+parents x = M.lookupDefault [] x . _parents++leaves :: Graph -> [String]+leaves g = filter (\x -> null $ children x g) $ _vertice g++fromUnits :: [Unit] -> Graph+fromUnits us = Graph cs ps vs'+  where+    cs = M.fromListWith (++) $ map (second return) es'+    ps = M.fromListWith (++) $ map (second return . swap) es'+    vs' = concat vs+    es' = concat es+    (vs,es) = unzip $ map f us+    f (S a) = ([a], [])+    f (L a t) = ([a,t], [(a,t)])+    f (L2 (a,b) t) = ([a,b,t], [(a,t),(b,t)])+    f (L3 (a,b,c) t) = ([a,b,c,t], [(a,t),(b,t),(c,t)])
+ src/Scientific/Workflow/Builder/TH.hs view
@@ -0,0 +1,45 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE OverloadedStrings #-}+module Scientific.Workflow.Builder.TH where++import Language.Haskell.TH++import Control.Arrow ((>>>))+import Control.Monad.State+import qualified Data.HashMap.Strict as M++import Scientific.Workflow.Types+import Scientific.Workflow.Builder++mkWorkflow :: String -> Builder () -> Q [Dec]+mkWorkflow name st = do+    nodeDec <- declareNodes nd+    wfDec <- [d| $(varP $ mkName name) = $(fmap ListE $ mapM (`linkNodes` m) endNodes) |]+    return $ nodeDec ++ wfDec+  where+    builder = execState st $ B [] []+    endNodes = map (\x -> M.lookupDefault undefined x m) . leaves . fromUnits . snd . unzip . _links $ builder+    m = M.fromList $ _links builder+    nd = map (\(a,b,_) -> (a,b)) $ _nodes builder++declareNodes :: [(String, String)] -> Q [Dec]+declareNodes nodes = do d <- mapM f nodes+                        return $ concat d+  where+    f (l, ar) = [d| $(varP $ mkName l) = proc l $(varE $ mkName ar) |]+{-# INLINE declareNodes #-}++linkNodes :: Unit -> M.HashMap String Unit -> Q Exp+linkNodes nd m = [| Workflow $(go nd) |]+  where+    lookup' x = M.lookupDefault (S x) x m+    go (S a)          = varE $ mkName a+    go (L a t)        = [| $(go $ lookup' a) >>> $(go $ S t) |]+    go (L2 (a,b) t)   = [| zipS  $(go $ lookup' a) +                                 $(go $ lookup' b)+                             >>> $(go $ S t) |]+    go (L3 (a,b,c) t) = [| zipS3 $(go $ lookup' a)+                                 $(go $ lookup' b)+                                 $(go $ lookup' c)+                             >>> $(go $ S t) |]+{-# INLINE linkNodes #-}
+ src/Scientific/Workflow/Serialization.hs view
@@ -0,0 +1,7 @@+module Scientific.Workflow.Serialization where++import qualified Data.ByteString as B++class Serializable a where+    serialize :: a -> B.ByteString+    deserialize :: B.ByteString -> Maybe a
+ src/Scientific/Workflow/Serialization/Show.hs view
@@ -0,0 +1,11 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-}+module Scientific.Workflow.Serialization.Show where++import qualified Data.ByteString.Char8 as B++import Scientific.Workflow.Serialization++instance (Read a, Show a) => Serializable a where+    serialize = B.pack . show +    deserialize = read . B.unpack
+ src/Scientific/Workflow/Serialization/Yaml.hs view
@@ -0,0 +1,13 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-}+module Scientific.Workflow.Serialization.Yaml+    (Serializable(..)+    ) where++import Data.Yaml (FromJSON, ToJSON, encode, decode)++import Scientific.Workflow.Serialization++instance (FromJSON a, ToJSON a) => Serializable a where+    serialize = encode+    deserialize = decode
+ src/Scientific/Workflow/Types.hs view
@@ -0,0 +1,105 @@+{-# LANGUAGE GADTs #-}+module Scientific.Workflow.Types where++import qualified Control.Category as C+import Control.Arrow (Kleisli(..), Arrow(..), first, second)+import Control.Monad.Reader (ReaderT, lift, reader, (>=>), MonadTrans)+import qualified Data.ByteString as B+import Data.Default.Class+import qualified Data.Text as T+import Shelly (shelly, test_f, fromText)++import Scientific.Workflow.Serialization (Serializable(..))++data Workflow where+    Workflow :: IOProcessor () b -> Workflow++-- | labeled Arrow+newtype Processor m a b = Processor { runProcessor :: a -> m b }++instance Monad m => C.Category (Processor m) where+    id = Processor return+    (Processor f) . (Processor g) = Processor $ g >=> f++instance Monad m => Arrow (Processor m) where+    arr f = Processor (return . f)+    first (Processor f) = Processor (\ ~(b,d) -> f b >>= \c -> return (c,d))+    second (Processor f) = Processor (\ ~(d,b) -> f b >>= \c -> return (d,c))++-- | Label is a pair of side effects+type Label m l o = (l -> m (Maybe o), l -> o -> m ())++-- | Turn a Kleisli arrow into a labeled arrow+label :: (MonadTrans t, Monad m, Monad (t m))+      => Label (t m) l b+      -> l+      -> Kleisli m a b+      -> Processor (t m) a b+label (pre, suc) l (Kleisli f) = Processor $ \x -> do+    d <- pre l+    v <- case d of+        Nothing -> lift $ f x+        Just v -> return v+    suc l v+    return v++type IOProcessor = Processor (ReaderT Config IO)++type Actor = Kleisli IO++actor :: (a -> IO b) -> Actor a b+actor = Kleisli++-- | Source produce an output without taking inputs+type Source i = IOProcessor () i++proc :: Serializable b => String -> Kleisli IO a b -> IOProcessor a b+proc = label (recover, save)++source :: Serializable o => String -> o -> Source o+source l x = proc l $ arr $ const x++recover :: Serializable a => String -> ReaderT Config IO (Maybe a)+recover l = do+    dir <- reader _baseDir+    let file = dir ++ l+    exist <- lift $ fileExist file+    if exist+       then do c <- lift $ B.readFile file+               return $ deserialize c+       else return Nothing++save :: Serializable a => String -> a -> ReaderT Config IO ()+save l x = do+    dir <- reader _baseDir+    lift $ B.writeFile (dir++l) $ serialize x++fileExist :: FilePath -> IO Bool+fileExist x = shelly $ test_f $ fromText $ T.pack x++-- | zip two sources+zipS :: Source a -> Source b -> Source (a,b)+zipS (Processor f) (Processor g) = Processor $ \_ -> do+    a <- f ()+    b <- g ()+    return (a,b)++zipS3 :: Source a -> Source b -> Source c -> Source (a,b,c)+zipS3 (Processor f) (Processor g) (Processor h) = Processor $ \_ -> do+    a <- f ()+    b <- g ()+    c <- h ()+    return (a,b,c)++data Config = Config+    { _baseDir :: !FilePath+    }++data WorkflowOpt = WorkflowOpt+    { _logDir :: !FilePath+    }++instance Default WorkflowOpt where+    def = WorkflowOpt+        { _logDir = "wfCache/"+        }