idris-0.12: src/Pkg/Package.hs
{-|
Module : Pkg.Package
Description : Functionality for working with Idris packages.
Copyright :
License : BSD3
Maintainer : The Idris Community.
-}
{-# LANGUAGE CPP #-}
module Pkg.Package where
import System.Process
import System.Directory
import System.Exit
import System.IO
import System.FilePath ((</>), addTrailingPathSeparator, takeFileName,
takeDirectory, normalise, addExtension, hasExtension)
import System.Directory (createDirectoryIfMissing, copyFile)
import Util.System
import Control.Monad
import Control.Monad.Trans.State.Strict (execStateT)
import Control.Monad.Trans.Except (runExceptT)
import Data.List
import Data.List.Split(splitOn)
import Data.Maybe(fromMaybe)
import Data.Either(partitionEithers)
import Idris.Core.TT
import Idris.REPL
import Idris.Parser (loadModule)
import Idris.Output (pshow)
import Idris.AbsSyntax
import Idris.IdrisDoc
import Idris.IBC
import Idris.Output
import Idris.Imports
import Idris.Error (ifail)
import Pkg.PParser
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
-- --------------------------------------------------------- [ 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 copts warnonly (install, fp) = do
pkgdesc <- parseDesc fp
dir <- getCurrentDirectory
let idx = PkgIndex (pkgIndex (pkgname pkgdesc))
oks <- mapM (testLib warnonly (pkgname pkgdesc)) (libdeps pkgdesc)
when (and oks) $ do
m_ist <- inPkgDir pkgdesc $ do
make (makefile pkgdesc)
case (execout pkgdesc) of
Nothing -> do
case mergeOptions copts (idx : NoREPL : Verbose : idris_opts pkgdesc) of
Left emsg -> do
putStrLn emsg
exitWith (ExitFailure 1)
Right opts -> buildMods opts (modules pkgdesc)
Just o -> do
let exec = dir </> o
case mergeOptions copts (idx : NoREPL : Verbose : Output exec : idris_opts pkgdesc) of
Left emsg -> do
putStrLn emsg
exitWith (ExitFailure 1)
Right opts -> buildMods opts [idris_main pkgdesc]
case m_ist of
Nothing -> exitWith (ExitFailure 1)
Just ist -> do
-- Quit with error code if there was a problem
case errSpan ist of
Just _ -> exitWith (ExitFailure 1)
_ -> return ()
when install $ installPkg (opt getIBCSubDir copts) pkgdesc
-- --------------------------------------------------------- [ 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 copts warnonly quit fpath = do
pkgdesc <- parseDesc 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 : idris_opts pkgdesc) of
Left emsg -> do
putStrLn emsg
exitWith (ExitFailure 1)
Right opts -> do
buildMods opts (modules pkgdesc)
when quit $ case res of
Nothing -> exitWith (ExitFailure 1)
Just res' -> do
case errSpan res' of
Just _ -> exitWith (ExitFailure 1)
_ -> 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 copts fp = do
orig <- getIState
runIO $ checkPkg copts False False fp
pkgdesc <- runIO $ parseDesc fp -- bzzt, repetition!
case mergeOptions copts (idris_opts pkgdesc) of
Left emsg -> ifail emsg
Right opts -> do
let mod = idris_main pkgdesc
let f = toPath (showCG mod)
putIState orig
dir <- runIO getCurrentDirectory
runIO $ setCurrentDirectory $ dir </> sourcedir pkgdesc
if (f /= "")
then idrisMain ((Filename f) : opts)
else iputStrLn "Can't start REPL: no main module given"
runIO $ setCurrentDirectory dir
where
toPath n = foldl1' (</>) $ splitOn "." n
-- --------------------------------------------------------------- [ Cleaning ]
-- | Clean Package build files
cleanPkg :: [Opt] -- ^ Command line options.
-> FilePath -- ^ Path to ipkg file.
-> IO ()
cleanPkg copts fp = do
pkgdesc <- parseDesc fp
dir <- getCurrentDirectory
inPkgDir pkgdesc $ do
clean (makefile pkgdesc)
mapM_ rmIBC (modules pkgdesc)
rmIdx (pkgname pkgdesc)
case execout pkgdesc of
Nothing -> return ()
Just s -> rmExe $ dir </> 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.
-> FilePath -- ^ Path to ipkg file.
-> IO ()
documentPkg copts fp = do
pkgdesc <- parseDesc fp
cd <- getCurrentDirectory
let pkgDir = cd </> takeDirectory fp
outputDir = cd </> pkgname pkgdesc ++ "_doc"
popts = NoREPL : Verbose : idris_opts pkgdesc
mods = modules pkgdesc
fs = map (foldl1' (</>) . splitOn "." . showCG) mods
setCurrentDirectory $ pkgDir </> sourcedir pkgdesc
make (makefile pkgdesc)
setCurrentDirectory pkgDir
case mergeOptions copts popts of
Left emsg -> do
putStrLn emsg
exitWith (ExitFailure 1)
Right opts -> do
let run l = runExceptT . execStateT l
load [] = return ()
load (f:fs) = do loadModule f IBC_Building; load fs
loader = do
idrisMain opts
addImportDir (sourcedir pkgdesc)
load fs
idrisInstance <- run loader idrisInit
setCurrentDirectory cd
case idrisInstance of
Left err -> do
putStrLn $ pshow idrisInit err
exitWith (ExitFailure 1)
Right ist -> do
docRes <- generateDocs ist mods outputDir
case docRes of
Right _ -> return ()
Left msg -> do
putStrLn msg
exitWith (ExitFailure 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 ()
testPkg copts fp = do
pkgdesc <- parseDesc fp
ok <- mapM (testLib True (pkgname pkgdesc)) (libdeps pkgdesc)
when (and ok) $ do
m_ist <- 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 = (Filename tmpn : NoREPL : Verbose : Output tmpn' : idris_opts pkgdesc)
case mergeOptions copts popts of
Left emsg -> do
putStrLn emsg
exitWith (ExitFailure 1)
Right opts -> do
m_ist <- idris opts
rawSystem tmpn' []
return m_ist
case m_ist of
Nothing -> exitWith (ExitFailure 1)
Just ist -> do
-- Quit with error code if problem building
case errSpan ist of
Just _ -> exitWith (ExitFailure 1)
_ -> return ()
-- ----------------------------------------------------------- [ Installation ]
-- | Install package
installPkg :: [String] -- ^ Alternate install location
-> PkgDesc -- ^ iPKG file.
-> IO ()
installPkg altdests pkgdesc = inPkgDir pkgdesc $ do
d <- getTargetDir
let destdir = case altdests of
[] -> d
(d':_) -> d'
case (execout pkgdesc) of
Nothing -> do
mapM_ (installIBC destdir (pkgname pkgdesc)) (modules pkgdesc)
installIdx destdir (pkgname pkgdesc)
Just o -> 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.
buildMods :: [Opt] -> [Name] -> IO (Maybe IState)
buildMods opts ns = do let f = map (toPath . showCG) ns
idris (map Filename f ++ opts)
where toPath n = foldl1' (</>) $ splitOn "." n
testLib :: Bool -> String -> String -> IO Bool
testLib warn p f
= do d <- getDataDir
gcc <- getCC
(tmpf, tmph) <- tempfile ""
hClose tmph
let libtest = d </> "rts" </> "libtest.c"
e <- rawSystem gcc [libtest, "-l" ++ f, "-o", tmpf]
case e of
ExitSuccess -> return True
_ -> do if warn
then do putStrLn $ "Not building " ++ p ++
" due to missing library " ++ f
return False
else fail $ "Missing library " ++ f
rmIBC :: Name -> IO ()
rmIBC m = rmFile $ toIBCFile m
rmIdx :: String -> IO ()
rmIdx p = do let f = pkgIndex p
ex <- doesFileExist f
when ex $ rmFile f
rmExe :: String -> IO ()
rmExe p = do
fn <- return $ if isWindows && not (hasExtension p)
then addExtension p ".exe" else p
rmFile fn
toIBCFile (UN n) = str n ++ ".ibc"
toIBCFile (NS n ns) = foldl1' (</>) (reverse (toIBCFile n : map str ns))
installIBC :: String -> String -> Name -> IO ()
installIBC dest p m = do
let f = toIBCFile m
let destdir = dest </> p </> getDest m
putStrLn $ "Installing " ++ f ++ " to " ++ destdir
createDirectoryIfMissing True destdir
copyFile f (destdir </> takeFileName f)
return ()
where
getDest (UN n) = ""
getDest (NS n ns) = foldl1' (</>) (reverse (getDest n : map str ns))
installIdx :: String -> String -> IO ()
installIdx dest p = do
let f = pkgIndex p
let destdir = dest </> p
putStrLn $ "Installing " ++ f ++ " to " ++ destdir
createDirectoryIfMissing True destdir
copyFile f (destdir </> takeFileName f)
return ()
installObj :: String -> String -> String -> IO ()
installObj dest p o = do
let destdir = addTrailingPathSeparator (dest </> p)
putStrLn $ "Installing " ++ o ++ " to " ++ destdir
createDirectoryIfMissing True destdir
copyFile o (destdir </> takeFileName o)
return ()
#ifdef mingw32_HOST_OS
mkDirCmd = "mkdir "
#else
mkDirCmd = "mkdir -p "
#endif
inPkgDir :: PkgDesc -> IO a -> IO a
inPkgDir pkgdesc action =
do dir <- 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 default target.
make :: Maybe String -> IO ()
make Nothing = return ()
make (Just s) = do rawSystem "make" ["-f", s]
return ()
-- | Invoke a Makefile's clean target.
clean :: Maybe String -> IO ()
clean Nothing = return ()
clean (Just s) = do rawSystem "make" ["-f", s, "clean"]
return ()
-- | 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 copts popts =
case partitionEithers (map chkOpt (normaliseOpts copts)) of
([], copts') -> Right $ copts' ++ popts
(es, _) -> Left $ genErrMsg es
where
normaliseOpts :: [Opt] -> [Opt]
normaliseOpts = filter filtOpt
filtOpt :: Opt -> Bool
filtOpt (PkgBuild _) = False
filtOpt (PkgInstall _) = False
filtOpt (PkgClean _) = False
filtOpt (PkgCheck _) = False
filtOpt (PkgREPL _) = False
filtOpt (PkgMkDoc _) = False
filtOpt (PkgTest _) = False
filtOpt _ = True
chkOpt :: Opt -> Either String Opt
chkOpt o@(OLogging _) = Right o
chkOpt o@(OLogCats _) = Right o
chkOpt o@(DefaultTotal) = Right o
chkOpt o@(DefaultPartial) = Right o
chkOpt o@(WarnPartial) = Right o
chkOpt o@(WarnReach) = Right o
chkOpt o@(IBCSubDir _) = Right o
chkOpt o@(ImportDir _ ) = Right o
chkOpt o@(UseCodegen _) = Right o
chkOpt o = Left (unwords ["\t", show o, "\n"])
genErrMsg :: [String] -> String
genErrMsg es = unlines
[ "Not all command line options can be used to override package options."
, "\nThe only changeable options are:"
, "\t--log <lvl>, --total, --warnpartial, --warnreach"
, "\t--ibcsubdir <path>, -i --idrispath <path>"
, "\t--logging-categories <cats>"
, "\nThe options need removing are:"
, unlines es
]
-- --------------------------------------------------------------------- [ EOF ]