git.iko.soy/elk
on 104faf1 help sign in
elk/compiler/Initialize.hs
97 lines 3.5 kB history raw
1module Initialize (build, buildFromSource) 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, preParse)
12import Rename
13import qualified Libraries as Libs
14import Types.Types ((-:))
15import Types.Hints (hints)
16import Types.Unify
17import Types.Alias (dealias, mistakes)
18import Optimize
19import CompileToJS (jsModule)
21checkMistakes :: Module -> Either String Module
22checkMistakes modul@(Module name ex im stmts) =
23 case mistakes stmts of
24 m:ms -> Left (unlines (m:ms))
25 [] -> return modul
27checkTypes :: Module -> Either String Module
28checkTypes modul =
29 do subs <- unify hints modul
30 subs `seq` return (optimize (renameModule modul))
32check :: Module -> Either String Module
33check = checkMistakes >=> checkTypes
35buildFromSource :: Bool -> String -> Either String Module
36buildFromSource withPrelude src = (check . add) =<< (parseProgram src)
37 where add = if withPrelude then Libs.addPrelude else id
39build :: Bool -> FilePath -> IO (Either String [Module])
40build withPrelude root = do
41 names <- getSortedModuleNames root
42 case names of
43 Left err -> return (Left err)
44 Right ns -> do srcs <- zipWithM buildFile' [1..] ns
45 return (sequence srcs)
46 where
47 buildFile' n name = putStrLn (msg n name) >> buildFile withPrelude name
48 msg n name = "["++show n++" of "++show (length ns)++"] Compiling "++name
50buildFile :: Bool -> String -> IO (Either String Module)
51buildFile withPrelude moduleName =
52 let filePath = toFilePath moduleName in
53 case isNative moduleName of
54 True -> return (Right $ Module [moduleName] [] [] [])
55 --return (Left "Can't do that yet")
56 --Right `liftM` readFile filePath
57 False -> do txt <- readFile filePath
58 return $ buildFromSource withPrelude txt
61getSortedModuleNames :: FilePath -> IO (Either String [String])
62getSortedModuleNames root = do
63 deps <- readDeps [] root
64 return (sortDeps =<< deps)
66type Deps = (String, [String])
68sortDeps :: [Deps] -> Either String [String]
69sortDeps deps = go [] (nub deps)
70 where
71 msg = "A cyclical or missing module dependency or was detected in: "
73 go :: [String] -> [Deps] -> Either String [String]
74 go sorted [] = Right sorted
75 go sorted unsorted =
76 case partition (all (`elem` sorted) . snd) unsorted of
77 ([],m:ms) -> Left (msg ++ intercalate ", " (map fst (m:ms)) ++ show sorted ++ show unsorted)
78 (srtd,unsrtd) -> go (sorted ++ map fst srtd) unsrtd
80readDeps :: [FilePath] -> FilePath -> IO (Either String [Deps])
81readDeps seen root = do
82 txt <- readFile root
83 case preParse txt of
84 Left err -> return (Left err)
85 Right (name,deps) -> do rest <- mapM (readDeps seen' . toFilePath) newDeps
86 return $ do rs <- sequence rest
87 return ((name, realDeps) : concat rs)
88 where realDeps = filter (`notElem` builtIns) deps
89 newDeps = filter (`notElem` seen) realDeps
90 seen' = root : seen ++ newDeps
91 builtIns = Map.keys Libs.libraries
93isNative name = takeWhile (/='.') name == "Native"
94toFilePath name = map swapDots name ++ ext
95 where swapDots '.' = '/'
96 swapDots c = c
97 ext = if isNative name then ".js" else ".elm"