git.iko.soy/elk
on aa7a67f help sign in
elk/compiler/Initialize.hs
105 lines 3.9 kB history raw
1module Initialize (build, buildFromSource) where
3import Control.Applicative ((<$>))
4import Control.Monad.Error
5import Data.List (lookup,nub)
7import Ast
8import Data.Either (lefts,rights)
9import Data.List (intercalate,partition)
10import Parse.Parser (parseProgram, preParse)
11import Rename
12import Types.Types ((-:))
13import Types.Hints (hints)
14import Types.Unify
15import Types.Alias
16import Optimize
17import CompileToJS (jsModule)
19checkMistakes :: Module -> Either String Module
20checkMistakes modul@(Module name ex im stmts) =
21 case mistakes stmts of
22 m:ms -> Left (unlines (m:ms))
23 [] -> return modul
25checkTypes :: Module -> Either String Module
26checkTypes (Module name ex im stmts) =
27 let stmts' = dealias stmts
28 modul = Module name ex im stmts'
29 in do subs <- unify hints modul
30 let --im' | any ((=="Prelude") . fst) im = im
31 -- | otherwise = ("Prelude", Importing []) : im
32 modul' = optimize . renameModule $ Module name ex im stmts'
33 subs `seq` return modul'
35check :: Module -> Either String Module
36check = checkMistakes >=> checkTypes
38buildFromSource :: String -> Either String Module
39buildFromSource src = check =<< parseProgram src
41build :: FilePath -> IO (Either String [Module])
42build root = do
43 names <- getSortedModuleNames root
44 case names of
45 Left err -> return (Left err)
46 Right ns -> do srcs <- zipWithM buildFile' [1..] ns
47 return (sequence srcs)
48 where
49 buildFile' n name = putStrLn (msg n name) >> buildFile name
50 msg n name = "["++show n++" of "++show (length ns)++"] Compiling "++name
52buildFile :: String -> IO (Either String Module)
53buildFile moduleName =
54 let filePath = toFilePath moduleName in
55 case isNative moduleName of
56 True -> return (Right $ Module [moduleName] [] [] [])
57 --return (Left "Can't do that yet")
58 --Right `liftM` readFile filePath
59 False -> do txt <- readFile filePath
60 return $ buildFromSource txt
63getSortedModuleNames :: FilePath -> IO (Either String [String])
64getSortedModuleNames root = do
65 deps <- readDeps [] root
66 return (sortDeps =<< deps)
68type Deps = (String, [String])
70sortDeps :: [Deps] -> Either String [String]
71sortDeps deps = go [] (nub deps)
72 where
73 msg = "A cyclical or missing module dependency or was detected in: "
75 go :: [String] -> [Deps] -> Either String [String]
76 go sorted [] = Right sorted
77 go sorted unsorted =
78 case partition (all (`elem` sorted) . snd) unsorted of
79 ([],m:ms) -> Left (msg ++ intercalate ", " (map fst (m:ms)) ++ show sorted ++ show unsorted)
80 (srtd,unsrtd) -> go (sorted ++ map fst srtd) unsrtd
82readDeps :: [FilePath] -> FilePath -> IO (Either String [Deps])
83readDeps seen root = do
84 txt <- readFile root
85 case preParse txt of
86 Left err -> return (Left err)
87 Right (name,deps) -> do rest <- mapM (readDeps seen' . toFilePath) newDeps
88 return $ do rs <- sequence rest
89 return ((name, realDeps) : concat rs)
90 where realDeps = filter (`notElem` builtIns) deps
91 newDeps = filter (`notElem` seen) realDeps
92 seen' = root : seen ++ newDeps
93 builtIns = [] {--
94 ["List","Char","Either","Maybe","Dict","Set","Date",
95 "Signal","Mouse","Keyboard.Raw","Keyboard","Touch",
96 "WebSocket","Window","Time","HTTP","Input","Random",
97 "Graphics","Text","Color","JavaScript","Automaton",
98 "JavaScript.Experimental","Prelude","JSON"]
99 --}
101isNative name = takeWhile (/='.') name == "Native"
102toFilePath name = map swapDots name ++ ext
103 where swapDots '.' = '/'
104 swapDots c = c
105 ext = if isNative name then ".js" else ".elm"