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

54
compiler/Build/Dependencies.hs
View file

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

155
compiler/Build/File.hs
View file

@ -1,92 +1,137 @@
{-# OPTIONS_GHC -W #-}
module Build.File (build) where
import Control.Monad (when)
import qualified Data.Binary as Binary
import qualified Data.Map as Map
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 Transform.Canonicalize as Canonical
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.Utils as Utils
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
build :: Flag.Flags -> Int -> M.Interfaces -> String -> [FilePath]
-> IO (String, M.Interfaces)
build _ _ interfaces moduleName [] =
return (moduleName, interfaces)
build flags numModules interfaces _ (filePath:rest) =
do (name,interface) <-
build1 flags (numModules - length rest) numModules interfaces filePath
let interfaces' = Map.insert name interface interfaces
build flags numModules interfaces' name rest
-- 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)
build1 :: Flag.Flags -> Int -> Int -> M.Interfaces -> FilePath
-> IO (String, M.ModuleInterface)
build1 flags moduleNum numModules interfaces filePath =
do compiled <- alreadyCompiled flags filePath
case compiled of
False -> compile flags number interfaces filePath
True -> retrieve flags interfaces filePath
evalBuild :: Flag.Flags -> M.Interfaces -> Build () -> IO (Maybe String)
evalBuild flags interfaces b = do
(_, s) <- evalRWST b flags (fmap notUpdated interfaces)
return . getLast $ s
where
number = "[" ++ show moduleNum ++ " of " ++ show numModules ++ "]"
notUpdated i = (False, i)
-- | 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
alreadyCompiled :: Flag.Flags -> FilePath -> IO Bool
alreadyCompiled flags filePath = do
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)
if not existsi || not existso
then return False
else do tsrc <- getModificationTime filePath
tint <- getModificationTime (Utils.elmo flags filePath)
return (tsrc <= tint)
return $ existsi && existso
retrieve :: Flag.Flags -> Map.Map String M.ModuleInterface -> FilePath
-> IO (String, M.ModuleInterface)
retrieve flags interfaces filePath = do
iface <- Interface.load (Utils.elmi flags filePath)
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 when (Flag.print_types flags) (Print.interfaceTypes interfaces interface)
return (name, interface)
Left err ->
do hPutStrLn stderr err
exitFailure
do binterfaces <- get
let interfaces = snd <$> binterfaces
liftIO $ when (Flag.print_types flags) (Print.interfaceTypes interfaces interface)
update name interface False
compile :: Flag.Flags -> String -> M.Interfaces -> FilePath
-> IO (String, M.ModuleInterface)
compile flags number interfaces filePath =
do source <- readFile filePath
let name = getName source
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 <-
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
Left errors -> do Print.errors errors
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)
generateCache intermediate metaModule
return intermediate
let newInters = Canonical.interface name $ M.metaToInterface metaModule
generateCache name newInters metaModule
update name newInters True
where
getName source = case Parser.getModuleName source of
@ -98,8 +143,14 @@ compile flags number interfaces filePath =
, replicate (max 1 (20 - length name)) ' '
, "( " ++ filePath ++ " )" ]
generateCache intermediate metaModule = do
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 intermediate)
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)

6
compiler/Build/Print.hs
View file

@ -1,5 +1,8 @@
module Build.Print where
import System.IO (hPutStrLn, stderr)
import System.Exit (exitFailure)
import qualified Data.Map as Map
import qualified Data.List as List
import qualified SourceSyntax.Module as M
@ -30,3 +33,6 @@ types interfaces types' aliases imports =
errors :: [P.Doc] -> IO ()
errors 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
else return [rootFile]
(moduleName, _) <-
File.build flags (length files) builtIns "" files
moduleName <- File.build flags builtIns files
js <- foldM appendToOutput BS.empty files