Finish refactoring code into Build/ directory, make some names more consistent and remove unneeded dependencies

This commit is contained in:
Evan Czaplicki 2013-12-14 23:29:39 -08:00
parent 6cb3b30062
commit dac51abc88
10 changed files with 240 additions and 191 deletions

View file

@ -53,7 +53,6 @@ Library
Transform.Substitute,
Transform.Optimize,
Metadata.Prelude,
Initialize,
InterfaceSerialization,
Parse.Binop,
Parse.Declaration,
@ -78,6 +77,13 @@ Library
Type.State,
Type.Type,
Type.Unify,
Build.Dependencies,
Build.File,
Build.Flags,
Build.Info,
Build.Print,
Build.Source,
Build.Utils,
Paths_Elm
Build-depends: base >=4.2 && <5,
@ -124,7 +130,6 @@ Executable elm
Transform.Substitute,
Transform.Optimize,
Metadata.Prelude,
Initialize,
InterfaceSerialization,
Parse.Binop,
Parse.Declaration,
@ -149,6 +154,13 @@ Executable elm
Type.State,
Type.Type,
Type.Unify,
Build.Dependencies,
Build.File,
Build.Flags,
Build.Info,
Build.Print,
Build.Source,
Build.Utils,
Paths_Elm
Build-depends: base >=4.2 && <5,

View file

@ -1,158 +0,0 @@
module Build.Build (build) where
import Control.Monad (when, forM_, foldM)
import qualified Data.Map as Map
import qualified Data.List as List
import qualified Data.Binary as Binary
import System.Directory
import System.Exit
import System.FilePath
import System.IO
import Text.Blaze.Html.Renderer.Utf8 (renderHtml)
import qualified Data.ByteString.Lazy.Char8 as BS
import qualified Data.ByteString.Lazy as L
import qualified Metadata.Prelude as Prelude
import qualified Transform.Canonicalize as Canonical
import SourceSyntax.Module
import Parse.Module (getModuleName)
import qualified Build.FromSource as FromSource
import Build.Dependencies (getSortedDependencies)
import Generate.JavaScript (jsModule)
import Generate.Html (createHtml, JSSource(..))
import qualified InterfaceSerialization as IS
import SourceSyntax.PrettyPrint (pretty, variable)
import Text.PrettyPrint as P
import qualified Type.Alias as Alias
import qualified Build.Utils as Utils
import qualified Build.Info as Info
import qualified Build.Flags as Flag
buildFile :: Flag.Flags -> Int -> Int -> Interfaces -> FilePath -> IO (String, ModuleInterface)
buildFile flags moduleNum numModules interfaces filePath = do
compiled <- alreadyCompiled
if not compiled then compile else do
bytes <- IS.loadInterface (Utils.elmi flags filePath)
let binary = IS.interfaceDecode (Utils.elmi flags filePath) =<< bytes
case IS.validVersion filePath =<< binary of
Left err -> do
hPutStrLn stderr err
exitFailure
Right (name, interface) -> do
when (Flag.print_types flags) $
printTypes interfaces
(iTypes interface)
(iAliases interface)
(iImports interface)
return (name, interface)
where
alreadyCompiled :: IO Bool
alreadyCompiled = 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)
number :: String
number = "[" ++ show moduleNum ++ " of " ++ show numModules ++ "]"
compile :: IO (String,ModuleInterface)
compile = do
source <- readFile filePath
let name = case getModuleName source of
Just n -> n
Nothing -> "Main"
putStrLn $ concat [ number, " Compiling ", name
, replicate (max 1 (20 - length name)) ' '
, "( " ++ filePath ++ " )" ]
createDirectoryIfMissing True (Flag.cache_dir flags)
createDirectoryIfMissing True (Flag.build_dir flags)
metaModule <-
case FromSource.build (Flag.no_prelude flags) interfaces source of
Left errors -> do
mapM print (List.intersperse (P.text " ") errors)
exitFailure
Right modul -> return modul
when (Flag.print_types flags)
(printTypes interfaces
(types metaModule) (aliases metaModule) (imports metaModule))
let interface = Canonical.interface name $ ModuleInterface {
iVersion = Info.version,
iTypes = types metaModule,
iImports = imports metaModule,
iAdts = datatypes metaModule,
iAliases = aliases metaModule,
iFixities = fixities metaModule
}
createDirectoryIfMissing True . dropFileName $ Utils.elmi flags filePath
handle <- openBinaryFile (Utils.elmi flags filePath) WriteMode
L.hPut handle (Binary.encode (name,interface))
hClose handle
writeFile (Utils.elmo flags filePath) (jsModule metaModule)
return (name,interface)
printTypes interfaces moduleTypes moduleAliases moduleImports = do
putStrLn ""
let rules = Alias.rules interfaces moduleAliases moduleImports
forM_ (Map.toList moduleTypes) $ \(n,t) -> do
print $ variable n <+> P.text ":" <+> pretty (Alias.realias rules t)
putStrLn ""
build :: Flag.Flags -> FilePath -> IO ()
build flags rootFile = do
let noPrelude = Flag.no_prelude flags
builtIns <- if noPrelude then return Map.empty else Prelude.interfaces
files <- if Flag.make flags
then getSortedDependencies (Flag.src_dir flags) builtIns rootFile
else return [rootFile]
(moduleName, interfaces) <- buildFiles flags (length files) builtIns "" files
js <- foldM appendToOutput BS.empty files
(extension, code) <- case Flag.only_js flags of
True -> do
putStr "Generating JavaScript ... "
return ("js", js)
False -> do
putStr "Generating HTML ... "
rtsPath <- case Flag.runtime flags of
Just fp -> return fp
Nothing -> Info.runtime
return ("html", renderHtml $
createHtml rtsPath (takeBaseName rootFile) (sources js) moduleName "")
let targetFile = Utils.buildPath flags rootFile extension
createDirectoryIfMissing True (takeDirectory targetFile)
BS.writeFile targetFile code
putStrLn "Done"
where
appendToOutput :: BS.ByteString -> FilePath -> IO BS.ByteString
appendToOutput js filePath =
do src <- BS.readFile (Utils.elmo flags filePath)
return (BS.append src js)
sources js = map Link (Flag.scripts flags) ++ [ Source js ]
buildFiles :: Flag.Flags -> Int -> Interfaces -> String -> [FilePath] -> IO (String, Interfaces)
buildFiles _ _ interfaces moduleName [] = return (moduleName, interfaces)
buildFiles flags numModules interfaces _ (filePath:rest) = do
(name,interface) <- buildFile flags (numModules - length rest) numModules interfaces filePath
let interfaces' = Map.insert name interface interfaces
buildFiles flags numModules interfaces' name rest

106
compiler/Build/File.hs Normal file
View file

@ -0,0 +1,106 @@
module Build.File (build) where
import Control.Monad (when)
import qualified Data.Binary as Binary
import qualified Data.List as List
import qualified Data.Map as Map
import System.Directory
import System.Exit
import System.FilePath
import System.IO
import qualified Transform.Canonicalize as Canonical
import qualified Data.ByteString.Lazy as L
import qualified Build.Utils as Utils
import qualified Build.Flags as Flag
import qualified Build.Source as Source
import qualified Build.Print as Print
import qualified Generate.JavaScript as JS
import qualified InterfaceSerialization as IS
import qualified Parse.Module as Parser
import qualified SourceSyntax.Module as M
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
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
where
number = "[" ++ show moduleNum ++ " of " ++ show numModules ++ "]"
alreadyCompiled :: Flag.Flags -> FilePath -> IO Bool
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
-> IO (String, M.ModuleInterface)
retrieve flags interfaces filePath = do
bytes <- IS.loadInterface (Utils.elmi flags filePath)
let binary = IS.interfaceDecode (Utils.elmi flags filePath) =<< bytes
case IS.validVersion filePath =<< binary of
Right (name, interface) ->
do when (Flag.print_types flags) (Print.interfaceTypes interfaces interface)
return (name, interface)
Left err ->
do hPutStrLn stderr err
exitFailure
compile :: Flag.Flags -> String -> M.Interfaces -> FilePath
-> 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)
createDirectoryIfMissing True (Flag.build_dir flags)
metaModule <-
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
let intermediate = (name, Canonical.interface name $ M.metaToInterface metaModule)
generateCache intermediate metaModule
return intermediate
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 intermediate metaModule = 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)

32
compiler/Build/Print.hs Normal file
View file

@ -0,0 +1,32 @@
module Build.Print where
import qualified Data.Map as Map
import qualified Data.List as List
import qualified SourceSyntax.Module as M
import qualified SourceSyntax.PrettyPrint as Pretty
import qualified Type.Alias as Alias
import qualified Text.PrettyPrint as P
metaTypes :: Map.Map String M.ModuleInterface -> M.MetadataModule () () -> IO ()
metaTypes interfaces meta =
types interfaces (M.types meta) (M.aliases meta) (M.imports meta)
interfaceTypes :: Map.Map String M.ModuleInterface -> M.ModuleInterface -> IO ()
interfaceTypes interfaces iface =
types interfaces (M.iTypes iface) (M.iAliases iface) (M.iImports iface)
types interfaces types' aliases imports =
do putStrLn ""
mapM_ printType (Map.toList types')
putStrLn ""
where
rules = Alias.rules interfaces aliases imports
printType (n,t) = do
print $ P.hsep [ Pretty.variable n
, P.text ":"
, Pretty.pretty (Alias.realias rules t) ]
errors :: [P.Doc] -> IO ()
errors errs =
mapM_ print (List.intersperse (P.text " ") errs)

View file

@ -1,4 +1,4 @@
module Build.FromSource (build) where
module Build.Source (build) where
import Data.Data
import Control.Monad.State

View file

@ -1,16 +1,71 @@
module Main where
import System.Console.CmdArgs
import Control.Monad (foldM)
import qualified Data.Map as Map
import qualified Text.Blaze.Html.Renderer.Utf8 as Blaze
import qualified Data.ByteString.Lazy.Char8 as BS
import qualified System.Console.CmdArgs as CmdArgs
import System.Directory
import System.FilePath
import GHC.Conc
import Build.Flags
import Build.Build
import Build.Dependencies (getSortedDependencies)
import qualified Generate.Html as Html
import qualified Metadata.Prelude as Prelude
import qualified Build.Utils as Utils
import qualified Build.Info as Info
import qualified Build.Flags as Flag
import qualified Build.File as File
main :: IO ()
main = do setNumCapabilities =<< getNumProcessors
compileArgs =<< cmdArgs flags
compileArgs =<< CmdArgs.cmdArgs Flag.flags
compileArgs :: Flags -> IO ()
compileArgs :: Flag.Flags -> IO ()
compileArgs flags =
case files flags of
case Flag.files flags of
[] -> putStrLn "Usage: elm [OPTIONS] [FILES]\nFor more help: elm --help"
fs -> mapM_ (build flags) fs
build :: Flag.Flags -> FilePath -> IO ()
build flags rootFile =
do let noPrelude = Flag.no_prelude flags
builtIns <- if noPrelude then return Map.empty else Prelude.interfaces
files <- if Flag.make flags
then getSortedDependencies (Flag.src_dir flags) builtIns rootFile
else return [rootFile]
(moduleName, interfaces) <-
File.build flags (length files) builtIns "" files
js <- foldM appendToOutput BS.empty files
(extension, code) <-
if Flag.only_js flags
then do putStr "Generating JavaScript ... "
return ("js", js)
else do putStr "Generating HTML ... "
makeHtml js moduleName
let targetFile = Utils.buildPath flags rootFile extension
createDirectoryIfMissing True (takeDirectory targetFile)
BS.writeFile targetFile code
putStrLn "Done"
where
appendToOutput :: BS.ByteString -> FilePath -> IO BS.ByteString
appendToOutput js filePath = do
src <- BS.readFile (Utils.elmo flags filePath)
return (BS.append src js)
sources js = map Html.Link (Flag.scripts flags) ++ [ Html.Source js ]
makeHtml js moduleName = do
rtsPath <- case Flag.runtime flags of
Just fp -> return fp
Nothing -> Info.runtime
let html = Html.generate
rtsPath (takeBaseName rootFile) (sources js) moduleName ""
return ("html", Blaze.renderHtml html)

View file

@ -1,8 +1,5 @@
{-# LANGUAGE OverloadedStrings #-}
module Generate.Html
(createHtml,
JSSource (..)
) where
module Generate.Html (generate, JSSource(..)) where
import Text.Blaze (preEscapedToMarkup)
import qualified Text.Blaze.Html5 as H
@ -20,8 +17,8 @@ makeScript source =
H.script ! A.type_ "text/javascript" $
preEscapedToMarkup $ BS.unpack src
createHtml :: FilePath -> String -> [JSSource] -> String -> String -> H.Html
createHtml libLoc title scripts moduleName noscript =
generate :: FilePath -> String -> [JSSource] -> String -> String -> H.Html
generate libLoc title scripts moduleName noscript =
H.docTypeHtml $ do
H.head $ do
H.meta ! A.charset "UTF-8"

View file

@ -290,8 +290,8 @@ clause span variable (Case.Clause value vars mtch) =
is -> drop (last is + 1) name
jsModule :: MetadataModule () () -> String
jsModule modul =
generate :: MetadataModule () () -> String
generate modul =
show . prettyPrint $ setup (Just "Elm") (names modul ++ ["make"]) ++
[ assign ("Elm" : names modul ++ ["make"]) (function ["elm"] programStmts) ]
where

View file

@ -8,38 +8,35 @@
module Language.Elm (compile, moduleName, runtime, docs) where
import qualified Data.List as List
import qualified Data.Map as Map
import Data.Version (showVersion)
import Generate.JavaScript (jsModule)
import Initialize (buildFromSource)
import Parse.Module (getModuleName)
import SourceSyntax.Module
import Text.Blaze.Html (Html)
import qualified Generate.JavaScript as JS
import qualified Build.Source as Source
import qualified Parse.Module as Parser
import qualified SourceSyntax.Module as M
import qualified Text.PrettyPrint as P
import qualified Metadata.Prelude as Prelude
import Paths_Elm
import qualified Paths_Elm as This
import System.IO.Unsafe
-- |This function compiles Elm code to JavaScript. It will return either
-- an error message or the compiled JS code.
compile :: String -> Either String String
compile source =
case buildFromSource False interfaces source of
case Source.build False interfaces source of
Left docs -> Left . unlines . List.intersperse "" $ map P.render docs
Right modul -> Right $ jsModule (modul :: MetadataModule () ())
Right modul -> Right $ JS.generate modul
{-# NOINLINE interfaces #-}
interfaces :: Interfaces
interfaces :: M.Interfaces
interfaces = unsafePerformIO $ Prelude.interfaces
-- |This function extracts the module name of a given source program.
moduleName :: String -> Maybe String
moduleName = getModuleName
moduleName = Parser.getModuleName
-- |The absolute path to Elm's runtime system.
runtime :: IO FilePath
runtime = getDataFileName "elm-runtime.js"
runtime = This.getDataFileName "elm-runtime.js"
-- |The absolute path to Elm's core library documentation.
docs :: IO FilePath
docs = getDataFileName "docs.json"
docs = This.getDataFileName "docs.json"

View file

@ -14,8 +14,7 @@ import SourceSyntax.Type
import System.FilePath (joinPath)
import Control.Monad (liftM)
import Paths_Elm (version)
import Data.Version (showVersion)
import qualified Build.Info as Info
data Module tipe var =
Module [String] Exports Imports [Declaration tipe var]
@ -70,6 +69,15 @@ data ModuleInterface = ModuleInterface {
iFixities :: [(Assoc, Int, String)]
} deriving Show
metaToInterface metaModule =
ModuleInterface
{ iVersion = Info.version
, iTypes = types metaModule
, iImports = imports metaModule
, iAdts = datatypes metaModule
, iAliases = aliases metaModule
, iFixities = fixities metaModule
}
instance Binary ModuleInterface where
get = ModuleInterface <$> get <*> get <*> get <*> get <*> get <*> get