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