@@ -0,0 +1,140 @@
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+-----------------------------------------------------------------------------
14+
15+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
16+
17+module Main where
18+
19+import Control.Applicative
20+import Control.Monad.Error
21+
22+import Data.Version (showVersion)
23+
24+import System.Console.CmdTheLine
25+import System.Directory
26+ (doesFileExist, getModificationTime, createDirectoryIfMissing)
27+import System.FilePath (takeDirectory)
28+import System.Exit (exitSuccess, exitFailure)
29+import System.IO.Error (tryIOError)
30+
31+import Text.Parsec (ParseError)
32+
33+import qualified Language.PureScript as P
34+import qualified Paths_purescript as Paths
35+import qualified System.IO.UTF8 as U
36+
37+preludeFilename :: IO FilePath
38+preludeFilename = Paths.getDataFileName "prelude/prelude.purs"
39+
40+readInput :: [FilePath] -> IO (Either ParseError [(FilePath, P.Module)])
41+readInput 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)
47+
48+newtype Make a = Make { unMake :: ErrorT String IO a } deriving (Functor, Monad, MonadIO, MonadError String)
49+
50+runMake :: Make a -> IO (Either String a)
51+runMake = runErrorT . unMake
52+
53+makeIO :: IO a -> Make a
54+makeIO = Make . ErrorT . fmap (either (Left . show) Right) . tryIOError
55+
56+instance 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
70+
71+compile :: P.Options -> [FilePath] -> IO ()
72+compile 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
86+
87+mkdirp :: FilePath -> IO ()
88+mkdirp = createDirectoryIfMissing True . takeDirectory
89+
90+inputFiles :: Term [FilePath]
91+inputFiles = value $ posAny [] $ posInfo
92+ { posDoc = "The input .ps files" }
93+
94+tco :: Term Bool
95+tco = value $ flag $ (optInfo [ "tco" ])
96+ { optDoc = "Perform tail call optimizations" }
97+
98+performRuntimeTypeChecks :: Term Bool
99+performRuntimeTypeChecks = value $ flag $ (optInfo [ "runtime-type-checks" ])
100+ { optDoc = "Generate runtime type checks" }
101+
102+noPrelude :: Term Bool
103+noPrelude = value $ flag $ (optInfo [ "no-prelude" ])
104+ { optDoc = "Omit the Prelude" }
105+
106+magicDo :: Term Bool
107+magicDo = value $ flag $ (optInfo [ "magic-do" ])
108+ { optDoc = "Overload the do keyword to generate efficient code specifically for the Eff monad." }
109+
110+noOpts :: Term Bool
111+noOpts = value $ flag $ (optInfo [ "no-opts" ])
112+ { optDoc = "Skip the optimization phase." }
113+
114+browserNamespace :: Term String
115+browserNamespace = value $ opt "PS" $ (optInfo [ "browser-namespace" ])
116+ { optDoc = "Specify the namespace that PureScript modules will be exported to when running in the browser." }
117+
118+options :: Term P.Options
119+options = P.Options <$> tco <*> performRuntimeTypeChecks <*> magicDo <*> pure Nothing <*> noOpts <*> browserNamespace <*> pure [] <*> pure []
120+
121+inputFilesAndPrelude :: FilePath -> Term [FilePath]
122+inputFilesAndPrelude prelude = combine <$> (not <$> noPrelude) <*> inputFiles
123+ where
124+ combine True input = prelude : input
125+ combine False input = input
126+
127+term :: FilePath -> Term (IO ())
128+term prelude = compile <$> options <*> inputFilesAndPrelude prelude
129+
130+termInfo :: TermInfo
131+termInfo = defTI
132+ { termName = "psc-make"
133+ , version = showVersion Paths.version
134+ , termDoc = "Compiles PureScript to Javascript"
135+ }
136+
137+main :: IO ()
138+main = do
139+ prelude <- preludeFilename
140+ run (term prelude, termInfo)