Skip to content
Browse files

--no-ghc to disable typechecking, --Wall for typechecking with Wall. …

…Type errors cause a failure, warnings lets the compilation proceed
  • Loading branch information...
1 parent cb9c379 commit dc2ad70e9a5b3036eabbf6db4b015533c168dc43 @bergmark bergmark committed
Showing with 32 additions and 18 deletions.
  1. +2 −2 examples/calc.hs
  2. +11 −7 src/Language/Fay.hs
  3. +3 −1 src/Language/Fay/Types.hs
  4. +5 −0 src/Main.hs
  5. +4 −4 src/System/Process/Extra.hs
  6. +6 −3 src/Test/CommandLine.hs
  7. +1 −1 src/Test/Util.hs
View
4 examples/calc.hs
@@ -10,8 +10,8 @@
module Calc (main) where
-import Language.Fay.FFI
-import Language.Fay.Prelude
+import Language.Fay.FFI
+import Language.Fay.Prelude
main :: Fay ()
main = do
View
18 src/Language/Fay.hs
@@ -122,9 +122,10 @@ compileForDocs mod = do
-- | Compile the top-level Fay module.
compileToplevelModule :: Module -> Compile [JsStmt]
compileToplevelModule mod@(Module _ (ModuleName modulename) _ _ _ _ _) = do
- compileConfig <- gets stateConfig
- liftIO $ typecheck (configDirectoryIncludes compileConfig)
- (fromMaybe modulename $ configFilePath compileConfig)
+ cfg <- gets stateConfig
+ when (configTypecheck cfg) $
+ typecheck (configDirectoryIncludes cfg) [] (configWall cfg) $
+ fromMaybe modulename $ configFilePath cfg
initialPass mod
stmts <- compileModule mod
fay2js <- gets (fayToJsDispatcher . stateFayToJs)
@@ -203,10 +204,13 @@ initialPass_dataDecl _ _decl constructors =
--------------------------------------------------------------------------------
-- Typechecking
-typecheck :: [FilePath] -> FilePath -> IO ()
-typecheck includeDirs fp = do
- res <- readAllFromProcess' "ghc" (["-fno-code", "-package fay", "-Wall", fp] ++ map ("-i" ++) includeDirs) ""
- either error (const $ return ()) res
+typecheck :: [FilePath] -> [String] -> Bool -> String -> Compile ()
+typecheck includeDirs ghcFlags wall fp = liftIO $ do
+ res <- readAllFromProcess' "ghc" (["-fno-code", "-package fay", fp] ++ map ("-i" ++) includeDirs ++ ghcFlags ++ wallF) ""
+ either error (hPutStrLn stderr . fst) res
+ where
+ wallF | wall = ["-Wall"]
+ | otherwise = []
--------------------------------------------------------------------------------
-- Compilers
View
4 src/Language/Fay/Types.hs
@@ -47,11 +47,13 @@ data CompileConfig = CompileConfig
, configAutorun :: Bool
, configWarn :: Bool
, configFilePath :: Maybe FilePath
+ , configTypecheck :: Bool
+ , configWall :: Bool
} deriving (Show)
-- | Default configuration.
instance Default CompileConfig where
- def = CompileConfig False False False True [] False False [] False True Nothing
+ def = CompileConfig False False False True [] False False [] False True Nothing True False
-- | State of the compiler.
data CompileState = CompileState
View
5 src/Main.hs
@@ -38,6 +38,9 @@ defineOptions "FayCompilerOptions" $ do
stringsOption "optInclude" "include" [] "dir1[, ..] additional directories for include"
+ boolOption "optWall" "Wall" False "Typecheck with -Wall"
+ boolOption "optNoGHC" "no-ghc" False "Don't typecheck, specify when not working with files"
+
option "optStdout" (\o -> o
{ optionLongFlags = ["stdout"]
, optionShortFlags = ['s']
@@ -94,6 +97,8 @@ main =
, configAutorun = optAutoRun opts
, configHtmlWrapper = optHTMLWrapper opts
, configHtmlJSLibs = optHTMLJSLibs opts
+ , configTypecheck = not $ optNoGHC opts
+ , configWall = optWall opts
}
void $ E.catch (incompatible htmlAndStdout opts "Html wrapping and stdout are incompatible")
errorUsage
View
8 src/System/Process/Extra.hs
@@ -16,9 +16,9 @@ readAllFromProcess program file = do
ExitSuccess -> fmap Right (hGetContents out)
ExitFailure _ -> fmap Left (hGetContents err)
-readAllFromProcess' :: FilePath -> [String] -> String -> IO (Either String String)
+readAllFromProcess' :: FilePath -> [String] -> String -> IO (Either String (String,String))
readAllFromProcess' program flags input = do
(code,out,err) <- readProcessWithExitCode program flags input
- case code of
- ExitSuccess -> return $ Right out
- ExitFailure _ -> return $ Left err
+ return $ case code of
+ ExitFailure _ -> Left err
+ ExitSuccess -> Right (err, out)
View
9 src/Test/CommandLine.hs
@@ -5,11 +5,11 @@ module Test.CommandLine (tests) where
import Control.Applicative
import Data.Maybe
import System.Process.Extra
-import Test.HUnit (Assertion, assertBool)
-import Test.Util
import Test.Framework
import Test.Framework.Providers.HUnit
import Test.Framework.TH
+import Test.HUnit (Assertion, assertBool)
+import Test.Util
tests :: Test
tests = $testGroupGenerator
@@ -17,7 +17,10 @@ tests = $testGroupGenerator
compileFile :: [String] -> IO (Either String String)
compileFile flags = do
fay <- fromJust <$> fayPath
- readAllFromProcess' fay flags ""
+ r <- readAllFromProcess' fay flags ""
+ return $ case r of
+ Left l -> Left l
+ Right t -> Right $ snd t
case_executable :: Assertion
case_executable = do
View
2 src/Test/Util.hs
@@ -14,7 +14,7 @@ fayPath = do
dist <- doesFileExist distPath
if dist
then return (Just distPath)
- else either (const Nothing) (Just . concat . lines) <$> readAllFromProcess' "which" ["fay"] ""
+ else either (const Nothing) (Just . concat . lines . snd) <$> readAllFromProcess' "which" ["fay"] ""
where
cabalDevPath = "./cabal-dev/bin/fay"
distPath = "./dist/build/fay/fay"

0 comments on commit dc2ad70

Please sign in to comment.
Something went wrong with that request. Please try again.