git.iko.soy/elk
on master help sign in
Detect native files, build into resulting programs
31ca14dEvan Czaplicki
compiler/Build/Dependencies.hs+64−42
compare with master
unifiedsplit
@@ -1,55 +1,57 @@
1{-# OPTIONS_GHC -W #-}
1{-# OPTIONS_GHC -W #-}
2−module Build.Dependencies (getSortedDependencies, readDeps) where
2+module Build.Dependencies (Recipe(..), getBuildRecipe, readDeps) where
3
3
4−import Control.Applicative
5import Control.Monad.Error
4import Control.Monad.Error
6import qualified Control.Monad.State as State
5import qualified Control.Monad.State as State
7−import qualified Data.Aeson as Json
8−import qualified Data.ByteString.Lazy.Char8 as BSC
9import qualified Data.Graph as Graph
6import qualified Data.Graph as Graph
10import qualified Data.List as List
7import qualified Data.List as List
11import qualified Data.Map as Map
8import qualified Data.Map as Map
12−import qualified Data.Maybe as Maybe
13import qualified Data.Set as Set
9import qualified Data.Set as Set
14import System.Directory
10import System.Directory
15import System.FilePath as FP
11import System.FilePath as FP
16
12
17−import Build.Print (failure)
18−
19import qualified SourceSyntax.Module as Module
13import qualified SourceSyntax.Module as Module
20import qualified Parse.Parse as Parse
14import qualified Parse.Parse as Parse
21import qualified Elm.Internal.Paths as Path
15import qualified Elm.Internal.Paths as Path
22import qualified Elm.Internal.Name as N
16import qualified Elm.Internal.Name as N
17+import qualified Elm.Internal.Version as V
23import qualified Elm.Internal.Dependencies as Deps
18import qualified Elm.Internal.Dependencies as Deps
24
19
20+data Recipe = Recipe
21+ { _elmFiles :: [FilePath]
22+ , _jsFiles :: [FilePath]
23+ }
24+
25−getSortedDependencies :: [FilePath] -> Module.Interfaces -> FilePath -> IO [String]
25+getBuildRecipe :: [FilePath] -> Module.Interfaces -> FilePath -> ErrorT String IO Recipe
26−getSortedDependencies srcDirs builtIns root =
26+getBuildRecipe srcDirs builtIns root =
27− do extras <- extraDependencies
27+ do directories <- getDependencies
28+ jsFiles <- nativeFiles ("." : directories)
28− let allSrcDirs = srcDirs ++ Maybe.fromMaybe [] extras
29+ let allSrcDirs = srcDirs ++ directories
29− result <- runErrorT $ readAllDeps allSrcDirs builtIns root
30+ nodes <- collectDependencies allSrcDirs builtIns root
30− case result of
31+ elmFiles <- sortElmFiles nodes
31− Right deps -> sortDeps deps
32+ return (Recipe elmFiles jsFiles)
32− Left err -> failure err
33+
33−
34+-- | Based on the projects elm_dependencies.json, find all of the paths and
34−extraDependencies :: IO (Maybe [FilePath])
35+-- dependency information we might need.
35−extraDependencies =
36+getDependencies :: ErrorT String IO [FilePath]
37+getDependencies =
36− do exists <- doesFileExist Path.dependencyFile
38+ do exists <- liftIO $ doesFileExist Path.dependencyFile
37− if not exists then return Nothing else Just <$> getPaths
39+ if not exists then return [] else getPaths
38 where
40 where
39− getPaths = do
41+ getPaths :: ErrorT String IO [FilePath]
40− raw <- BSC.readFile Path.dependencyFile
42+ getPaths =
41− case Json.eitherDecode raw of
43+ Deps.withDeps Path.dependencyFile $ \deps ->
42− Right (Deps.Mini deps) -> mapM validate deps
44+ mapM getPath (Deps.dependencies deps)
43− Left err ->
45+
44− failure $ "Error reading the " ++ Path.dependencyFile ++ " file:\n" ++ err
46+ getPath :: (N.Name, V.Version) -> ErrorT String IO FilePath
45−
46− validate (name,version) = do
47+ getPath (name,version) = do
47− let path = Path.dependencyDirectory </> toPath name version
48+ let path = Path.dependencyDirectory </> N.toFilePath name </> show version
48− exists <- doesDirectoryExist path
49+ exists <- liftIO $ doesDirectoryExist path
50+ if exists
51+ then return path
49− if exists then return path else failure (notFound name version)
52+ else throwError (notFound name version)
50−
53+
51− toPath name version = N.toFilePath name </> show version
54+ notFound :: N.Name -> V.Version -> String
52−
53 notFound name version =
55 notFound name version =
54 unlines
56 unlines
55 [ "Your " ++ Path.dependencyFile ++ " file says you depend on library"
57 [ "Your " ++ Path.dependencyFile ++ " file says you depend on library"
@@ -58,27 +60,47 @@ extraDependencies =
58 , ""
60 , ""
59 , " elm-get install " ++ show name ++ " " ++ show version ]
61 , " elm-get install " ++ show name ++ " " ++ show version ]
60
62
63+nativeFiles :: [FilePath] -> ErrorT String IO [FilePath]
64+nativeFiles directories =
65+ concat `fmap` mapM getNativeFiles directories
66+ where
67+ getNativeFiles dir =
68+ Deps.withDeps (dir </> Path.dependencyFile) $ \deps ->
69+ return (map (toPath dir) (Deps.native deps))
70+
71+ toPath dir moduleName =
72+ dir </> joinPath (split moduleName) <.> "js"
73+
74+split :: String -> [String]
75+split moduleName = go [] moduleName
76+ where
77+ go paths str =
78+ case break (=='.') str of
79+ (path, _:rest) -> go (paths ++ [path]) rest
80+ (path, []) -> paths ++ [path]
81+
61−type Deps = (FilePath, String, [String])
82+type DependencyNode = (FilePath, String, [String])
62
83
63−sortDeps :: [Deps] -> IO [String]
84+sortElmFiles :: [DependencyNode] -> ErrorT String IO [FilePath]
64−sortDeps depends =
85+sortElmFiles depends =
65 if null mistakes
86 if null mistakes
66 then return (concat sccs)
87 then return (concat sccs)
67− else failure $ msg ++ unlines (map show mistakes)
88+ else throwError $ msg ++ unlines (map show mistakes)
68 where
89 where
69 sccs = map Graph.flattenSCC $ Graph.stronglyConnComp depends
90 sccs = map Graph.flattenSCC $ Graph.stronglyConnComp depends
70
91
71 mistakes = filter (\scc -> length scc > 1) sccs
92 mistakes = filter (\scc -> length scc > 1) sccs
72 msg = "A cyclical module dependency or was detected in:\n"
93 msg = "A cyclical module dependency or was detected in:\n"
73
94
74−readAllDeps :: [FilePath] -> Module.Interfaces -> FilePath -> ErrorT String IO [Deps]
95+collectDependencies :: [FilePath] -> Module.Interfaces -> FilePath
96+ -> ErrorT String IO [DependencyNode]
75−readAllDeps srcDirs rawBuiltIns filePath =
97+collectDependencies srcDirs rawBuiltIns filePath =
76 State.evalStateT (go Nothing filePath) Set.empty
98 State.evalStateT (go Nothing filePath) Set.empty
77 where
99 where
78 builtIns :: Set.Set String
100 builtIns :: Set.Set String
79 builtIns = Set.fromList $ Map.keys rawBuiltIns
101 builtIns = Set.fromList $ Map.keys rawBuiltIns
80
102
81− go :: Maybe String -> FilePath -> State.StateT (Set.Set String) (ErrorT String IO) [Deps]
103+ go :: Maybe String -> FilePath -> State.StateT (Set.Set String) (ErrorT String IO) [DependencyNode]
82 go parentModuleName filePath = do
104 go parentModuleName filePath = do
83 filePath' <- lift $ findSrcFile parentModuleName srcDirs filePath
105 filePath' <- lift $ findSrcFile parentModuleName srcDirs filePath
84 (moduleName, deps) <- lift $ readDeps filePath'
106 (moduleName, deps) <- lift $ readDeps filePath'
@@ -93,9 +115,9 @@ readDeps :: FilePath -> ErrorT String IO (String, [String])
93readDeps path = do
115readDeps path = do
94 txt <- lift $ readFile path
116 txt <- lift $ readFile path
95 case Parse.dependencies txt of
117 case Parse.dependencies txt of
118+ Right o -> return o
96 Left err -> throwError $ msg ++ show err
119 Left err -> throwError $ msg ++ show err
97 where msg = "Error resolving dependencies in " ++ path ++ ":\n"
120 where msg = "Error resolving dependencies in " ++ path ++ ":\n"
98− Right o -> return o
99
121
100findSrcFile :: Maybe String -> [FilePath] -> FilePath -> ErrorT String IO FilePath
122findSrcFile :: Maybe String -> [FilePath] -> FilePath -> ErrorT String IO FilePath
101findSrcFile parentModuleName dirs path =
123findSrcFile parentModuleName dirs path =
compiler/Build/Utils.hs+9
@@ -1,10 +1,12 @@
1{-# OPTIONS_GHC -W #-}
1{-# OPTIONS_GHC -W #-}
2module Build.Utils where
2module Build.Utils where
3
3
4+import Control.Monad.Error
4import System.Directory (doesFileExist)
5import System.Directory (doesFileExist)
5import System.Environment (getEnv)
6import System.Environment (getEnv)
6import System.FilePath ((</>), replaceExtension)
7import System.FilePath ((</>), replaceExtension)
7import qualified Build.Flags as Flag
8import qualified Build.Flags as Flag
9+import qualified Build.Print as Print
8import qualified Paths_Elm as This
10import qualified Paths_Elm as This
9
11
10buildPath :: Flag.Flags -> FilePath -> String -> FilePath
12buildPath :: Flag.Flags -> FilePath -> String -> FilePath
@@ -33,3 +35,10 @@ getDataFile name = do
33 else do
35 else do
34 env <- getEnv "ELM_HOME"
36 env <- getEnv "ELM_HOME"
35 return (env </> name)
37 return (env </> name)
38+
39+run :: ErrorT String IO a -> IO a
40+run command = do
41+ either <- runErrorT command
42+ case either of
43+ Left err -> Print.failure err
44+ Right result -> return result
compiler/Compiler.hs+9−7
@@ -10,7 +10,7 @@ import System.Directory
10import System.FilePath
10import System.FilePath
11import GHC.Conc
11import GHC.Conc
12
12
13−import Build.Dependencies (getSortedDependencies)
13+import Build.Dependencies (getBuildRecipe, Recipe(..))
14import qualified Generate.Html as Html
14import qualified Generate.Html as Html
15import qualified Metadata.Prelude as Prelude
15import qualified Metadata.Prelude as Prelude
16import qualified Build.Utils as Utils
16import qualified Build.Utils as Utils
@@ -33,13 +33,15 @@ build flags rootFile =
33 do let noPrelude = Flag.no_prelude flags
33 do let noPrelude = Flag.no_prelude flags
34 builtIns <- Prelude.interfaces noPrelude
34 builtIns <- Prelude.interfaces noPrelude
35
35
36+ (Recipe elmFiles jsFiles) <-
36− files <- if Flag.make flags
37+ if Flag.make flags
37− then getSortedDependencies (Flag.src_dir flags) builtIns rootFile
38+ then Utils.run (getBuildRecipe (Flag.src_dir flags) builtIns rootFile)
38− else return [rootFile]
39+ else return (Recipe [rootFile] [])
39
40
40− moduleName <- File.build flags builtIns files
41+ moduleName <- File.build flags builtIns elmFiles
41
42
43+ let elmos = map (Utils.elmo flags) elmFiles
42− js <- foldM appendToOutput BS.empty files
44+ js <- foldM appendToOutput BS.empty (elmos ++ jsFiles)
43
45
44 (extension, code) <-
46 (extension, code) <-
45 if Flag.only_js flags
47 if Flag.only_js flags
@@ -56,7 +58,7 @@ build flags rootFile =
56 where
58 where
57 appendToOutput :: BS.ByteString -> FilePath -> IO BS.ByteString
59 appendToOutput :: BS.ByteString -> FilePath -> IO BS.ByteString
58 appendToOutput js filePath = do
60 appendToOutput js filePath = do
59− src <- BS.readFile (Utils.elmo flags filePath)
61+ src <- BS.readFile filePath
60 return (BS.append src js)
62 return (BS.append src js)
61
63
62 sources js = map Html.Link (Flag.scripts flags) ++ [ Html.Source js ]
64 sources js = map Html.Link (Flag.scripts flags) ++ [ Html.Source js ]
compiler/Elm/Internal/Dependencies.hs+4−14
@@ -31,16 +31,6 @@ data Deps = Deps
31 , dependencies :: [(N.Name,V.Version)]
31 , dependencies :: [(N.Name,V.Version)]
32 } deriving (Show, Eq, Ord)
32 } deriving (Show, Eq, Ord)
33
33
34−data MiniDeps = Mini [(N.Name,V.Version)]
35− deriving (Show, Eq, Ord)
36−
37−instance ToJSON MiniDeps where
38− toJSON (Mini m) = toJSON m
39−
40−instance FromJSON MiniDeps where
41− parseJSON (Object obj) = Mini <$> getDependencies obj
42− parseJSON _ = mzero
43−
44instance ToJSON Deps where
34instance ToJSON Deps where
45 toJSON d =
35 toJSON d =
46 object $
36 object $
@@ -128,12 +118,12 @@ repoToName repo
128 \like <https://github.com/USER/PROJECT.git> where USER is your GitHub name\n\
118 \like <https://github.com/USER/PROJECT.git> where USER is your GitHub name\n\
129 \and PROJECT is the repo you want to upload."
119 \and PROJECT is the repo you want to upload."
130
120
131−withDeps :: (Deps -> a) -> FilePath -> ErrorT String IO a
121+withDeps :: FilePath -> (Deps -> ErrorT String IO a) -> ErrorT String IO a
132−withDeps handle path =
122+withDeps path handle =
133 do json <- readPath
123 do json <- readPath
134 case eitherDecode json of
124 case eitherDecode json of
135 Left err -> throwError $ "Error reading file " ++ path ++ ":\n " ++ err
125 Left err -> throwError $ "Error reading file " ++ path ++ ":\n " ++ err
136− Right ds -> return (handle ds)
126+ Right ds -> handle ds
137 where
127 where
138 readPath :: ErrorT String IO BS.ByteString
128 readPath :: ErrorT String IO BS.ByteString
139 readPath = do
129 readPath = do
@@ -147,7 +137,7 @@ withDeps handle path =
147 " <https://github.com/evancz/automaton/blob/master/elm_dependencies.json>"
137 " <https://github.com/evancz/automaton/blob/master/elm_dependencies.json>"
148
138
149depsAt :: FilePath -> ErrorT String IO Deps
139depsAt :: FilePath -> ErrorT String IO Deps
150−depsAt = withDeps id
140+depsAt filePath = withDeps filePath return
151
141
152-- | Encode dependencies in a canonical JSON format
142-- | Encode dependencies in a canonical JSON format
153prettyJSON :: Deps -> BS.ByteString
143prettyJSON :: Deps -> BS.ByteString