git.iko.soy/elk
on fbad8ea help sign in
elk/compiler/Initialize.hs
106 lines 4.0 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.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 let exports'
35 | null exs =
36 let get = Set.toList . SD.boundVars in
37 concat [ get pattern | Definition (Def pattern _) <- decls ] ++
38 concat [ map fst ctors | Datatype _ _ ctors <- decls ]
39 | otherwise = exs
41 metaModule <- Canonical.metadataModule interfaces $ MetadataModule {
42 names = names,
43 path = FP.joinPath names,
44 exports = exports',
45 imports = ims,
46 -- reorder AST into strongly connected components
47 program = SD.sortDefs . dummyLet $ TcDecl.toExpr decls,
48 types = Map.empty,
49 datatypes = [ (name,vars,ctors) | Datatype name vars ctors <- decls ],
50 fixities = [ (assoc,level,op) | Fixity assoc level op <- decls ],
51 aliases = [ (name,tvs,tipe) | TypeAlias name tvs tipe <- decls ],
52 foreignImports = [ (evt,v,name,typ) | ImportEvent evt v name typ <- decls ],
53 foreignExports = [ (evt,name,typ) | ExportEvent evt name typ <- decls ]
54 }
56 types <- TI.infer interfaces metaModule
58 return $ metaModule { types = types }
61getSortedDependencies :: Bool -> FilePath -> IO [String]
62getSortedDependencies noPrelude root =
63 sortDeps =<< readDeps noPrelude root
65type Deps = (FilePath, String, [String])
67sortDeps :: [Deps] -> IO [String]
68sortDeps depends =
69 if null mistakes
70 then return (concat sccs)
71 else print msg >> mapM print mistakes >> exitFailure
72 where
73 sccs = map Graph.flattenSCC $ Graph.stronglyConnComp depends
75 mistakes = filter (\scc -> length scc > 1) sccs
76 msg = "A cyclical module dependency or was detected in: "
78readDeps :: Bool -> FilePath -> IO [Deps]
79readDeps noPrelude root = evalStateT (go root) Set.empty
80 where
81 builtIns = if noPrelude then Set.empty
82 else Set.fromList (Map.keys Prelude.interfaces)
84 go :: FilePath -> StateT (Set.Set String) IO [Deps]
85 go root = do
86 txt <- liftIO $ readFile root
87 case Parse.dependencies txt of
88 Left err -> liftIO (putStrLn msg >> print err >> exitFailure)
89 where msg = "Error resolving dependencies in " ++ root ++ ":"
91 Right (name,deps) ->
92 do seen <- get
93 let realDeps = Set.difference (Set.fromList deps) builtIns
94 newDeps = Set.difference (Set.filter (not . isNative) realDeps) seen
95 put (Set.insert name (Set.union newDeps seen))
96 rest <- mapM (go . toFilePath) (Set.toList newDeps)
97 return ((makeRelative "." root, name, Set.toList realDeps) : concat rest)
100isNative name = List.isPrefixOf "Native." name
102toFilePath :: String -> FilePath
103toFilePath name = map swapDots name ++ ext
104 where swapDots '.' = '/'
105 swapDots c = c
106 ext = if isNative name then ".js" else ".elm"