git.iko.soy/elk
on f20fa4e help sign in
elk/compiler/Initialize.hs
124 lines 4.9 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] -> Bool -> FilePath -> IO [String]
67getSortedDependencies srcDirs noPrelude root =
68 sortDeps =<< readDeps srcDirs noPrelude 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] -> Bool -> FilePath -> IO [Deps]
84readDeps srcDirs noPrelude root = evalStateT (go root) Set.empty
85 where
86 builtIns = if noPrelude then Set.empty
87 else Set.fromList (Map.keys Prelude.interfaces)
89 go :: FilePath -> StateT (Set.Set String) IO [Deps]
90 go root = do
91 (root', txt) <- liftIO $ getFile srcDirs root
92 case Parse.dependencies txt of
93 Left err -> liftIO (putStrLn msg >> print err >> exitFailure)
94 where msg = "Error resolving dependencies in " ++ root' ++ ":"
96 Right (name,deps) ->
97 do seen <- get
98 let realDeps = Set.difference (Set.fromList deps) builtIns
99 newDeps = Set.difference (Set.filter (not . isNative) realDeps) seen
100 put (Set.insert name (Set.union newDeps seen))
101 rest <- mapM (go . toFilePath) (Set.toList newDeps)
102 return ((makeRelative "." root', name, Set.toList realDeps) : concat rest)
104getFile :: [FilePath] -> FilePath -> IO (FilePath,String)
105getFile [] path = do
106 putStrLn $ unlines [ "Could not find file: " ++ path
107 , " If it is not in the root directory of your project, use"
108 , " --src-dir to declare additional locations for source files." ]
109 exitFailure
111getFile (dir:dirs) path = do
112 let path' = dir </> path
113 exists <- doesFileExist path'
114 case exists of
115 True -> (,) path' `fmap` readFile path'
116 False -> getFile dirs path
118isNative name = List.isPrefixOf "Native." name
120toFilePath :: String -> FilePath
121toFilePath name = map swapDots name ++ ext
122 where swapDots '.' = '/'
123 swapDots c = c
124 ext = if isNative name then ".js" else ".elm"