2014-01-04 09:54:46 +00:00
|
|
|
{-# OPTIONS_GHC -W #-}
|
2013-12-15 07:29:39 +00:00
|
|
|
module Build.File (build) where
|
|
|
|
|
2014-01-13 15:21:39 +00:00
|
|
|
import Control.Applicative ((<$>))
|
2013-12-30 22:03:46 +00:00
|
|
|
import Control.Monad.Error (runErrorT)
|
2013-12-30 18:01:45 +00:00
|
|
|
import Control.Monad.RWS.Strict
|
2013-12-15 07:29:39 +00:00
|
|
|
import System.Directory
|
|
|
|
import System.Exit
|
|
|
|
import System.FilePath
|
|
|
|
import System.IO
|
|
|
|
|
2013-12-30 22:03:46 +00:00
|
|
|
import qualified Data.Binary as Binary
|
|
|
|
import qualified Data.Maybe as Maybe
|
|
|
|
import qualified Data.Map as Map
|
|
|
|
import qualified Data.ByteString.Lazy as L
|
|
|
|
|
|
|
|
import qualified Build.Dependencies as Deps
|
|
|
|
import qualified Build.Flags as Flag
|
2014-01-15 12:54:40 +00:00
|
|
|
import qualified Build.Interface as Interface
|
2013-12-30 22:03:46 +00:00
|
|
|
import qualified Build.Print as Print
|
|
|
|
import qualified Build.Source as Source
|
|
|
|
import qualified Build.Utils as Utils
|
|
|
|
import qualified Generate.JavaScript as JS
|
|
|
|
import qualified Parse.Module as Parser
|
|
|
|
import qualified SourceSyntax.Module as M
|
2013-12-15 07:29:39 +00:00
|
|
|
import qualified Transform.Canonicalize as Canonical
|
|
|
|
|
2013-12-30 18:01:45 +00:00
|
|
|
-- Reader: Runtime flags, always accessible
|
|
|
|
-- Writer: Remember the last module to be accessed
|
|
|
|
-- State: Build up a map of the module interfaces
|
2013-12-30 22:03:46 +00:00
|
|
|
type BuildT m a = RWST Flag.Flags (Last String) BInterfaces m a
|
2013-12-30 18:01:45 +00:00
|
|
|
type Build a = BuildT IO a
|
|
|
|
|
2013-12-30 22:03:46 +00:00
|
|
|
-- Interfaces, remembering if something was recompiled
|
|
|
|
type BInterfaces = Map.Map String (Bool, M.ModuleInterface)
|
|
|
|
|
2013-12-30 18:01:45 +00:00
|
|
|
evalBuild :: Flag.Flags -> M.Interfaces -> Build () -> IO (Maybe String)
|
2014-01-13 15:21:39 +00:00
|
|
|
evalBuild flags interfaces b = do
|
|
|
|
(_, s) <- evalRWST b flags (fmap notUpdated interfaces)
|
2013-12-30 18:01:45 +00:00
|
|
|
return . getLast $ s
|
2014-01-13 15:21:39 +00:00
|
|
|
where
|
|
|
|
notUpdated i = (False, i)
|
2013-12-30 18:01:45 +00:00
|
|
|
|
2013-12-30 22:03:46 +00:00
|
|
|
-- | Builds a list of files, returning the moduleName of the last one.
|
|
|
|
-- Returns \"\" if the list is empty
|
2013-12-30 18:01:45 +00:00
|
|
|
build :: Flag.Flags -> M.Interfaces -> [FilePath] -> IO String
|
|
|
|
build flags is = fmap (Maybe.fromMaybe "") . evalBuild flags is . buildAll
|
|
|
|
|
|
|
|
buildAll :: [FilePath] -> Build ()
|
2013-12-30 22:03:46 +00:00
|
|
|
buildAll fs = mapM_ (uncurry build1) (zip [1..] fs)
|
2014-01-13 15:21:39 +00:00
|
|
|
where build1 :: Integer -> FilePath -> Build ()
|
|
|
|
build1 num fname = do
|
2013-12-30 22:03:46 +00:00
|
|
|
shouldCompile <- shouldBeCompiled fname
|
|
|
|
if shouldCompile
|
|
|
|
then compile number fname
|
|
|
|
else retrieve fname
|
|
|
|
|
|
|
|
where number = join ["[", show num, " of ", show total, "]"]
|
|
|
|
|
2013-12-30 18:01:45 +00:00
|
|
|
total = length fs
|
|
|
|
|
2013-12-30 22:03:46 +00:00
|
|
|
shouldBeCompiled :: FilePath -> Build Bool
|
|
|
|
shouldBeCompiled filePath = do
|
2013-12-30 18:01:45 +00:00
|
|
|
flags <- ask
|
2013-12-30 22:03:46 +00:00
|
|
|
let alreadyCompiled = liftIO $ do
|
|
|
|
existsi <- doesFileExist (Utils.elmi flags filePath)
|
|
|
|
existso <- doesFileExist (Utils.elmo flags filePath)
|
|
|
|
return $ existsi && existso
|
|
|
|
|
|
|
|
outDated = liftIO $ do
|
|
|
|
tsrc <- getModificationTime filePath
|
|
|
|
tint <- getModificationTime (Utils.elmo flags filePath)
|
|
|
|
return (tsrc > tint)
|
|
|
|
|
|
|
|
dependenciesUpdated = do
|
|
|
|
eDeps <- liftIO . runErrorT $ Deps.readDeps filePath
|
|
|
|
case eDeps of
|
|
|
|
-- Should never actually reach here
|
|
|
|
Left err -> liftIO $ Print.failure err
|
|
|
|
Right (_, deps) -> anyM wasCompiled deps
|
|
|
|
|
|
|
|
|
|
|
|
in (not <$> alreadyCompiled) `orM` outDated `orM` dependenciesUpdated
|
|
|
|
|
|
|
|
wasCompiled :: String -> Build Bool
|
|
|
|
wasCompiled modul = maybe False fst . Map.lookup modul <$> get
|
|
|
|
|
|
|
|
-- Short-circuiting monadic (||)
|
|
|
|
infixr 2 `orM`
|
|
|
|
orM :: (Monad m) => m Bool -> m Bool -> m Bool
|
|
|
|
orM m1 m2 = do b1 <- m1
|
|
|
|
if b1
|
|
|
|
then return b1
|
|
|
|
else m2
|
|
|
|
|
|
|
|
anyM :: (Monad m) => (a -> m Bool) -> [a] -> m Bool
|
|
|
|
anyM f = foldr (orM . f) (return False)
|
2013-12-30 18:01:45 +00:00
|
|
|
|
|
|
|
retrieve :: FilePath -> Build ()
|
|
|
|
retrieve filePath = do
|
|
|
|
flags <- ask
|
2014-01-15 12:54:40 +00:00
|
|
|
iface <- liftIO $ Interface.load (Utils.elmi flags filePath)
|
2014-01-04 14:59:24 +00:00
|
|
|
case Interface.isValid filePath iface of
|
2013-12-15 07:29:39 +00:00
|
|
|
Right (name, interface) ->
|
2013-12-30 22:03:46 +00:00
|
|
|
do binterfaces <- get
|
|
|
|
let interfaces = snd <$> binterfaces
|
2013-12-30 18:01:45 +00:00
|
|
|
liftIO $ when (Flag.print_types flags) (Print.interfaceTypes interfaces interface)
|
2013-12-30 22:03:46 +00:00
|
|
|
update name interface False
|
2013-12-30 18:01:45 +00:00
|
|
|
|
2013-12-30 22:03:46 +00:00
|
|
|
Left err -> liftIO $ Print.failure err
|
2013-12-15 07:29:39 +00:00
|
|
|
|
2013-12-30 18:01:45 +00:00
|
|
|
compile :: String -> FilePath -> Build ()
|
|
|
|
compile number filePath =
|
|
|
|
do flags <- ask
|
2013-12-30 22:03:46 +00:00
|
|
|
binterfaces <- get
|
2013-12-30 18:01:45 +00:00
|
|
|
source <- liftIO $ readFile filePath
|
2013-12-30 22:03:46 +00:00
|
|
|
let interfaces = snd <$> binterfaces
|
|
|
|
name = getName source
|
2013-12-30 18:01:45 +00:00
|
|
|
liftIO $ do
|
|
|
|
printStatus name
|
|
|
|
createDirectoryIfMissing True (Flag.cache_dir flags)
|
|
|
|
createDirectoryIfMissing True (Flag.build_dir flags)
|
2013-12-15 07:29:39 +00:00
|
|
|
|
2013-12-30 18:01:45 +00:00
|
|
|
metaModule <-
|
|
|
|
liftIO $ case Source.build (Flag.no_prelude flags) interfaces source of
|
2013-12-15 07:29:39 +00:00
|
|
|
Right modul -> return modul
|
|
|
|
Left errors -> do Print.errors errors
|
|
|
|
exitFailure
|
|
|
|
|
2013-12-30 18:01:45 +00:00
|
|
|
liftIO $ when (Flag.print_types flags) $ Print.metaTypes interfaces metaModule
|
|
|
|
|
2013-12-30 22:03:46 +00:00
|
|
|
let newInters = Canonical.interface name $ M.metaToInterface metaModule
|
|
|
|
generateCache name newInters metaModule
|
|
|
|
update name newInters True
|
2013-12-15 07:29:39 +00:00
|
|
|
|
|
|
|
where
|
|
|
|
getName source = case Parser.getModuleName source of
|
|
|
|
Just n -> n
|
|
|
|
Nothing -> "Main"
|
|
|
|
|
|
|
|
printStatus name =
|
|
|
|
hPutStrLn stdout $ concat [ number, " Compiling ", name
|
|
|
|
, replicate (max 1 (20 - length name)) ' '
|
|
|
|
, "( " ++ filePath ++ " )" ]
|
|
|
|
|
2013-12-30 22:03:46 +00:00
|
|
|
generateCache name interfs metaModule = do
|
2013-12-30 18:01:45 +00:00
|
|
|
flags <- ask
|
|
|
|
liftIO $ do
|
|
|
|
createDirectoryIfMissing True . dropFileName $ Utils.elmi flags filePath
|
|
|
|
writeFile (Utils.elmo flags filePath) (JS.generate metaModule)
|
|
|
|
withBinaryFile (Utils.elmi flags filePath) WriteMode $ \handle ->
|
2013-12-30 22:03:46 +00:00
|
|
|
L.hPut handle (Binary.encode (name, interfs))
|
2013-12-30 18:01:45 +00:00
|
|
|
|
2013-12-30 22:03:46 +00:00
|
|
|
update :: String -> M.ModuleInterface -> Bool -> Build ()
|
|
|
|
update name inter wasUpdated = modify (Map.insert name (wasUpdated, inter))
|
|
|
|
>> tell (Last . Just $ name)
|