{-# LANGUAGE Arrows #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}

module Main where

import Control.Arrow
import Control.Exception (SomeException (..))
import Control.Kernmantle.Error (tryE)
import Control.Monad (guard)
import qualified Data.ByteString as BS
import Data.CAS.ContentHashable (ContentHashable)
import Data.CAS.ContentStore (Content (..))
import qualified Data.CAS.ContentStore as CS
import qualified Data.CAS.RemoteCache as RC
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
import Data.Typeable (Typeable)
import Funflow
  ( Flow,
    RunFlowConfig (..),
    caching,
    dockerFlow,
    ioFlow,
    pureFlow,
    runFlowWithConfig,
  )
import qualified Funflow.Tasks.Docker as DE
import Parse (getValidMakeFile)
import Path
  ( Abs,
    Dir,
    File,
    Path,
    Rel,
    absdir,
    filename,
    fromAbsDir,
    fromAbsFile,
    parseAbsDir,
    parseRelFile,
    reldir,
    relfile,
    toFilePath,
    (</>),
  )
import Path.IO (getCurrentDir)
import System.Posix.Files (accessModes, createLink, setFileMode)
import Types

type Set = Set.Set

type Map = Map.Map

type FileName = String

type FileContent = String

main :: IO ()
main :: IO ()
main = do
  Either MakeFile MFError
perhapsMakeFile <- Maybe FilePath -> IO (Either MakeFile MFError)
getValidMakeFile Maybe FilePath
forall a. Maybe a
Nothing
  case Either MakeFile MFError
perhapsMakeFile of
    Right (MFError FilePath
errMsg) -> FilePath -> IO ()
putStrLn (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Invalid make file:\n" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
errMsg
    Left MakeFile
mfile -> do
      Path Abs Dir
cwd <- IO (Path Abs Dir)
forall (m :: * -> *). MonadIO m => m (Path Abs Dir)
getCurrentDir
      let contentStore :: Path Abs Dir
contentStore = Path Abs Dir
cwd Path Abs Dir -> Path Rel Dir -> Path Abs Dir
forall b t. Path b Dir -> Path Rel t -> Path b t
</> [reldir|makefiletest/store|]
          defGoalRule :: MakeRule
defGoalRule = MakeFile -> MakeRule
defaultGoal MakeFile
mfile
          runCfg :: RunFlowConfig
runCfg = Path Abs Dir -> RunFlowConfig
getRunConfigWithoutFile Path Abs Dir
contentStore
      FilePath -> IO ()
putStrLn (FilePath
"Attempting build:\n" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ MakeRule -> FilePath
forall a. Show a => a -> FilePath
show MakeRule
defGoalRule)
      Either SomeException (Path Abs File)
result <- RunFlowConfig
-> LooseRopeWith
     RequiredStrands
     (RequiredCore IO)
     ()
     (Either SomeException (Path Abs File))
-> ()
-> IO (Either SomeException (Path Abs File))
forall input output.
RunFlowConfig
-> LooseRopeWith RequiredStrands (RequiredCore IO) input output
-> input
-> IO output
runFlowWithConfig RunFlowConfig
runCfg (Rope Rec mantle core () (Path Abs File)
-> Rope Rec mantle core () (Either SomeException (Path Abs File))
forall ex (eff :: * -> * -> *) a b.
TryEffect ex eff =>
eff a b -> eff a (Either ex b)
tryE @SomeException (Path Abs Dir -> MakeFile -> MakeRule -> Flow () (Path Abs File)
buildTarget Path Abs Dir
contentStore MakeFile
mfile MakeRule
defGoalRule)) () :: IO (Either SomeException (Path Abs File))
      FilePath -> IO ()
putStrLn FilePath
"Build attempt complete"
      case Either SomeException (Path Abs File)
result of
        Left SomeException
ex -> FilePath -> IO ()
putStrLn (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"\n\nFailed, target failed:\n\n" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ (SomeException -> FilePath
forall a. Show a => a -> FilePath
show SomeException
ex)
        Right Path Abs File
execFile -> do
          -- Build succeeded; write executable to target location and set exec bit.
          let outpath :: FilePath
outpath = Path Abs Dir -> FilePath
fromAbsDir Path Abs Dir
cwd FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"/" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ MakeRule -> FilePath
mkRuleTarNm MakeRule
defGoalRule
          FilePath -> IO ByteString
BS.readFile (Path Abs File -> FilePath
fromAbsFile Path Abs File
execFile) IO ByteString -> (ByteString -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= FilePath -> ByteString -> IO ()
BS.writeFile FilePath
outpath
          FilePath -> FileMode -> IO ()
setFileMode FilePath
outpath FileMode
accessModes -- chmod +x
          FilePath -> IO ()
putStrLn FilePath
"\n\nSuccess, target executable made."

-- | Building A Target

--------------------------------------------------------------------------------
-- Note: assuming the makefile is valid at this point!
buildTarget :: Path Abs Dir -> MakeFile -> MakeRule -> Flow () (Path Abs File)
buildTarget :: Path Abs Dir -> MakeFile -> MakeRule -> Flow () (Path Abs File)
buildTarget Path Abs Dir
storeRoot MakeFile
mkfile target :: MakeRule
target@(MakeRule FilePath
targetNm Set FilePath
deps FilePath
cmd) =
  let srcfiles :: Set FilePath
srcfiles = MakeFile -> Set FilePath
sourceFiles MakeFile
mkfile
      -- What must be built is the collection of non-source dependencies.
      neededTargets :: [FilePath]
neededTargets = Set FilePath -> [FilePath]
forall a. Set a -> [a]
Set.toList (Set FilePath -> [FilePath]) -> Set FilePath -> [FilePath]
forall a b. (a -> b) -> a -> b
$ Set FilePath -> Set FilePath -> Set FilePath
forall a. Ord a => Set a -> Set a -> Set a
Set.difference Set FilePath
deps Set FilePath
srcfiles
      -- We only need the sources that are pertinent for the current rule's dependencies.
      neededSources :: [FilePath]
neededSources = Set FilePath -> [FilePath]
forall a. Set a -> [a]
Set.toList (Set FilePath -> [FilePath]) -> Set FilePath -> [FilePath]
forall a b. (a -> b) -> a -> b
$ Set FilePath
deps Set FilePath -> Set FilePath -> Set FilePath
forall a. Ord a => Set a -> Set a -> Set a
`Set.intersection` Set FilePath
srcfiles
      maybeFindDepRules :: Maybe [MakeRule]
maybeFindDepRules = MakeFile -> [FilePath] -> Maybe [MakeRule]
findRules MakeFile
mkfile [FilePath]
neededTargets
   in case Maybe [MakeRule]
maybeFindDepRules of
        Maybe [MakeRule]
Nothing -> Rope r mantle core () (Path Abs File)
forall a. Flow () a
failNow
        Just ([MakeRule]
depRules :: [MakeRule]) ->
          let -- found rules for dependencies to be built for current rule
              grabSrcsActions :: [FilePath] -> IO [FilePath]
grabSrcsActions = (FilePath -> IO FilePath) -> [FilePath] -> IO [FilePath]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (FilePath -> IO FilePath
readFile (FilePath -> IO FilePath)
-> (FilePath -> FilePath) -> FilePath -> IO FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath
"./" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++))
           in proc ()
_ -> do
                FilePath -> Flow () ()
msgFlow (FilePath
"Current rule: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ MakeRule -> FilePath
forall a. Show a => a -> FilePath
show MakeRule
target) -< ()
                () <- Rope r mantle core Bool ()
Flow Bool ()
failGuardFlow -< (MakeRule
target MakeRule -> Set MakeRule -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` (MakeFile -> Set MakeRule
allrules MakeFile
mkfile))
                -- Read content from source files.
                [FilePath]
contentSrcFiles <- (([FilePath] -> IO [FilePath]) -> Flow [FilePath] [FilePath]
forall i o. (i -> IO o) -> Flow i o
ioFlow [FilePath] -> IO [FilePath]
grabSrcsActions) -< [FilePath]
neededSources
                -- Result from building each dependency.
                [Path Abs File]
depFiles <- [Id () (Path Abs File)] -> Flow [()] [Path Abs File]
forall a b. [Id a b] -> Flow [a] [b]
flowJoin [Id :: forall a b. Flow a b -> Id a b
Id {unId :: Flow () (Path Abs File)
unId = Path Abs Dir -> MakeFile -> MakeRule -> Flow () (Path Abs File)
buildTarget Path Abs Dir
storeRoot MakeFile
mkfile MakeRule
r} | MakeRule
r <- [MakeRule]
depRules] -< (Int -> () -> [()]
forall a. Int -> a -> [a]
replicate ([MakeRule] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [MakeRule]
depRules) ())
                let fullSrcFiles :: Map FilePath FilePath
fullSrcFiles = [(FilePath, FilePath)] -> Map FilePath FilePath
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(FilePath, FilePath)] -> Map FilePath FilePath)
-> [(FilePath, FilePath)] -> Map FilePath FilePath
forall a b. (a -> b) -> a -> b
$ [FilePath] -> [FilePath] -> [(FilePath, FilePath)]
forall a b. [a] -> [b] -> [(a, b)]
zip [FilePath]
neededSources [FilePath]
contentSrcFiles
                -- Compile the target of the current rule.
                Path Abs File
compFile <- FilePath
-> Rope
     r
     mantle
     core
     (FilePath, Map FilePath FilePath, [Path Abs File], FilePath)
     (Path Abs File)
-> Rope
     r
     mantle
     core
     (FilePath, Map FilePath FilePath, [Path Abs File], FilePath)
     (Path Abs File)
forall (core :: * -> * -> *) ident a b (r :: RopeRec)
       (mantle :: [Strand]).
(Arrow core, ProvidesCaching core, ContentHashable IO ident,
 ContentHashable IO a, Store b) =>
ident -> Rope r mantle core a b -> Rope r mantle core a b
caching FilePath
targetNm (Path Abs Dir
-> Flow
     (FilePath, Map FilePath FilePath, [Path Abs File], FilePath)
     (Path Abs File)
compileFile Path Abs Dir
storeRoot) -< (FilePath
targetNm, Map FilePath FilePath
fullSrcFiles, [Path Abs File]
depFiles, FilePath
cmd)
                Rope r mantle core (Path Abs File) (Path Abs File)
forall (a :: * -> * -> *) b. Arrow a => a b b
returnA -< Path Abs File
compFile

-- | Compiles a C file in a docker container.
compileFile :: Path Abs Dir -> Flow (TargetFile, Map.Map SourceFile String, [Path Abs File], Command) (Path Abs File)
compileFile :: Path Abs Dir
-> Flow
     (FilePath, Map FilePath FilePath, [Path Abs File], FilePath)
     (Path Abs File)
compileFile Path Abs Dir
root = proc (FilePath
tf, Map FilePath FilePath
srcDeps, [Path Abs File]
tarDeps, FilePath
cmd) -> do
  Path Rel File
relpathCompiledFile <- ((FilePath -> IO (Path Rel File)) -> Flow FilePath (Path Rel File)
forall i o. (i -> IO o) -> Flow i o
ioFlow FilePath -> IO (Path Rel File)
forall (m :: * -> *). MonadThrow m => FilePath -> m (Path Rel File)
parseRelFile) -< FilePath
tf
  [Path Abs File]
srcsInStore <- Path Abs Dir -> Flow (Map FilePath FilePath) [Path Abs File]
write2Store Path Abs Dir
root -< Map FilePath FilePath
srcDeps
  let inputFilesInStore :: [Path Abs File]
inputFilesInStore = [Path Abs File]
srcsInStore [Path Abs File] -> [Path Abs File] -> [Path Abs File]
forall a. [a] -> [a] -> [a]
++ [Path Abs File]
tarDeps
  Content Dir
inputDir <- Path Abs Dir -> Flow [Path Abs File] (Content Dir)
mergeFiles Path Abs Dir
root -< [Path Abs File]
inputFilesInStore
  let finalCmd :: FilePath
finalCmd = FilePath
cmd FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" -o " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
tf
      scriptSrc :: FilePath
scriptSrc =
        FilePath
"#!/usr/bin/env bash\n\
        \cp $1/*.* $PWD\n"
          FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
finalCmd
          FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"\n"
  ()
_ <- (FilePath -> IO ()) -> Flow FilePath ()
forall i o. (i -> IO o) -> Flow i o
ioFlow (\FilePath
msg -> FilePath -> IO ()
putStrLn (FilePath
"Current command: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
msg)) -< FilePath
finalCmd
  (Item
compItem, Content File
_) <- Path Abs Dir -> Flow (FilePath, Path Rel File) (Item, Content File)
writeExecutableString Path Abs Dir
root -< (FilePath
scriptSrc, [relfile|script.sh|])
  Path Abs Dir
inMnt <- (FilePath -> IO (Path Abs Dir)) -> Flow FilePath (Path Abs Dir)
forall i o. (i -> IO o) -> Flow i o
ioFlow FilePath -> IO (Path Abs Dir)
forall (m :: * -> *). MonadThrow m => FilePath -> m (Path Abs Dir)
parseAbsDir -< FilePath
"/sandbox"
  DockerTaskInput
taskIn <- ((Content Dir, Item, Path Abs Dir) -> DockerTaskInput)
-> Flow (Content Dir, Item, Path Abs Dir) DockerTaskInput
forall i o. (i -> o) -> Flow i o
pureFlow (Content Dir, Item, Path Abs Dir) -> DockerTaskInput
forall t. (Content t, Item, Path Abs Dir) -> DockerTaskInput
buildTaskInput -< (Content Dir
inputDir, Item
compItem, Path Abs Dir
inMnt)
  Item
resDir <- DockerTaskConfig -> Flow DockerTaskInput Item
dockerFlow DockerTaskConfig
dockConf -< DockerTaskInput
taskIn
  Path Abs File
resFile <- (Content File -> IO (Path Abs File))
-> Flow (Content File) (Path Abs File)
forall i o. (i -> IO o) -> Flow i o
ioFlow (Path Abs Dir -> Content File -> IO (Path Abs File)
forall t. Path Abs Dir -> Content t -> IO (Path Abs t)
ioContentPath Path Abs Dir
root) -< (Item
resDir Item -> Path Rel File -> Content File
forall t. Item -> Path Rel t -> Content t
CS.:</> Path Rel File
relpathCompiledFile)
  Rope r mantle core (Path Abs File) (Path Abs File)
forall (a :: * -> * -> *) b. Arrow a => a b b
returnA -< Path Abs File
resFile
  where
    dockConf :: DockerTaskConfig
dockConf = DockerTaskConfig :: Text -> Text -> [Arg] -> DockerTaskConfig
DE.DockerTaskConfig {image :: Text
DE.image = Text
"gcc:7.3.0", command :: Text
DE.command = Text
"/script/script.sh", args :: [Arg]
DE.args = [Arg
"/sandbox"]}
    buildTaskInput :: (Content t, Item, Path Abs Dir) -> DockerTaskInput
buildTaskInput (Content t
indir, Item
compItem, Path Abs Dir
mnt) =
      DockerTaskInput :: [VolumeBinding] -> Map FilePath Text -> DockerTaskInput
DE.DockerTaskInput
        { inputBindings :: [VolumeBinding]
DE.inputBindings =
            [ VolumeBinding :: Item -> Path Abs Dir -> VolumeBinding
DE.VolumeBinding {item :: Item
DE.item = Item
compItem, mount :: Path Abs Dir
DE.mount = [absdir|/script/|]},
              VolumeBinding :: Item -> Path Abs Dir -> VolumeBinding
DE.VolumeBinding {item :: Item
DE.item = Content t -> Item
forall t. Content t -> Item
CS.contentItem Content t
indir, mount :: Path Abs Dir
DE.mount = Path Abs Dir
mnt}
            ],
          argsVals :: Map FilePath Text
DE.argsVals = Map FilePath Text
forall a. Monoid a => a
mempty
        }

----------------------------------------------------------------------------------------
-- These are helpers for overcoming challenge of typelevel polymorphism in kernmantle.
-- In particular, this is for beating "illegal polymorphic type..."
-- related to impredicative polymorphism
----------------------------------------------------------------------------------------

-- Wrap a flow so that we can overcome impredicative polymporphism.
-- See SO (answer by Jon Purdy): https://stackoverflow.com/a/56449258
newtype Id a b = Id {Id a b
-> forall (m :: * -> *).
   MonadIO m =>
   AnyRopeWith ('[] ++ RequiredStrands) (RequiredCore m) a b
unId :: (Flow a b)}

-- "Merge" a a collection of "atomic" flows into a single flow from one collection to another.
-- Note that order should not matter, else the result should be reversed.
-- In particular, we process the flow/input pairs left-to-right, but build the result right-to-left.
flowJoin :: [Id a b] -> Flow [a] [b]
flowJoin :: [Id a b] -> Flow [a] [b]
flowJoin [] = ([a] -> [b]) -> Flow [a] [b]
forall i o. (i -> o) -> Flow i o
pureFlow (\[a]
_ -> [])
flowJoin ff :: [Id a b]
ff@(Id a b
f : [Id a b]
fs) = proc aa :: [a]
aa@(a
a : [a]
as) -> do
  -- Enforce dimensional match between flows and inputs.
  () <- Rope r mantle core Bool ()
Flow Bool ()
failGuardFlow -< ([Id a b] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Id a b]
ff Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
aa)
  -- "Run" the "current" flow
  b
b <- Id a b
-> forall (m :: * -> *).
   MonadIO m =>
   AnyRopeWith ('[] ++ RequiredStrands) (RequiredCore m) a b
forall a b. Id a b -> Flow a b
unId Id a b
f -< a
a
  -- Recurse on the remaining flows and inputs.
  [b]
bs <- [Id a b] -> Flow [a] [b]
forall a b. [Id a b] -> Flow [a] [b]
flowJoin [Id a b]
fs -< [a]
as
  Rope r mantle core [b] [b]
forall (a :: * -> * -> *) b. Arrow a => a b b
returnA -< (b
b b -> [b] -> [b]
forall a. a -> [a] -> [a]
: [b]
bs)

-------------------------------------------------------------------------------
-- Application-related
-------------------------------------------------------------------------------

-- For each of a collection of files, create a link in the store root.
mergeFilesRaw :: Path Abs Dir -> [Path Abs File] -> IO (Content Dir)
mergeFilesRaw :: Path Abs Dir -> [Path Abs File] -> IO (Content Dir)
mergeFilesRaw Path Abs Dir
root [Path Abs File]
fs = Path Abs Dir
-> (ContentStore -> IO (Content Dir)) -> IO (Content Dir)
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
Path Abs Dir -> (ContentStore -> m a) -> m a
CS.withStore Path Abs Dir
root (\ContentStore
s -> ContentStore -> [Path Abs File] -> IO (Content Dir)
forall (t :: * -> *) b.
(ContentHashable IO (t (Path b File)), Foldable t) =>
ContentStore -> t (Path b File) -> IO (Content Dir)
merge ContentStore
s [Path Abs File]
fs)
  where
    merge :: ContentStore -> t (Path b File) -> IO (Content Dir)
merge ContentStore
store t (Path b File)
files =
      let linkIn :: Path b Dir -> t (Path b File) -> IO ()
linkIn Path b Dir
d = (Path b File -> IO ()) -> t (Path b File) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\Path b File
f -> FilePath -> FilePath -> IO ()
createLink (Path b File -> FilePath
forall b t. Path b t -> FilePath
toFilePath Path b File
f) (Path b File -> FilePath
forall b t. Path b t -> FilePath
toFilePath (Path b File -> FilePath) -> Path b File -> FilePath
forall a b. (a -> b) -> a -> b
$ Path b Dir
d Path b Dir -> Path Rel File -> Path b File
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path b File -> Path Rel File
forall b. Path b File -> Path Rel File
filename Path b File
f))
       in Item -> Content Dir
CS.All (Item -> Content Dir) -> IO Item -> IO (Content Dir)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ContentStore
-> NoCache
-> (ContentHash -> IO ())
-> (Path Abs Dir -> t (Path b File) -> IO ())
-> t (Path b File)
-> IO Item
forall (m :: * -> *) remoteCacher t.
(MonadIO m, MonadMask m, MonadUnliftIO m, Cacher m remoteCacher,
 ContentHashable IO t) =>
ContentStore
-> remoteCacher
-> (ContentHash -> m ())
-> (Path Abs Dir -> t -> m ())
-> t
-> m Item
CS.putInStore ContentStore
store NoCache
RC.NoCache (\ContentHash
_ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath -> ()
forall a. HasCallStack => FilePath -> a
error FilePath
"uh-oh!")) Path Abs Dir -> t (Path b File) -> IO ()
forall (t :: * -> *) b b.
Foldable t =>
Path b Dir -> t (Path b File) -> IO ()
linkIn t (Path b File)
files

-- Flow version of linking a collection of files into the store root
mergeFiles :: Path Abs Dir -> Flow [Path Abs File] (Content Dir)
mergeFiles :: Path Abs Dir -> Flow [Path Abs File] (Content Dir)
mergeFiles Path Abs Dir
root = ([Path Abs File] -> IO (Content Dir))
-> Flow [Path Abs File] (Content Dir)
forall i o. (i -> IO o) -> Flow i o
ioFlow (Path Abs Dir -> [Path Abs File] -> IO (Content Dir)
mergeFilesRaw Path Abs Dir
root)

-- Write to a file at given relpath, in the store at the given root.
writeExecutableString :: Path Abs Dir -> Flow (String, Path Rel File) (CS.Item, Content File)
writeExecutableString :: Path Abs Dir -> Flow (FilePath, Path Rel File) (Item, Content File)
writeExecutableString Path Abs Dir
root = ((FilePath, Path Rel File) -> IO (Item, Content File))
-> Flow (FilePath, Path Rel File) (Item, Content File)
forall i o. (i -> IO o) -> Flow i o
ioFlow (Path Abs Dir
-> (Path Abs File -> FilePath -> IO ())
-> (FilePath, Path Rel File)
-> IO (Item, Content File)
forall a t.
(ContentHashable IO a, Typeable t) =>
Path Abs Dir
-> (Path Abs t -> a -> IO ())
-> (a, Path Rel t)
-> IO (Item, Content t)
putInStoreAt Path Abs Dir
root (\Path Abs File
p FilePath
x -> let p' :: FilePath
p' = Path Abs File -> FilePath
fromAbsFile Path Abs File
p in FilePath -> FilePath -> IO ()
writeFile FilePath
p' FilePath
x IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> FilePath -> FileMode -> IO ()
setFileMode FilePath
p' FileMode
accessModes))

-- Find the collection of rules in the given makefile for the given collection of targets.
findRules :: MakeFile -> [TargetFile] -> Maybe [MakeRule]
findRules :: MakeFile -> [FilePath] -> Maybe [MakeRule]
findRules MakeFile {allrules :: MakeFile -> Set MakeRule
allrules = Set MakeRule
rules} [FilePath]
targets = do
  Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ())
-> (Set FilePath -> Bool) -> Set FilePath -> Maybe ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set FilePath -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Set FilePath -> Maybe ()) -> Set FilePath -> Maybe ()
forall a b. (a -> b) -> a -> b
$ Set FilePath -> Set FilePath -> Set FilePath
forall a. Ord a => Set a -> Set a -> Set a
Set.difference Set FilePath
tfileSet Set FilePath
ruleTarNmSet -- check that each each target has a rule.
  -- We're only interested in the rules for the given set of targets
  let targetRules :: Set MakeRule
targetRules = (MakeRule -> Bool) -> Set MakeRule -> Set MakeRule
forall a. (a -> Bool) -> Set a -> Set a
Set.filter ((FilePath -> Set FilePath -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set FilePath
tfileSet) (FilePath -> Bool) -> (MakeRule -> FilePath) -> MakeRule -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MakeRule -> FilePath
mkRuleTarNm) Set MakeRule
rules
  [MakeRule] -> Maybe [MakeRule]
forall (m :: * -> *) a. Monad m => a -> m a
return ([MakeRule] -> Maybe [MakeRule]) -> [MakeRule] -> Maybe [MakeRule]
forall a b. (a -> b) -> a -> b
$ Set MakeRule -> [MakeRule]
forall a. Set a -> [a]
Set.toList Set MakeRule
targetRules
  where
    ruleTarNmSet :: Set FilePath
ruleTarNmSet = (MakeRule -> FilePath) -> Set MakeRule -> Set FilePath
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map MakeRule -> FilePath
mkRuleTarNm Set MakeRule
rules
    tfileSet :: Set FilePath
tfileSet = [FilePath] -> Set FilePath
forall a. Ord a => [a] -> Set a
Set.fromList [FilePath]
targets

-------------------------------------------------------------------------------
-- Storage-related
-------------------------------------------------------------------------------
-- Use a given function to store a given value at given relative path, within store rooted at given path.
putInStoreAt ::
  (ContentHashable IO a, Typeable t) =>
  Path Abs Dir ->
  (Path Abs t -> a -> IO ()) ->
  (a, Path Rel t) ->
  IO (CS.Item, CS.Content t)
putInStoreAt :: Path Abs Dir
-> (Path Abs t -> a -> IO ())
-> (a, Path Rel t)
-> IO (Item, Content t)
putInStoreAt Path Abs Dir
root Path Abs t -> a -> IO ()
put (a
a, Path Rel t
p) =
  Path Abs Dir
-> (ContentStore -> IO (Item, Content t)) -> IO (Item, Content t)
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
Path Abs Dir -> (ContentStore -> m a) -> m a
CS.withStore
    Path Abs Dir
root
    ( \ContentStore
store -> do
        Item
item <- ContentStore
-> NoCache
-> (ContentHash -> IO ())
-> (Path Abs Dir -> a -> IO ())
-> a
-> IO Item
forall (m :: * -> *) remoteCacher t.
(MonadIO m, MonadMask m, MonadUnliftIO m, Cacher m remoteCacher,
 ContentHashable IO t) =>
ContentStore
-> remoteCacher
-> (ContentHash -> m ())
-> (Path Abs Dir -> t -> m ())
-> t
-> m Item
CS.putInStore ContentStore
store NoCache
RC.NoCache (\ContentHash
_ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) (\Path Abs Dir
d a
x -> Path Abs t -> a -> IO ()
put (Path Abs Dir
d Path Abs Dir -> Path Rel t -> Path Abs t
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel t
p) a
x) a
a
        (Item, Content t) -> IO (Item, Content t)
forall (m :: * -> *) a. Monad m => a -> m a
return (Item
item, Item
item Item -> Path Rel t -> Content t
forall t. Item -> Path Rel t -> Content t
CS.:</> Path Rel t
p)
    )

-- Write each content to file with associated name, within store rooted at given path.
write2Store :: Path Abs Dir -> Flow (Map.Map FileName FileContent) [Path Abs File]
write2Store :: Path Abs Dir -> Flow (Map FilePath FilePath) [Path Abs File]
write2Store Path Abs Dir
root =
  let ioFixSrcFileData :: (FilePath, a) -> f (a, Path Rel File)
ioFixSrcFileData (FilePath
x, a
y) = (\Path Rel File
y' -> (a
y, Path Rel File
y')) (Path Rel File -> (a, Path Rel File))
-> f (Path Rel File) -> f (a, Path Rel File)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> f (Path Rel File)
forall (m :: * -> *). MonadThrow m => FilePath -> m (Path Rel File)
parseRelFile FilePath
x
   in (Map FilePath FilePath -> IO [Path Abs File])
-> Flow (Map FilePath FilePath) [Path Abs File]
forall i o. (i -> IO o) -> Flow i o
ioFlow
        ( \Map FilePath FilePath
files ->
            ((FilePath, FilePath) -> IO (Path Abs File))
-> [(FilePath, FilePath)] -> IO [Path Abs File]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM
              ( \(FilePath, FilePath)
x -> do
                  (FilePath, Path Rel File)
y <- (FilePath, FilePath) -> IO (FilePath, Path Rel File)
forall (f :: * -> *) a.
MonadThrow f =>
(FilePath, a) -> f (a, Path Rel File)
ioFixSrcFileData (FilePath, FilePath)
x
                  (Item
_, Content File
z) <- Path Abs Dir
-> (Path Abs File -> FilePath -> IO ())
-> (FilePath, Path Rel File)
-> IO (Item, Content File)
forall a t.
(ContentHashable IO a, Typeable t) =>
Path Abs Dir
-> (Path Abs t -> a -> IO ())
-> (a, Path Rel t)
-> IO (Item, Content t)
putInStoreAt Path Abs Dir
root (FilePath -> FilePath -> IO ()
writeFile (FilePath -> FilePath -> IO ())
-> (Path Abs File -> FilePath)
-> Path Abs File
-> FilePath
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path Abs File -> FilePath
fromAbsFile) (FilePath, Path Rel File)
y
                  Path Abs File
fp <- Path Abs Dir -> Content File -> IO (Path Abs File)
forall t. Path Abs Dir -> Content t -> IO (Path Abs t)
ioContentPath Path Abs Dir
root Content File
z
                  Path Abs File -> IO (Path Abs File)
forall (m :: * -> *) a. Monad m => a -> m a
return Path Abs File
fp
              )
              (Map FilePath FilePath -> [(FilePath, FilePath)]
forall k a. Map k a -> [(k, a)]
Map.toList Map FilePath FilePath
files)
        )

-- Get the path to content in the store.
ioContentPath :: Path Abs Dir -> Content t -> IO (Path Abs t)
ioContentPath :: Path Abs Dir -> Content t -> IO (Path Abs t)
ioContentPath Path Abs Dir
root Content t
x = Path Abs Dir
-> (ContentStore -> IO (Path Abs t)) -> IO (Path Abs t)
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
Path Abs Dir -> (ContentStore -> m a) -> m a
CS.withStore Path Abs Dir
root (\ContentStore
s -> Path Abs t -> IO (Path Abs t)
forall (m :: * -> *) a. Monad m => a -> m a
return (ContentStore -> Content t -> Path Abs t
forall t. ContentStore -> Content t -> Path Abs t
CS.contentPath ContentStore
s Content t
x))

-------------------------------------------------------------------------------
-- General flow-related
-------------------------------------------------------------------------------
getRunConfigWithoutFile :: Path Abs Dir -> RunFlowConfig
getRunConfigWithoutFile :: Path Abs Dir -> RunFlowConfig
getRunConfigWithoutFile Path Abs Dir
d = RunFlowConfig :: Path Abs Dir -> Maybe (Path Abs File) -> RunFlowConfig
RunFlowConfig {storePath :: Path Abs Dir
storePath = Path Abs Dir
d, configFile :: Maybe (Path Abs File)
configFile = Maybe (Path Abs File)
forall a. Maybe a
Nothing}

-- Flow that fails iff given flag is False.
failGuardFlow :: Flow Bool ()
failGuardFlow :: AnyRopeWith ('[] ++ RequiredStrands) (RequiredCore m) Bool ()
failGuardFlow = proc Bool
test -> do
  case Bool
test of
    Bool
True -> Rope r mantle core () ()
forall (a :: * -> * -> *) b. Arrow a => a b b
returnA -< ()
    Bool
False -> do
      () <- Rope r mantle core () ()
forall a. Flow () a
failNow -< ()
      Rope r mantle core () ()
forall (a :: * -> * -> *) b. Arrow a => a b b
returnA -< ()

-- Degenerate flow failing with fixed, basic error message
failNow :: Flow () a
failNow :: AnyRopeWith ('[] ++ RequiredStrands) (RequiredCore m) () a
failNow = proc ()
_ -> do
  (() -> IO a) -> Flow () a
forall i o. (i -> IO o) -> Flow i o
ioFlow () -> IO a
forall a. () -> a
err -< ()
  where
    err :: () -> a
err () = do (FilePath -> a
forall a. HasCallStack => FilePath -> a
error FilePath
"error")

-- Flow that accepts message and fails with that as the error message
failWith :: Flow String a
failWith :: AnyRopeWith ('[] ++ RequiredStrands) (RequiredCore m) FilePath a
failWith = (FilePath -> IO a) -> Flow FilePath a
forall i o. (i -> IO o) -> Flow i o
ioFlow (\FilePath
msg -> do FilePath -> IO a
forall a. HasCallStack => FilePath -> a
error FilePath
msg)

-- Degenerate flow that prints the given message
msgFlow :: String -> Flow () ()
msgFlow :: FilePath -> Flow () ()
msgFlow FilePath
msg = (() -> IO ()) -> Flow () ()
forall i o. (i -> IO o) -> Flow i o
ioFlow (\()
_ -> FilePath -> IO ()
putStrLn FilePath
msg)