summaryrefslogtreecommitdiff
path: root/src/System/TaskPipeline/Repetition.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/System/TaskPipeline/Repetition.hs')
-rw-r--r--src/System/TaskPipeline/Repetition.hs119
1 files changed, 119 insertions, 0 deletions
diff --git a/src/System/TaskPipeline/Repetition.hs b/src/System/TaskPipeline/Repetition.hs
new file mode 100644
index 0000000..8dde3e4
--- /dev/null
+++ b/src/System/TaskPipeline/Repetition.hs
@@ -0,0 +1,119 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TupleSections #-}
+
+module System.TaskPipeline.Repetition
+ ( RepInfo(..)
+ , TRIndex(..)
+ , HasTRIndex(..)
+ , OneOrSeveral(..)
+ , parMapTask
+ , parMapTask_
+ , IndexRange(..)
+ , oneIndex
+ , oneRange
+ , enumIndices
+ , enumTRIndices
+ ) where
+
+import Control.Applicative
+import Control.Arrow.Free (mapA)
+import Control.Lens hiding ((.=))
+import Control.Monad
+import Data.Aeson
+import Data.Aeson.Types (Parser)
+import qualified Data.Text as T
+import Prelude hiding ((.))
+import System.TaskPipeline.PTask
+import System.TaskPipeline.Repetition.Internal
+
+
+-- | Makes a 'PTask' repeatable and maps it in parallel over a list.
+parMapTask
+ :: (HasTRIndex a, KatipContext m)
+ => RepInfo
+ -> PTask m a b
+ -> PTask m [a] [b]
+parMapTask ri =
+ over taskRunnablePart mapA . makeTaskRepeatable ri
+
+-- | Simply repeats a task which takes no input over a list of indices, and
+-- ignores the end result. See 'RepInfo' for how these indices are
+-- used. See 'parMapTask' for a more complete version.
+parMapTask_
+ :: (HasTRIndex idx, KatipContext m)
+ => RepInfo
+ -> PTask m () b
+ -> PTask m [idx] ()
+parMapTask_ ri task =
+ arr (map (, ())) >>> parMapTask ri (arr snd >>> task) >>> arr (const ())
+
+
+-- * A simple type to handle index ranges
+
+data OneRange i = OneIndex i | OneRange i i
+
+toJSONStr :: (ToJSON a) => a -> Either Value T.Text
+toJSONStr a = case toJSON a of
+ String s -> Right s
+ Number n -> Right $ T.pack $ show n
+ o -> Left o
+
+parseJSONStr :: (FromJSON a) => T.Text -> Parser a
+parseJSONStr v = tryNumber v <|> parseJSON (String v)
+ where
+ tryNumber n = case reads $ T.unpack n of
+ [(n',_)] -> parseJSON $ Number n'
+ _ -> fail "Not a number"
+
+instance (ToJSON i) => ToJSON (OneRange i) where
+ toJSON (OneIndex i) = toJSON i
+ toJSON (OneRange a b) = case (toJSONStr a, toJSONStr b) of
+ (Right a', Right b') -> String $ a' <> ".." <> b'
+ (a', b') -> object ["lower" .= toJ a', "upper" .= toJ b']
+ where toJ (Left o) = o
+ toJ (Right s) = String s
+
+instance (FromJSON i) => FromJSON (OneRange i) where
+ parseJSON o@(String s) = case T.splitOn ".." s of
+ [a,b] -> (OneRange <$> parseJSONStr a <*> parseJSONStr b)
+ <|> (OneIndex <$> parseJSON o)
+ _ -> OneIndex <$> parseJSON o
+ parseJSON (Object o) = OneRange <$> o .: "lower" <*> o .: "upper"
+ parseJSON o = OneIndex <$> parseJSON o
+
+-- | Allows to read from a JSON file either one @a@ or an array of @a@
+newtype OneOrSeveral a = OneOrSeveral {getOneOrSeveral :: [a]}
+
+instance (ToJSON a) => ToJSON (OneOrSeveral a) where
+ toJSON (OneOrSeveral [r]) = toJSON r
+ toJSON (OneOrSeveral rs) = toJSON rs
+
+instance (FromJSON a) => FromJSON (OneOrSeveral a) where
+ parseJSON o@(Array _) = OneOrSeveral <$> parseJSON o
+ parseJSON o = OneOrSeveral . (:[]) <$> parseJSON o
+
+-- | A simple index list that can be used in configuration, and from which a
+-- list of indices can be extracted. The JSON representation of it is more
+-- compact than that of [(i,i)], as ranges are represented by "a..b" strings
+newtype IndexRange i = IndexRange (OneOrSeveral (OneRange i))
+ deriving (FromJSON, ToJSON)
+
+-- | A range of just one index
+oneIndex :: i -> IndexRange i
+oneIndex i = IndexRange $ OneOrSeveral [OneIndex i]
+
+-- | A range of consecutive values
+oneRange :: i -> i -> IndexRange i
+oneRange a b = IndexRange $ OneOrSeveral [OneRange a b]
+
+-- | Gives a list of indices from an index range
+enumIndices :: (Enum i) => IndexRange i -> [i]
+enumIndices (IndexRange (OneOrSeveral rs)) = concatMap toL rs
+ where
+ toL (OneIndex i) = [i]
+ toL (OneRange a b) = [a..b]
+
+-- | Gives a list of TaskRepetitionIndex
+enumTRIndices :: (Enum i, Show i) => IndexRange i -> [TRIndex]
+enumTRIndices = map (TRIndex . show) . enumIndices