Enhance consolidated config.yaml and remove extensions.yaml

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

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"

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

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

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,17 +374,17 @@ 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
     target = basePath </> "build" </> targetFile programId
     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,15 +407,15 @@ 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"
       let linkBase = tmpdir </> "LinkBase.hs"
       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)

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)"
+    "Vector": "(0,0)"
+extraExtensions:
+  codeworld: []
+  haskell:
+    - LambdaCase
+    - NoTemplateHaskell
+    - TupleSections

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:

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
 

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