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