git.iko.soy/elk
on c2eecc2 help sign in
elk/compiler/Initialize.hs
110 lines 4.3 kB history raw
1module Initialize (buildFromSource, getSortedDependencies) where
3import Data.Data
4import Control.Monad.State
5import qualified Data.Graph as Graph
6import qualified Data.List as List
7import qualified Data.Map as Map
8import qualified Data.Set as Set
9import System.Exit
10import System.FilePath as FP
11import Text.PrettyPrint (Doc)
13import SourceSyntax.Everything
14import qualified SourceSyntax.Type as Type
15import qualified Parse.Parse as Parse
16import qualified Metadata.Prelude as Prelude
17import qualified Transform.Check as Check
18import qualified Transform.SortDefinitions as SD
19import qualified Type.Inference as TI
20import qualified Type.Constrain.Declaration as TcDecl
21import qualified Transform.Canonicalize as Canonical
23buildFromSource :: Bool -> Interfaces -> String -> Either [Doc] (MetadataModule () ())
24buildFromSource noPrelude interfaces source =
25 do let add = if noPrelude then id else Prelude.add
26 infixes = Map.fromList . map (\(assoc,lvl,op) -> (op,(lvl,assoc)))
27 . concatMap iFixities $ Map.elems interfaces
29 modul@(Module _ _ _ decls') <- add `fmap` Parse.program infixes source
31 -- check for structural errors
32 Module names exs ims decls <-
33 case Check.mistakes decls' of
34 [] -> return modul
35 ms -> Left ms
37 let exports'
38 | null exs =
39 let get = Set.toList . SD.boundVars in
40 concat [ get pattern | Definition (Def pattern _) <- decls ] ++
41 concat [ map fst ctors | Datatype _ _ ctors <- decls ] ++
42 [ name | TypeAlias name _ (Type.Record _ _) <- decls ]
43 | otherwise = exs
45 metaModule <- Canonical.metadataModule interfaces $ MetadataModule {
46 names = names,
47 path = FP.joinPath names,
48 exports = exports',
49 imports = ims,
50 -- reorder AST into strongly connected components
51 program = SD.sortDefs . dummyLet $ TcDecl.toExpr decls,
52 types = Map.empty,
53 datatypes = [ (name,vars,ctors) | Datatype name vars ctors <- decls ],
54 fixities = [ (assoc,level,op) | Fixity assoc level op <- decls ],
55 aliases = [ (name,tvs,tipe) | TypeAlias name tvs tipe <- decls ],
56 foreignImports = [ (evt,v,name,typ) | ImportEvent evt v name typ <- decls ],
57 foreignExports = [ (evt,name,typ) | ExportEvent evt name typ <- decls ]
58 }
60 types <- TI.infer interfaces metaModule
62 return $ metaModule { types = types }
65getSortedDependencies :: Bool -> FilePath -> IO [String]
66getSortedDependencies noPrelude root =
67 sortDeps =<< readDeps noPrelude root
69type Deps = (FilePath, String, [String])
71sortDeps :: [Deps] -> IO [String]
72sortDeps depends =
73 if null mistakes
74 then return (concat sccs)
75 else print msg >> mapM print mistakes >> exitFailure
76 where
77 sccs = map Graph.flattenSCC $ Graph.stronglyConnComp depends
79 mistakes = filter (\scc -> length scc > 1) sccs
80 msg = "A cyclical module dependency or was detected in: "
82readDeps :: Bool -> FilePath -> IO [Deps]
83readDeps noPrelude root = evalStateT (go root) Set.empty
84 where
85 builtIns = if noPrelude then Set.empty
86 else Set.fromList (Map.keys Prelude.interfaces)
88 go :: FilePath -> StateT (Set.Set String) IO [Deps]
89 go root = do
90 txt <- liftIO $ readFile root
91 case Parse.dependencies txt of
92 Left err -> liftIO (putStrLn msg >> print err >> exitFailure)
93 where msg = "Error resolving dependencies in " ++ root ++ ":"
95 Right (name,deps) ->
96 do seen <- get
97 let realDeps = Set.difference (Set.fromList deps) builtIns
98 newDeps = Set.difference (Set.filter (not . isNative) realDeps) seen
99 put (Set.insert name (Set.union newDeps seen))
100 rest <- mapM (go . toFilePath) (Set.toList newDeps)
101 return ((makeRelative "." root, name, Set.toList realDeps) : concat rest)
104isNative name = List.isPrefixOf "Native." name
106toFilePath :: String -> FilePath
107toFilePath name = map swapDots name ++ ext
108 where swapDots '.' = '/'
109 swapDots c = c
110 ext = if isNative name then ".js" else ".elm"