Permalink
Browse files

Port to 'optparse-applicative' from 'options'.

This gets rid of the 'monads-tf' dependency, which is problematic for Debian
packaging due to modules overlap with mtl.  As a bonus,
optparse-applicative means we can easily support Bash completions for the
fay command-line.
  • Loading branch information...
1 parent 8243db0 commit 4dde976d43307306ff9f5d1e46b0cd57b37f99c8 @dag dag committed with chrisdone Sep 30, 2012
Showing with 61 additions and 93 deletions.
  1. +4 −2 fay.cabal
  2. +57 −91 src/Main.hs
View
@@ -175,7 +175,8 @@ library
blaze-markup,
bytestring,
time,
- options,
+ optparse-applicative,
+ split,
test-framework,
test-framework-hunit,
test-framework-th
@@ -203,7 +204,8 @@ executable fay
directory,
filepath,
groom,
- options,
+ optparse-applicative,
+ split,
haskeline
executable fay-tests
View
@@ -1,7 +1,6 @@
{-# OPTIONS -fno-warn-orphans #-}
{-# OPTIONS -fno-warn-orphans #-}
{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE TemplateHaskell #-}
-- | Main compiler executable.
module Main where
@@ -15,78 +14,71 @@ import qualified Control.Exception as E
import Control.Monad
import Control.Monad.Error
import Data.Default
+import Data.List.Split (wordsBy)
import Data.Maybe
import Data.Version (showVersion)
-import Options
+import Options.Applicative
import System.Console.Haskeline
-import System.Environment
-import System.Exit
import System.IO
-- | Options and help.
-defineOptions "FayCompilerOptions" $ do
-
- -- boolOption "optExportBuiltins" "export-builtins" True ""
- -- boolOption "optTCO" "tco" False ""
-
- boolOption "optLibrary" "library" False "Don't automatically call main in generated JavaScript"
- boolOption "optInlineForce" "inline-force" False "inline forcing, adds some speed for numbers, blows up code a bit"
- boolOption "optFlattenApps" "flatten-apps" False "flatten function applicaton"
-
- boolOption "optHTMLWrapper" "html-wrapper" False "Create an html file that loads the javascript"
- stringsOption "optHTMLJSLibs" "html-js-lib" [] "file1[, ..] javascript files to add to <head> if using option html-wrapper"
-
- 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']
- , optionDefault = "false"
- , optionType = optionTypeBool
- , optionDescription = "Output to stdout"
- })
- option "optVersion" (\o -> o
- { optionLongFlags = ["version"]
- , optionShortFlags = []
- , optionDefault = "false"
- , optionType = optionTypeBool
- , optionDescription = "Output version number"
- })
- option "optOutput" (\o -> o
- { optionLongFlags = ["output"]
- , optionShortFlags = ['o']
- , optionDefault = ""
- , optionType = optionTypeMaybe optionTypeString
- , optionDescription = "Output to specified file"
- })
- option "optPretty" (\o -> o
- { optionLongFlags = ["pretty"]
- , optionShortFlags = ['p']
- , optionDefault = "false"
- , optionType = optionTypeBool
- , optionDescription = "Run javascript through js-beautify"
- })
+data FayCompilerOptions = FayCompilerOptions
+ { optLibrary :: Bool
+ , optInlineForce :: Bool
+ , optFlattenApps :: Bool
+ , optHTMLWrapper :: Bool
+ , optHTMLJSLibs :: [String]
+ , optInclude :: [String]
+ , optWall :: Bool
+ , optNoGHC :: Bool
+ , optStdout :: Bool
+ , optVersion :: Bool
+ , optOutput :: Maybe String
+ , optPretty :: Bool
+ , optFiles :: [String]
+ }
+
+options :: Parser FayCompilerOptions
+options = FayCompilerOptions
+ <$> switch (long "library" & help "Don't automatically call main in generated JavaScript")
+ <*> switch (long "inline-force" & help "inline forcing, adds some speed for numbers, blows up code a bit")
+ <*> switch (long "flatten-apps" & help "flatten function applicaton")
+
+ <*> switch (long "html-wrapper" & help "Create an html file that loads the javascript")
+ <*> strsOption (long "html-js-lib" & metavar "file1[, ..]" & help "javascript files to add to <head> if using option html-wrapper")
+
+ <*> strsOption (long "include" & metavar "dir1[, ..]" & help "additional directories for include")
+
+ <*> switch (long "Wall" & help "Typecheck with -Wall")
+ <*> switch (long "no-ghc" & help "Don't typecheck, specify when not working with files")
+
+ <*> switch (long "stdout" & short 's' & help "Output to stdout")
+ <*> switch (long "version" & help "Output version number")
+ <*> nullOption (long "output" & short 'o' & reader (Just . Just) & value Nothing & help "Output to specified file")
+ <*> switch (long "pretty" & short 'p' & help "Pretty print the output")
+
+ <*> arguments Just (metavar "- | <hs-file>...")
+
+ where
+ strsOption m = nullOption (m & reader (Just . wordsBy (== ',')) & value [])
-- | The basic help text.
-helpTxt :: [String]
-helpTxt =
- ["fay -- The fay compiler from (a proper subset of) Haskell to Javascript"
- ,"USAGE"
- ," fay [OPTIONS] [- | <hs-file>...]"
- ," fay - takes input on stdin and prints to stdout. Runs through js-beautify if available"
+helpTxt :: String
+helpTxt = concat
+ ["fay -- The fay compiler from (a proper subset of) Haskell to Javascript\n\n"
+ ,"SYNOPSIS\n"
+ ," fay [OPTIONS] [- | <hs-file>...]\n"
+ ," fay - takes input on stdin and prints to stdout. Pretty prints\n"
," fay <hs-file>... processes each .hs file"
]
-- | Main entry point.
main :: IO ()
-main =
- runCommandHelp (unlines helpTxt) $ \opts files ->
- if optVersion opts
- then runCommandVersion
- else (do
+main = do
+ opts <- execParser parser
+ if optVersion opts
+ then runCommandVersion
+ else (do
let config = def { configTCO = False -- optTCO opts
, configInlineForce = optInlineForce opts
, configFlattenApps = optFlattenApps opts
@@ -100,30 +92,25 @@ main =
, configTypecheck = not $ optNoGHC opts
, configWall = optWall opts
}
- void $ E.catch (incompatible htmlAndStdout opts "Html wrapping and stdout are incompatible")
- errorUsage
+ void $ incompatible htmlAndStdout opts "Html wrapping and stdout are incompatible"
- case files of
+ case optFiles opts of
["-"] -> do
hGetContents stdin >>= printCompile config compileModule
[] -> runInteractive
- _ -> forM_ files $ \file -> do
+ files -> forM_ files $ \file -> do
if optStdout opts
then compileReadWrite config file stdout
else
compileFromTo config file $ outPutFile opts file)
where
+ parser = info (helper <*> options) (fullDesc & header helpTxt)
+
outPutFile :: FayCompilerOptions -> String -> FilePath
outPutFile opts file = fromMaybe (toJsName file) $ optOutput opts
- errorUsage :: IOError -> IO a
- errorUsage e = do
- putStrLn $ "ERROR: \n " ++ (show e)
- args <- getArgs
- usageMsg args $ unlines $ drop 1 helpTxt
-
runInteractive :: IO ()
runInteractive =
runInputT defaultSettings loop
@@ -140,32 +127,11 @@ runInteractive =
Right (ok,_) -> liftIO (prettyPrintString ok) >>= outputStr
loop
-runCommandHelp :: (MonadIO m, Options opts) => String -> (opts -> [String] -> m a) -> m a
-runCommandHelp help io = do
- argv <- liftIO getArgs
- let parsed = parseOptions argv
- case parsedOptions parsed of
- Just opts -> io opts (parsedArguments parsed)
- Nothing -> liftIO $ usageMsg argv help
-
runCommandVersion :: IO ()
runCommandVersion = putStrLn $ "fay " ++ showVersion version
-usageMsg :: [String] -> String -> IO a
-usageMsg argv help = do
- putStrLn help
- let parsed = parseOptions argv :: ParsedOptions FayCompilerOptions
- case parsedError parsed of
- Just err -> do
- hPutStrLn stderr (parsedHelp parsed)
- hPutStrLn stderr err
- exitFailure
- Nothing -> do
- hPutStr stdout (parsedHelp parsed)
- exitSuccess
-
htmlAndStdout :: FayCompilerOptions -> Bool
htmlAndStdout opts = optHTMLWrapper opts && optStdout opts

0 comments on commit 4dde976

Please sign in to comment.