diff --git a/codeworld-compiler/exec/Main.hs b/codeworld-compiler/exec/Main.hs index 66c64e11..9792ac81 100644 --- a/codeworld-compiler/exec/Main.hs +++ b/codeworld-compiler/exec/Main.hs @@ -123,7 +123,7 @@ compileBase Options {..} err = do readFile linkBase >>= hPutStrLn stderr hPutStrLn stderr "=========================" let stage = GenBase "LinkBase" linkBase (fromJust output) (fromJust baseSymbols) - compileSource stage linkMain noModuleFinder Nothing err mode verbose + compileSource stage linkMain noModuleFinder (ExtraExtensions [] []) err mode verbose compile :: Options -> FilePath -> IO CompileStatus compile opts@Options {..} err = do @@ -132,7 +132,7 @@ compile opts@Options {..} err = do (Nothing, _, _) -> ErrorCheck (Just out, Nothing, _) -> FullBuild out (Just out, Just syms, Just url) -> UseBase out syms url - compileSource stage source noModuleFinder Nothing err mode verbose + compileSource stage source noModuleFinder (ExtraExtensions [] []) err mode verbose noModuleFinder :: String -> IO (Maybe FilePath) noModuleFinder _ = return Nothing diff --git a/codeworld-compiler/src/CodeWorld/Compile.hs b/codeworld-compiler/src/CodeWorld/Compile.hs index a11cd4e4..45eca0bc 100644 --- a/codeworld-compiler/src/CodeWorld/Compile.hs +++ b/codeworld-compiler/src/CodeWorld/Compile.hs @@ -6,6 +6,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE RecordWildCards #-} {- Copyright 2020 The CodeWorld Authors. All rights reserved. @@ -27,6 +28,7 @@ module CodeWorld.Compile ( compileSource, Stage (..), CompileStatus (..), + ExtraExtensions (..), ) where @@ -49,11 +51,9 @@ import qualified Data.Set as Set import Data.Text (Text) import qualified Data.Text as T import Data.Text.Encoding (decodeUtf8, encodeUtf8) -import Data.Yaml (FromJSON(..), withObject, (.:), decodeFileEither, prettyPrintParseException) import ErrorSanitizer import Language.Haskell.Exts.SrcLoc import System.Directory -import System.Environment import System.Exit (ExitCode (..)) import System.FilePath import System.IO @@ -108,8 +108,8 @@ writeUtf8 :: FilePath -> Text -> IO () writeUtf8 f = B.writeFile f . encodeUtf8 compileSource :: - Stage -> FilePath -> (String -> IO (Maybe FilePath)) -> Maybe FilePath -> FilePath -> String -> Bool -> IO CompileStatus -compileSource stage src moduleFinder extConfigPath err mode verbose = + Stage -> FilePath -> (String -> IO (Maybe FilePath)) -> ExtraExtensions -> FilePath -> String -> Bool -> IO CompileStatus +compileSource stage src moduleFinder extraExt err mode verbose = fromMaybe CompileAborted <$> do withTimeout timeout $ withSystemTempDirectory "build" $ @@ -133,7 +133,7 @@ compileSource stage src moduleFinder extConfigPath err mode verbose = compileParsedSource = Map.empty, compileGHCParsedSource = Map.empty, compileImportLocations = Map.empty, - compileExtensionsConfigPath = extConfigPath + compileExtraExtensions = extraExt } timeout = case stage of GenBase _ _ _ _ -> maxBound :: Int @@ -192,19 +192,10 @@ prepareCompile dir = do liftIO $ copyFile syms (dir "out.base.symbs") return ["-dedupe", "-use-base", "out.base.symbs"] mainMod <- getMainModuleName - extConfigPath <- gets compileExtensionsConfigPath - exePath <- liftIO $ getExecutablePath - let configDir = fromMaybe (takeDirectory exePath ++ "/extensions.yaml") extConfigPath - parseResult <- liftIO $ decodeFileEither configDir - ExtraExtensions extraCW extraH <- case parseResult of - Left error -> do - liftIO $ hPutStrLn stderr "An error occurred while trying to load extensions.yaml." - liftIO $ hPutStrLn stderr $ prettyPrintParseException error - pure $ ExtraExtensions [] [] - Right result -> pure result + ExtraExtensions {..} <- gets compileExtraExtensions let extraExts - | mode == "codeworld" = extraCW - | otherwise = extraH + | mode == "codeworld" = codeworldExtensions + | otherwise = haskellExtensions return $ localSrcs ++ buildArgs mainMod mode extraExts ++ extraPkgArgs ++ linkArgs buildArgs :: String -> SourceMode -> [String] -> [String] @@ -392,9 +383,3 @@ copyOutputFrom target = writeUtf8 out (rtsCode <> libCode <> outCode) ErrorCheck -> return () -data ExtraExtensions = ExtraExtensions [String] [String] - -instance FromJSON ExtraExtensions where - parseJSON = withObject "ExtraExtensions" $ \v -> ExtraExtensions - <$> v .: "codeworld" - <*> v .: "haskell" diff --git a/codeworld-compiler/src/CodeWorld/Compile/Framework.hs b/codeworld-compiler/src/CodeWorld/Compile/Framework.hs index 5dd9fd73..7fa05280 100644 --- a/codeworld-compiler/src/CodeWorld/Compile/Framework.hs +++ b/codeworld-compiler/src/CodeWorld/Compile/Framework.hs @@ -50,6 +50,7 @@ import Data.Text (Text) import qualified Data.Text as T import Data.Text.Encoding (decodeUtf8, encodeUtf8) import qualified Data.Text.IO as T +import Data.Yaml (FromJSON(..), withObject, (.:?), (.!=)) import qualified "ghc" DynFlags as GHC import ErrorSanitizer import qualified "ghc" FastString as GHC @@ -121,7 +122,7 @@ data CompileState = CompileState compileParsedSource :: Map FilePath ParsedCode, compileGHCParsedSource :: Map FilePath GHCParsedCode, compileImportLocations :: Map FilePath SrcSpanInfo, - compileExtensionsConfigPath :: Maybe FilePath + compileExtraExtensions :: ExtraExtensions } type MonadCompile m = (MonadState CompileState m, MonadIO m, MonadMask m) @@ -136,6 +137,16 @@ data ParsedCode = Parsed (Module SrcSpanInfo) | NoParse data GHCParsedCode = GHCParsed (GHC.HsModule GHC.GhcPs) | GHCNoParse deriving (Typeable, Data) +data ExtraExtensions = ExtraExtensions + { codeworldExtensions :: [String] + , haskellExtensions :: [String] + } deriving Show + +instance FromJSON ExtraExtensions where + parseJSON = withObject "ExtraExtensions" $ \v -> ExtraExtensions + <$> v .:? "codeworld" .!= [] + <*> v .:? "haskell" .!= [] + getSourceCode :: MonadCompile m => FilePath -> m ByteString getSourceCode src = do cached <- gets compileReadSource diff --git a/codeworld-server/src/Config.hs b/codeworld-server/src/Config.hs index 63794c67..c57c8916 100644 --- a/codeworld-server/src/Config.hs +++ b/codeworld-server/src/Config.hs @@ -1,11 +1,13 @@ {-# LANGUAGE OverloadedStrings #-} module Config ( Config (..) + , CompilerConfig (..) , PreviewConfig (..) , loadConfig ) where +import CodeWorld.Compile (ExtraExtensions(..)) import Data.Map (Map, fromAscList) import Data.Text (Text) import Data.Yaml (FromJSON(..), withObject, (.:?), (.!=), decodeFileEither, prettyPrintParseException) @@ -14,7 +16,14 @@ import System.FilePath (FilePath, takeDirectory) import System.IO (hPutStrLn, stderr) data Config = Config - { previewConfig :: PreviewConfig + { compilerConfig :: CompilerConfig + , previewConfig :: PreviewConfig + , extraExtensions :: ExtraExtensions + } deriving Show + +data CompilerConfig = CompilerConfig + { maxSimultaneousCompiles :: Int + , maxSimultaneousErrorChecks :: Int } deriving Show data PreviewConfig = PreviewConfig @@ -24,7 +33,15 @@ data PreviewConfig = PreviewConfig defaultConfig :: Config defaultConfig = Config - { previewConfig = defaultPreviewConfig + { compilerConfig = defaultCompilerConfig + , previewConfig = defaultPreviewConfig + , extraExtensions = ExtraExtensions [] [] + } + +defaultCompilerConfig :: CompilerConfig +defaultCompilerConfig = CompilerConfig + { maxSimultaneousCompiles = 4 + , maxSimultaneousErrorChecks = 2 } defaultPreviewConfig :: PreviewConfig @@ -35,7 +52,14 @@ defaultPreviewConfig = PreviewConfig instance FromJSON Config where parseJSON = withObject "Config" $ \v -> Config - <$> v .:? "preview" .!= defaultPreviewConfig + <$> v .:? "compile" .!= defaultCompilerConfig + <*> v .:? "preview" .!= defaultPreviewConfig + <*> v .:? "extraExtensions" .!= ExtraExtensions [] [] + +instance FromJSON CompilerConfig where + parseJSON = withObject "CompilerConfig" $ \v -> CompilerConfig + <$> v .:? "maxSimultaneousCompiles" .!= 4 + <*> v .:? "maxSimultaneousErrorChecks" .!= 2 instance FromJSON PreviewConfig where parseJSON = withObject "PreviewConfig" $ \v -> PreviewConfig diff --git a/codeworld-server/src/Main.hs b/codeworld-server/src/Main.hs index 3951ded2..0368a739 100644 --- a/codeworld-server/src/Main.hs +++ b/codeworld-server/src/Main.hs @@ -68,12 +68,6 @@ import Util import Text.Read (readMaybe) import Text.Regex.TDFA -maxSimultaneousCompiles :: Int -maxSimultaneousCompiles = 4 - -maxSimultaneousErrorChecks :: Int -maxSimultaneousErrorChecks = 2 - data Context = Context { compileSem :: MSem Int, errorSem :: MSem Int, @@ -94,8 +88,8 @@ makeContext :: Config -> IO Context makeContext cfg = do ctx <- Context - <$> MSem.new maxSimultaneousCompiles - <*> MSem.new maxSimultaneousErrorChecks + <$> MSem.new (maxSimultaneousCompiles $ compilerConfig cfg) + <*> MSem.new (maxSimultaneousErrorChecks $ compilerConfig cfg) <*> MSem.new 1 <*> pure cfg return ctx @@ -369,7 +363,7 @@ compileProgram ctx basePath mode programId = do case baseStatus of CompileSuccess -> do - status <- compileIncrementally basePath mode programId ver + status <- compileIncrementally ctx basePath mode programId ver T.writeFile (basePath "build" baseVersionFile programId) ver -- It's possible that a new library was built during the compile. If so, then the code @@ -380,10 +374,9 @@ compileProgram ctx basePath mode programId = do else compileProgram ctx basePath mode programId _ -> return CompileAborted -compileIncrementally :: FilePath -> BuildMode -> ProgramId -> Text -> IO CompileStatus -compileIncrementally basePath mode programId ver = do - extConfigPath <- lookupEnv "EXTENSIONS_CONFIG_PATH" :: IO (Maybe FilePath) - compileSource stage source (projectModuleFinder (Just sourceDir) mode) extConfigPath result (getMode mode) False +compileIncrementally :: Context -> FilePath -> BuildMode -> ProgramId -> Text -> IO CompileStatus +compileIncrementally ctx basePath mode programId ver = + compileSource stage source (projectModuleFinder (Just sourceDir) mode) extraExt result (getMode mode) False where sourceDir = basePath "source" source = sourceDir sourceFile programId @@ -391,6 +384,7 @@ compileIncrementally basePath mode programId ver = do result = basePath "build" resultFile programId baseURL = "runBaseJS?version=" ++ T.unpack ver stage = UseBase target (baseSymbolFile ver) baseURL + extraExt = extraExtensions $ config ctx projectModuleFinder :: Maybe FilePath -> BuildMode -> String -> IO (Maybe FilePath) projectModuleFinder mSourceDir mode modName @@ -413,7 +407,6 @@ buildBaseIfNeeded :: Context -> Text -> IO CompileStatus buildBaseIfNeeded ctx ver = do codeExists <- doesFileExist (baseCodeFile ver) symbolsExist <- doesFileExist (baseSymbolFile ver) - extConfigPath <- lookupEnv "EXTENSIONS_CONFIG_PATH" :: IO (Maybe FilePath) if not codeExists || not symbolsExist then MSem.with (baseSem ctx) $ withSystemTempDirectory "genbase" $ \tmpdir -> do let linkMain = tmpdir "LinkMain.hs" @@ -421,7 +414,8 @@ buildBaseIfNeeded ctx ver = do let err = tmpdir "output.txt" generateBaseBundle basePaths baseIgnore "codeworld" linkMain linkBase let stage = GenBase "LinkBase" linkBase (baseCodeFile ver) (baseSymbolFile ver) - compileSource stage linkMain noModuleFinder extConfigPath err "codeworld" False + let extraExt = extraExtensions $ config ctx + compileSource stage linkMain noModuleFinder extraExt err "codeworld" False else return CompileSuccess basePaths :: [FilePath] @@ -435,10 +429,10 @@ errorCheck ctx mode source = withSystemTempDirectory "cw_errorCheck" $ \dir -> d let srcFile = dir "program.hs" let errFile = dir "output.txt" B.writeFile srcFile source - extConfigPath <- lookupEnv "EXTENSIONS_CONFIG_PATH" :: IO (Maybe FilePath) + let extraExt = extraExtensions $ config ctx status <- MSem.with (errorSem ctx) $ MSem.with (compileSem ctx) $ - compileSource ErrorCheck srcFile (projectModuleFinder Nothing mode) extConfigPath errFile (getMode mode) False + compileSource ErrorCheck srcFile (projectModuleFinder Nothing mode) extraExt errFile (getMode mode) False hasOutput <- doesFileExist errFile output <- if hasOutput then B.readFile errFile else return B.empty return (status, output) diff --git a/config.yaml b/config.yaml index b3418225..ec9c141a 100644 --- a/config.yaml +++ b/config.yaml @@ -1,3 +1,6 @@ +compile: + maxSimultaneousCompiles: 4 + maxSimultaneousErrorChecks: 2 preview: enabledByDefault: false defaultHoleValues: @@ -10,4 +13,10 @@ preview: "Text": "mempty" "Data.Text.Internal.Text": "mempty" "Point": "(0,0)" - "Vector": "(0,0)" \ No newline at end of file + "Vector": "(0,0)" +extraExtensions: + codeworld: [] + haskell: + - LambdaCase + - NoTemplateHaskell + - TupleSections diff --git a/config/keter.yaml b/config/keter.yaml index add66b3d..b9e48b80 100644 --- a/config/keter.yaml +++ b/config/keter.yaml @@ -10,7 +10,6 @@ stanzas: LANG: "C.UTF-8" LC_ALL: "C.UTF-8" PATH: "/usr/local/sbin:/usr/local/bin:/usr/sbin:/usr/bin:/sbin:/bin:/opt/codeworld/build/bin" - EXTENSIONS_CONFIG_PATH: "/opt/codeworld/extensions.yaml" CONFIG_PATH: "/opt/codeworld/config.yaml" hosts: diff --git a/extensions.yaml b/extensions.yaml deleted file mode 100644 index 9ce66d84..00000000 --- a/extensions.yaml +++ /dev/null @@ -1,5 +0,0 @@ -codeworld: [] -haskell: - - LambdaCase - - NoTemplateHaskell - - TupleSections diff --git a/publish.sh b/publish.sh index 7afe3361..f8231372 100755 --- a/publish.sh +++ b/publish.sh @@ -20,7 +20,7 @@ fi cp codeworld.tar codeworld-tmp.tar -tar -rf codeworld-tmp.tar config/keter.yaml extensions.yaml config.yaml +tar -rf codeworld-tmp.tar config/keter.yaml config.yaml gzip codeworld-tmp.tar diff --git a/run.sh b/run.sh index 31534eab..519aa457 100755 --- a/run.sh +++ b/run.sh @@ -29,5 +29,4 @@ fuser -k -n tcp "${PORT}" mkdir -p log export CONFIG_PATH=$(pwd)/config.yaml -export EXTENSIONS_CONFIG_PATH=$(pwd)/extensions.yaml run . ./build/bin/codeworld-server -p $PORT --no-access-log