git.iko.soy/rowtype-yoga/purescript-native
on e82e607 help sign in
rowtype-yoga/purescript-native/psc-make/Main.hs
144 lines 4.6 kB history raw
1-----------------------------------------------------------------------------
2--
3-- Module : Main
4-- Copyright : (c) Phil Freeman 2013
5-- License : MIT
6--
7-- Maintainer : Phil Freeman <paf31@cantab.net>
8-- Stability : experimental
9-- Portability :
10--
11-- |
12--
13-----------------------------------------------------------------------------
15{-# LANGUAGE GeneralizedNewtypeDeriving #-}
17module Main where
19import Control.Applicative
20import Control.Monad.Error
22import Data.Version (showVersion)
24import System.Console.CmdTheLine
25import System.Directory
26 (doesFileExist, getModificationTime, createDirectoryIfMissing)
27import System.FilePath (takeDirectory)
28import System.Exit (exitSuccess, exitFailure)
29import System.IO.Error (tryIOError)
31import Text.Parsec (ParseError)
33import qualified Language.PureScript as P
34import qualified Paths_purescript as Paths
35import qualified System.IO.UTF8 as U
37preludeFilename :: IO FilePath
38preludeFilename = Paths.getDataFileName "prelude/prelude.purs"
40readInput :: [FilePath] -> IO (Either ParseError [(FilePath, P.Module)])
41readInput input = fmap collect $ forM input $ \inputFile -> do
42 text <- U.readFile inputFile
43 return $ (inputFile, P.runIndentParser inputFile P.parseModules text)
44 where
45 collect :: [(FilePath, Either ParseError [P.Module])] -> Either ParseError [(FilePath, P.Module)]
46 collect = fmap concat . sequence . map (\(fp, e) -> fmap (map ((,) fp)) e)
48newtype Make a = Make { unMake :: ErrorT String IO a } deriving (Functor, Monad, MonadIO, MonadError String)
50runMake :: Make a -> IO (Either String a)
51runMake = runErrorT . unMake
53makeIO :: IO a -> Make a
54makeIO = Make . ErrorT . fmap (either (Left . show) Right) . tryIOError
56instance P.MonadMake Make where
57 getTimestamp path = makeIO $ do
58 exists <- doesFileExist path
59 case exists of
60 True -> Just <$> getModificationTime path
61 False -> return Nothing
62 readTextFile path = makeIO $ do
63 U.putStrLn $ "Reading " ++ path
64 U.readFile path
65 writeTextFile path text = makeIO $ do
66 mkdirp path
67 U.putStrLn $ "Writing " ++ path
68 U.writeFile path text
69 liftError = either throwError return
71compile :: P.Options -> [FilePath] -> IO ()
72compile opts input = do
73 modules <- readInput input
74 case modules of
75 Left err -> do
76 U.print err
77 exitFailure
78 Right ms -> do
79 e <- runMake $ P.make opts ms
80 case e of
81 Left err -> do
82 U.putStrLn err
83 exitFailure
84 Right _ -> do
85 exitSuccess
87mkdirp :: FilePath -> IO ()
88mkdirp = createDirectoryIfMissing True . takeDirectory
90inputFiles :: Term [FilePath]
91inputFiles = value $ posAny [] $ posInfo
92 { posDoc = "The input .ps files" }
94noTco :: Term Bool
95noTco = value $ flag $ (optInfo [ "no-tco" ])
96 { optDoc = "Disable tail call optimizations" }
98performRuntimeTypeChecks :: Term Bool
99performRuntimeTypeChecks = value $ flag $ (optInfo [ "runtime-type-checks" ])
100 { optDoc = "Generate runtime type checks" }
102noPrelude :: Term Bool
103noPrelude = value $ flag $ (optInfo [ "no-prelude" ])
104 { optDoc = "Omit the Prelude" }
106noMagicDo :: Term Bool
107noMagicDo = value $ flag $ (optInfo [ "no-magic-do" ])
108 { optDoc = "Disable the optimization that overloads the do keyword to generate efficient code specifically for the Eff monad." }
110noOpts :: Term Bool
111noOpts = value $ flag $ (optInfo [ "no-opts" ])
112 { optDoc = "Skip the optimization phase." }
114browserNamespace :: Term String
115browserNamespace = value $ opt "PS" $ (optInfo [ "browser-namespace" ])
116 { optDoc = "Specify the namespace that PureScript modules will be exported to when running in the browser." }
118verboseErrors :: Term Bool
119verboseErrors = value $ flag $ (optInfo [ "v", "verbose-errors" ])
120 { optDoc = "Display verbose error messages" }
122options :: Term P.Options
123options = P.Options <$> noPrelude <*> noTco <*> performRuntimeTypeChecks <*> noMagicDo <*> pure Nothing <*> noOpts <*> browserNamespace <*> pure [] <*> pure [] <*> verboseErrors
125inputFilesAndPrelude :: FilePath -> Term [FilePath]
126inputFilesAndPrelude prelude = combine <$> (not <$> noPrelude) <*> inputFiles
127 where
128 combine True input = prelude : input
129 combine False input = input
131term :: FilePath -> Term (IO ())
132term prelude = compile <$> options <*> inputFilesAndPrelude prelude
134termInfo :: TermInfo
135termInfo = defTI
136 { termName = "psc-make"
137 , version = showVersion Paths.version
138 , termDoc = "Compiles PureScript to Javascript"
139 }
141main :: IO ()
142main = do
143 prelude <- preludeFilename
144 run (term prelude, termInfo)