git.iko.soy/elk
on 2d4afca help sign in
elk/compiler/Initialize.hs
103 lines 3.9 kB history raw
1module Initialize (buildFromSource, getSortedModuleNames, Interfaces) where
3import Data.Data
4import Control.Monad.State
5import qualified Data.Graph as Graph
6import qualified Data.List as List
7import qualified Data.Map as Map
8import qualified Data.Set as Set
9import System.Exit
10import System.FilePath as FP
11import Text.PrettyPrint (Doc)
13import SourceSyntax.Everything
14import SourceSyntax.Type
15import qualified Parse.Parse as Parse
16import qualified Metadata.Prelude as Prelude
17import qualified Transform.Check as Check
18import qualified Transform.SortDefinitions as SD
19import qualified Type.Inference as TI
20import qualified Type.Constrain.Declaration as TcDecl
21import qualified Transform.Canonicalize as Canonical
23buildFromSource :: Bool -> Interfaces -> String -> Either [Doc] (MetadataModule () ())
24buildFromSource noPrelude interfaces source =
25 do let add = if noPrelude then id else Prelude.add
26 modul@(Module _ _ _ decls') <- add `fmap` Parse.program source
28 -- check for structural errors
29 Module names exs ims decls <-
30 case Check.mistakes decls' of
31 [] -> return modul
32 ms -> Left ms
34 metaModule <- Canonical.metadataModule interfaces $ MetadataModule {
35 names = names,
36 path = FP.joinPath names,
37 exports = exs,
38 imports = ims,
39 -- reorder AST into strongly connected components
40 program = SD.sortDefs . dummyLet $ TcDecl.toExpr decls,
41 types = Map.empty,
42 datatypes = [ (name,vars,ctors) | Datatype name vars ctors <- decls ],
43 fixities = [ (assoc,level,op) | Fixity assoc level op <- decls ],
44 aliases = [ (name,tvs,tipe) | TypeAlias name tvs tipe <- decls ],
45 foreignImports = [ (evt,v,name,typ) | ImportEvent evt v name typ <- decls ],
46 foreignExports = [ (evt,name,typ) | ExportEvent evt name typ <- decls ]
47 }
49 types <- TI.infer interfaces metaModule
51 let exports' | null exs = Map.keys types
52 | otherwise = exs
54 return $ metaModule { types = types, exports = exports' }
57getSortedModuleNames :: Bool -> FilePath -> IO [String]
58getSortedModuleNames noPrelude root =
59 sortDeps =<< readDeps noPrelude root
61type Deps = (String, [String])
63sortDeps :: [Deps] -> IO [String]
64sortDeps depends =
65 if null mistakes
66 then return (concat sccs)
67 else print msg >> mapM print mistakes >> exitFailure
68 where
69 graph = map (\(name, deps) -> (toFilePath name, name, deps)) depends
70 sccs = map Graph.flattenSCC $ Graph.stronglyConnComp graph
72 mistakes = filter (\scc -> length scc > 1) sccs
73 msg = "A cyclical module dependency or was detected in: "
75readDeps :: Bool -> FilePath -> IO [Deps]
76readDeps noPrelude root = evalStateT (go root) Set.empty
77 where
78 builtIns = if noPrelude then Set.empty
79 else Set.fromList (Map.keys Prelude.interfaces)
81 go :: FilePath -> StateT (Set.Set String) IO [Deps]
82 go root = do
83 txt <- liftIO $ readFile root
84 case Parse.dependencies txt of
85 Left err -> liftIO (putStrLn msg >> print err >> exitFailure)
86 where msg = "Error resolving dependencies in " ++ root ++ ":"
88 Right (name,deps) ->
89 do seen <- get
90 let realDeps = Set.difference (Set.fromList deps) builtIns
91 newDeps = Set.difference (Set.filter (not . isNative) realDeps) seen
92 put (Set.insert name (Set.union newDeps seen))
93 rest <- mapM (go . toFilePath) (Set.toList newDeps)
94 return ((name, Set.toList realDeps) : concat rest)
97isNative name = List.isPrefixOf "Native." name
99toFilePath :: String -> FilePath
100toFilePath name = map swapDots name ++ ext
101 where swapDots '.' = '/'
102 swapDots c = c
103 ext = if isNative name then ".js" else ".elm"