{-|
Module      : Idris.Package
Description : Functionality for working with Idris packages.

License     : BSD3
Maintainer  : The Idris Community.
-}
{-# LANGUAGE CPP #-}
module Idris.Package where

import System.Directory
import System.Environment
import System.Exit
import System.FilePath (addExtension, addTrailingPathSeparator, dropExtension,
                        hasExtension, takeDirectory, takeExtension,
                        takeFileName, (</>))
import System.IO
import System.Process

import Util.System

import Control.Monad
import Control.Monad.Trans.Except (runExceptT)
import Control.Monad.Trans.State.Strict (execStateT)
import Data.Either (partitionEithers)
import Data.List
import Data.List.Split (splitOn)

import Idris.AbsSyntax
import Idris.Core.TT
import Idris.Error (ifail)
import Idris.IBC
import Idris.IdrisDoc
import Idris.Imports
import Idris.Main (idris, idrisMain)
import Idris.Options
import Idris.Output
import Idris.Parser (loadModule)

import Idris.Package.Common
import Idris.Package.Parser

import IRTS.System

-- To build a package:
-- * read the package description
-- * check all the library dependencies exist
-- * invoke the makefile if there is one
-- * invoke idris on each module, with idris_opts
-- * install everything into datadir/pname, if install flag is set

getPkgDesc :: FilePath -> IO PkgDesc
getPkgDesc :: String -> IO PkgDesc
getPkgDesc = String -> IO PkgDesc
parseDesc

--  --------------------------------------------------------- [ Build Packages ]

-- | Run the package through the idris compiler.
buildPkg :: [Opt]            -- ^ Command line options
         -> Bool             -- ^ Provide Warnings
         -> (Bool, FilePath) -- ^ (Should we install, Location of iPKG file)
         -> IO ()
buildPkg :: [Opt] -> Bool -> (Bool, String) -> IO ()
buildPkg [Opt]
copts Bool
warnonly (Bool
install, String
fp) = do
  pkgdesc <- String -> IO PkgDesc
parseDesc String
fp
  dir <- getCurrentDirectory
  let idx' = PkgName -> String
pkgIndex (PkgName -> String) -> PkgName -> String
forall a b. (a -> b) -> a -> b
$ PkgDesc -> PkgName
pkgname PkgDesc
pkgdesc
      idx  = String -> Opt
PkgIndex (String -> Opt) -> String -> Opt
forall a b. (a -> b) -> a -> b
$ case (Opt -> Maybe String) -> [Opt] -> [String]
forall a. (Opt -> Maybe a) -> [Opt] -> [a]
opt Opt -> Maybe String
getIBCSubDir [Opt]
copts of
        (String
ibcsubdir:[String]
_) -> String
ibcsubdir String -> String -> String
</> String
idx'
        []            -> String
idx'
  oks <- mapM (testLib warnonly (pkgname pkgdesc)) (libdeps pkgdesc)
  when (and oks) $ do
    m_ist <- inPkgDir pkgdesc $ do

      make (makefile pkgdesc)
      case (execout pkgdesc) of
        Maybe String
Nothing -> do
          case [Opt] -> [Opt] -> Either String [Opt]
mergeOptions [Opt]
copts (Opt
idx Opt -> [Opt] -> [Opt]
forall a. a -> [a] -> [a]
: Opt
NoREPL Opt -> [Opt] -> [Opt]
forall a. a -> [a] -> [a]
: Int -> Opt
Verbose Int
1 Opt -> [Opt] -> [Opt]
forall a. a -> [a] -> [a]
: PkgDesc -> [Opt]
idris_opts PkgDesc
pkgdesc) of
            Left String
emsg -> do
              String -> IO ()
putStrLn String
emsg
              ExitCode -> IO (Maybe IState)
forall a. ExitCode -> IO a
exitWith (Int -> ExitCode
ExitFailure Int
1)
            Right [Opt]
opts -> do
              Bool -> PkgDesc -> IO ()
auditPackage (Opt
AuditIPkg Opt -> [Opt] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Opt]
opts) PkgDesc
pkgdesc
              [Opt] -> [Name] -> IO (Maybe IState)
buildMods [Opt]
opts (PkgDesc -> [Name]
modules PkgDesc
pkgdesc)
        Just String
o -> do
          let exec :: String
exec = String
dir String -> String -> String
</> String
o
          case [Opt] -> [Opt] -> Either String [Opt]
mergeOptions [Opt]
copts (Opt
idx Opt -> [Opt] -> [Opt]
forall a. a -> [a] -> [a]
: Opt
NoREPL Opt -> [Opt] -> [Opt]
forall a. a -> [a] -> [a]
: Int -> Opt
Verbose Int
1 Opt -> [Opt] -> [Opt]
forall a. a -> [a] -> [a]
: String -> Opt
Output String
exec Opt -> [Opt] -> [Opt]
forall a. a -> [a] -> [a]
: PkgDesc -> [Opt]
idris_opts PkgDesc
pkgdesc) of
            Left String
emsg -> do
              String -> IO ()
putStrLn String
emsg
              ExitCode -> IO (Maybe IState)
forall a. ExitCode -> IO a
exitWith (Int -> ExitCode
ExitFailure Int
1)
            Right [Opt]
opts -> do
              Bool -> PkgDesc -> IO ()
auditPackage (Opt
AuditIPkg Opt -> [Opt] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Opt]
opts) PkgDesc
pkgdesc
              [Opt] -> Maybe Name -> IO (Maybe IState)
buildMain [Opt]
opts (PkgDesc -> Maybe Name
idris_main PkgDesc
pkgdesc)
    case m_ist of
      Maybe IState
Nothing  -> ExitCode -> IO ()
forall a. ExitCode -> IO a
exitWith (Int -> ExitCode
ExitFailure Int
1)
      Just IState
ist -> do
        -- Quit with error code if there was a problem
        case IState -> Maybe FC
errSpan IState
ist of
          Just FC
_ -> ExitCode -> IO ()
forall a. ExitCode -> IO a
exitWith (Int -> ExitCode
ExitFailure Int
1)
          Maybe FC
_      -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
install (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> PkgDesc -> IO ()
installPkg ((Opt -> Maybe String) -> [Opt] -> [String]
forall a. (Opt -> Maybe a) -> [Opt] -> [a]
opt Opt -> Maybe String
getIBCSubDir [Opt]
copts) PkgDesc
pkgdesc
  where
    buildMain :: [Opt] -> Maybe Name -> IO (Maybe IState)
buildMain [Opt]
opts (Just Name
mod) = [Opt] -> [Name] -> IO (Maybe IState)
buildMods [Opt]
opts [Name
mod]
    buildMain [Opt]
_ Maybe Name
Nothing = do
      String -> IO ()
putStrLn String
"Can't build an executable: No main module given"
      ExitCode -> IO (Maybe IState)
forall a. ExitCode -> IO a
exitWith (Int -> ExitCode
ExitFailure Int
1)

--  --------------------------------------------------------- [ Check Packages ]

-- | Type check packages only
--
-- This differs from build in that executables are not built, if the
-- package contains an executable.
checkPkg :: [Opt]     -- ^ Command line Options
         -> Bool      -- ^ Show Warnings
         -> Bool      -- ^ quit on failure
         -> FilePath  -- ^ Path to ipkg file.
         -> IO ()
checkPkg :: [Opt] -> Bool -> Bool -> String -> IO ()
checkPkg [Opt]
copts Bool
warnonly Bool
quit String
fpath = do
  pkgdesc <- String -> IO PkgDesc
parseDesc String
fpath
  oks <- mapM (testLib warnonly (pkgname pkgdesc)) (libdeps pkgdesc)
  when (and oks) $ do
    res <- inPkgDir pkgdesc $ do
      make (makefile pkgdesc)

      case mergeOptions copts (NoREPL : Verbose 1 : idris_opts pkgdesc) of
        Left String
emsg -> do
          String -> IO ()
putStrLn String
emsg
          ExitCode -> IO (Maybe IState)
forall a. ExitCode -> IO a
exitWith (Int -> ExitCode
ExitFailure Int
1)
        Right [Opt]
opts -> do
          Bool -> PkgDesc -> IO ()
auditPackage (Opt
AuditIPkg Opt -> [Opt] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Opt]
opts) PkgDesc
pkgdesc
          [Opt] -> [Name] -> IO (Maybe IState)
buildMods [Opt]
opts (PkgDesc -> [Name]
modules PkgDesc
pkgdesc)
    when quit $ case res of
                  Maybe IState
Nothing -> ExitCode -> IO ()
forall a. ExitCode -> IO a
exitWith (Int -> ExitCode
ExitFailure Int
1)
                  Just IState
res' -> do
                    case IState -> Maybe FC
errSpan IState
res' of
                      Just FC
_ -> ExitCode -> IO ()
forall a. ExitCode -> IO a
exitWith (Int -> ExitCode
ExitFailure Int
1)
                      Maybe FC
_      -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

--  ------------------------------------------------------------------- [ REPL ]

-- | Check a package and start a REPL.
--
-- This function only works with packages that have a main module.
--
replPkg :: [Opt]    -- ^ Command line Options
        -> FilePath -- ^ Path to ipkg file.
        -> Idris ()
replPkg :: [Opt] -> String -> Idris ()
replPkg [Opt]
copts String
fp = do
    orig <- Idris IState
getIState
    runIO $ checkPkg copts False False fp
    pkgdesc <- runIO $ parseDesc fp -- bzzt, repetition!

    case mergeOptions copts (idris_opts pkgdesc) of
      Left String
emsg  -> String -> Idris ()
forall a. String -> Idris a
ifail String
emsg
      Right [Opt]
opts -> do

        IState -> Idris ()
putIState IState
orig
        dir <- IO String -> Idris String
forall a. IO a -> Idris a
runIO IO String
getCurrentDirectory
        runIO $ setCurrentDirectory $ dir </> sourcedir pkgdesc
        runMain opts (idris_main pkgdesc)
        runIO $ setCurrentDirectory dir

  where
    toPath :: String -> String
toPath String
n = (String -> String -> String) -> [String] -> String
forall a. HasCallStack => (a -> a -> a) -> [a] -> a
foldl1' String -> String -> String
(</>) ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ String -> String -> [String]
forall a. Eq a => [a] -> [a] -> [[a]]
splitOn String
"." String
n

    runMain :: [Opt] -> Maybe Name -> Idris ()
runMain [Opt]
opts (Just Name
mod) = do
      let f :: String
f = String -> String
toPath (Name -> String
showCG Name
mod)
      [Opt] -> Idris ()
idrisMain ((String -> Opt
Filename String
f) Opt -> [Opt] -> [Opt]
forall a. a -> [a] -> [a]
: [Opt]
opts)
    runMain [Opt]
_ Maybe Name
Nothing =
      String -> Idris ()
iputStrLn String
"Can't start REPL: no main module given"

--  --------------------------------------------------------------- [ Cleaning ]

-- | Clean Package build files
cleanPkg :: [Opt]    -- ^ Command line options.
         -> FilePath -- ^ Path to ipkg file.
         -> IO ()
cleanPkg :: [Opt] -> String -> IO ()
cleanPkg [Opt]
copts String
fp = do
  pkgdesc <- String -> IO PkgDesc
parseDesc String
fp
  dir <- getCurrentDirectory
  inPkgDir pkgdesc $ do
    clean (makefile pkgdesc)
    mapM_ rmIBC (modules pkgdesc)
    rmIdx (pkgname pkgdesc)
    case execout pkgdesc of
      Maybe String
Nothing -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      Just String
s -> String -> IO ()
rmExe (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
dir String -> String -> String
</> String
s

--  ------------------------------------------------------ [ Generate IdrisDoc ]


-- | Generate IdrisDoc for package
-- TODO: Handle case where module does not contain a matching namespace
--       E.g. from prelude.ipkg: IO, Prelude.Chars, Builtins
--
-- Issue number #1572 on the issue tracker
--       https://github.com/idris-lang/Idris-dev/issues/1572
documentPkg :: [Opt]           -- ^ Command line options.
            -> (Bool,FilePath) -- ^ (Should we install?, Path to ipkg file).
            -> IO ()
documentPkg :: [Opt] -> (Bool, String) -> IO ()
documentPkg [Opt]
copts (Bool
install,String
fp) = do
  pkgdesc        <- String -> IO PkgDesc
parseDesc String
fp
  cd             <- getCurrentDirectory
  let pkgDir      = String
cd String -> String -> String
</> String -> String
takeDirectory String
fp
      outputDir   = String
cd String -> String -> String
</> PkgName -> String
unPkgName (PkgDesc -> PkgName
pkgname PkgDesc
pkgdesc) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"_doc"
      popts       = Opt
NoREPL Opt -> [Opt] -> [Opt]
forall a. a -> [a] -> [a]
: Int -> Opt
Verbose Int
1 Opt -> [Opt] -> [Opt]
forall a. a -> [a] -> [a]
: PkgDesc -> [Opt]
idris_opts PkgDesc
pkgdesc
      mods        = PkgDesc -> [Name]
modules PkgDesc
pkgdesc
      fs          = (Name -> String) -> [Name] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ((String -> String -> String) -> [String] -> String
forall a. HasCallStack => (a -> a -> a) -> [a] -> a
foldl1' String -> String -> String
(</>) ([String] -> String) -> (Name -> [String]) -> Name -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> [String]
forall a. Eq a => [a] -> [a] -> [[a]]
splitOn String
"." (String -> [String]) -> (Name -> String) -> Name -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> String
showCG) [Name]
mods
  setCurrentDirectory $ pkgDir </> sourcedir pkgdesc
  make (makefile pkgdesc)
  setCurrentDirectory pkgDir
  case mergeOptions copts popts of
    Left String
emsg -> do
      String -> IO ()
putStrLn String
emsg
      ExitCode -> IO ()
forall a. ExitCode -> IO a
exitWith (Int -> ExitCode
ExitFailure Int
1)
    Right [Opt]
opts -> do
      let run :: StateT a (ExceptT e m) a -> a -> m (Either e a)
run StateT a (ExceptT e m) a
l       = ExceptT e m a -> m (Either e a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT e m a -> m (Either e a))
-> (a -> ExceptT e m a) -> a -> m (Either e a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StateT a (ExceptT e m) a -> a -> ExceptT e m a
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m s
execStateT StateT a (ExceptT e m) a
l
          load :: [String] -> Idris ()
load []     = () -> Idris ()
forall a. a -> StateT IState (ExceptT Err IO) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
          load (String
f:[String]
fs) = do String -> IBCPhase -> Idris (Maybe String)
loadModule String
f IBCPhase
IBC_Building; [String] -> Idris ()
load [String]
fs
          loader :: Idris ()
loader      = do
            [Opt] -> Idris ()
idrisMain [Opt]
opts
            String -> Idris ()
addImportDir (PkgDesc -> String
sourcedir PkgDesc
pkgdesc)
            [String] -> Idris ()
load [String]
fs
      idrisImplementation  <- Idris () -> IState -> IO (Either Err IState)
forall {m :: * -> *} {a} {e} {a}.
Monad m =>
StateT a (ExceptT e m) a -> a -> m (Either e a)
run Idris ()
loader IState
idrisInit
      setCurrentDirectory cd
      case idrisImplementation of
        Left  Err
err -> do
          String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ IState -> Err -> String
pshow IState
idrisInit Err
err
          ExitCode -> IO ()
forall a. ExitCode -> IO a
exitWith (Int -> ExitCode
ExitFailure Int
1)
        Right IState
ist -> do
          iDocDir   <- IO String
getIdrisDocDir
          pkgDocDir <- makeAbsolute (iDocDir </> unPkgName (pkgname pkgdesc))
          let out_dir = if Bool
install then String
pkgDocDir else String
outputDir
          when install $ do
              putStrLn $ unwords ["Attempting to install IdrisDocs for", show $ pkgname pkgdesc, "in:", out_dir]

          docRes <- generateDocs ist mods out_dir
          case docRes of
            Right ()
_  -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            Left String
msg -> do
              String -> IO ()
putStrLn String
msg
              ExitCode -> IO ()
forall a. ExitCode -> IO a
exitWith (Int -> ExitCode
ExitFailure Int
1)

--  ------------------------------------------------------------------- [ Test ]

-- | Build a package with a sythesized main function that runs the tests
testPkg :: [Opt]     -- ^ Command line options.
        -> FilePath  -- ^ Path to ipkg file.
        -> IO ExitCode
testPkg :: [Opt] -> String -> IO ExitCode
testPkg [Opt]
copts String
fp = do
  pkgdesc <- String -> IO PkgDesc
parseDesc String
fp
  ok <- mapM (testLib True (pkgname pkgdesc)) (libdeps pkgdesc)
  if and ok
    then do
      (m_ist, exitCode) <- inPkgDir pkgdesc $ do
        make (makefile pkgdesc)
        -- Get a temporary file to save the tests' source in
        (tmpn, tmph) <- tempfile ".idr"
        hPutStrLn tmph $
            "module Test_______\n" ++
            concat ["import " ++ show m ++ "\n" | m <- modules pkgdesc]
                ++ "namespace Main\n"
                ++ "  main : IO ()\n"
                ++ "  main = do "
                ++ concat [ show t ++ "\n            "
                          | t <- idris_tests pkgdesc]
        hClose tmph
        (tmpn', tmph') <- tempfile ""
        hClose tmph'
        let popts = (String -> Opt
Filename String
tmpn Opt -> [Opt] -> [Opt]
forall a. a -> [a] -> [a]
: Opt
NoREPL Opt -> [Opt] -> [Opt]
forall a. a -> [a] -> [a]
: Int -> Opt
Verbose Int
1 Opt -> [Opt] -> [Opt]
forall a. a -> [a] -> [a]
: String -> Opt
Output String
tmpn' Opt -> [Opt] -> [Opt]
forall a. a -> [a] -> [a]
: PkgDesc -> [Opt]
idris_opts PkgDesc
pkgdesc)
        case mergeOptions copts popts of
          Left String
emsg -> do
            String -> IO ()
putStrLn String
emsg
            ExitCode -> IO (Maybe IState, ExitCode)
forall a. ExitCode -> IO a
exitWith (Int -> ExitCode
ExitFailure Int
1)
          Right [Opt]
opts -> do
            m_ist    <- [Opt] -> IO (Maybe IState)
idris [Opt]
opts
            let texe = if Bool
isWindows then String -> String -> String
addExtension String
tmpn' String
".exe" else String
tmpn'
            exitCode <- rawSystem texe []
            return (m_ist, exitCode)
      case m_ist of
        Maybe IState
Nothing  -> ExitCode -> IO ExitCode
forall a. ExitCode -> IO a
exitWith (Int -> ExitCode
ExitFailure Int
1)
        Just IState
ist -> do
          -- Quit with error code if problem building
          case IState -> Maybe FC
errSpan IState
ist of
            Just FC
_ -> ExitCode -> IO ExitCode
forall a. ExitCode -> IO a
exitWith (Int -> ExitCode
ExitFailure Int
1)
            Maybe FC
_      -> ExitCode -> IO ExitCode
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ExitCode
exitCode
    else return (ExitFailure 1)

--  ----------------------------------------------------------- [ Installation ]

-- | Install package
installPkg :: [String]  -- ^ Alternate install location
           -> PkgDesc   -- ^ iPKG file.
           -> IO ()
installPkg :: [String] -> PkgDesc -> IO ()
installPkg [String]
altdests PkgDesc
pkgdesc = PkgDesc -> IO () -> IO ()
forall a. PkgDesc -> IO a -> IO a
inPkgDir PkgDesc
pkgdesc (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
  d <- IO String
getIdrisLibDir
  let destdir = case [String]
altdests of
                  []     -> String
d
                  (String
d':[String]
_) -> String
d'
  case (execout pkgdesc) of
    Maybe String
Nothing -> do
      (Name -> IO ()) -> [Name] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (String -> PkgName -> Name -> IO ()
installIBC String
destdir (PkgDesc -> PkgName
pkgname PkgDesc
pkgdesc)) (PkgDesc -> [Name]
modules PkgDesc
pkgdesc)
      String -> PkgName -> IO ()
installIdx String
destdir (PkgDesc -> PkgName
pkgname PkgDesc
pkgdesc)
    Just String
o -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return () -- do nothing, keep executable locally, for noe

  mapM_ (installObj destdir (pkgname pkgdesc)) (objs pkgdesc)

-- ---------------------------------------------------------- [ Helper Methods ]
-- Methods for building, testing, installing, and removal of idris
-- packages.

auditPackage :: Bool -> PkgDesc -> IO ()
auditPackage :: Bool -> PkgDesc -> IO ()
auditPackage Bool
False PkgDesc
_    = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
auditPackage Bool
True  PkgDesc
ipkg = do
    cwd <- IO String
getCurrentDirectory

    let ms = (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (PkgDesc -> String
sourcedir PkgDesc
ipkg String -> String -> String
</>) ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ (Name -> String) -> [Name] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String -> String
toPath (String -> String) -> (Name -> String) -> Name -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> String
showCG) (PkgDesc -> [Name]
modules PkgDesc
ipkg)
    ms' <- mapM makeAbsolute ms

    ifiles <- getIdrisFiles cwd

    let ifiles' = (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map String -> String
dropExtension [String]
ifiles

    not_listed <- mapM makeRelativeToCurrentDirectory (ifiles' \\ ms')

    putStrLn $ unlines $
         ["Warning: The following modules are not listed in your iPkg file:\n"]
      ++ map (\String
m -> [String] -> String
unwords [String
"-", String
m]) not_listed
      ++ ["\nModules that are not listed, are not installed."]

  where
    toPath :: String -> String
toPath String
n = (String -> String -> String) -> [String] -> String
forall a. HasCallStack => (a -> a -> a) -> [a] -> a
foldl1' String -> String -> String
(</>) ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ String -> String -> [String]
forall a. Eq a => [a] -> [a] -> [[a]]
splitOn String
"." String
n

    getIdrisFiles :: FilePath -> IO [FilePath]
    getIdrisFiles :: String -> IO [String]
getIdrisFiles String
dir = do
      contents <- String -> IO [String]
getDirectoryContents String
dir

      -- [ NOTE ] Directory >= 1.2.5.0 introduced `listDirectory` but later versions of directory appear to be causing problems with ghc 7.10.3 and cabal 1.22 in travis. Let's reintroduce the old ranges for directory to be sure.

      files <- forM contents (findRest dir)
      return $ filter (isIdrisFile) (concat files)

    isIdrisFile :: FilePath -> Bool
    isIdrisFile :: String -> Bool
isIdrisFile String
fp = String -> String
takeExtension String
fp String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
".idr" Bool -> Bool -> Bool
|| String -> String
takeExtension String
fp String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
".lidr"

    findRest :: FilePath -> FilePath -> IO [FilePath]
    findRest :: String -> String -> IO [String]
findRest String
dir String
fn = do
      path <- String -> IO String
makeAbsolute (String
dir String -> String -> String
</> String
fn)
      isDir <- doesDirectoryExist path
      if isDir
        then getIdrisFiles path
        else return [path]

buildMods :: [Opt] -> [Name] -> IO (Maybe IState)
buildMods :: [Opt] -> [Name] -> IO (Maybe IState)
buildMods [Opt]
opts [Name]
ns = do let f :: [String]
f = (Name -> String) -> [Name] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String -> String
toPath (String -> String) -> (Name -> String) -> Name -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> String
showCG) [Name]
ns
                       [Opt] -> IO (Maybe IState)
idris ((String -> Opt) -> [String] -> [Opt]
forall a b. (a -> b) -> [a] -> [b]
map String -> Opt
Filename [String]
f [Opt] -> [Opt] -> [Opt]
forall a. [a] -> [a] -> [a]
++ [Opt]
opts)
    where
      toPath :: String -> String
toPath String
n = (String -> String -> String) -> [String] -> String
forall a. HasCallStack => (a -> a -> a) -> [a] -> a
foldl1' String -> String -> String
(</>) ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ String -> String -> [String]
forall a. Eq a => [a] -> [a] -> [[a]]
splitOn String
"." String
n

testLib :: Bool -> PkgName -> String -> IO Bool
testLib :: Bool -> PkgName -> String -> IO Bool
testLib Bool
warn PkgName
p String
f
    = do d <- IO String
getIdrisCRTSDir
         gcc <- getCC
         (tmpf, tmph) <- tempfile ""
         hClose tmph
         let libtest = String
d String -> String -> String
</> String
"libtest.c"
         e <- rawSystem gcc [libtest, "-l" ++ f, "-o", tmpf]
         case e of
            ExitCode
ExitSuccess -> Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
            ExitCode
_ -> do if Bool
warn
                       then do String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Not building " String -> String -> String
forall a. [a] -> [a] -> [a]
++ PkgName -> String
forall a. Show a => a -> String
show PkgName
p String -> String -> String
forall a. [a] -> [a] -> [a]
++
                                          String
" due to missing library " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
f
                               Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
                       else String -> IO Bool
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO Bool) -> String -> IO Bool
forall a b. (a -> b) -> a -> b
$ String
"Missing library " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
f

rmIBC :: Name -> IO ()
rmIBC :: Name -> IO ()
rmIBC Name
m = String -> IO ()
rmFile (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Name -> String
toIBCFile Name
m

rmIdx :: PkgName -> IO ()
rmIdx :: PkgName -> IO ()
rmIdx PkgName
p = do let f :: String
f = PkgName -> String
pkgIndex PkgName
p
             ex <- String -> IO Bool
doesFileExist String
f
             when ex $ rmFile f

rmExe :: String -> IO ()
rmExe :: String -> IO ()
rmExe String
p = do
            fn <- String -> IO String
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ if Bool
isWindows Bool -> Bool -> Bool
&& Bool -> Bool
not (String -> Bool
hasExtension String
p)
                                then String -> String -> String
addExtension String
p String
".exe" else String
p
            rmFile fn

toIBCFile :: Name -> String
toIBCFile (UN Text
n) = Text -> String
str Text
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
".ibc"
toIBCFile (NS Name
n [Text]
ns) = (String -> String -> String) -> [String] -> String
forall a. HasCallStack => (a -> a -> a) -> [a] -> a
foldl1' String -> String -> String
(</>) ([String] -> [String]
forall a. [a] -> [a]
reverse (Name -> String
toIBCFile Name
n String -> [String] -> [String]
forall a. a -> [a] -> [a]
: (Text -> String) -> [Text] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Text -> String
str [Text]
ns))

installIBC :: String -> PkgName -> Name -> IO ()
installIBC :: String -> PkgName -> Name -> IO ()
installIBC String
dest PkgName
p Name
m = do
    let f :: String
f = Name -> String
toIBCFile Name
m
    let destdir :: String
destdir = String
dest String -> String -> String
</> PkgName -> String
unPkgName PkgName
p String -> String -> String
</> Name -> String
getDest Name
m
    String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Installing " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
f String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" to " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
destdir
    Bool -> String -> IO ()
createDirectoryIfMissing Bool
True String
destdir
    String -> String -> IO ()
copyFile String
f (String
destdir String -> String -> String
</> String -> String
takeFileName String
f)
    () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  where
    getDest :: Name -> String
getDest (UN Text
n) = String
""
    getDest (NS Name
n [Text]
ns) = (String -> String -> String) -> [String] -> String
forall a. HasCallStack => (a -> a -> a) -> [a] -> a
foldl1' String -> String -> String
(</>) ([String] -> [String]
forall a. [a] -> [a]
reverse (Name -> String
getDest Name
n String -> [String] -> [String]
forall a. a -> [a] -> [a]
: (Text -> String) -> [Text] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Text -> String
str [Text]
ns))

installIdx :: String -> PkgName -> IO ()
installIdx :: String -> PkgName -> IO ()
installIdx String
dest PkgName
p = do
  let f :: String
f = PkgName -> String
pkgIndex PkgName
p
  let destdir :: String
destdir = String
dest String -> String -> String
</> PkgName -> String
unPkgName PkgName
p
  String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Installing " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
f String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" to " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
destdir
  Bool -> String -> IO ()
createDirectoryIfMissing Bool
True String
destdir
  String -> String -> IO ()
copyFile String
f (String
destdir String -> String -> String
</> String -> String
takeFileName String
f)
  () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

installObj :: String -> PkgName -> String -> IO ()
installObj :: String -> PkgName -> String -> IO ()
installObj String
dest PkgName
p String
o = do
  let destdir :: String
destdir = String -> String
addTrailingPathSeparator (String
dest String -> String -> String
</> PkgName -> String
unPkgName PkgName
p)
  String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Installing " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
o String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" to " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
destdir
  Bool -> String -> IO ()
createDirectoryIfMissing Bool
True String
destdir
  String -> String -> IO ()
copyFile String
o (String
destdir String -> String -> String
</> String -> String
takeFileName String
o)
  () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

#ifdef mingw32_HOST_OS
mkDirCmd = "mkdir "
#else
mkDirCmd :: String
mkDirCmd = String
"mkdir -p "
#endif

inPkgDir :: PkgDesc -> IO a -> IO a
inPkgDir :: forall a. PkgDesc -> IO a -> IO a
inPkgDir PkgDesc
pkgdesc IO a
action =
  do dir <- IO String
getCurrentDirectory
     when (sourcedir pkgdesc /= "") $
       do putStrLn $ "Entering directory `" ++ ("." </> sourcedir pkgdesc) ++ "'"
          setCurrentDirectory $ dir </> sourcedir pkgdesc
     res <- action
     when (sourcedir pkgdesc /= "") $
       do putStrLn $ "Leaving directory `" ++ ("." </> sourcedir pkgdesc) ++ "'"
          setCurrentDirectory dir
     return res

-- ------------------------------------------------------- [ Makefile Commands ]
-- | Invoke a Makefile's target with an enriched system environment
makeTarget :: Maybe String -> Maybe String -> IO ()
makeTarget :: Maybe String -> Maybe String -> IO ()
makeTarget Maybe String
_ Maybe String
Nothing = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
makeTarget Maybe String
mtgt (Just String
s) = do incFlags <- String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
" " ([String] -> String) -> IO [String] -> IO String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO [String]
getIncFlags
                              libFlags <- intercalate " " <$> getLibFlags
                              newEnv <- (++ [("IDRIS_INCLUDES", incFlags),
                                             ("IDRIS_LDFLAGS", libFlags)]) <$> getEnvironment
                              let cmdLine = case Maybe String
mtgt of
                                              Maybe String
Nothing -> String
"make -f " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s
                                              Just String
tgt -> String
"make -f " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
tgt
                              (_, _, _, r) <- createProcess (shell cmdLine) { env = Just newEnv }
                              waitForProcess r
                              return ()


-- | Invoke a Makefile's default target.
make :: Maybe String -> IO ()
make :: Maybe String -> IO ()
make = Maybe String -> Maybe String -> IO ()
makeTarget Maybe String
forall a. Maybe a
Nothing

-- | Invoke a Makefile's clean target.
clean :: Maybe String -> IO ()
clean :: Maybe String -> IO ()
clean = Maybe String -> Maybe String -> IO ()
makeTarget (String -> Maybe String
forall a. a -> Maybe a
Just String
"clean")

-- | Merge an option list representing the command line options into
-- those specified for a package description.
--
-- This is not a complete union between the two options sets. First,
-- to prevent important package specified options from being
-- overwritten. Second, the semantics for this merge are not fully
-- defined.
--
-- A discussion for this is on the issue tracker:
--     https://github.com/idris-lang/Idris-dev/issues/1448
--
mergeOptions :: [Opt] -- ^ The command line options
             -> [Opt] -- ^ The package options
             -> Either String [Opt]
mergeOptions :: [Opt] -> [Opt] -> Either String [Opt]
mergeOptions [Opt]
copts [Opt]
popts =
    case [Either String Opt] -> ([String], [Opt])
forall a b. [Either a b] -> ([a], [b])
partitionEithers ((Opt -> Either String Opt) -> [Opt] -> [Either String Opt]
forall a b. (a -> b) -> [a] -> [b]
map Opt -> Either String Opt
chkOpt ([Opt] -> [Opt]
normaliseOpts [Opt]
copts)) of
      ([], [Opt]
copts') -> [Opt] -> Either String [Opt]
forall a b. b -> Either a b
Right ([Opt] -> Either String [Opt]) -> [Opt] -> Either String [Opt]
forall a b. (a -> b) -> a -> b
$ [Opt]
copts' [Opt] -> [Opt] -> [Opt]
forall a. [a] -> [a] -> [a]
++ [Opt]
popts
      ([String]
es, [Opt]
_)      -> String -> Either String [Opt]
forall a b. a -> Either a b
Left  (String -> Either String [Opt]) -> String -> Either String [Opt]
forall a b. (a -> b) -> a -> b
$ [String] -> String
genErrMsg [String]
es
  where
    normaliseOpts :: [Opt] -> [Opt]
    normaliseOpts :: [Opt] -> [Opt]
normaliseOpts = (Opt -> Bool) -> [Opt] -> [Opt]
forall a. (a -> Bool) -> [a] -> [a]
filter Opt -> Bool
filtOpt

    filtOpt :: Opt -> Bool
    filtOpt :: Opt -> Bool
filtOpt (PkgBuild        String
_) = Bool
False
    filtOpt (PkgInstall      String
_) = Bool
False
    filtOpt (PkgClean        String
_) = Bool
False
    filtOpt (PkgCheck        String
_) = Bool
False
    filtOpt (PkgREPL         String
_) = Bool
False
    filtOpt (PkgDocBuild     String
_) = Bool
False
    filtOpt (PkgDocInstall   String
_) = Bool
False
    filtOpt (PkgTest         String
_) = Bool
False
    filtOpt Opt
_                   = Bool
True

    chkOpt :: Opt -> Either String Opt
    chkOpt :: Opt -> Either String Opt
chkOpt o :: Opt
o@(OLogging Int
_)     = Opt -> Either String Opt
forall a b. b -> Either a b
Right Opt
o
    chkOpt o :: Opt
o@(OLogCats [LogCat]
_)     = Opt -> Either String Opt
forall a b. b -> Either a b
Right Opt
o
    chkOpt o :: Opt
o@(Opt
DefaultTotal)   = Opt -> Either String Opt
forall a b. b -> Either a b
Right Opt
o
    chkOpt o :: Opt
o@(Opt
DefaultPartial) = Opt -> Either String Opt
forall a b. b -> Either a b
Right Opt
o
    chkOpt o :: Opt
o@(Opt
WarnPartial)    = Opt -> Either String Opt
forall a b. b -> Either a b
Right Opt
o
    chkOpt o :: Opt
o@(Opt
WarnReach)      = Opt -> Either String Opt
forall a b. b -> Either a b
Right Opt
o
    chkOpt o :: Opt
o@(IBCSubDir String
_)    = Opt -> Either String Opt
forall a b. b -> Either a b
Right Opt
o
    chkOpt o :: Opt
o@(ImportDir String
_ )   = Opt -> Either String Opt
forall a b. b -> Either a b
Right Opt
o
    chkOpt o :: Opt
o@(UseCodegen Codegen
_)   = Opt -> Either String Opt
forall a b. b -> Either a b
Right Opt
o
    chkOpt o :: Opt
o@(Verbose Int
_)      = Opt -> Either String Opt
forall a b. b -> Either a b
Right Opt
o
    chkOpt o :: Opt
o@(Opt
AuditIPkg)      = Opt -> Either String Opt
forall a b. b -> Either a b
Right Opt
o
    chkOpt o :: Opt
o@(Opt
DumpHighlights) = Opt -> Either String Opt
forall a b. b -> Either a b
Right Opt
o
    chkOpt Opt
o                  = String -> Either String Opt
forall a b. a -> Either a b
Left ([String] -> String
unwords [String
"\t", Opt -> String
forall a. Show a => a -> String
show Opt
o, String
"\n"])

    genErrMsg :: [String] -> String
    genErrMsg :: [String] -> String
genErrMsg [String]
es = [String] -> String
unlines
        [ String
"Not all command line options can be used to override package options."
        , String
"\nThe only changeable options are:"
        , String
"\t--log <lvl>, --total, --warnpartial, --warnreach, --warnipkg"
        , String
"\t--ibcsubdir <path>, -i --idrispath <path>"
        , String
"\t--logging-categories <cats>"
        , String
"\t--highlight"
        , String
"\nThe options need removing are:"
        , [String] -> String
unlines [String]
es
        ]

-- --------------------------------------------------------------------- [ EOF ]