yogsototh/elm
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Merge in @maxsnew's fixes from #424

Browse source 
Tested on small file where I changed a dependency and on elm-lang.org
code.
This commit is contained in:
Evan Czaplicki 2014-01-15 13:54:40 +01:00
commit b9e627f78e
4 changed files with 170 additions and 110 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

82
compiler/Build/Dependencies.hs
View file

@ -1,5 +1,5 @@
{-# OPTIONS_GHC -W #-} {-# OPTIONS_GHC -W #-}
module Build.Dependencies (getSortedDependencies) where module Build.Dependencies (getSortedDependencies, readDeps) where
import Control.Applicative import Control.Applicative
import Control.Monad.Error import Control.Monad.Error
@ -12,9 +12,9 @@ import qualified Data.Map as Map
import qualified Data.Maybe as Maybe import qualified Data.Maybe as Maybe
import qualified Data.Set as Set import qualified Data.Set as Set
import System.Directory import System.Directory
import System.Exit
import System.FilePath as FP import System.FilePath as FP
import System.IO
import Build.Print (failure)
import qualified SourceSyntax.Module as Module import qualified SourceSyntax.Module as Module
import qualified Parse.Parse as Parse import qualified Parse.Parse as Parse
@ -26,7 +26,7 @@ getSortedDependencies :: [FilePath] -> Module.Interfaces -> FilePath -> IO [Stri
getSortedDependencies srcDirs builtIns root = getSortedDependencies srcDirs builtIns root =
do extras <- extraDependencies do extras <- extraDependencies
let allSrcDirs = srcDirs ++ Maybe.fromMaybe [] extras let allSrcDirs = srcDirs ++ Maybe.fromMaybe [] extras
result <- runErrorT $ readDeps allSrcDirs builtIns root result <- runErrorT $ readAllDeps allSrcDirs builtIns root
case result of case result of
Right deps -> sortDeps deps Right deps -> sortDeps deps
Left err -> failure $ err ++ if Maybe.isJust extras then "" else msg Left err -> failure $ err ++ if Maybe.isJust extras then "" else msg
@ -34,8 +34,6 @@ getSortedDependencies srcDirs builtIns root =
Path.dependencyFile ++ Path.dependencyFile ++
" file if you\nare trying to use a 3rd party library." " file if you\nare trying to use a 3rd party library."
failure msg = hPutStrLn stderr msg >> exitFailure
extraDependencies :: IO (Maybe [FilePath]) extraDependencies :: IO (Maybe [FilePath])
extraDependencies = extraDependencies =
do exists <- doesFileExist Path.dependencyFile do exists <- doesFileExist Path.dependencyFile
@ -76,46 +74,52 @@ sortDeps depends =
mistakes = filter (\scc -> length scc > 1) sccs mistakes = filter (\scc -> length scc > 1) sccs
msg = "A cyclical module dependency or was detected in:\n" msg = "A cyclical module dependency or was detected in:\n"
readDeps :: [FilePath] -> Module.Interfaces -> FilePath -> ErrorT String IO [Deps] readAllDeps :: [FilePath] -> Module.Interfaces -> FilePath -> ErrorT String IO [Deps]
readDeps srcDirs builtIns root = do readAllDeps srcDirs builtIns root =
let ifaces = (Set.fromList . Map.keys) builtIns do let ifaces = (Set.fromList . Map.keys) builtIns
State.evalStateT (go ifaces root) Set.empty State.evalStateT (go ifaces root) Set.empty
where where
go :: Set.Set String -> FilePath -> State.StateT (Set.Set String) (ErrorT String IO) [Deps] go :: Set.Set String -> FilePath -> State.StateT (Set.Set String) (ErrorT String IO) [Deps]
go builtIns root = do go builtIns root = do
(root', txt) <- lift $ getFile srcDirs root root' <- lift $ findSrcFile srcDirs root
case Parse.dependencies txt of (name, deps) <- lift $ readDeps root'
Left err -> throwError $ msg ++ show err seen <- State.get
where msg = "Error resolving dependencies in " ++ root' ++ ":\n" let realDeps = Set.difference (Set.fromList deps) builtIns
newDeps = Set.difference (Set.filter (not . isNative) realDeps) seen
State.put (Set.insert name (Set.union newDeps seen))
rest <- mapM (go builtIns . toFilePath) (Set.toList newDeps)
return ((makeRelative "." root', name, Set.toList realDeps) : concat rest)
Right (name,deps) -> readDeps :: FilePath -> ErrorT String IO (String, [String])
do seen <- State.get readDeps path = do
let realDeps = Set.difference (Set.fromList deps) builtIns txt <- lift $ readFile path
newDeps = Set.difference (Set.filter (not . isNative) realDeps) seen case Parse.dependencies txt of
State.put (Set.insert name (Set.union newDeps seen)) Left err -> throwError $ msg ++ show err
rest <- mapM (go builtIns . toFilePath) (Set.toList newDeps) where msg = "Error resolving dependencies in " ++ path ++ ":\n"
return ((makeRelative "." root', name, Set.toList realDeps) : concat rest) Right o -> return o
getFile :: [FilePath] -> FilePath -> ErrorT String IO (FilePath,String) findSrcFile :: [FilePath] -> FilePath -> ErrorT String IO FilePath
getFile [] path = findSrcFile dirs path = foldr tryDir notFound dirs
throwError $ unlines where
[ "Could not find file: " ++ path notFound = throwError $ unlines
, " If it is not in the root directory of your project, use" [ "Could not find file: " ++ path
, " --src-dir to declare additional locations for source files." , " If it is not in the root directory of your project, use"
, " If it is part of a 3rd party library, it needs to be declared" , " --src-dir to declare additional locations for source files."
, " as a dependency in the " ++ Path.dependencyFile ++ " file." ] , " If it is part of a 3rd party library, it needs to be declared"
, " as a dependency in the " ++ Path.dependencyFile ++ " file." ]
getFile (dir:dirs) path = do tryDir dir next = do
let path' = dir </> path let path' = dir </> path
exists <- liftIO $ doesFileExist path' exists <- liftIO $ doesFileExist path'
case exists of if exists
True -> (,) path' `fmap` liftIO (readFile path') then return path'
False -> getFile dirs path else next
isNative :: String -> Bool
isNative name = List.isPrefixOf "Native." name isNative name = List.isPrefixOf "Native." name
toFilePath :: String -> FilePath toFilePath :: String -> FilePath
toFilePath name = map swapDots name ++ ext toFilePath name = map swapDots name ++ ext
where swapDots '.' = '/' where
swapDots c = c swapDots '.' = '/'
ext = if isNative name then ".js" else ".elm" swapDots c = c
ext = if isNative name then ".js" else ".elm"

187
compiler/Build/File.hs
View file

@ -1,92 +1,137 @@
{-# OPTIONS_GHC -W #-} {-# OPTIONS_GHC -W #-}
module Build.File (build) where module Build.File (build) where
import Control.Monad (when) import Control.Applicative ((<$>))
import qualified Data.Binary as Binary import Control.Monad.Error (runErrorT)
import qualified Data.Map as Map import Control.Monad.RWS.Strict
import System.Directory import System.Directory
import System.Exit import System.Exit
import System.FilePath import System.FilePath
import System.IO import System.IO
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
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 import qualified Transform.Canonicalize as Canonical
import qualified Data.ByteString.Lazy as L -- 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
import qualified Build.Utils as Utils -- Interfaces, remembering if something was recompiled
import qualified Build.Flags as Flag type BInterfaces = Map.Map String (Bool, M.ModuleInterface)
import qualified Build.Interface as Interface
import qualified Build.Print as Print
import qualified Build.Source as Source
import qualified Generate.JavaScript as JS
import qualified Parse.Module as Parser
import qualified SourceSyntax.Module as M
build :: Flag.Flags -> Int -> M.Interfaces -> String -> [FilePath] evalBuild :: Flag.Flags -> M.Interfaces -> Build () -> IO (Maybe String)
-> IO (String, M.Interfaces) evalBuild flags interfaces b = do
build _ _ interfaces moduleName [] = (_, s) <- evalRWST b flags (fmap notUpdated interfaces)
return (moduleName, interfaces) return . getLast $ s
build flags numModules interfaces _ (filePath:rest) = where
do (name,interface) <- notUpdated i = (False, i)
build1 flags (numModules - length rest) numModules interfaces filePath
let interfaces' = Map.insert name interface interfaces
build flags numModules interfaces' name rest
-- | 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 is = fmap (Maybe.fromMaybe "") . evalBuild flags is . buildAll
build1 :: Flag.Flags -> Int -> Int -> M.Interfaces -> FilePath buildAll :: [FilePath] -> Build ()
-> IO (String, M.ModuleInterface) buildAll fs = mapM_ (uncurry build1) (zip [1..] fs)
build1 flags moduleNum numModules interfaces filePath = where build1 :: Integer -> FilePath -> Build ()
do compiled <- alreadyCompiled flags filePath build1 num fname = do
case compiled of shouldCompile <- shouldBeCompiled fname
False -> compile flags number interfaces filePath if shouldCompile
True -> retrieve flags interfaces filePath then compile number fname
where else retrieve fname
number = "[" ++ show moduleNum ++ " of " ++ show numModules ++ "]"
where number = join ["[", show num, " of ", show total, "]"]
alreadyCompiled :: Flag.Flags -> FilePath -> IO Bool total = length fs
alreadyCompiled flags filePath = do
existsi <- doesFileExist (Utils.elmi flags filePath)
existso <- doesFileExist (Utils.elmo flags filePath)
if not existsi || not existso
then return False
else do tsrc <- getModificationTime filePath
tint <- getModificationTime (Utils.elmo flags filePath)
return (tsrc <= tint)
retrieve :: Flag.Flags -> Map.Map String M.ModuleInterface -> FilePath shouldBeCompiled :: FilePath -> Build Bool
-> IO (String, M.ModuleInterface) shouldBeCompiled filePath = do
retrieve flags interfaces filePath = do flags <- ask
iface <- Interface.load (Utils.elmi flags filePath) 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 case Interface.isValid filePath iface of
Right (name, interface) -> Right (name, interface) ->
do when (Flag.print_types flags) (Print.interfaceTypes interfaces interface) do binterfaces <- get
return (name, interface) let interfaces = snd <$> binterfaces
Left err -> liftIO $ when (Flag.print_types flags) (Print.interfaceTypes interfaces interface)
do hPutStrLn stderr err update name interface False
exitFailure
compile :: Flag.Flags -> String -> M.Interfaces -> FilePath Left err -> liftIO $ Print.failure err
-> IO (String, M.ModuleInterface)
compile flags number interfaces filePath =
do source <- readFile filePath
let name = getName source
printStatus name
createDirectoryIfMissing True (Flag.cache_dir flags) compile :: String -> FilePath -> Build ()
createDirectoryIfMissing True (Flag.build_dir flags) 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 <- metaModule <-
case Source.build (Flag.no_prelude flags) interfaces source of liftIO $ case Source.build (Flag.no_prelude flags) interfaces source of
Right modul -> return modul Right modul -> return modul
Left errors -> do Print.errors errors Left errors -> do Print.errors errors
exitFailure exitFailure
when (Flag.print_types flags) $ Print.metaTypes interfaces metaModule liftIO $ when (Flag.print_types flags) $ Print.metaTypes interfaces metaModule
let intermediate = (name, Canonical.interface name $ M.metaToInterface metaModule) let newInters = Canonical.interface name $ M.metaToInterface metaModule
generateCache intermediate metaModule generateCache name newInters metaModule
return intermediate update name newInters True
where where
getName source = case Parser.getModuleName source of getName source = case Parser.getModuleName source of
@ -98,8 +143,14 @@ compile flags number interfaces filePath =
, replicate (max 1 (20 - length name)) ' ' , replicate (max 1 (20 - length name)) ' '
, "( " ++ filePath ++ " )" ] , "( " ++ filePath ++ " )" ]
generateCache intermediate metaModule = do generateCache name interfs metaModule = do
createDirectoryIfMissing True . dropFileName $ Utils.elmi flags filePath flags <- ask
writeFile (Utils.elmo flags filePath) (JS.generate metaModule) liftIO $ do
withBinaryFile (Utils.elmi flags filePath) WriteMode $ \handle -> createDirectoryIfMissing True . dropFileName $ Utils.elmi flags filePath
L.hPut handle (Binary.encode intermediate) 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 = modify (Map.insert name (wasUpdated, inter))
>> tell (Last . Just $ name)

8
compiler/Build/Print.hs
View file

@ -1,5 +1,8 @@
module Build.Print where module Build.Print where
import System.IO (hPutStrLn, stderr)
import System.Exit (exitFailure)
import qualified Data.Map as Map import qualified Data.Map as Map
import qualified Data.List as List import qualified Data.List as List
import qualified SourceSyntax.Module as M import qualified SourceSyntax.Module as M
@ -29,4 +32,7 @@ types interfaces types' aliases imports =
errors :: [P.Doc] -> IO () errors :: [P.Doc] -> IO ()
errors errs = errors errs =
mapM_ print (List.intersperse (P.text " ") errs) mapM_ print (List.intersperse (P.text " ") errs)
failure :: String -> IO a
failure msg = hPutStrLn stderr msg >> exitFailure

3
compiler/Compiler.hs
View file

@ -37,8 +37,7 @@ build flags rootFile =
then getSortedDependencies (Flag.src_dir flags) builtIns rootFile then getSortedDependencies (Flag.src_dir flags) builtIns rootFile
else return [rootFile] else return [rootFile]
(moduleName, _) <- moduleName <- File.build flags builtIns files
File.build flags (length files) builtIns "" files
js <- foldM appendToOutput BS.empty files js <- foldM appendToOutput BS.empty files