git.iko.soy/rowtype-yoga/purescript-native
on 2a4e404 help sign in
rowtype-yoga/purescript-native/psc/Main.hs
201 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
31import Language.PureScript.Errors.JSON
33data PSCMakeOptions = PSCMakeOptions
34 { pscmInput :: [FilePath]
35 , pscmForeignInput :: [FilePath]
36 , pscmOutputDir :: FilePath
37 , pscmOpts :: P.Options
38 , pscmUsePrefix :: Bool
39 , pscmJSONErrors :: Bool
40 }
42data InputOptions = InputOptions
43 { ioInputFiles :: [FilePath]
44 }
46-- | Argumnets: verbose, use JSON, warnings, errors
47printWarningsAndErrors :: Bool -> Bool -> P.MultipleErrors -> Either P.MultipleErrors a -> IO ()
48printWarningsAndErrors verbose False warnings errors = do
49 when (P.nonEmpty warnings) $
50 hPutStrLn stderr (P.prettyPrintMultipleWarnings verbose warnings)
51 case errors of
52 Left errs -> do
53 hPutStrLn stderr (P.prettyPrintMultipleErrors verbose errs)
54 exitFailure
55 Right _ -> return ()
56printWarningsAndErrors verbose True warnings errors = do
57 hPutStrLn stderr . BU8.toString . B.toStrict . A.encode $
58 JSONResult (toJSONErrors verbose P.Warning warnings)
59 (either (toJSONErrors verbose P.Error) (const []) errors)
60 either (const exitFailure) (const (return ())) errors
62compile :: PSCMakeOptions -> IO ()
63compile PSCMakeOptions{..} = do
64 input <- globWarningOnMisses (unless pscmJSONErrors . warnFileTypeNotFound) pscmInput
65 when (null input && not pscmJSONErrors) $ do
66 hPutStrLn stderr "psc: No input files."
67 exitFailure
68 let (jsFiles, pursFiles) = partition (isSuffixOf ".js") input
69 moduleFiles <- readInput (InputOptions pursFiles)
70 inputForeign <- globWarningOnMisses (unless pscmJSONErrors . warnFileTypeNotFound) pscmForeignInput
71 foreignFiles <- forM (inputForeign ++ jsFiles) (\inFile -> (inFile,) <$> readUTF8File inFile)
72 (makeErrors, makeWarnings) <- runMake pscmOpts $ do
73 (ms, foreigns) <- parseInputs moduleFiles foreignFiles
74 let filePathMap = M.fromList $ map (\(fp, P.Module _ _ mn _ _) -> (mn, fp)) ms
75 makeActions = buildMakeActions pscmOutputDir filePathMap foreigns pscmUsePrefix
76 P.make makeActions (map snd ms)
77 printWarningsAndErrors (P.optionsVerboseErrors pscmOpts) pscmJSONErrors makeWarnings makeErrors
78 exitSuccess
80warnFileTypeNotFound :: String -> IO ()
81warnFileTypeNotFound = hPutStrLn stderr . ("psc: No files found using pattern: " ++)
83globWarningOnMisses :: (String -> IO ()) -> [FilePath] -> IO [FilePath]
84globWarningOnMisses warn = concatMapM globWithWarning
85 where
86 globWithWarning pattern = do
87 paths <- glob pattern
88 when (null paths) $ warn pattern
89 return paths
90 concatMapM f = liftM concat . mapM f
92readInput :: InputOptions -> IO [(Either P.RebuildPolicy FilePath, String)]
93readInput InputOptions{..} = forM ioInputFiles $ \inFile -> (Right inFile, ) <$> readUTF8File inFile
95parseInputs :: (MonadError P.MultipleErrors m, MonadWriter P.MultipleErrors m)
96 => [(Either P.RebuildPolicy FilePath, String)]
97 -> [(FilePath, P.ForeignJS)]
98 -> m ([(Either P.RebuildPolicy FilePath, P.Module)], M.Map P.ModuleName FilePath)
99parseInputs modules foreigns =
100 (,) <$> P.parseModulesFromFiles (either (const "") id) modules
101 <*> P.parseForeignModulesFromFiles foreigns
103inputFile :: Parser FilePath
104inputFile = strArgument $
105 metavar "FILE"
106 <> help "The input .purs file(s)"
108inputForeignFile :: Parser FilePath
109inputForeignFile = strOption $
110 short 'f'
111 <> long "ffi"
112 <> help "The input .js file(s) providing foreign import implementations"
114outputDirectory :: Parser FilePath
115outputDirectory = strOption $
116 short 'o'
117 <> long "output"
118 <> Opts.value "output"
119 <> showDefault
120 <> help "The output directory"
122requirePath :: Parser (Maybe FilePath)
123requirePath = optional $ strOption $
124 short 'r'
125 <> long "require-path"
126 <> help "The path prefix to use for require() calls in the generated JavaScript [deprecated]"
128noTco :: Parser Bool
129noTco = switch $
130 long "no-tco"
131 <> help "Disable tail call optimizations"
133noMagicDo :: Parser Bool
134noMagicDo = switch $
135 long "no-magic-do"
136 <> help "Disable the optimization that overloads the do keyword to generate efficient code specifically for the Eff monad"
138noOpts :: Parser Bool
139noOpts = switch $
140 long "no-opts"
141 <> help "Skip the optimization phase"
143comments :: Parser Bool
144comments = switch $
145 short 'c'
146 <> long "comments"
147 <> help "Include comments in the generated code"
149verboseErrors :: Parser Bool
150verboseErrors = switch $
151 short 'v'
152 <> long "verbose-errors"
153 <> help "Display verbose error messages"
155noPrefix :: Parser Bool
156noPrefix = switch $
157 short 'p'
158 <> long "no-prefix"
159 <> help "Do not include comment header"
161jsonErrors :: Parser Bool
162jsonErrors = switch $
163 long "json-errors"
164 <> help "Print errors to stderr as JSON"
165sourceMaps :: Parser Bool
166sourceMaps = switch $
167 long "source-maps"
168 <> help "Generate source maps"
171options :: Parser P.Options
172options = P.Options <$> noTco
173 <*> noMagicDo
174 <*> pure Nothing
175 <*> noOpts
176 <*> verboseErrors
177 <*> (not <$> comments)
178 <*> requirePath
179 <*> sourceMaps
181pscMakeOptions :: Parser PSCMakeOptions
182pscMakeOptions = PSCMakeOptions <$> many inputFile
183 <*> many inputForeignFile
184 <*> outputDirectory
185 <*> options
186 <*> (not <$> noPrefix)
187 <*> jsonErrors
189main :: IO ()
190main = do
191 hSetEncoding stdout utf8
192 hSetEncoding stderr utf8
193 execParser opts >>= compile
194 where
195 opts = info (version <*> helper <*> pscMakeOptions) infoModList
196 infoModList = fullDesc <> headerInfo <> footerInfo
197 headerInfo = header "psc - Compiles PureScript to Javascript"
198 footerInfo = footer $ "psc " ++ showVersion Paths.version
200 version :: Parser (a -> a)
201 version = abortOption (InfoMsg (showVersion Paths.version)) $ long "version" <> help "Show the version number" <> hidden