{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}
{-# LANGUAGE FlexibleInstances    #-}
{-# LANGUAGE RecordWildCards      #-}
{-# LANGUAGE ScopedTypeVariables  #-}
{-# LANGUAGE TypeSynonymInstances #-}

module Development.Shake.ATS ( -- * Shake Rules
                               cleanATS
                             , atsBin
                             , cgen
                             , genATS
                             , atsLex
                             -- * Helper functions
                             , getSubdirs
                             , ccToDir
                             , withPF
                             -- * Environment/configuration
                             , patscc
                             , patsopt
                             -- * Types
                             , ForeignCabal (..)
                             , ATSTarget (..)
                             , ATSToolConfig (..)
                             , CCompiler (..)
                             , ArtifactType (..)
                             , ATSGen (..)
                             -- * Lenses
                             , atsTarget
                             , cFlags
                             , binTarget
                             , cc
                             , gc
                             , hasPretty
                             , genTargets
                             , hsLibs
                             , patsHome
                             , patsHomeLocs
                             , libs
                             , linkStatic
                             , linkTargets
                             , otherDeps
                             , src
                             , tgtType
                             , toolConfig
                             ) where

import           Control.Arrow
import           Control.Monad
import           Control.Monad.IO.Class
import           Data.Bool                         (bool)
import           Data.Either                       (fromRight)
import           Data.Maybe                        (fromMaybe)
import           Data.Semigroup                    (Semigroup (..))
import qualified Data.Text.Lazy                    as TL
import           Development.Shake                 hiding (doesFileExist, getEnv)
import           Development.Shake.ATS.Environment
import           Development.Shake.ATS.Rules
import           Development.Shake.ATS.Type
import           Development.Shake.C
import           Development.Shake.FilePath
import           Development.Shake.Version
import           Language.ATS
import           Lens.Micro
import           System.Directory                  (copyFile, createDirectoryIfMissing, doesFileExist)
import           System.Environment                (getEnv)
import           System.Exit                       (ExitCode (ExitSuccess))

-- | Run @patsopt@ given information about various things
atsCommand :: CmdResult r => ATSToolConfig
                          -> String -- ^ Source file
                          -> String -- ^ C code to be generated
                          -> Action r
atsCommand :: ATSToolConfig -> String -> String -> Action r
atsCommand ATSToolConfig
tc String
sourceFile String
out = do
    String
path <- IO String -> Action String
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO String -> Action String) -> IO String -> Action String
forall a b. (a -> b) -> a -> b
$ String -> IO String
getEnv String
"PATH"
    let env :: [CmdOption]
env = ATSToolConfig -> String -> [CmdOption]
patsEnv ATSToolConfig
tc String
path
        patsc :: String
patsc = ATSToolConfig -> String
patsopt ATSToolConfig
tc

    [CmdOption] -> String -> [String] -> Action r
forall r.
(Partial, CmdResult r) =>
[CmdOption] -> String -> [String] -> Action r
command [CmdOption]
env String
patsc [String
"--output", String
out, String
"-dd", String
sourceFile, String
"-cc"]

-- | Filter any generated errors with @pats-filter@.
withPF :: Action (Exit, Stderr String, Stdout String) -- ^ Result of a 'cmd' or 'command'
       -> Action (Exit, Stderr String, Stdout String)
withPF :: Action (Exit, Stderr String, Stdout String)
-> Action (Exit, Stderr String, Stdout String)
withPF Action (Exit, Stderr String, Stdout String)
act = do
    ret :: (Exit, Stderr String, Stdout String)
ret@(Exit ExitCode
c, Stderr String
err, Stdout String
_) <- Action (Exit, Stderr String, Stdout String)
act :: Action (Exit, Stderr String, Stdout String)
    ([CmdOption] -> CmdOption -> String -> Action ()) :-> Action ()
forall args. (Partial, CmdArguments args, Unit args) => args
cmd_ [String -> CmdOption
Stdin String
err] CmdOption
Shell String
"pats-filter"
    if ExitCode
c ExitCode -> ExitCode -> Bool
forall a. Eq a => a -> a -> Bool
/= ExitCode
ExitSuccess
        then String -> Action (Exit, Stderr String, Stdout String)
forall a. Partial => String -> a
error String
"patsopt failure"
        else (Exit, Stderr String, Stdout String)
-> Action (Exit, Stderr String, Stdout String)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exit, Stderr String, Stdout String)
ret

gcFlag :: Bool -> String
gcFlag :: Bool -> String
gcFlag Bool
False = String
"-DATS_MEMALLOC_LIBC"
gcFlag Bool
True  = String
"-DATS_MEMALLOC_GCBDW"

-- Copy source files to the appropriate place. This is necessary because
-- @#include@s in ATS are weird.
copySources :: ATSToolConfig -> [FilePath] -> Action ()
copySources :: ATSToolConfig -> [String] -> Action ()
copySources (ATSToolConfig String
home' String
_ Bool
_ CCompiler
_ Bool
_) [String]
sources =
    [String] -> (String -> Action ()) -> Action ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [String]
sources ((String -> Action ()) -> Action ())
-> (String -> Action ()) -> Action ()
forall a b. (a -> b) -> a -> b
$ \String
dep -> do
        IO () -> Action ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Action ()) -> IO () -> Action ()
forall a b. (a -> b) -> a -> b
$ Bool -> String -> IO ()
createDirectoryIfMissing Bool
True (String
home' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"/" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
takeDirectory String
dep)
        IO () -> Action ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Action ()) -> IO () -> Action ()
forall a b. (a -> b) -> a -> b
$ String -> String -> IO ()
copyFile String
dep (String
home' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"/" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
dep)

makeCFlags :: [String] -- ^ Inputs
           -> [ForeignCabal] -- ^ Haskell libraries
           -> String -- ^ GHC version
           -> Bool -- ^ Whether to use the Garbage collector
           -> [String]
makeCFlags :: [String] -> [ForeignCabal] -> String -> Bool -> [String]
makeCFlags [String]
ss [ForeignCabal]
fc String
ghcV' Bool
b = String
gcFlag' String -> [String] -> [String]
forall a. a -> [a] -> [a]
: ([String]
hsExtra [String] -> [String] -> [String]
forall a. Semigroup a => a -> a -> a
<> [String]
ss) where
    gcFlag' :: String
gcFlag' = (String -> String)
-> (String -> String) -> Bool -> String -> String
forall a. a -> a -> Bool -> a
bool (String
"-optc" String -> String -> String
forall a. Semigroup a => a -> a -> a
<>) String -> String
forall a. a -> a
id Bool
noHs (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ Bool -> String
gcFlag Bool
b
    hsExtra :: [String]
hsExtra = [String] -> [String] -> Bool -> [String]
forall a. a -> a -> Bool -> a
bool ([String
"--make", String
"-I.", String
"-odir", String
".atspkg", String
"-no-hs-main", String
"-package-db", String
"~/.cabal/store/ghc-" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
ghcV' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"/package.db/"] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
packageDbs) [String]
forall a. Monoid a => a
mempty Bool
noHs
    noHs :: Bool
noHs = [ForeignCabal] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ForeignCabal]
fc
    packageDbs :: [String]
packageDbs = (\String
x -> [String
"-package-db", String
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"/dist-newstyle/packagedb/ghc-" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
ghcV']) (String -> [String]) -> [String] -> [String]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [ForeignCabal] -> [String]
libToDirs [ForeignCabal]
fc

libToDirs :: [ForeignCabal] -> [String]
libToDirs :: [ForeignCabal] -> [String]
libToDirs = (ForeignCabal -> String) -> [ForeignCabal] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String -> String
takeDirectory (String -> String)
-> (ForeignCabal -> String) -> ForeignCabal -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
TL.unpack (Text -> String)
-> (ForeignCabal -> Text) -> ForeignCabal -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ForeignCabal -> Text
h)
    where h :: ForeignCabal -> Text
h (ForeignCabal Maybe Text
mpr Text
cf Text
_) = Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
cf Maybe Text
mpr

-- | Location of @patscc@
patscc :: ATSToolConfig -> String
patscc :: ATSToolConfig -> String
patscc = String -> ATSToolConfig -> String
patsTool String
"patscc"

-- | Location of @patsopt@
patsopt :: ATSToolConfig -> String
patsopt :: ATSToolConfig -> String
patsopt = String -> ATSToolConfig -> String
patsTool String
"patsopt"

patsTool :: String -> ATSToolConfig -> String
patsTool :: String -> ATSToolConfig -> String
patsTool String
tool ATSToolConfig
tc = ATSToolConfig -> String
_patsHome ATSToolConfig
tc String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"/bin/" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
tool

cconfig :: MonadIO m => ATSToolConfig -> [String] -> Bool -> [String] -> m CConfig
cconfig :: ATSToolConfig -> [String] -> Bool -> [String] -> m CConfig
cconfig ATSToolConfig
tc [String]
libs' Bool
gc' [String]
extras = do
    let h :: String
h = ATSToolConfig -> String
_patsHome ATSToolConfig
tc
    let cc' :: CCompiler
cc' = ATSToolConfig -> CCompiler
_cc ATSToolConfig
tc
    String
h' <- CCompiler -> m String
forall (m :: * -> *). MonadIO m => CCompiler -> m String
pkgHome CCompiler
cc'
    let libs'' :: [String]
libs'' = (String
"atslib" String -> [String] -> [String]
forall a. a -> [a] -> [a]
:) ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ [String] -> [String] -> Bool -> [String]
forall a. a -> a -> Bool -> a
bool [String]
libs' (String
"gc" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
libs') Bool
gc'
    -- TODO only include /ccomp/atslib/lib if it's not a cross build
    CConfig -> m CConfig
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CConfig -> m CConfig) -> CConfig -> m CConfig
forall a b. (a -> b) -> a -> b
$ [String] -> [String] -> [String] -> [String] -> Bool -> CConfig
CConfig [String
h String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"/ccomp/runtime/", String
h, String
h' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"include", String
".atspkg/contrib"] [String]
libs'' [String
h' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"lib", ATSToolConfig -> String
_patsHome ATSToolConfig
tc String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"/ccomp/atslib/lib"] [String]
extras (ATSToolConfig -> Bool
_linkStatic ATSToolConfig
tc)

patsEnv :: ATSToolConfig -> FilePath -> [CmdOption]
patsEnv :: ATSToolConfig -> String -> [CmdOption]
patsEnv ATSToolConfig
cfg String
path = Bool -> CmdOption
EchoStderr Bool
False CmdOption -> [CmdOption] -> [CmdOption]
forall a. a -> [a] -> [a]
:
    (String -> String -> CmdOption)
-> [String] -> [String] -> [CmdOption]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith String -> String -> CmdOption
AddEnv
        [String
"PATSHOME", String
"PATH", String
"PATSHOMELOCS"]
        [ATSToolConfig -> String
_patsHome ATSToolConfig
cfg, ATSToolConfig -> String
_patsHome ATSToolConfig
cfg String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"/bin:" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
path, ATSToolConfig -> String
_patsHomeLocs ATSToolConfig
cfg]

atsToC :: FilePath -> FilePath
atsToC :: String -> String
atsToC = (String -> String -> String
-<.> String
"c") (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
".atspkg/c/" String -> String -> String
forall a. Semigroup a => a -> a -> a
<>)

ghcV :: [ForeignCabal] -> Action String
ghcV :: [ForeignCabal] -> Action String
ghcV [ForeignCabal]
hsLibs' = case [ForeignCabal]
hsLibs' of
    [] -> String -> Action String
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
forall a. Partial => a
undefined
    [ForeignCabal]
_  -> Action String
ghcVersion

doLib :: ArtifactType -> Rules () -> Rules ()
doLib :: ArtifactType -> Rules () -> Rules ()
doLib ArtifactType
Executable = Rules () -> Rules () -> Rules ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure Rules ()
forall a. Monoid a => a
mempty
doLib ArtifactType
_          = Rules () -> Rules ()
forall a. a -> a
id

-- | Rules for generating binaries or libraries from ATS code. This is very
-- general; use 'defaultATSTarget' for sensible defaults that can be modified
-- with the provided lenses.
atsBin :: ATSTarget -> Rules ()
atsBin :: ATSTarget -> Rules ()
atsBin ATSTarget{Bool
String
[String]
[(String, String)]
[ForeignCabal]
[ATSGen]
ATSToolConfig
ArtifactType
_tgtType :: ATSTarget -> ArtifactType
_otherDeps :: ATSTarget -> [String]
_binTarget :: ATSTarget -> String
_linkTargets :: ATSTarget -> [(String, String)]
_genTargets :: ATSTarget -> [ATSGen]
_hsLibs :: ATSTarget -> [ForeignCabal]
_src :: ATSTarget -> [String]
_libs :: ATSTarget -> [String]
_gc :: ATSTarget -> Bool
_toolConfig :: ATSTarget -> ATSToolConfig
_cFlags :: ATSTarget -> [String]
_tgtType :: ArtifactType
_otherDeps :: [String]
_binTarget :: String
_linkTargets :: [(String, String)]
_genTargets :: [ATSGen]
_hsLibs :: [ForeignCabal]
_src :: [String]
_libs :: [String]
_gc :: Bool
_toolConfig :: ATSToolConfig
_cFlags :: [String]
..} = do

    ((String, String) -> Rules ()) -> [(String, String)] -> Rules ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((String -> String -> Rules ()) -> (String, String) -> Rules ()
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry String -> String -> Rules ()
genLinks) [(String, String)]
_linkTargets

    (ATSGen -> Rules ()) -> [ATSGen] -> Rules ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\(ATSGen String
x String
y Bool
z) -> String -> String -> Bool -> Rules ()
genATS String
x String
y Bool
z) [ATSGen]
_genTargets

    (ForeignCabal -> Rules ()) -> [ForeignCabal] -> Rules ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ForeignCabal -> Rules ()
cabalExport [ForeignCabal]
_hsLibs

    let cTargets :: [String]
cTargets = String -> String
atsToC (String -> String) -> [String] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String]
_src

    let h :: ArtifactType -> f String -> f String
h ArtifactType
Executable    = f String -> f String
forall a. a -> a
id
        h ArtifactType
StaticLibrary = (String -> String) -> f String -> f String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String -> String -> String
-<.> String
"o")
        h ArtifactType
SharedLibrary = (String -> String) -> f String -> f String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String -> String -> String
-<.> String
"o")
        g :: ArtifactType
-> CCompiler -> [String] -> String -> CConfig -> Action r
g ArtifactType
Executable    = CCompiler -> [String] -> String -> CConfig -> Action r
forall r.
CmdResult r =>
CCompiler -> [String] -> String -> CConfig -> Action r
binaryA
        g ArtifactType
StaticLibrary = CCompiler -> [String] -> String -> CConfig -> Action r
forall r.
CmdResult r =>
CCompiler -> [String] -> String -> CConfig -> Action r
staticLibA
        g ArtifactType
SharedLibrary = CCompiler -> [String] -> String -> CConfig -> Action r
forall r.
CmdResult r =>
CCompiler -> [String] -> String -> CConfig -> Action r
sharedLibA
        h' :: [String] -> [String]
h' = ArtifactType -> [String] -> [String]
forall (f :: * -> *).
Functor f =>
ArtifactType -> f String -> f String
h ArtifactType
_tgtType

    CConfig
cconfig' <- ATSToolConfig -> [String] -> Bool -> [String] -> Rules CConfig
forall (m :: * -> *).
MonadIO m =>
ATSToolConfig -> [String] -> Bool -> [String] -> m CConfig
cconfig ATSToolConfig
_toolConfig [String]
_libs Bool
_gc ([String] -> [ForeignCabal] -> String -> Bool -> [String]
makeCFlags [String]
_cFlags [ForeignCabal]
forall a. Monoid a => a
mempty (Char -> String
forall (f :: * -> *) a. Applicative f => a -> f a
pure Char
forall a. Partial => a
undefined) Bool
_gc)

    let atsGen :: [String]
atsGen = ((String, String) -> String
forall a b. (a, b) -> b
snd ((String, String) -> String) -> [(String, String)] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(String, String)]
_linkTargets) [String] -> [String] -> [String]
forall a. Semigroup a => a -> a -> a
<> ((ATSGen -> Getting String ATSGen String -> String
forall s a. s -> Getting a s a -> a
^.Getting String ATSGen String
Lens' ATSGen String
atsTarget) (ATSGen -> String) -> [ATSGen] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ATSGen]
_genTargets)
        atsExtras :: [String]
atsExtras = [String]
_otherDeps [String] -> [String] -> [String]
forall a. Semigroup a => a -> a -> a
<> (Text -> String
TL.unpack (Text -> String)
-> (ForeignCabal -> Text) -> ForeignCabal -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ForeignCabal -> Text
objectFile (ForeignCabal -> String) -> [ForeignCabal] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ForeignCabal]
_hsLibs)
    (String -> String -> Rules ()) -> [String] -> [String] -> Rules ()
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m ()
zipWithM_ (ATSToolConfig
-> [String] -> [String] -> String -> String -> Rules ()
cgen ATSToolConfig
_toolConfig [String]
atsExtras [String]
atsGen) [String]
_src [String]
cTargets

    ArtifactType -> Rules () -> Rules ()
doLib ArtifactType
_tgtType ((String -> String -> Rules ()) -> [String] -> [String] -> Rules ()
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m ()
zipWithM_ (CCompiler -> CConfig -> String -> String -> Rules ()
objectFileR (ATSToolConfig -> CCompiler
_cc ATSToolConfig
_toolConfig) CConfig
cconfig') [String]
cTargets ([String] -> [String]
h' [String]
cTargets))

    String
_binTarget Partial => String -> (String -> Action ()) -> Rules ()
String -> (String -> Action ()) -> Rules ()
%> \String
_ -> do

        Partial => [String] -> Action ()
[String] -> Action ()
need ([String] -> [String]
h' [String]
cTargets)

        String
ghcV' <- [ForeignCabal] -> Action String
ghcV [ForeignCabal]
_hsLibs

        CConfig
cconfig'' <- ATSToolConfig -> [String] -> Bool -> [String] -> Action CConfig
forall (m :: * -> *).
MonadIO m =>
ATSToolConfig -> [String] -> Bool -> [String] -> m CConfig
cconfig ATSToolConfig
_toolConfig [String]
_libs Bool
_gc ([String] -> [ForeignCabal] -> String -> Bool -> [String]
makeCFlags [String]
_cFlags [ForeignCabal]
_hsLibs String
ghcV' Bool
_gc)

        Action () -> Action ()
forall (m :: * -> *). m () -> m ()
unit (Action () -> Action ()) -> Action () -> Action ()
forall a b. (a -> b) -> a -> b
$ ArtifactType
-> CCompiler -> [String] -> String -> CConfig -> Action ()
forall r.
CmdResult r =>
ArtifactType
-> CCompiler -> [String] -> String -> CConfig -> Action r
g ArtifactType
_tgtType (ATSToolConfig -> CCompiler
_cc ATSToolConfig
_toolConfig) ([String] -> [String]
h' [String]
cTargets) String
_binTarget CConfig
cconfig''

-- | Generate C code from ATS code.
cgen :: ATSToolConfig
     -> [FilePath] -- ^ Extra files to track
     -> [FilePath] -- ^ ATS source that may be generated.
     -> FilePath -- ^ ATS source
     -> FilePattern -- ^ Pattern for C file to be generated
     -> Rules ()
cgen :: ATSToolConfig
-> [String] -> [String] -> String -> String -> Rules ()
cgen ATSToolConfig
toolConfig' [String]
extras [String]
atsGens String
atsSrc String
cFiles =
    String
cFiles Partial => String -> (String -> Action ()) -> Rules ()
String -> (String -> Action ()) -> Rules ()
%> \String
out -> do

        -- tell shake which files to track and copy them to the appropriate
        -- directory
        Partial => [String] -> Action ()
[String] -> Action ()
need [String]
extras
        [String]
sources <- [String] -> [String] -> Action [String]
forall (m :: * -> *).
MonadIO m =>
[String] -> [String] -> m [String]
transitiveDeps [String]
atsGens [String
atsSrc]
        Partial => [String] -> Action ()
[String] -> Action ()
need [String]
sources
        ATSToolConfig -> [String] -> Action ()
copySources ATSToolConfig
toolConfig' [String]
sources

        ATSToolConfig -> String -> String -> Action ()
forall r.
CmdResult r =>
ATSToolConfig -> String -> String -> Action r
atsCommand ATSToolConfig
toolConfig' String
atsSrc String
out

-- | This provides rules for generating C code from ATS source files in the
trim :: String -> String
trim :: String -> String
trim = String -> String
forall a. [a] -> [a]
init (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String -> String
forall a. Int -> [a] -> [a]
drop Int
1

-- | Print any errors to standard error.
maybeError :: (MonadIO m) => FilePath -> Either ATSError b -> m ()
maybeError :: String -> Either ATSError b -> m ()
maybeError String
_ Right{}  = () -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
maybeError String
p (Left ATSError
y) = String -> ATSError -> m ()
forall (m :: * -> *). MonadIO m => String -> ATSError -> m ()
warnErr String
p ATSError
y

transitiveDeps :: (MonadIO m) => [FilePath] -> [FilePath] -> m [FilePath]
transitiveDeps :: [String] -> [String] -> m [String]
transitiveDeps [String]
_ [] = [String] -> m [String]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
transitiveDeps [String]
gen [String]
ps = ([[String]] -> [String]) -> m [[String]] -> m [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[String]] -> [String]
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (m [[String]] -> m [String]) -> m [[String]] -> m [String]
forall a b. (a -> b) -> a -> b
$ [String] -> (String -> m [String]) -> m [[String]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [String]
ps ((String -> m [String]) -> m [[String]])
-> (String -> m [String]) -> m [[String]]
forall a b. (a -> b) -> a -> b
$ \String
p -> if String
p String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
gen then [String] -> m [String]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [String]
forall a. Monoid a => a
mempty else do
    String
contents <- IO String -> m String
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO String -> m String) -> IO String -> m String
forall a b. (a -> b) -> a -> b
$ String -> IO String
readFile String
p
    let (ATS AlexPosn
ats, m ()
err) = (ATS AlexPosn -> Either ATSError (ATS AlexPosn) -> ATS AlexPosn
forall b a. b -> Either a b -> b
fromRight ATS AlexPosn
forall a. Monoid a => a
mempty (Either ATSError (ATS AlexPosn) -> ATS AlexPosn)
-> (Either ATSError (ATS AlexPosn) -> m ())
-> Either ATSError (ATS AlexPosn)
-> (ATS AlexPosn, m ())
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& String -> Either ATSError (ATS AlexPosn) -> m ()
forall (m :: * -> *) b.
MonadIO m =>
String -> Either ATSError b -> m ()
maybeError String
p) (Either ATSError (ATS AlexPosn) -> (ATS AlexPosn, m ()))
-> (String -> Either ATSError (ATS AlexPosn))
-> String
-> (ATS AlexPosn, m ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Either ATSError (ATS AlexPosn)
parseM (String -> (ATS AlexPosn, m ())) -> String -> (ATS AlexPosn, m ())
forall a b. (a -> b) -> a -> b
$ String
contents
    m ()
err
    let dir :: String
dir = String -> String
takeDirectory String
p
    [String]
deps <- (String -> m Bool) -> [String] -> m [String]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM (\String
f -> ((String
f String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
gen) Bool -> Bool -> Bool
||) (Bool -> Bool) -> m Bool -> m Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (IO Bool -> m Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> m Bool) -> (String -> IO Bool) -> String -> m Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO Bool
doesFileExist) String
f) ([String] -> m [String]) -> [String] -> m [String]
forall a b. (a -> b) -> a -> b
$ String -> String -> String
fixDir String
dir (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
trim (String -> String) -> [String] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ATS AlexPosn -> [String]
forall a. ATS a -> [String]
getDependencies ATS AlexPosn
ats
    [String]
deps' <- [String] -> [String] -> m [String]
forall (m :: * -> *).
MonadIO m =>
[String] -> [String] -> m [String]
transitiveDeps [String]
gen [String]
deps
    [String] -> m [String]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([String] -> m [String]) -> [String] -> m [String]
forall a b. (a -> b) -> a -> b
$ (String
pString -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
deps) [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
deps'