b00a8cb9b5
It is unclear what it means if ports are used in sub-modules, so to be cautious, we want to rule it out in the first release. As people use the API it’ll become clear how sub-module ports are necessary and what problems they might cause.
178 lines
6.4 KiB
Haskell
178 lines
6.4 KiB
Haskell
{-# OPTIONS_GHC -W #-}
|
|
module Build.File (build) where
|
|
|
|
import Control.Applicative ((<$>))
|
|
import Control.Monad.Error (runErrorT)
|
|
import Control.Monad.RWS.Strict
|
|
import System.Directory
|
|
import System.Exit
|
|
import System.FilePath
|
|
import System.IO
|
|
|
|
import qualified Data.Binary as Binary
|
|
import qualified Data.List as List
|
|
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
|
|
import qualified Build.Interface as Interface
|
|
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
|
|
import qualified Transform.Canonicalize as Canonical
|
|
|
|
-- Reader: Runtime flags, always accessible
|
|
-- Writer: Remember the last module to be accessed
|
|
-- State: Build up a map of the module interfaces
|
|
type BuildT m a = RWST Flag.Flags (Last String) BInterfaces m a
|
|
type Build a = BuildT IO a
|
|
|
|
-- Interfaces, remembering if something was recompiled
|
|
type BInterfaces = Map.Map String (Bool, M.ModuleInterface)
|
|
|
|
evalBuild :: Flag.Flags -> M.Interfaces -> Build ()
|
|
-> IO (Map.Map String M.ModuleInterface, Maybe String)
|
|
evalBuild flags interfaces build =
|
|
do (ifaces, moduleNames) <- execRWST build flags (fmap notUpdated interfaces)
|
|
return (fmap snd ifaces, getLast moduleNames)
|
|
where
|
|
notUpdated iface = (False, iface)
|
|
|
|
-- | Builds a list of files, returning the moduleName of the last one.
|
|
-- Returns \"\" if the list is empty
|
|
build :: Flag.Flags -> M.Interfaces -> [FilePath] -> IO String
|
|
build flags interfaces files =
|
|
do (ifaces, topName) <- evalBuild flags interfaces (buildAll files)
|
|
let removeTopName = Maybe.maybe id Map.delete topName
|
|
mapM_ (checkPorts topName) (Map.toList $ removeTopName ifaces)
|
|
return $ Maybe.fromMaybe "" topName
|
|
where
|
|
checkPorts topName (name,iface)
|
|
| null ports = return ()
|
|
| otherwise = Print.failure msg
|
|
where
|
|
ports = M.iPorts iface
|
|
msg = concat
|
|
[ "Port Error: ports may only appear in the main module, but\n"
|
|
, " sub-module ", name, " declares the following port"
|
|
, if length ports == 1 then "" else "s", ": "
|
|
, List.intercalate ", " ports
|
|
, case topName of
|
|
Nothing -> ""
|
|
Just tname -> "\n All ports must appear in module " ++ tname
|
|
]
|
|
|
|
buildAll :: [FilePath] -> Build ()
|
|
buildAll fs = mapM_ (uncurry build1) (zip [1..] fs)
|
|
where build1 :: Integer -> FilePath -> Build ()
|
|
build1 num fname = do
|
|
shouldCompile <- shouldBeCompiled fname
|
|
if shouldCompile
|
|
then compile number fname
|
|
else retrieve fname
|
|
|
|
where number = join ["[", show num, " of ", show total, "]"]
|
|
|
|
total = length fs
|
|
|
|
shouldBeCompiled :: FilePath -> Build Bool
|
|
shouldBeCompiled filePath = do
|
|
flags <- ask
|
|
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)
|
|
|
|
retrieve :: FilePath -> Build ()
|
|
retrieve filePath = do
|
|
flags <- ask
|
|
iface <- liftIO $ Interface.load (Utils.elmi flags filePath)
|
|
case Interface.isValid filePath iface of
|
|
Right (name, interface) ->
|
|
do binterfaces <- get
|
|
let interfaces = snd <$> binterfaces
|
|
liftIO $ when (Flag.print_types flags) (Print.interfaceTypes interfaces interface)
|
|
update name interface False
|
|
|
|
Left err -> liftIO $ Print.failure err
|
|
|
|
compile :: String -> FilePath -> Build ()
|
|
compile number filePath =
|
|
do flags <- ask
|
|
binterfaces <- get
|
|
source <- liftIO $ readFile filePath
|
|
let interfaces = snd <$> binterfaces
|
|
name = getName source
|
|
liftIO $ do
|
|
printStatus name
|
|
createDirectoryIfMissing True (Flag.cache_dir flags)
|
|
createDirectoryIfMissing True (Flag.build_dir flags)
|
|
|
|
metaModule <-
|
|
liftIO $ case Source.build (Flag.no_prelude flags) interfaces source of
|
|
Right modul -> return modul
|
|
Left errors -> do Print.errors errors
|
|
exitFailure
|
|
|
|
liftIO $ when (Flag.print_types flags) $ Print.metaTypes interfaces metaModule
|
|
|
|
let newInters = Canonical.interface name $ M.metaToInterface metaModule
|
|
generateCache name newInters metaModule
|
|
update name newInters True
|
|
|
|
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 ++ " )" ]
|
|
|
|
generateCache name interfs metaModule = do
|
|
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 ->
|
|
L.hPut handle (Binary.encode (name, interfs))
|
|
|
|
update :: String -> M.ModuleInterface -> Bool -> Build ()
|
|
update name inter wasUpdated =
|
|
do modify (Map.insert name (wasUpdated, inter))
|
|
tell (Last . Just $ name)
|