2013-06-05 07:44:04 +00:00
|
|
|
module Initialize (buildFromSource, getSortedModuleNames) where
|
2012-05-29 18:25:43 +00:00
|
|
|
|
2012-08-01 23:37:37 +00:00
|
|
|
import Control.Applicative ((<$>))
|
2012-06-12 06:28:45 +00:00
|
|
|
import Control.Monad.Error
|
2013-07-16 12:52:50 +00:00
|
|
|
import Data.List (nub)
|
2013-04-03 17:27:23 +00:00
|
|
|
import qualified Data.Map as Map
|
2013-06-15 02:23:58 +00:00
|
|
|
import Data.Data
|
2013-02-08 09:33:21 +00:00
|
|
|
import Data.List (intercalate,partition)
|
2013-07-16 12:52:50 +00:00
|
|
|
import System.Exit
|
|
|
|
import System.FilePath
|
|
|
|
import Text.PrettyPrint (Doc)
|
|
|
|
|
2013-06-05 21:22:11 +00:00
|
|
|
import Parse.Parser (parseProgram, parseDependencies)
|
2013-07-16 12:52:50 +00:00
|
|
|
import SourceSyntax.Everything
|
2013-06-14 05:45:08 +00:00
|
|
|
import qualified Metadata.Libraries as Libs
|
2013-07-15 22:40:11 +00:00
|
|
|
import qualified Transform.Optimize as Optimize
|
2013-07-14 23:06:00 +00:00
|
|
|
import qualified Transform.Check as Check
|
2013-07-16 12:52:50 +00:00
|
|
|
import qualified Type.Inference as TI
|
|
|
|
import qualified Type.Type as T
|
2012-05-29 18:25:43 +00:00
|
|
|
|
2013-07-11 10:48:37 +00:00
|
|
|
|
|
|
|
|
2013-07-16 12:52:50 +00:00
|
|
|
checkMistakes :: (Data t, Data v) => Module t v -> Either [Doc] (Module t v)
|
2013-07-14 23:06:00 +00:00
|
|
|
checkMistakes modul@(Module name ex im decls) =
|
|
|
|
case Check.mistakes decls of
|
2013-07-15 22:40:11 +00:00
|
|
|
[] -> return modul
|
2013-07-16 12:52:50 +00:00
|
|
|
ms -> Left ms
|
|
|
|
|
|
|
|
-- subs `seq` return (Optimize.optimize (renameModule modul))
|
2013-02-08 09:33:21 +00:00
|
|
|
|
2013-07-16 12:52:50 +00:00
|
|
|
buildFromSource :: (Data t, Data v) => Bool -> String -> Either [Doc] (Module t v, Map.Map String T.Variable)
|
|
|
|
buildFromSource noPrelude src = do
|
|
|
|
modul <- parseProgram src
|
2013-02-08 09:33:21 +00:00
|
|
|
|
2013-07-16 12:52:50 +00:00
|
|
|
-- check for structural errors and give all variables unique names
|
|
|
|
modul' <- renameModule <$> checkMistakes modul
|
|
|
|
-- reorder AST into strongly connected components
|
2013-02-08 09:33:21 +00:00
|
|
|
|
2013-07-16 12:52:50 +00:00
|
|
|
types <- TI.infer modul'
|
|
|
|
return (modul', types)
|
2013-02-08 09:33:21 +00:00
|
|
|
|
2013-06-05 07:44:04 +00:00
|
|
|
getSortedModuleNames :: FilePath -> IO [String]
|
|
|
|
getSortedModuleNames root =
|
|
|
|
sortDeps =<< readDeps [] root
|
2013-02-08 09:33:21 +00:00
|
|
|
|
2013-02-27 07:33:47 +00:00
|
|
|
type Deps = (String, [String])
|
|
|
|
|
2013-06-05 07:44:04 +00:00
|
|
|
sortDeps :: [Deps] -> IO [String]
|
2013-02-27 07:33:47 +00:00
|
|
|
sortDeps deps = go [] (nub deps)
|
2013-02-08 09:33:21 +00:00
|
|
|
where
|
|
|
|
msg = "A cyclical or missing module dependency or was detected in: "
|
|
|
|
|
2013-06-05 07:44:04 +00:00
|
|
|
go :: [String] -> [Deps] -> IO [String]
|
|
|
|
go sorted [] = return (map toFilePath sorted)
|
2013-02-08 09:33:21 +00:00
|
|
|
go sorted unsorted =
|
2013-02-27 07:33:47 +00:00
|
|
|
case partition (all (`elem` sorted) . snd) unsorted of
|
2013-06-05 07:44:04 +00:00
|
|
|
([],m:ms) -> do putStrLn (msg ++ intercalate ", " (map fst (m:ms)) ++ show sorted ++ show unsorted)
|
|
|
|
exitFailure
|
2013-02-27 07:33:47 +00:00
|
|
|
(srtd,unsrtd) -> go (sorted ++ map fst srtd) unsrtd
|
|
|
|
|
2013-06-05 07:44:04 +00:00
|
|
|
readDeps :: [FilePath] -> FilePath -> IO [Deps]
|
2013-02-27 07:33:47 +00:00
|
|
|
readDeps seen root = do
|
|
|
|
txt <- readFile root
|
2013-06-05 21:22:11 +00:00
|
|
|
case parseDependencies txt of
|
2013-06-05 07:44:04 +00:00
|
|
|
Left err ->
|
|
|
|
let msg = "Error resolving dependencies in " ++ root ++ ":\n" in
|
|
|
|
putStrLn (msg ++ err) >> exitFailure
|
|
|
|
Right (name,deps) ->
|
|
|
|
do rest <- mapM (readDeps seen' . toFilePath) newDeps
|
|
|
|
return ((name, realDeps) : concat rest)
|
|
|
|
where
|
|
|
|
realDeps = filter (`notElem` builtIns) deps
|
|
|
|
newDeps = filter (\d -> d `notElem` seen && not (isNative d)) realDeps
|
|
|
|
seen' = root : seen ++ newDeps
|
|
|
|
builtIns = Map.keys Libs.libraries
|
|
|
|
|
2013-02-27 07:33:47 +00:00
|
|
|
|
|
|
|
isNative name = takeWhile (/='.') name == "Native"
|
2013-06-05 07:44:04 +00:00
|
|
|
|
|
|
|
toFilePath :: String -> FilePath
|
2013-02-27 07:33:47 +00:00
|
|
|
toFilePath name = map swapDots name ++ ext
|
|
|
|
where swapDots '.' = '/'
|
|
|
|
swapDots c = c
|
|
|
|
ext = if isNative name then ".js" else ".elm"
|