git.iko.soy/elk
on cd4b4e2 help sign in
elk/compiler/Initialize.hs
123 lines 4.8 kB history raw
1module Initialize (buildFromSource, getSortedDependencies) 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.Directory
10import System.Exit
11import System.FilePath as FP
12import Text.PrettyPrint (Doc)
14import SourceSyntax.Everything
15import qualified SourceSyntax.Type as Type
16import qualified Parse.Parse as Parse
17import qualified Metadata.Prelude as Prelude
18import qualified Transform.Check as Check
19import qualified Transform.SortDefinitions as SD
20import qualified Type.Inference as TI
21import qualified Type.Constrain.Declaration as TcDecl
22import qualified Transform.Canonicalize as Canonical
24buildFromSource :: Bool -> Interfaces -> String -> Either [Doc] (MetadataModule () ())
25buildFromSource noPrelude interfaces source =
26 do let add = if noPrelude then id else Prelude.add
27 infixes = Map.fromList . map (\(assoc,lvl,op) -> (op,(lvl,assoc)))
28 . concatMap iFixities $ Map.elems interfaces
30 modul@(Module _ _ _ decls') <- add `fmap` Parse.program infixes source
32 -- check for structural errors
33 Module names exs ims decls <-
34 case Check.mistakes decls' of
35 [] -> return modul
36 ms -> Left ms
38 let exports'
39 | null exs =
40 let get = Set.toList . SD.boundVars in
41 concat [ get pattern | Definition (Def pattern _) <- decls ] ++
42 concat [ map fst ctors | Datatype _ _ ctors <- decls ] ++
43 [ name | TypeAlias name _ (Type.Record _ _) <- decls ]
44 | otherwise = exs
46 metaModule <- Canonical.metadataModule interfaces $ MetadataModule {
47 names = names,
48 path = FP.joinPath names,
49 exports = exports',
50 imports = ims,
51 -- reorder AST into strongly connected components
52 program = SD.sortDefs . dummyLet $ TcDecl.toExpr decls,
53 types = Map.empty,
54 datatypes = [ (name,vars,ctors) | Datatype name vars ctors <- decls ],
55 fixities = [ (assoc,level,op) | Fixity assoc level op <- decls ],
56 aliases = [ (name,tvs,tipe) | TypeAlias name tvs tipe <- decls ],
57 foreignImports = [ (evt,v,name,typ) | ImportEvent evt v name typ <- decls ],
58 foreignExports = [ (evt,name,typ) | ExportEvent evt name typ <- decls ]
59 }
61 types <- TI.infer interfaces metaModule
63 return $ metaModule { types = types }
66getSortedDependencies :: [FilePath] -> Interfaces -> FilePath -> IO [String]
67getSortedDependencies srcDirs builtIns root =
68 sortDeps =<< readDeps srcDirs builtIns root
70type Deps = (FilePath, String, [String])
72sortDeps :: [Deps] -> IO [String]
73sortDeps depends =
74 if null mistakes
75 then return (concat sccs)
76 else print msg >> mapM print mistakes >> exitFailure
77 where
78 sccs = map Graph.flattenSCC $ Graph.stronglyConnComp depends
80 mistakes = filter (\scc -> length scc > 1) sccs
81 msg = "A cyclical module dependency or was detected in: "
83readDeps :: [FilePath] -> Interfaces -> FilePath -> IO [Deps]
84readDeps srcDirs builtIns root = do
85 let ifaces = (Set.fromList . Map.keys) builtIns
86 evalStateT (go ifaces root) Set.empty
87 where
88 go :: Set.Set String -> FilePath -> StateT (Set.Set String) IO [Deps]
89 go builtIns root = do
90 (root', txt) <- liftIO $ getFile srcDirs root
91 case Parse.dependencies txt of
92 Left err -> liftIO (putStrLn msg >> print err >> exitFailure)
93 where msg = "Error resolving dependencies in " ++ root' ++ ":"
95 Right (name,deps) ->
96 do seen <- get
97 let realDeps = Set.difference (Set.fromList deps) builtIns
98 newDeps = Set.difference (Set.filter (not . isNative) realDeps) seen
99 put (Set.insert name (Set.union newDeps seen))
100 rest <- mapM (go builtIns . toFilePath) (Set.toList newDeps)
101 return ((makeRelative "." root', name, Set.toList realDeps) : concat rest)
103getFile :: [FilePath] -> FilePath -> IO (FilePath,String)
104getFile [] path = do
105 putStrLn $ unlines [ "Could not find file: " ++ path
106 , " If it is not in the root directory of your project, use"
107 , " --src-dir to declare additional locations for source files." ]
108 exitFailure
110getFile (dir:dirs) path = do
111 let path' = dir </> path
112 exists <- doesFileExist path'
113 case exists of
114 True -> (,) path' `fmap` readFile path'
115 False -> getFile dirs path
117isNative name = List.isPrefixOf "Native." name
119toFilePath :: String -> FilePath
120toFilePath name = map swapDots name ++ ext
121 where swapDots '.' = '/'
122 swapDots c = c
123 ext = if isNative name then ".js" else ".elm"