git.iko.soy/rowtype-yoga/purescript-native
on ec342ef help sign in
rowtype-yoga/purescript-native/psc/Main.hs
182 lines 6.1 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 Data.Bool (bool)
15import qualified Data.ByteString.Lazy as B
16import qualified Data.ByteString.UTF8 as BU8
17import qualified Data.Map as M
18import Data.Text (Text)
19import Data.Version (showVersion)
21import qualified Language.PureScript as P
22import Language.PureScript.Errors.JSON
23import Language.PureScript.Make
25import Options.Applicative as Opts
27import qualified Paths_purescript as Paths
29import qualified System.Console.ANSI as ANSI
30import System.Exit (exitSuccess, exitFailure)
31import System.FilePath.Glob (glob)
32import System.IO (hSetEncoding, hPutStrLn, stdout, stderr, utf8)
33import System.IO.UTF8 (readUTF8FileT)
35data PSCMakeOptions = PSCMakeOptions
36 { pscmInput :: [FilePath]
37 , pscmOutputDir :: FilePath
38 , pscmOpts :: P.Options
39 , pscmUsePrefix :: Bool
40 , pscmJSONErrors :: Bool
41 }
43-- | Argumnets: verbose, use JSON, warnings, errors
44printWarningsAndErrors :: Bool -> Bool -> P.MultipleErrors -> Either P.MultipleErrors a -> IO ()
45printWarningsAndErrors verbose False warnings errors = do
46 cc <- bool Nothing (Just P.defaultCodeColor) <$> ANSI.hSupportsANSI stderr
47 let ppeOpts = P.defaultPPEOptions { P.ppeCodeColor = cc, P.ppeFull = verbose }
48 when (P.nonEmpty warnings) $
49 hPutStrLn stderr (P.prettyPrintMultipleWarnings ppeOpts warnings)
50 case errors of
51 Left errs -> do
52 hPutStrLn stderr (P.prettyPrintMultipleErrors ppeOpts errs)
53 exitFailure
54 Right _ -> return ()
55printWarningsAndErrors verbose True warnings errors = do
56 hPutStrLn stderr . BU8.toString . B.toStrict . A.encode $
57 JSONResult (toJSONErrors verbose P.Warning warnings)
58 (either (toJSONErrors verbose P.Error) (const []) errors)
59 either (const exitFailure) (const (return ())) errors
61compile :: PSCMakeOptions -> IO ()
62compile PSCMakeOptions{..} = do
63 input <- globWarningOnMisses (unless pscmJSONErrors . warnFileTypeNotFound) pscmInput
64 when (null input && not pscmJSONErrors) $ do
65 hPutStrLn stderr "psc: No input files."
66 exitFailure
67 moduleFiles <- readInput input
68 (makeErrors, makeWarnings) <- runMake pscmOpts $ do
69 ms <- P.parseModulesFromFiles id moduleFiles
70 let filePathMap = M.fromList $ map (\(fp, P.Module _ _ mn _ _) -> (mn, Right fp)) ms
71 foreigns <- inferForeignModules filePathMap
72 let makeActions = buildMakeActions pscmOutputDir filePathMap foreigns pscmUsePrefix
73 P.make makeActions (map snd ms)
74 printWarningsAndErrors (P.optionsVerboseErrors pscmOpts) pscmJSONErrors makeWarnings makeErrors
75 exitSuccess
77warnFileTypeNotFound :: String -> IO ()
78warnFileTypeNotFound = hPutStrLn stderr . ("psc: No files found using pattern: " ++)
80globWarningOnMisses :: (String -> IO ()) -> [FilePath] -> IO [FilePath]
81globWarningOnMisses warn = concatMapM globWithWarning
82 where
83 globWithWarning pattern' = do
84 paths <- glob pattern'
85 when (null paths) $ warn pattern'
86 return paths
87 concatMapM f = fmap concat . mapM f
89readInput :: [FilePath] -> IO [(FilePath, Text)]
90readInput inputFiles = forM inputFiles $ \inFile -> (inFile, ) <$> readUTF8FileT inFile
92inputFile :: Parser FilePath
93inputFile = strArgument $
94 metavar "FILE"
95 <> help "The input .purs file(s)"
97outputDirectory :: Parser FilePath
98outputDirectory = strOption $
99 short 'o'
100 <> long "output"
101 <> Opts.value "output"
102 <> showDefault
103 <> help "The output directory"
105noTco :: Parser Bool
106noTco = switch $
107 long "no-tco"
108 <> help "Disable tail call optimizations"
110noMagicDo :: Parser Bool
111noMagicDo = switch $
112 long "no-magic-do"
113 <> help "Disable the optimization that overloads the do keyword to generate efficient code specifically for the Eff monad"
115noOpts :: Parser Bool
116noOpts = switch $
117 long "no-opts"
118 <> help "Skip the optimization phase"
120comments :: Parser Bool
121comments = switch $
122 short 'c'
123 <> long "comments"
124 <> help "Include comments in the generated code"
126verboseErrors :: Parser Bool
127verboseErrors = switch $
128 short 'v'
129 <> long "verbose-errors"
130 <> help "Display verbose error messages"
132noPrefix :: Parser Bool
133noPrefix = switch $
134 short 'p'
135 <> long "no-prefix"
136 <> help "Do not include comment header"
138jsonErrors :: Parser Bool
139jsonErrors = switch $
140 long "json-errors"
141 <> help "Print errors to stderr as JSON"
142sourceMaps :: Parser Bool
143sourceMaps = switch $
144 long "source-maps"
145 <> help "Generate source maps"
147dumpCoreFn :: Parser Bool
148dumpCoreFn = switch $
149 long "dump-corefn"
150 <> help "Dump the (functional) core representation of the compiled code at output/*/corefn.json"
153options :: Parser P.Options
154options = P.Options <$> noTco
155 <*> noMagicDo
156 <*> pure Nothing
157 <*> noOpts
158 <*> verboseErrors
159 <*> (not <$> comments)
160 <*> sourceMaps
161 <*> dumpCoreFn
163pscMakeOptions :: Parser PSCMakeOptions
164pscMakeOptions = PSCMakeOptions <$> many inputFile
165 <*> outputDirectory
166 <*> options
167 <*> (not <$> noPrefix)
168 <*> jsonErrors
170main :: IO ()
171main = do
172 hSetEncoding stdout utf8
173 hSetEncoding stderr utf8
174 execParser opts >>= compile
175 where
176 opts = info (version <*> helper <*> pscMakeOptions) infoModList
177 infoModList = fullDesc <> headerInfo <> footerInfo
178 headerInfo = header "psc - Compiles PureScript to Javascript"
179 footerInfo = footer $ "psc " ++ showVersion Paths.version
181 version :: Parser (a -> a)
182 version = abortOption (InfoMsg (showVersion Paths.version)) $ long "version" <> help "Show the version number" <> hidden