git.iko.soy/rowtype-yoga/purescript-native
on c6e0ff3 help sign in
rowtype-yoga/purescript-native/src/Language/PureScript.hs
258 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, FlexibleContexts #-}
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.Traversable as T (traverse)
26import qualified Data.ByteString.UTF8 as BU
27import qualified Data.Map as M
28import qualified Data.Set as S
30import Control.Applicative
31import Control.Arrow ((&&&))
32import Control.Monad.Except
33import Control.Monad.Reader
35import System.FilePath ((</>))
37import Language.PureScript.AST as P
38import Language.PureScript.Comments as P
39import Language.PureScript.CodeGen as P
40import Language.PureScript.DeadCodeElimination as P
41import Language.PureScript.Environment as P
42import Language.PureScript.Errors as P
43import Language.PureScript.Kinds as P
44import Language.PureScript.ModuleDependencies as P
45import Language.PureScript.Names as P
46import Language.PureScript.Options as P
47import Language.PureScript.Parser as P
48import Language.PureScript.Pretty as P
49import Language.PureScript.Renamer as P
50import Language.PureScript.Sugar as P
51import Control.Monad.Supply as P
52import Language.PureScript.TypeChecker as P
53import Language.PureScript.Types as P
54import qualified Language.PureScript.CoreFn as CoreFn
55import qualified Language.PureScript.Constants as C
57-- |
58-- Compile a collection of modules
59--
60-- The compilation pipeline proceeds as follows:
61--
62-- * Sort the modules based on module dependencies, checking for cyclic dependencies.
63--
64-- * Perform a set of desugaring passes.
65--
66-- * Type check, and elaborate values to include type annotations and type class dictionaries.
67--
68-- * Regroup values to take into account new value dependencies introduced by elaboration.
69--
70-- * Eliminate dead code.
71--
72-- * Generate Javascript, and perform optimization passes.
73--
74-- * Pretty-print the generated Javascript
75--
76compile :: (Functor m, Applicative m, MonadError String m, MonadReader (Options Compile) m)
77 => [Module] -> [String] -> m (String, String, Environment)
78compile = compile' initEnvironment
80compile' :: (Functor m, Applicative m, MonadError String m, MonadReader (Options Compile) m)
81 => Environment -> [Module] -> [String] -> m (String, String, Environment)
82compile' env ms prefix = do
83 noPrelude <- asks optionsNoPrelude
84 additional <- asks optionsAdditional
85 mainModuleIdent <- asks (fmap moduleNameFromString . optionsMain)
86 (sorted, _) <- sortModules $ map importPrim $ if noPrelude then ms else map importPrelude ms
87 (desugared, nextVar) <- stringifyErrorStack True $ runSupplyT 0 $ desugar sorted
88 (elaborated, env') <- runCheck' env $ forM desugared $ typeCheckModule mainModuleIdent
89 regrouped <- stringifyErrorStack True $ createBindingGroupsModule . collapseBindingGroupsModule $ elaborated
90 let corefn = map (CoreFn.moduleToCoreFn env') regrouped
91 let entryPoints = moduleNameFromString `map` entryPointModules additional
92 let elim = if null entryPoints then corefn else eliminateDeadCode entryPoints corefn
93 let renamed = renameInModules elim
94 let codeGenModuleNames = moduleNameFromString `map` codeGenModules additional
95 let modulesToCodeGen = if null codeGenModuleNames then renamed else filter (\(CoreFn.Module mn _ _ _ _) -> mn `elem` codeGenModuleNames) renamed
96 js <- concat <$> (evalSupplyT nextVar $ T.traverse moduleToJs modulesToCodeGen)
97 let exts = intercalate "\n" . map (`moduleToPs` env') $ regrouped
98 js' <- generateMain env' js
99 let pjs = unlines $ map ("// " ++) prefix ++ [prettyPrintJS js']
100 return (pjs, exts, env')
102generateMain :: (MonadError String m, MonadReader (Options Compile) m) => Environment -> [JS] -> m [JS]
103generateMain env js = do
104 main <- asks optionsMain
105 additional <- asks optionsAdditional
106 case moduleNameFromString <$> main of
107 Just mmi -> do
108 when ((mmi, Ident C.main) `M.notMember` names env) $
109 throwError $ show mmi ++ "." ++ C.main ++ " is undefined"
110 return $ js ++ [JSApp (JSAccessor C.main (JSAccessor (moduleNameToJs mmi) (JSVar (browserNamespace additional)))) []]
111 _ -> return js
113-- |
114-- A type class which collects the IO actions we need to be able to run in "make" mode
115--
116class (MonadReader (P.Options P.Make) m, MonadError String m) => MonadMake m where
117 -- |
118 -- Get a file timestamp
119 --
120 getTimestamp :: FilePath -> m (Maybe UTCTime)
122 -- |
123 -- Read a file as a string
124 --
125 readTextFile :: FilePath -> m String
127 -- |
128 -- Write a text file
129 --
130 writeTextFile :: FilePath -> String -> m ()
132 -- |
133 -- Respond to a progress update
134 --
135 progress :: String -> m ()
137-- |
138-- Determines when to rebuild a module
139--
140data RebuildPolicy
141 -- | Never rebuild this module
142 = RebuildNever
143 -- | Always rebuild this module
144 | RebuildAlways deriving (Show, Eq, Ord)
146-- Traverse (Either e) instance (base 4.7)
147traverseEither :: Applicative f => (a -> f b) -> Either e a -> f (Either e b)
148traverseEither _ (Left x) = pure (Left x)
149traverseEither f (Right y) = Right <$> f y
151-- |
152-- Compiles in "make" mode, compiling each module separately to a js files and an externs file
153--
154-- If timestamps have not changed, the externs file can be used to provide the module's types without
155-- having to typecheck the module again.
156--
157make :: (Functor m, Applicative m, Monad m, MonadMake m)
158 => FilePath -> [(Either RebuildPolicy FilePath, Module)] -> [String] -> m Environment
159make outputDir ms prefix = do
160 noPrelude <- asks optionsNoPrelude
161 let filePathMap = M.fromList (map (\(fp, Module mn _ _) -> (mn, fp)) ms)
163 (sorted, graph) <- sortModules $ map importPrim $ if noPrelude then map snd ms else map (importPrelude . snd) ms
165 toRebuild <- foldM (\s (Module moduleName' _ _) -> do
166 let filePath = runModuleName moduleName'
168 jsFile = outputDir </> filePath </> "index.js"
169 externsFile = outputDir </> filePath </> "externs.purs"
170 inputFile = fromMaybe (error "Module has no filename in 'make'") $ M.lookup moduleName' filePathMap
172 jsTimestamp <- getTimestamp jsFile
173 externsTimestamp <- getTimestamp externsFile
174 inputTimestamp <- traverseEither getTimestamp inputFile
176 return $ case (inputTimestamp, jsTimestamp, externsTimestamp) of
177 (Right (Just t1), Just t2, Just t3) | t1 < min t2 t3 -> s
178 (Left RebuildNever, Just _, Just _) -> s
179 _ -> S.insert moduleName' s) S.empty sorted
181 marked <- rebuildIfNecessary (reverseDependencies graph) toRebuild sorted
183 (desugared, nextVar) <- stringifyErrorStack True $ runSupplyT 0 $ zip (map fst marked) <$> desugar (map snd marked)
185 evalSupplyT nextVar $ go initEnvironment desugared
187 where
188 go :: (Functor m, Applicative m, Monad m, MonadMake m)
189 => Environment -> [(Bool, Module)] -> SupplyT m Environment
190 go env [] = return env
191 go env ((False, m) : ms') = do
192 (_, env') <- lift . runCheck' env $ typeCheckModule Nothing m
194 go env' ms'
195 go env ((True, m@(Module moduleName' _ exps)) : ms') = do
196 let filePath = runModuleName moduleName'
197 jsFile = outputDir </> filePath </> "index.js"
198 externsFile = outputDir </> filePath </> "externs.purs"
200 lift . progress $ "Compiling " ++ runModuleName moduleName'
202 (Module _ elaborated _, env') <- lift . runCheck' env $ typeCheckModule Nothing m
204 regrouped <- stringifyErrorStack True . createBindingGroups moduleName' . collapseBindingGroups $ elaborated
206 let mod' = Module moduleName' regrouped exps
207 let corefn = CoreFn.moduleToCoreFn env' mod'
208 let [renamed] = renameInModules [corefn]
210 pjs <- prettyPrintJS <$> moduleToJs renamed
211 let js = unlines $ map ("// " ++) prefix ++ [pjs]
212 let exts = unlines $ map ("-- " ++) prefix ++ [moduleToPs mod' env']
214 lift $ writeTextFile jsFile js
215 lift $ writeTextFile externsFile exts
217 go env' ms'
219 rebuildIfNecessary :: (Functor m, Monad m, MonadMake m) => M.Map ModuleName [ModuleName] -> S.Set ModuleName -> [Module] -> m [(Bool, Module)]
220 rebuildIfNecessary _ _ [] = return []
221 rebuildIfNecessary graph toRebuild (m@(Module moduleName' _ _) : ms') | moduleName' `S.member` toRebuild = do
222 let deps = fromMaybe [] $ moduleName' `M.lookup` graph
223 toRebuild' = toRebuild `S.union` S.fromList deps
224 (:) (True, m) <$> rebuildIfNecessary graph toRebuild' ms'
225 rebuildIfNecessary graph toRebuild (Module moduleName' _ _ : ms') = do
226 let externsFile = outputDir </> runModuleName moduleName' </> "externs.purs"
227 externs <- readTextFile externsFile
228 externsModules <- fmap (map snd) . either (throwError . show) return $ P.parseModulesFromFiles id [(externsFile, externs)]
229 case externsModules of
230 [m'@(Module moduleName'' _ _)] | moduleName'' == moduleName' -> (:) (False, m') <$> rebuildIfNecessary graph toRebuild ms'
231 _ -> throwError $ "Externs file " ++ externsFile ++ " was invalid"
233reverseDependencies :: ModuleGraph -> M.Map ModuleName [ModuleName]
234reverseDependencies g = combine [ (dep, mn) | (mn, deps) <- g, dep <- deps ]
235 where
236 combine :: (Ord a) => [(a, b)] -> M.Map a [b]
237 combine = M.fromList . map ((fst . head) &&& map snd) . groupBy ((==) `on` fst) . sortBy (compare `on` fst)
239-- |
240-- Add an import declaration for a module if it does not already explicitly import it.
241--
242addDefaultImport :: ModuleName -> Module -> Module
243addDefaultImport toImport m@(Module mn decls exps) =
244 if isExistingImport `any` decls || mn == toImport then m
245 else Module mn (ImportDeclaration toImport Unqualified Nothing : decls) exps
246 where
247 isExistingImport (ImportDeclaration mn' _ _) | mn' == toImport = True
248 isExistingImport (PositionedDeclaration _ _ d) = isExistingImport d
249 isExistingImport _ = False
251importPrim :: Module -> Module
252importPrim = addDefaultImport (ModuleName [ProperName C.prim])
254importPrelude :: Module -> Module
255importPrelude = addDefaultImport (ModuleName [ProperName C.prelude])
257prelude :: String
258prelude = BU.toString $(embedFile "prelude/prelude.purs")