git.iko.soy/rowtype-yoga/purescript-native
on cc52a68 help sign in
rowtype-yoga/purescript-native/src/Language/PureScript.hs
247 lines 9.7 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 #-}
17{-# LANGUAGE FlexibleContexts #-}
18{-# LANGUAGE ScopedTypeVariables #-}
20module Language.PureScript
21 ( module P
22 , compile
23 , compile'
24 , RebuildPolicy(..)
25 , MonadMake(..)
26 , make
27 , version
28 ) where
30import Data.Function (on)
31import Data.List (sortBy, groupBy, intercalate)
32import Data.Maybe (fromMaybe)
33import Data.Time.Clock
34import Data.Version (Version)
35import qualified Data.Map as M
36import qualified Data.Set as S
38import Control.Applicative
39import Control.Arrow ((&&&))
40import Control.Monad
41import Control.Monad.Error.Class (MonadError(..))
42import Control.Monad.Reader
43import Control.Monad.Writer
44import Control.Monad.Supply.Class (fresh)
46import Language.PureScript.AST as P
47import Language.PureScript.Comments as P
48import Language.PureScript.CodeGen
49import Language.PureScript.DeadCodeElimination as P
50import Language.PureScript.Environment as P
51import Language.PureScript.Errors as P
52import Language.PureScript.Kinds as P
53import Language.PureScript.Linter as P
54import Language.PureScript.ModuleDependencies as P
55import Language.PureScript.Names as P
56import Language.PureScript.Options as P
57import Language.PureScript.Parser as P
58import Language.PureScript.Pretty as P
59import Language.PureScript.Renamer as P
60import Language.PureScript.Sugar as P
61import Control.Monad.Supply as P
62import Language.PureScript.TypeChecker as P
63import Language.PureScript.Types as P
64import qualified Language.PureScript.CoreFn as CoreFn
65import qualified Language.PureScript.Constants as C
67import qualified Paths_purescript as Paths
69-- |
70-- Compile a collection of modules
71--
72-- The compilation pipeline proceeds as follows:
73--
74-- * Sort the modules based on module dependencies, checking for cyclic dependencies.
75--
76-- * Perform a set of desugaring passes.
77--
78-- * Type check, and elaborate values to include type annotations and type class dictionaries.
79--
80-- * Regroup values to take into account new value dependencies introduced by elaboration.
81--
82-- * Eliminate dead code.
83--
84-- * Generate Javascript, and perform optimization passes.
85--
86-- * Pretty-print the generated Javascript
87--
88compile :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m, MonadReader (Options Compile) m)
89 => [Module] -> m ([CoreFn.Module CoreFn.Ann], String, Environment, Integer)
90compile = compile' initEnvironment
92compile' :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m, MonadReader (Options Compile) m)
93 => Environment -> [Module] -> m ([CoreFn.Module CoreFn.Ann], String, Environment, Integer)
94compile' env ms = do
95 noPrelude <- asks optionsNoPrelude
96 unless noPrelude (checkPreludeIsDefined ms)
97 additional <- asks optionsAdditional
98 mainModuleIdent <- asks (fmap moduleNameFromString . optionsMain)
99 (sorted, _) <- sortModules $ map importPrim $ if noPrelude then ms else map importPrelude ms
100 mapM_ lint sorted
101 (desugared, nextVar) <- runSupplyT 0 $ desugar sorted
102 (elaborated, env') <- runCheck' env $ forM desugared $ typeCheckModule mainModuleIdent
103 regrouped <- createBindingGroupsModule . collapseBindingGroupsModule $ elaborated
104 let corefn = map (CoreFn.moduleToCoreFn env') regrouped
105 entryPoints = moduleNameFromString `map` entryPointModules additional
106 elim = if null entryPoints then corefn else eliminateDeadCode entryPoints corefn
107 renamed = renameInModules elim
108 codeGenModuleNames = moduleNameFromString `map` codeGenModules additional
109 modulesToCodeGen = if null codeGenModuleNames then renamed else filter (\(CoreFn.Module _ mn _ _ _ _) -> mn `elem` codeGenModuleNames) renamed
110 let exts = intercalate "\n" . map (`moduleToPs` env') $ regrouped
111 return (modulesToCodeGen, exts, env', nextVar)
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 MultipleErrors m, MonadWriter MultipleErrors 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-- |
147-- Compiles in "make" mode, compiling each module separately to a js files and an externs file
148--
149-- If timestamps have not changed, the externs file can be used to provide the module's types without
150-- having to typecheck the module again.
151--
152make :: forall m. (Functor m, Applicative m, Monad m, MonadMake m)
153 => (ModuleName -> m (Either RebuildPolicy (Maybe UTCTime)))
154 -> (ModuleName -> m (Maybe UTCTime))
155 -> (ModuleName -> m (FilePath, String))
156 -> (CoreFn.Module CoreFn.Ann -> String -> Environment -> Integer -> m ())
157 -> [(Either RebuildPolicy FilePath, Module)]
158 -> m Environment
159make getInputTimestamp getOutputTimestamp readExterns codegen ms = do
160 noPrelude <- asks optionsNoPrelude
161 unless noPrelude (checkPreludeIsDefined (map snd ms))
162 (sorted, graph) <- sortModules $ map importPrim $ if noPrelude then map snd ms else map (importPrelude . snd) ms
163 mapM_ lint sorted
164 toRebuild <- foldM (\s (Module _ moduleName' _ _) -> do
165 inputTimestamp <- getInputTimestamp moduleName'
166 outputTimestamp <- getOutputTimestamp moduleName'
167 return $ case (inputTimestamp, outputTimestamp) of
168 (Right (Just t1), Just t2) | t1 < t2 -> s
169 (Left RebuildNever, Just _) -> s
170 _ -> S.insert moduleName' s) S.empty sorted
172 marked <- rebuildIfNecessary (reverseDependencies graph) toRebuild sorted
173 (desugared, nextVar) <- runSupplyT 0 $ zip (map fst marked) <$> desugar (map snd marked)
174 evalSupplyT nextVar $ go initEnvironment desugared
175 where
177 go :: Environment -> [(Bool, Module)] -> SupplyT m Environment
178 go env [] = return env
179 go env ((False, m) : ms') = do
180 (_, env') <- lift . runCheck' env $ typeCheckModule Nothing m
181 go env' ms'
182 go env ((True, m@(Module coms moduleName' _ exps)) : ms') = do
184 lift . progress $ "Compiling " ++ runModuleName moduleName'
185 (Module _ _ elaborated _, env') <- lift . runCheck' env $ typeCheckModule Nothing m
186 regrouped <- createBindingGroups moduleName' . collapseBindingGroups $ elaborated
187 let mod' = Module coms moduleName' regrouped exps
188 corefn = CoreFn.moduleToCoreFn env' mod'
189 [renamed] = renameInModules [corefn]
190 let exts = moduleToPs mod' env'
191 nextVar <- fresh
192 lift $ codegen renamed exts env' nextVar
193 go env' ms'
195 rebuildIfNecessary :: M.Map ModuleName [ModuleName] -> S.Set ModuleName -> [Module] -> m [(Bool, Module)]
196 rebuildIfNecessary _ _ [] = return []
197 rebuildIfNecessary graph toRebuild (m@(Module _ moduleName' _ _) : ms') | moduleName' `S.member` toRebuild = do
198 let deps = fromMaybe [] $ moduleName' `M.lookup` graph
199 toRebuild' = toRebuild `S.union` S.fromList deps
200 (:) (True, m) <$> rebuildIfNecessary graph toRebuild' ms'
201 rebuildIfNecessary graph toRebuild (Module _ moduleName' _ _ : ms') = do
202 (path, externs) <- readExterns moduleName'
203 externsModules <- fmap (map snd) . alterErrors $ P.parseModulesFromFiles id [(path, externs)]
204 case externsModules of
205 [m'@(Module _ moduleName'' _ _)] | moduleName'' == moduleName' -> (:) (False, m') <$> rebuildIfNecessary graph toRebuild ms'
206 _ -> throwError . errorMessage . InvalidExternsFile $ path
207 where
208 alterErrors = flip catchError $ \(MultipleErrors errs) ->
209 throwError . MultipleErrors $ flip map errs $ \e -> case e of
210 SimpleErrorWrapper (ErrorParsingModule err) -> SimpleErrorWrapper (ErrorParsingExterns err)
211 _ -> e
213checkPreludeIsDefined :: (MonadWriter MultipleErrors m) => [Module] -> m ()
214checkPreludeIsDefined ms = do
215 let mns = map getModuleName ms
216 unless (preludeModuleName `elem` mns) $
217 tell (errorMessage PreludeNotPresent)
219reverseDependencies :: ModuleGraph -> M.Map ModuleName [ModuleName]
220reverseDependencies g = combine [ (dep, mn) | (mn, deps) <- g, dep <- deps ]
221 where
222 combine :: (Ord a) => [(a, b)] -> M.Map a [b]
223 combine = M.fromList . map ((fst . head) &&& map snd) . groupBy ((==) `on` fst) . sortBy (compare `on` fst)
225-- |
226-- Add an import declaration for a module if it does not already explicitly import it.
227--
228addDefaultImport :: ModuleName -> Module -> Module
229addDefaultImport toImport m@(Module coms mn decls exps) =
230 if isExistingImport `any` decls || mn == toImport then m
231 else Module coms mn (ImportDeclaration toImport Implicit Nothing : decls) exps
232 where
233 isExistingImport (ImportDeclaration mn' _ _) | mn' == toImport = True
234 isExistingImport (PositionedDeclaration _ _ d) = isExistingImport d
235 isExistingImport _ = False
237importPrim :: Module -> Module
238importPrim = addDefaultImport (ModuleName [ProperName C.prim])
240preludeModuleName :: ModuleName
241preludeModuleName = ModuleName [ProperName C.prelude]
243importPrelude :: Module -> Module
244importPrelude = addDefaultImport preludeModuleName
246version :: Version
247version = Paths.version