git.iko.soy/rowtype-yoga/purescript-native
on cd4c708 help sign in
rowtype-yoga/purescript-native/psc/Main.hs
171 lines 5.6 kB history raw
1{-# LANGUAGE DataKinds #-}
2{-# LANGUAGE FlexibleContexts #-}
3{-# LANGUAGE RecordWildCards #-}
4{-# LANGUAGE ScopedTypeVariables #-}
5{-# LANGUAGE TupleSections #-}
7module Main where
9import Control.Applicative
10import Control.Monad
11import Control.Monad.Writer.Strict
13import qualified Data.Aeson as A
14import qualified Data.ByteString.Lazy as B
15import qualified Data.ByteString.UTF8 as BU8
16import qualified Data.Map as M
17import Data.Version (showVersion)
19import qualified Language.PureScript as P
20import Language.PureScript.Errors.JSON
21import Language.PureScript.Make
23import Options.Applicative as Opts
25import qualified Paths_purescript as Paths
27import System.Exit (exitSuccess, exitFailure)
28import System.FilePath.Glob (glob)
29import System.IO (hSetEncoding, hPutStrLn, stdout, stderr, utf8)
30import System.IO.UTF8
32data PSCMakeOptions = PSCMakeOptions
33 { pscmInput :: [FilePath]
34 , pscmOutputDir :: FilePath
35 , pscmOpts :: P.Options
36 , pscmUsePrefix :: Bool
37 , pscmJSONErrors :: Bool
38 }
40-- | Argumnets: verbose, use JSON, warnings, errors
41printWarningsAndErrors :: Bool -> Bool -> P.MultipleErrors -> Either P.MultipleErrors a -> IO ()
42printWarningsAndErrors verbose False warnings errors = do
43 when (P.nonEmpty warnings) $
44 hPutStrLn stderr (P.prettyPrintMultipleWarnings verbose warnings)
45 case errors of
46 Left errs -> do
47 hPutStrLn stderr (P.prettyPrintMultipleErrors verbose errs)
48 exitFailure
49 Right _ -> return ()
50printWarningsAndErrors verbose True warnings errors = do
51 hPutStrLn stderr . BU8.toString . B.toStrict . A.encode $
52 JSONResult (toJSONErrors verbose P.Warning warnings)
53 (either (toJSONErrors verbose P.Error) (const []) errors)
54 either (const exitFailure) (const (return ())) errors
56compile :: PSCMakeOptions -> IO ()
57compile PSCMakeOptions{..} = do
58 input <- globWarningOnMisses (unless pscmJSONErrors . warnFileTypeNotFound) pscmInput
59 when (null input && not pscmJSONErrors) $ do
60 hPutStrLn stderr "psc: No input files."
61 exitFailure
62 moduleFiles <- readInput input
63 (makeErrors, makeWarnings) <- runMake pscmOpts $ do
64 ms <- P.parseModulesFromFiles id moduleFiles
65 let filePathMap = M.fromList $ map (\(fp, P.Module _ _ mn _ _) -> (mn, Right fp)) ms
66 foreigns <- inferForeignModules filePathMap
67 let makeActions = buildMakeActions pscmOutputDir filePathMap foreigns pscmUsePrefix
68 P.make makeActions (map snd ms)
69 printWarningsAndErrors (P.optionsVerboseErrors pscmOpts) pscmJSONErrors makeWarnings makeErrors
70 exitSuccess
72warnFileTypeNotFound :: String -> IO ()
73warnFileTypeNotFound = hPutStrLn stderr . ("psc: No files found using pattern: " ++)
75globWarningOnMisses :: (String -> IO ()) -> [FilePath] -> IO [FilePath]
76globWarningOnMisses warn = concatMapM globWithWarning
77 where
78 globWithWarning pattern = do
79 paths <- glob pattern
80 when (null paths) $ warn pattern
81 return paths
82 concatMapM f = liftM concat . mapM f
84readInput :: [FilePath] -> IO [(FilePath, String)]
85readInput inputFiles = forM inputFiles $ \inFile -> (inFile, ) <$> readUTF8File inFile
87inputFile :: Parser FilePath
88inputFile = strArgument $
89 metavar "FILE"
90 <> help "The input .purs file(s)"
92outputDirectory :: Parser FilePath
93outputDirectory = strOption $
94 short 'o'
95 <> long "output"
96 <> Opts.value "output"
97 <> showDefault
98 <> help "The output directory"
100noTco :: Parser Bool
101noTco = switch $
102 long "no-tco"
103 <> help "Disable tail call optimizations"
105noMagicDo :: Parser Bool
106noMagicDo = switch $
107 long "no-magic-do"
108 <> help "Disable the optimization that overloads the do keyword to generate efficient code specifically for the Eff monad"
110noOpts :: Parser Bool
111noOpts = switch $
112 long "no-opts"
113 <> help "Skip the optimization phase"
115comments :: Parser Bool
116comments = switch $
117 short 'c'
118 <> long "comments"
119 <> help "Include comments in the generated code"
121verboseErrors :: Parser Bool
122verboseErrors = switch $
123 short 'v'
124 <> long "verbose-errors"
125 <> help "Display verbose error messages"
127noPrefix :: Parser Bool
128noPrefix = switch $
129 short 'p'
130 <> long "no-prefix"
131 <> help "Do not include comment header"
133jsonErrors :: Parser Bool
134jsonErrors = switch $
135 long "json-errors"
136 <> help "Print errors to stderr as JSON"
137sourceMaps :: Parser Bool
138sourceMaps = switch $
139 long "source-maps"
140 <> help "Generate source maps"
143options :: Parser P.Options
144options = P.Options <$> noTco
145 <*> noMagicDo
146 <*> pure Nothing
147 <*> noOpts
148 <*> verboseErrors
149 <*> (not <$> comments)
150 <*> sourceMaps
152pscMakeOptions :: Parser PSCMakeOptions
153pscMakeOptions = PSCMakeOptions <$> many inputFile
154 <*> outputDirectory
155 <*> options
156 <*> (not <$> noPrefix)
157 <*> jsonErrors
159main :: IO ()
160main = do
161 hSetEncoding stdout utf8
162 hSetEncoding stderr utf8
163 execParser opts >>= compile
164 where
165 opts = info (version <*> helper <*> pscMakeOptions) infoModList
166 infoModList = fullDesc <> headerInfo <> footerInfo
167 headerInfo = header "psc - Compiles PureScript to Javascript"
168 footerInfo = footer $ "psc " ++ showVersion Paths.version
170 version :: Parser (a -> a)
171 version = abortOption (InfoMsg (showVersion Paths.version)) $ long "version" <> help "Show the version number" <> hidden