git.iko.soy/rowtype-yoga/purescript-native
on eb5d4e4 help sign in
rowtype-yoga/purescript-native/psc/Main.hs
202 lines 6.8 kB history raw
1{-# LANGUAGE DataKinds #-}
2{-# LANGUAGE FlexibleContexts #-}
3{-# LANGUAGE RecordWildCards #-}
4{-# LANGUAGE TupleSections #-}
6module Main where
8import Control.Applicative
9import Control.Monad
10import Control.Monad.Error.Class (MonadError(..))
11import Control.Monad.Writer.Strict
13import Data.List (isSuffixOf, partition)
14import Data.Version (showVersion)
15import qualified Data.Map as M
16import qualified Data.Aeson as A
17import qualified Data.ByteString.Lazy as B
18import qualified Data.ByteString.UTF8 as BU8
20import Options.Applicative as Opts
22import System.Exit (exitSuccess, exitFailure)
23import System.IO (hSetEncoding, hPutStrLn, stdout, stderr, utf8)
24import System.IO.UTF8
25import System.FilePath.Glob (glob)
27import qualified Language.PureScript as P
28import qualified Paths_purescript as Paths
30import Language.PureScript.Make
32import JSON
34data PSCMakeOptions = PSCMakeOptions
35 { pscmInput :: [FilePath]
36 , pscmForeignInput :: [FilePath]
37 , pscmOutputDir :: FilePath
38 , pscmOpts :: P.Options
39 , pscmUsePrefix :: Bool
40 , pscmJSONErrors :: Bool
41 }
43data InputOptions = InputOptions
44 { ioInputFiles :: [FilePath]
45 }
47-- | Argumnets: verbose, use JSON, warnings, errors
48printWarningsAndErrors :: Bool -> Bool -> P.MultipleErrors -> Either P.MultipleErrors a -> IO ()
49printWarningsAndErrors verbose False warnings errors = do
50 when (P.nonEmpty warnings) $
51 hPutStrLn stderr (P.prettyPrintMultipleWarnings verbose warnings)
52 case errors of
53 Left errs -> do
54 hPutStrLn stderr (P.prettyPrintMultipleErrors verbose errs)
55 exitFailure
56 Right _ -> return ()
57printWarningsAndErrors verbose True warnings errors = do
58 hPutStrLn stderr . BU8.toString . B.toStrict . A.encode $
59 JSONResult (toJSONErrors verbose P.Warning warnings)
60 (either (toJSONErrors verbose P.Error) (const []) errors)
61 either (const exitFailure) (const (return ())) errors
63compile :: PSCMakeOptions -> IO ()
64compile PSCMakeOptions{..} = do
65 input <- globWarningOnMisses (unless pscmJSONErrors . warnFileTypeNotFound) pscmInput
66 when (null input && not pscmJSONErrors) $ do
67 hPutStrLn stderr "psc: No input files."
68 exitFailure
69 let (jsFiles, pursFiles) = partition (isSuffixOf ".js") input
70 moduleFiles <- readInput (InputOptions pursFiles)
71 inputForeign <- globWarningOnMisses (unless pscmJSONErrors . warnFileTypeNotFound) pscmForeignInput
72 foreignFiles <- forM (inputForeign ++ jsFiles) (\inFile -> (inFile,) <$> readUTF8File inFile)
73 (makeErrors, makeWarnings) <- runMake pscmOpts $ do
74 (ms, foreigns) <- parseInputs moduleFiles foreignFiles
75 let filePathMap = M.fromList $ map (\(fp, P.Module _ _ mn _ _) -> (mn, fp)) ms
76 makeActions = buildMakeActions pscmOutputDir filePathMap foreigns pscmUsePrefix
77 P.make makeActions (map snd ms)
78 printWarningsAndErrors (P.optionsVerboseErrors pscmOpts) pscmJSONErrors makeWarnings makeErrors
79 exitSuccess
81warnFileTypeNotFound :: String -> IO ()
82warnFileTypeNotFound = hPutStrLn stderr . ("psc: No files found using pattern: " ++)
84globWarningOnMisses :: (String -> IO ()) -> [FilePath] -> IO [FilePath]
85globWarningOnMisses warn = concatMapM globWithWarning
86 where
87 globWithWarning pattern = do
88 paths <- glob pattern
89 when (null paths) $ warn pattern
90 return paths
91 concatMapM f = liftM concat . mapM f
93readInput :: InputOptions -> IO [(Either P.RebuildPolicy FilePath, String)]
94readInput InputOptions{..} = forM ioInputFiles $ \inFile -> (Right inFile, ) <$> readUTF8File inFile
96parseInputs :: (MonadError P.MultipleErrors m, MonadWriter P.MultipleErrors m)
97 => [(Either P.RebuildPolicy FilePath, String)]
98 -> [(FilePath, P.ForeignJS)]
99 -> m ([(Either P.RebuildPolicy FilePath, P.Module)], M.Map P.ModuleName FilePath)
100parseInputs modules foreigns =
101 (,) <$> P.parseModulesFromFiles (either (const "") id) modules
102 <*> P.parseForeignModulesFromFiles foreigns
104inputFile :: Parser FilePath
105inputFile = strArgument $
106 metavar "FILE"
107 <> help "The input .purs file(s)"
109inputForeignFile :: Parser FilePath
110inputForeignFile = strOption $
111 short 'f'
112 <> long "ffi"
113 <> help "The input .js file(s) providing foreign import implementations"
115outputDirectory :: Parser FilePath
116outputDirectory = strOption $
117 short 'o'
118 <> long "output"
119 <> Opts.value "output"
120 <> showDefault
121 <> help "The output directory"
123requirePath :: Parser (Maybe FilePath)
124requirePath = optional $ strOption $
125 short 'r'
126 <> long "require-path"
127 <> help "The path prefix to use for require() calls in the generated JavaScript [deprecated]"
129noTco :: Parser Bool
130noTco = switch $
131 long "no-tco"
132 <> help "Disable tail call optimizations"
134noMagicDo :: Parser Bool
135noMagicDo = switch $
136 long "no-magic-do"
137 <> help "Disable the optimization that overloads the do keyword to generate efficient code specifically for the Eff monad"
139noOpts :: Parser Bool
140noOpts = switch $
141 long "no-opts"
142 <> help "Skip the optimization phase"
144comments :: Parser Bool
145comments = switch $
146 short 'c'
147 <> long "comments"
148 <> help "Include comments in the generated code"
150verboseErrors :: Parser Bool
151verboseErrors = switch $
152 short 'v'
153 <> long "verbose-errors"
154 <> help "Display verbose error messages"
156noPrefix :: Parser Bool
157noPrefix = switch $
158 short 'p'
159 <> long "no-prefix"
160 <> help "Do not include comment header"
162jsonErrors :: Parser Bool
163jsonErrors = switch $
164 long "json-errors"
165 <> help "Print errors to stderr as JSON"
166sourceMaps :: Parser Bool
167sourceMaps = switch $
168 long "source-maps"
169 <> help "Generate source maps"
172options :: Parser P.Options
173options = P.Options <$> noTco
174 <*> noMagicDo
175 <*> pure Nothing
176 <*> noOpts
177 <*> verboseErrors
178 <*> (not <$> comments)
179 <*> requirePath
180 <*> sourceMaps
182pscMakeOptions :: Parser PSCMakeOptions
183pscMakeOptions = PSCMakeOptions <$> many inputFile
184 <*> many inputForeignFile
185 <*> outputDirectory
186 <*> options
187 <*> (not <$> noPrefix)
188 <*> jsonErrors
190main :: IO ()
191main = do
192 hSetEncoding stdout utf8
193 hSetEncoding stderr utf8
194 execParser opts >>= compile
195 where
196 opts = info (version <*> helper <*> pscMakeOptions) infoModList
197 infoModList = fullDesc <> headerInfo <> footerInfo
198 headerInfo = header "psc - Compiles PureScript to Javascript"
199 footerInfo = footer $ "psc " ++ showVersion Paths.version
201 version :: Parser (a -> a)
202 version = abortOption (InfoMsg (showVersion Paths.version)) $ long "version" <> help "Show the version number" <> hidden