git.iko.soy/elk
on a3801ac help sign in
elk/compiler/Initialize.hs
83 lines 2.8 kB history raw
1module Initialize (buildFromSource, getSortedModuleNames) where
3import Control.Applicative ((<$>))
4import Control.Monad.Error
5import Data.List (lookup,nub)
6import qualified Data.Map as Map
8import Ast
9import Data.Either (lefts,rights)
10import Data.List (intercalate,partition)
11import Parse.Parser (parseProgram, parseDependencies)
12import Rename
13import qualified Libraries as Libs
14import Types.Types ((-:))
15import Types.Hints (hints)
16import Types.Unify (unify)
17import Types.Alias (dealias, mistakes)
18import Optimize
19import System.Exit
20import System.FilePath
22checkMistakes :: Module -> Either String Module
23checkMistakes modul@(Module name ex im stmts) =
24 case mistakes stmts of
25 m:ms -> Left (unlines (m:ms))
26 [] -> return modul
28checkTypes :: Module -> Either String Module
29checkTypes modul =
30 do subs <- unify hints modul
31 subs `seq` return (optimize (renameModule modul))
33check :: Module -> Either String Module
34check = checkMistakes >=> checkTypes
36buildFromSource :: Bool -> String -> Either String Module
37buildFromSource noPrelude src =
38 let add = if noPrelude then id else Libs.addPrelude in
39 (check . add) =<< (parseProgram src)
41getSortedModuleNames :: FilePath -> IO [String]
42getSortedModuleNames root =
43 sortDeps =<< readDeps [] root
45type Deps = (String, [String])
47sortDeps :: [Deps] -> IO [String]
48sortDeps deps = go [] (nub deps)
49 where
50 msg = "A cyclical or missing module dependency or was detected in: "
52 go :: [String] -> [Deps] -> IO [String]
53 go sorted [] = return (map toFilePath sorted)
54 go sorted unsorted =
55 case partition (all (`elem` sorted) . snd) unsorted of
56 ([],m:ms) -> do putStrLn (msg ++ intercalate ", " (map fst (m:ms)) ++ show sorted ++ show unsorted)
57 exitFailure
58 (srtd,unsrtd) -> go (sorted ++ map fst srtd) unsrtd
60readDeps :: [FilePath] -> FilePath -> IO [Deps]
61readDeps seen root = do
62 txt <- readFile root
63 case parseDependencies txt of
64 Left err ->
65 let msg = "Error resolving dependencies in " ++ root ++ ":\n" in
66 putStrLn (msg ++ err) >> exitFailure
67 Right (name,deps) ->
68 do rest <- mapM (readDeps seen' . toFilePath) newDeps
69 return ((name, realDeps) : concat rest)
70 where
71 realDeps = filter (`notElem` builtIns) deps
72 newDeps = filter (\d -> d `notElem` seen && not (isNative d)) realDeps
73 seen' = root : seen ++ newDeps
74 builtIns = Map.keys Libs.libraries
77isNative name = takeWhile (/='.') name == "Native"
79toFilePath :: String -> FilePath
80toFilePath name = map swapDots name ++ ext
81 where swapDots '.' = '/'
82 swapDots c = c
83 ext = if isNative name then ".js" else ".elm"