Finish refactoring code into Build/ directory, make some names more consistent and remove unneeded dependencies
This commit is contained in:
parent
6cb3b30062
commit
dac51abc88
10 changed files with 240 additions and 191 deletions
16
Elm.cabal
16
Elm.cabal
|
@ -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,
|
||||
|
|
|
@ -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
106
compiler/Build/File.hs
Normal 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
32
compiler/Build/Print.hs
Normal 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)
|
|
@ -1,4 +1,4 @@
|
|||
module Build.FromSource (build) where
|
||||
module Build.Source (build) where
|
||||
|
||||
import Data.Data
|
||||
import Control.Monad.State
|
|
@ -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)
|
||||
|
|
|
@ -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"
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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"
|
||||
|
|
|
@ -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
|
||||
|
|
Loading…
Reference in a new issue