git.iko.soy/rowtype-yoga/purescript-native
on de41349 help sign in
rowtype-yoga/purescript-native/src/Language/PureScript.hs
253 lines 10 kB history raw
1-----------------------------------------------------------------------------
2--
3-- Module : Language.PureScript
4-- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors
5-- License : MIT
6--
7-- Maintainer : Phil Freeman <paf31@cantab.net>
8-- Stability : experimental
9-- Portability :
10--
11-- |
12-- The main compiler module
13--
14-----------------------------------------------------------------------------
16{-# LANGUAGE DataKinds, QuasiQuotes, TemplateHaskell #-}
18module Language.PureScript (module P, compile, compile', RebuildPolicy(..), MonadMake(..), make, prelude) where
20import Data.FileEmbed (embedFile)
21import Data.Function (on)
22import Data.List (sortBy, groupBy, intercalate)
23import Data.Maybe (fromMaybe)
24import Data.Time.Clock
25import qualified Data.ByteString.UTF8 as BU
26import qualified Data.Map as M
27import qualified Data.Set as S
29import Control.Applicative
30import Control.Arrow ((&&&))
31import Control.Monad.Error
33import System.FilePath ((</>))
35import Language.PureScript.AST as P
36import Language.PureScript.Comments as P
37import Language.PureScript.CodeGen as P
38import Language.PureScript.DeadCodeElimination as P
39import Language.PureScript.Environment as P
40import Language.PureScript.Errors as P
41import Language.PureScript.Kinds as P
42import Language.PureScript.ModuleDependencies as P
43import Language.PureScript.Names as P
44import Language.PureScript.Options as P
45import Language.PureScript.Parser as P
46import Language.PureScript.Pretty as P
47import Language.PureScript.Renamer as P
48import Language.PureScript.Sugar as P
49import Language.PureScript.Supply as P
50import Language.PureScript.TypeChecker as P
51import Language.PureScript.Types as P
52import qualified Language.PureScript.CoreFn as CoreFn
53import qualified Language.PureScript.Constants as C
55-- |
56-- Compile a collection of modules
57--
58-- The compilation pipeline proceeds as follows:
59--
60-- * Sort the modules based on module dependencies, checking for cyclic dependencies.
61--
62-- * Perform a set of desugaring passes.
63--
64-- * Type check, and elaborate values to include type annotations and type class dictionaries.
65--
66-- * Regroup values to take into account new value dependencies introduced by elaboration.
67--
68-- * Eliminate dead code.
69--
70-- * Generate Javascript, and perform optimization passes.
71--
72-- * Pretty-print the generated Javascript
73--
74compile :: Options Compile -> [Module] -> [String] -> Either String (String, String, Environment)
75compile = compile' initEnvironment
77compile' :: Environment -> Options Compile -> [Module] -> [String] -> Either String (String, String, Environment)
78compile' env opts ms prefix = do
79 (sorted, _) <- sortModules $ map importPrim $ if optionsNoPrelude opts then ms else map importPrelude ms
80 (desugared, nextVar) <- stringifyErrorStack True $ runSupplyT 0 $ desugar sorted
81 (elaborated, env') <- runCheck' opts env $ forM desugared $ typeCheckModule mainModuleIdent
82 regrouped <- stringifyErrorStack True $ createBindingGroupsModule . collapseBindingGroupsModule $ elaborated
83 let corefn = map (CoreFn.moduleToCoreFn env') regrouped
84 let entryPoints = moduleNameFromString `map` entryPointModules (optionsAdditional opts)
85 let elim = if null entryPoints then corefn else eliminateDeadCode entryPoints corefn
86 let renamed = renameInModules elim
87 let codeGenModuleNames = moduleNameFromString `map` codeGenModules (optionsAdditional opts)
88 let modulesToCodeGen = if null codeGenModuleNames then renamed else filter (\(CoreFn.Module mn _ _ _ _) -> mn `elem` codeGenModuleNames) renamed
89 let js = evalSupply nextVar $ concat <$> mapM (moduleToJs opts) modulesToCodeGen
90 let exts = intercalate "\n" . map (`moduleToPs` env') $ regrouped
91 js' <- generateMain env' opts js
92 let pjs = unlines $ map ("// " ++) prefix ++ [prettyPrintJS js']
93 return (pjs, exts, env')
94 where
95 mainModuleIdent = moduleNameFromString <$> optionsMain opts
97generateMain :: Environment -> Options Compile -> [JS] -> Either String [JS]
98generateMain env opts js =
99 case moduleNameFromString <$> optionsMain opts of
100 Just mmi -> do
101 when ((mmi, Ident C.main) `M.notMember` names env) $
102 Left $ show mmi ++ "." ++ C.main ++ " is undefined"
103 return $ js ++ [JSApp (JSAccessor C.main (JSAccessor (moduleNameToJs mmi) (JSVar (browserNamespace (optionsAdditional opts))))) []]
104 _ -> return js
106-- |
107-- A type class which collects the IO actions we need to be able to run in "make" mode
108--
109class MonadMake m where
110 -- |
111 -- Get a file timestamp
112 --
113 getTimestamp :: FilePath -> m (Maybe UTCTime)
115 -- |
116 -- Read a file as a string
117 --
118 readTextFile :: FilePath -> m String
120 -- |
121 -- Write a text file
122 --
123 writeTextFile :: FilePath -> String -> m ()
125 -- |
126 -- Report an error
127 --
128 liftError :: Either String a -> m a
130 -- |
131 -- Respond to a progress update
132 --
133 progress :: String -> m ()
135-- |
136-- Determines when to rebuild a module
137--
138data RebuildPolicy
139 -- | Never rebuild this module
140 = RebuildNever
141 -- | Always rebuild this module
142 | RebuildAlways deriving (Show, Eq, Ord)
144-- Traverse (Either e) instance (base 4.7)
145traverseEither :: Applicative f => (a -> f b) -> Either e a -> f (Either e b)
146traverseEither _ (Left x) = pure (Left x)
147traverseEither f (Right y) = Right <$> f y
149-- |
150-- Compiles in "make" mode, compiling each module separately to a js files and an externs file
151--
152-- If timestamps have not changed, the externs file can be used to provide the module's types without
153-- having to typecheck the module again.
154--
155make :: (Functor m, Applicative m, Monad m, MonadMake m) => FilePath -> Options Make -> [(Either RebuildPolicy FilePath, Module)] -> [String] -> m Environment
156make outputDir opts ms prefix = do
157 let filePathMap = M.fromList (map (\(fp, Module mn _ _) -> (mn, fp)) ms)
159 (sorted, graph) <- liftError $ sortModules $ map importPrim $ if optionsNoPrelude opts then map snd ms else map (importPrelude . snd) ms
161 toRebuild <- foldM (\s (Module moduleName' _ _) -> do
162 let filePath = runModuleName moduleName'
164 jsFile = outputDir </> filePath </> "index.js"
165 externsFile = outputDir </> filePath </> "externs.purs"
166 inputFile = fromMaybe (error "Module has no filename in 'make'") $ M.lookup moduleName' filePathMap
168 jsTimestamp <- getTimestamp jsFile
169 externsTimestamp <- getTimestamp externsFile
170 inputTimestamp <- traverseEither getTimestamp inputFile
172 return $ case (inputTimestamp, jsTimestamp, externsTimestamp) of
173 (Right (Just t1), Just t2, Just t3) | t1 < min t2 t3 -> s
174 (Left RebuildNever, Just _, Just _) -> s
175 _ -> S.insert moduleName' s) S.empty sorted
177 marked <- rebuildIfNecessary (reverseDependencies graph) toRebuild sorted
179 (desugared, nextVar) <- liftError $ stringifyErrorStack True $ runSupplyT 0 $ zip (map fst marked) <$> desugar (map snd marked)
181 evalSupplyT nextVar (go initEnvironment desugared)
183 where
184 go :: (Functor m, Applicative m, Monad m, MonadMake m) => Environment -> [(Bool, Module)] -> SupplyT m Environment
185 go env [] = return env
186 go env ((False, m) : ms') = do
187 (_, env') <- lift . liftError . runCheck' opts env $ typeCheckModule Nothing m
189 go env' ms'
190 go env ((True, m@(Module moduleName' _ exps)) : ms') = do
191 let filePath = runModuleName moduleName'
192 jsFile = outputDir </> filePath </> "index.js"
193 externsFile = outputDir </> filePath </> "externs.purs"
195 lift . progress $ "Compiling " ++ runModuleName moduleName'
197 (Module _ elaborated _, env') <- lift . liftError . runCheck' opts env $ typeCheckModule Nothing m
199 regrouped <- lift . liftError . stringifyErrorStack True . createBindingGroups moduleName' . collapseBindingGroups $ elaborated
201 let mod' = Module moduleName' regrouped exps
202 let corefn = CoreFn.moduleToCoreFn env' mod'
203 let [renamed] = renameInModules [corefn]
205 pjs <- prettyPrintJS <$> moduleToJs opts renamed
206 let js = unlines $ map ("// " ++) prefix ++ [pjs]
207 let exts = unlines $ map ("-- " ++) prefix ++ [moduleToPs mod' env']
209 lift $ writeTextFile jsFile js
210 lift $ writeTextFile externsFile exts
212 go env' ms'
214 rebuildIfNecessary :: (Functor m, Monad m, MonadMake m) => M.Map ModuleName [ModuleName] -> S.Set ModuleName -> [Module] -> m [(Bool, Module)]
215 rebuildIfNecessary _ _ [] = return []
216 rebuildIfNecessary graph toRebuild (m@(Module moduleName' _ _) : ms') | moduleName' `S.member` toRebuild = do
217 let deps = fromMaybe [] $ moduleName' `M.lookup` graph
218 toRebuild' = toRebuild `S.union` S.fromList deps
219 (:) (True, m) <$> rebuildIfNecessary graph toRebuild' ms'
220 rebuildIfNecessary graph toRebuild (Module moduleName' _ _ : ms') = do
221 let externsFile = outputDir </> runModuleName moduleName' </> "externs.purs"
222 externs <- readTextFile externsFile
223 externsModules <- liftError . fmap (map snd) . either (Left . show) Right $ P.parseModulesFromFiles id [(externsFile, externs)]
224 case externsModules of
225 [m'@(Module moduleName'' _ _)] | moduleName'' == moduleName' -> (:) (False, m') <$> rebuildIfNecessary graph toRebuild ms'
226 _ -> liftError . Left $ "Externs file " ++ externsFile ++ " was invalid"
228reverseDependencies :: ModuleGraph -> M.Map ModuleName [ModuleName]
229reverseDependencies g = combine [ (dep, mn) | (mn, deps) <- g, dep <- deps ]
230 where
231 combine :: (Ord a) => [(a, b)] -> M.Map a [b]
232 combine = M.fromList . map ((fst . head) &&& map snd) . groupBy ((==) `on` fst) . sortBy (compare `on` fst)
234-- |
235-- Add an import declaration for a module if it does not already explicitly import it.
236--
237addDefaultImport :: ModuleName -> Module -> Module
238addDefaultImport toImport m@(Module mn decls exps) =
239 if isExistingImport `any` decls || mn == toImport then m
240 else Module mn (ImportDeclaration toImport Unqualified Nothing : decls) exps
241 where
242 isExistingImport (ImportDeclaration mn' _ _) | mn' == toImport = True
243 isExistingImport (PositionedDeclaration _ _ d) = isExistingImport d
244 isExistingImport _ = False
246importPrim :: Module -> Module
247importPrim = addDefaultImport (ModuleName [ProperName C.prim])
249importPrelude :: Module -> Module
250importPrelude = addDefaultImport (ModuleName [ProperName C.prelude])
252prelude :: String
253prelude = BU.toString $(embedFile "prelude/prelude.purs")