git.iko.soy/elk
on fa132ea help sign in
elk/compiler/Initialize.hs
101 lines 3.7 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
22import System.IO.Unsafe
23import SourceSyntax.PrettyPrint
25buildFromSource :: Interfaces -> String -> Either [Doc] (MetadataModule () ())
26buildFromSource interfaces source =
27 do modul@(Module _ _ _ decls') <- Parse.program source
29 -- check for structural errors
30 Module names exs ims decls <-
31 case Check.mistakes decls' of
32 [] -> return modul
33 ms -> Left ms
35 let metaModule = MetadataModule {
36 names = names,
37 path = FP.joinPath names,
38 exports = exs,
39 imports = ims,
40 -- reorder AST into strongly connected components
41 program = SD.sortDefs . dummyLet $ TcDecl.toExpr decls,
42 types = Map.empty,
43 datatypes = [ (name,vars,ctors) | Datatype name vars ctors <- decls ],
44 fixities = [ (assoc,level,op) | Fixity assoc level op <- decls ],
45 aliases = [ (name,tvs,tipe) | TypeAlias name tvs tipe <- decls ],
46 foreignImports = [ (evt,v,name,typ) | ImportEvent evt v name typ <- decls ],
47 foreignExports = [ (evt,name,typ) | ExportEvent evt name typ <- decls ]
48 }
50 types <- TI.infer interfaces metaModule
52 return $ metaModule { types = types }
55getSortedModuleNames :: Bool -> FilePath -> IO [String]
56getSortedModuleNames noPrelude root =
57 sortDeps =<< readDeps noPrelude root
59type Deps = (String, [String])
61sortDeps :: [Deps] -> IO [String]
62sortDeps depends =
63 if null mistakes
64 then return (concat sccs)
65 else print msg >> mapM print mistakes >> exitFailure
66 where
67 graph = map (\(name, deps) -> (toFilePath name, name, deps)) depends
68 sccs = map Graph.flattenSCC $ Graph.stronglyConnComp graph
70 mistakes = filter (\scc -> length scc > 1) sccs
71 msg = "A cyclical module dependency or was detected in: "
73readDeps :: Bool -> FilePath -> IO [Deps]
74readDeps noPrelude root = evalStateT (go root) Set.empty
75 where
76 builtIns = if noPrelude then Set.empty
77 else Set.fromList (Map.keys Prelude.interfaces)
79 go :: FilePath -> StateT (Set.Set String) IO [Deps]
80 go root = do
81 txt <- liftIO $ readFile root
82 case Parse.dependencies txt of
83 Left err -> liftIO (putStrLn msg >> print err >> exitFailure)
84 where msg = "Error resolving dependencies in " ++ root ++ ":"
86 Right (name,deps) ->
87 do seen <- get
88 let realDeps = Set.difference (Set.fromList deps) builtIns
89 newDeps = Set.difference (Set.filter (not . isNative) realDeps) seen
90 put (Set.insert name (Set.union newDeps seen))
91 rest <- mapM (go . toFilePath) (Set.toList newDeps)
92 return ((name, Set.toList realDeps) : concat rest)
95isNative name = List.isPrefixOf "Native." name
97toFilePath :: String -> FilePath
98toFilePath name = map swapDots name ++ ext
99 where swapDots '.' = '/'
100 swapDots c = c
101 ext = if isNative name then ".js" else ".elm"