Bioshake.hs

{-# LANGUAGE FlexibleContexts  #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs             #-}
{-# LANGUAGE Rank2Types        #-}
{-# LANGUAGE TemplateHaskell   #-}
{-# LANGUAGE TypeOperators     #-}
{-# LANGUAGE ViewPatterns      #-}

-- | Bioshake is a small framework for specifying bioinformatics pipelines. The
-- goal is to specify stages in a forward chaining manner (as is natural for the
-- domain) while guaranteeing as much robustness as possible to errors such as
-- mismatched file types or other attributes. Almost everything is handled in
-- the type system, and pipelines are compiled down to "Development.Shake"
-- 'Rules' for actual execution.
module Bioshake( module Types
               , module Data.Reflection
               , module Tags
               , All(..)
               , On(..)
               , Referenced(..)
               , Capture(..)
               , ignoringIOErrors
               , withTempDirectory
               , bioshake
               , out
               , Out
               , split
               , withAll
               , withPair) where

import           Bioshake.Cluster.Torque
import           Bioshake.Tags                    as Tags
import           Bioshake.Types                   as Types
import qualified Control.Exception                as E
import           Control.Monad
import           Control.Monad.Trans
import           Control.Monad.Trans.State.Strict
import           Data.List
import           Data.Reflection                  (Given, give, given)
import qualified Data.Set                         as S
import           Data.String
import           Development.Shake
import           Language.Haskell.TH
import           System.Directory                 (copyFile,
                                                   removeDirectoryRecursive)
import           System.IO.Temp                   (createTempDirectory)


-- | Attaches a reference genome.
class Referenced a where
  -- | The path to the reference fasta file.
  getRef :: a -> FilePath

  -- | The short name, e.g., hg19.
  name :: a -> String

  -- | Path to dbNSFP for the genome
  dbnsfp :: a -> FilePath
  dbnsfp _ = error "dbNSFP not available"

  -- | Gene annotations
  annotations :: a -> FilePath
  annotations _ = error "annotations not available"

-- | References flows down the pipeline regardless of the stage
instance Referenced a => Referenced (a :-> b) where
  getRef (a :-> _) = getRef a
  name (a :-> _) = name a
  dbnsfp (a :-> _) = dbnsfp a
  annotations (a :-> _) = annotations a

-- | Asserts a capture region.
class Capture a where
  getBED :: a -> FilePath

instance Capture a => Capture (a :-> b) where
  getBED (a :-> _) = getBED a

-- Hard naming outputs
data Out = Out [FilePath] deriving Show

-- | Explicitly names an output product. Outputs are automatically named in the
-- temporary directory except for this special case: this is how you obtain the
-- artifacts you are specifically interested in.
out = Out

instance Pathable (a :-> Out) where
  paths (_ :-> Out outs) = outs

instance Pathable a => Buildable (a :-> Out) where
  build ((paths -> inputs) :-> Out outs) = zipWithM_ ((liftIO .) . copyFile) inputs outs

$(allTransTagsPipe ''Out)

-- |Datatype to represent fan-in combinations.

data All a where
  All :: (Functor f, Foldable f) => f a -> All a

-- |Fan-in style combinator. Takes a collection of combines their output paths
-- as input paths for the subsequent stage.
withAll :: (Functor f, Foldable f) => f a -> All a
withAll = All

-- | Explicitly construct a fan-in of exactly two items
withPair :: a -> a -> All a
withPair a b = All [a, b]

instance Compilable a => Compilable (All a) where
  compile (All as) = mapM_ compile as

instance Pathable a => Pathable (All a) where
  paths (All ps) = nub $ concatMap paths ps

-- |Fan-ins are 'Referenced' iff all items are consistently 'Referenced'. Problems are caught at runtime unfortunately.
instance Referenced a => Referenced (All a) where
  getRef (All as) =  foldl1 (\l r -> if l == r then l else error "cannot combine mixed references") $ fmap getRef as
  name (All as) =  foldl1 (\l r -> if l == r then l else error "cannot combine mixed references") $ fmap name as
  dbnsfp (All as) =  foldl1 (\l r -> if l == r then l else error "cannot combine mixed references") $ fmap dbnsfp as
  annotations (All as) =  foldl1 (\l r -> if l == r then l else error "cannot combine mixed references") $ fmap annotations as

-- |Fan-ins are a 'Capture' iff all items are consistent.
instance Capture a => Capture (All a) where
  getBED (All as) = foldl1 (\l r -> if l == r then l else error "cannot combine mixed captures") $ fmap getBED as

instance Show a => Show (All a) where
  show (All as) = foldl1 (\l r -> l ++ "," ++ r) $ fmap show as

$(allTransTags ''All)

-- |Datatype to split outputs

data On a = On a Int

instance Compilable a => Compilable (On a) where
  compile (On a _) = compile a

instance Pathable a => Pathable (On a) where
  paths (On a i) = [paths a !! i]

instance Referenced a => Referenced (On a) where
  getRef (On a _) = getRef a
  name (On a _) = name a
  dbnsfp (On a _) = dbnsfp a
  annotations (On a _) = annotations a

instance Capture a => Capture (On a) where
  getBED (On a _) = getBED a

instance Show a => Show (On a) where
  show (On a i) = "(" ++ show a ++ ")_" ++ show i

$(allTransTags ''On)

on :: Pathable a => a -> Int -> On a
on a i
  | i >= 0 && i < length (paths a) = On a i
  | otherwise = error "on: index out of bounds"

split :: Pathable a => a -> [On a]
split a = [on a i | i <- [0..n - 1]]
  where
    n = length $ paths a

-- | Entry point to bioshake. Like 'shakeArgs' but also takes a number of
-- threads to use.
bioshake :: Int -- ^ Number of threads
         -> ShakeOptions -- ^ Options to pass to 'shakeArgs'.
         -> (Given Resource => Rules ()) -> IO ()
bioshake n opts cont = shakeArgs opts{shakeThreads = n} $ do
  res <- newResource "cpus" n
  give res cont

-- | Creates a temporary directory under a target directory according to a
-- naming template. The directory is cleaned up after executing the action. This
-- differs from "Development.Shake"'s 'withTempDir' in that it takes a target
-- directory and template whereas "Development.Shake" uses /tmp. This is
-- generally more useful, as ./tmp is used as the target directory by convention
-- in BioShake.
withTempDirectory :: FilePath -- ^ Target directory under which the temporary directory is created
                  -> String -- ^ Template for the temporary directory name
                  -> (FilePath -> Action b) -- ^ Action to carry out
                  -> Action b
withTempDirectory targetDir template act = do
  path <- liftIO $ createTempDirectory targetDir template
  act path `actionFinally` (liftIO . ignoringIOErrors $ removeDirectoryRecursive path)

ignoringIOErrors :: IO () -> IO ()
ignoringIOErrors ioe = ioe `E.catch` (\e -> const (return ()) (e :: IOError))