-
Notifications
You must be signed in to change notification settings - Fork 86
/
Main.hs
177 lines (151 loc) · 6.62 KB
/
Main.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
{-# OPTIONS -fno-warn-orphans #-}
{-# OPTIONS -fno-warn-orphans #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TemplateHaskell #-}
-- | Main compiler executable.
module Main where
import Language.Fay
import Language.Fay.Compiler
import Language.Fay.Types
import Paths_fay (version)
import qualified Control.Exception as E
import Control.Monad
import Control.Monad.Error
import Data.Default
import Data.Maybe
import Data.Version (showVersion)
import Options
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 "optAutoRun" "autorun" False "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"
option "optStdout" (\o -> o
{ optionLongFlags = ["stdout"]
, optionShortFlags = ['s']
, optionDefault = "false"
, optionType = optionTypeBool
, optionDescription = "Output to stdout"
})
option "optVersion" (\o -> o
{ optionLongFlags = ["version"]
, optionShortFlags = ['v']
, 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"
})
-- | 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"
," 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
let config = def { configTCO = False -- optTCO opts
, configInlineForce = optInlineForce opts
, configFlattenApps = optFlattenApps opts
, configExportBuiltins = True -- optExportBuiltins opts
, configDirectoryIncludes = "." : optInclude opts
, configPrettyPrint = optPretty opts
, configAutorun = optAutoRun opts
, configHtmlWrapper = optHTMLWrapper opts
, configHtmlJSLibs = optHTMLJSLibs opts
}
void $ E.catch (incompatible htmlAndStdout opts "Html wrapping and stdout are incompatible")
errorUsage
case files of
["-"] -> do
hGetContents stdin >>= printCompile config compileModule
[] -> runInteractive
_ -> forM_ files $ \file -> do
if optStdout opts
then compileReadWrite config file stdout
else
compileFromTo config file $ outPutFile opts file)
where
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
where
loop = do
minput <- getInputLine "> "
case minput of
Nothing -> return ()
Just "" -> loop
Just input -> do
result <- liftIO $ compileViaStr def compileExp input
case result of
Left err -> outputStrLn . show $ err
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
incompatible :: Monad m => (FayCompilerOptions -> Bool)
-> FayCompilerOptions -> String -> m Bool
incompatible test opts message = case test opts of
True -> E.throw $ userError message
False -> return True
instance Writer Handle where
writeout = hPutStr
instance Reader Handle where
readin = hGetContents