-
Notifications
You must be signed in to change notification settings - Fork 18
/
Builder.purs
112 lines (104 loc) · 4.63 KB
/
Builder.purs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
module PureScript.Backend.Optimizer.Codegen.EcmaScript.Builder where
import Prelude
import Control.Monad.Except (ExceptT(..), lift, runExceptT)
import Control.Parallel (parTraverse)
import Data.Argonaut as Json
import Data.Array.NonEmpty (NonEmptyArray)
import Data.Array.NonEmpty as NonEmptyArray
import Data.Bifunctor (lmap)
import Data.Compactable (separate)
import Data.Either (Either(..))
import Data.Foldable (foldl, for_)
import Data.Lazy as Lazy
import Data.List (List)
import Data.Map (Map)
import Data.Map as Map
import Data.Maybe (maybe)
import Data.Set as Set
import Data.Set.NonEmpty as NonEmptySet
import Data.Tuple (Tuple(..))
import Effect.Aff (Aff, parallel, sequential)
import Effect.Class (liftEffect)
import Effect.Class.Console as Console
import Node.Encoding (Encoding(..))
import Node.FS.Aff as FS
import Node.Glob.Basic (expandGlobs)
import Node.Path (FilePath)
import Node.Process as Process
import PureScript.Backend.Optimizer.Builder (BuildEnv, buildModules)
import PureScript.Backend.Optimizer.Convert (BackendModule)
import PureScript.Backend.Optimizer.CoreFn (Ann, Ident, Module, ModuleName(..), Qualified)
import PureScript.Backend.Optimizer.CoreFn.Json (decodeModule)
import PureScript.Backend.Optimizer.CoreFn.Sort (emptyPull, pullResult, resumePull, sortModules)
import PureScript.Backend.Optimizer.Directives (parseDirectiveFile)
import PureScript.Backend.Optimizer.Directives.Defaults as Defaults
import PureScript.Backend.Optimizer.Semantics (InlineDirectiveMap)
import PureScript.Backend.Optimizer.Semantics.Foreign (ForeignEval)
import PureScript.CST.Errors (printParseError)
coreFnModulesFromOutput :: String -> NonEmptyArray String -> Aff (Either (NonEmptyArray (Tuple FilePath String)) (List (Module Ann)))
coreFnModulesFromOutput path globs = runExceptT do
paths <- Set.toUnfoldable <$> lift (expandGlobs path ((_ <> "/corefn.json") <$> NonEmptyArray.toArray globs))
case NonEmptyArray.toArray globs of
[ "**" ] ->
sortModules <$> modulesFromPaths paths
_ ->
go <<< foldl resumePull emptyPull =<< modulesFromPaths paths
where
modulesFromPaths paths = ExceptT do
{ left, right } <- separate <$> parTraverse readCoreFnModule paths
pure $ maybe (Right right) Left $ NonEmptyArray.fromArray left
pathFromModuleName (ModuleName mn) =
path <> "/" <> mn <> "/corefn.json"
go pull = case pullResult pull of
Left needed ->
go <<< foldl resumePull pull =<< modulesFromPaths (pathFromModuleName <$> NonEmptySet.toUnfoldable needed)
Right modules ->
pure $ Lazy.force modules
readCoreFnModule :: String -> Aff (Either (Tuple FilePath String) (Module Ann))
readCoreFnModule filePath = do
contents <- FS.readTextFile UTF8 filePath
case lmap Json.printJsonDecodeError <<< decodeModule =<< Json.jsonParser contents of
Left err -> do
pure $ Left $ Tuple filePath err
Right mod ->
pure $ Right mod
externalDirectivesFromFile :: FilePath -> Aff InlineDirectiveMap
externalDirectivesFromFile filePath = do
fileContent <- FS.readTextFile UTF8 filePath
let { errors, directives } = parseDirectiveFile fileContent
for_ errors \(Tuple directive { position, error }) -> do
Console.warn $ "Invalid directive [" <> show (position.line + 1) <> ":" <> show (position.column + 1) <> "]"
Console.warn $ " " <> directive
Console.warn $ " " <> printParseError error
pure directives
basicBuildMain
:: { resolveCoreFnDirectory :: Aff FilePath
, resolveExternalDirectives :: Aff InlineDirectiveMap
, foreignSemantics :: Map (Qualified Ident) ForeignEval
, onCodegenBefore :: Aff Unit
, onCodegenAfter :: Aff Unit
, onCodegenModule :: BuildEnv -> Module Ann -> BackendModule -> Aff Unit
, onPrepareModule :: BuildEnv -> Module Ann -> Aff (Module Ann)
}
-> Aff Unit
basicBuildMain options = do
{ coreFnDir, externalDirectives } <- sequential do
{ coreFnDir: _, externalDirectives: _ }
<$> parallel options.resolveCoreFnDirectory
<*> parallel options.resolveExternalDirectives
let defaultDirectives = (parseDirectiveFile Defaults.defaultDirectives).directives
let allDirectives = Map.union externalDirectives defaultDirectives
coreFnModulesFromOutput coreFnDir (pure "**") >>= case _ of
Left errors -> do
for_ errors \(Tuple filePath err) -> do
Console.error $ filePath <> " " <> err
liftEffect $ Process.exit 1
Right coreFnModules -> do
options.onCodegenBefore
coreFnModules # buildModules
{ directives: allDirectives
, foreignSemantics: options.foreignSemantics
, onCodegenModule: options.onCodegenModule
, onPrepareModule: options.onPrepareModule
}
options.onCodegenAfter