2013-07-21 20:50:48 +00:00
|
|
|
module Initialize (buildFromSource, getSortedModuleNames, Interfaces) where
|
2012-05-29 18:25:43 +00:00
|
|
|
|
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-07-19 16:05:31 +00:00
|
|
|
import qualified Data.Graph as Graph
|
|
|
|
import qualified Data.List as List
|
2013-07-16 12:52:50 +00:00
|
|
|
import System.Exit
|
2013-07-16 19:43:56 +00:00
|
|
|
import System.FilePath as FP
|
2013-07-20 16:52:43 +00:00
|
|
|
import Text.PrettyPrint (Doc)
|
2013-07-16 12:52:50 +00:00
|
|
|
|
|
|
|
import SourceSyntax.Everything
|
2013-07-20 22:15:35 +00:00
|
|
|
import SourceSyntax.Type
|
2013-07-16 19:43:56 +00:00
|
|
|
import qualified Parse.Parse as Parse
|
2013-06-14 05:45:08 +00:00
|
|
|
import qualified Metadata.Libraries as Libs
|
2013-07-14 23:06:00 +00:00
|
|
|
import qualified Transform.Check as Check
|
2013-07-16 19:43:56 +00:00
|
|
|
import qualified Transform.SortDefinitions as SD
|
2013-07-16 12:52:50 +00:00
|
|
|
import qualified Type.Inference as TI
|
2013-07-16 19:43:56 +00:00
|
|
|
import qualified Type.Constrain.Declaration as TcDecl
|
2012-05-29 18:25:43 +00:00
|
|
|
|
2013-07-21 20:50:48 +00:00
|
|
|
import System.IO.Unsafe
|
2013-07-22 12:41:55 +00:00
|
|
|
import SourceSyntax.PrettyPrint
|
2013-07-20 22:15:35 +00:00
|
|
|
|
2013-07-22 12:41:55 +00:00
|
|
|
buildFromSource :: Interfaces -> String -> Either [Doc] (MetadataModule () ())
|
2013-07-21 20:50:48 +00:00
|
|
|
buildFromSource interfaces source =
|
2013-07-20 22:15:35 +00:00
|
|
|
do modul@(Module _ _ _ decls') <- Parse.program source
|
2013-07-11 10:48:37 +00:00
|
|
|
|
2013-07-16 19:43:56 +00:00
|
|
|
-- check for structural errors
|
2013-07-20 16:52:43 +00:00
|
|
|
Module names exs ims decls <-
|
2013-07-20 22:15:35 +00:00
|
|
|
case Check.mistakes decls' of
|
2013-07-20 16:52:43 +00:00
|
|
|
[] -> return modul
|
|
|
|
ms -> Left ms
|
2013-07-19 16:05:31 +00:00
|
|
|
|
2013-07-16 19:43:56 +00:00
|
|
|
let metaModule = MetadataModule {
|
|
|
|
names = names,
|
|
|
|
path = FP.joinPath names,
|
|
|
|
exports = exs,
|
|
|
|
imports = ims,
|
2013-07-19 16:05:31 +00:00
|
|
|
-- reorder AST into strongly connected components
|
|
|
|
program = SD.sortDefs . dummyLet $ TcDecl.toExpr decls,
|
2013-07-16 19:43:56 +00:00
|
|
|
types = Map.empty,
|
2013-07-25 18:19:50 +00:00
|
|
|
datatypes = [ (name,vars,ctors) | Datatype name vars ctors <- decls ],
|
2013-07-16 19:43:56 +00:00
|
|
|
fixities = [ (assoc,level,op) | Fixity assoc level op <- decls ],
|
|
|
|
aliases = [ (name,tvs,tipe) | TypeAlias name tvs tipe <- decls ],
|
|
|
|
foreignImports = [ (evt,v,name,typ) | ImportEvent evt v name typ <- decls ],
|
|
|
|
foreignExports = [ (evt,name,typ) | ExportEvent evt name typ <- decls ]
|
|
|
|
}
|
2013-02-08 09:33:21 +00:00
|
|
|
|
2013-07-21 20:50:48 +00:00
|
|
|
types <- TI.infer interfaces metaModule
|
2013-07-19 16:05:31 +00:00
|
|
|
|
2013-07-20 16:52:43 +00:00
|
|
|
return $ metaModule { types = 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-07-19 16:05:31 +00:00
|
|
|
sortDeps depends =
|
|
|
|
if null mistakes
|
|
|
|
then return (concat sccs)
|
2013-07-20 22:15:35 +00:00
|
|
|
else print msg >> mapM print mistakes >> exitFailure
|
2013-07-19 16:05:31 +00:00
|
|
|
where
|
|
|
|
graph = map (\(name, deps) -> (toFilePath name, name, deps)) depends
|
|
|
|
sccs = map Graph.flattenSCC $ Graph.stronglyConnComp graph
|
|
|
|
|
|
|
|
mistakes = filter (\scc -> length scc > 1) sccs
|
|
|
|
msg = "A cyclical module dependency or was detected in: "
|
2013-02-27 07:33:47 +00:00
|
|
|
|
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-07-16 19:43:56 +00:00
|
|
|
case Parse.dependencies txt of
|
|
|
|
Left err -> putStrLn msg >> print err >> exitFailure
|
|
|
|
where msg = "Error resolving dependencies in " ++ root ++ ":"
|
|
|
|
|
2013-06-05 07:44:04 +00:00
|
|
|
Right (name,deps) ->
|
|
|
|
do rest <- mapM (readDeps seen' . toFilePath) newDeps
|
|
|
|
return ((name, realDeps) : concat rest)
|
|
|
|
where
|
|
|
|
realDeps = filter (`notElem` builtIns) deps
|
2013-07-19 16:05:31 +00:00
|
|
|
newDeps = filter (\d -> not (d `elem` seen || isNative d)) realDeps
|
2013-06-05 07:44:04 +00:00
|
|
|
seen' = root : seen ++ newDeps
|
|
|
|
builtIns = Map.keys Libs.libraries
|
|
|
|
|
2013-02-27 07:33:47 +00:00
|
|
|
|
2013-07-19 16:05:31 +00:00
|
|
|
isNative name = List.isPrefixOf "Native." name
|
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"
|