git.iko.soy/elk
on master help sign in
Merge remote-tracking branch 'evan/dev' into arbitary-tipe
d647bfdJohn P Mayer Jr
compiler/Build/Dependencies.hs+46−42
compare with master
unifiedsplit
@@ -1,5 +1,5 @@
1{-# OPTIONS_GHC -W #-}
1{-# OPTIONS_GHC -W #-}
2−module Build.Dependencies (getSortedDependencies) where
2+module Build.Dependencies (getSortedDependencies, readDeps) where
3
3
4import Control.Applicative
4import Control.Applicative
5import Control.Monad.Error
5import Control.Monad.Error
@@ -12,9 +12,9 @@ import qualified Data.Map as Map
12import qualified Data.Maybe as Maybe
12import qualified Data.Maybe as Maybe
13import qualified Data.Set as Set
13import qualified Data.Set as Set
14import System.Directory
14import System.Directory
15−import System.Exit
16import System.FilePath as FP
15import System.FilePath as FP
17−import System.IO
16+
17+import Build.Print (failure)
18
18
19import qualified SourceSyntax.Module as Module
19import qualified SourceSyntax.Module as Module
20import qualified Parse.Parse as Parse
20import qualified Parse.Parse as Parse
@@ -26,7 +26,7 @@ getSortedDependencies :: [FilePath] -> Module.Interfaces -> FilePath -> IO [Stri
26getSortedDependencies srcDirs builtIns root =
26getSortedDependencies srcDirs builtIns root =
27 do extras <- extraDependencies
27 do extras <- extraDependencies
28 let allSrcDirs = srcDirs ++ Maybe.fromMaybe [] extras
28 let allSrcDirs = srcDirs ++ Maybe.fromMaybe [] extras
29− result <- runErrorT $ readDeps allSrcDirs builtIns root
29+ result <- runErrorT $ readAllDeps allSrcDirs builtIns root
30 case result of
30 case result of
31 Right deps -> sortDeps deps
31 Right deps -> sortDeps deps
32 Left err -> failure $ err ++ if Maybe.isJust extras then "" else msg
32 Left err -> failure $ err ++ if Maybe.isJust extras then "" else msg
@@ -34,8 +34,6 @@ getSortedDependencies srcDirs builtIns root =
34 Path.dependencyFile ++
34 Path.dependencyFile ++
35 " file if you\nare trying to use a 3rd party library."
35 " file if you\nare trying to use a 3rd party library."
36
36
37−failure msg = hPutStrLn stderr msg >> exitFailure
38−
39extraDependencies :: IO (Maybe [FilePath])
37extraDependencies :: IO (Maybe [FilePath])
40extraDependencies =
38extraDependencies =
41 do exists <- doesFileExist Path.dependencyFile
39 do exists <- doesFileExist Path.dependencyFile
@@ -76,46 +74,52 @@ sortDeps depends =
76 mistakes = filter (\scc -> length scc > 1) sccs
74 mistakes = filter (\scc -> length scc > 1) sccs
77 msg = "A cyclical module dependency or was detected in:\n"
75 msg = "A cyclical module dependency or was detected in:\n"
78
76
79−readDeps :: [FilePath] -> Module.Interfaces -> FilePath -> ErrorT String IO [Deps]
77+readAllDeps :: [FilePath] -> Module.Interfaces -> FilePath -> ErrorT String IO [Deps]
80−readDeps srcDirs builtIns root = do
78+readAllDeps srcDirs builtIns root =
81− let ifaces = (Set.fromList . Map.keys) builtIns
79+ do let ifaces = (Set.fromList . Map.keys) builtIns
82− State.evalStateT (go ifaces root) Set.empty
80+ State.evalStateT (go ifaces root) Set.empty
83 where
81 where
84 go :: Set.Set String -> FilePath -> State.StateT (Set.Set String) (ErrorT String IO) [Deps]
82 go :: Set.Set String -> FilePath -> State.StateT (Set.Set String) (ErrorT String IO) [Deps]
85 go builtIns root = do
83 go builtIns root = do
86− (root', txt) <- lift $ getFile srcDirs root
84+ root' <- lift $ findSrcFile srcDirs root
87− case Parse.dependencies txt of
85+ (name, deps) <- lift $ readDeps root'
88− Left err -> throwError $ msg ++ show err
89− where msg = "Error resolving dependencies in " ++ root' ++ ":\n"
90−
91− Right (name,deps) ->
92− do seen <- State.get
86+ seen <- State.get
93− let realDeps = Set.difference (Set.fromList deps) builtIns
87+ let realDeps = Set.difference (Set.fromList deps) builtIns
94− newDeps = Set.difference (Set.filter (not . isNative) realDeps) seen
88+ newDeps = Set.difference (Set.filter (not . isNative) realDeps) seen
95− State.put (Set.insert name (Set.union newDeps seen))
89+ State.put (Set.insert name (Set.union newDeps seen))
96− rest <- mapM (go builtIns . toFilePath) (Set.toList newDeps)
90+ rest <- mapM (go builtIns . toFilePath) (Set.toList newDeps)
97− return ((makeRelative "." root', name, Set.toList realDeps) : concat rest)
91+ return ((makeRelative "." root', name, Set.toList realDeps) : concat rest)
98−
92+
93+readDeps :: FilePath -> ErrorT String IO (String, [String])
94+readDeps path = do
95+ txt <- lift $ readFile path
96+ case Parse.dependencies txt of
97+ Left err -> throwError $ msg ++ show err
98+ where msg = "Error resolving dependencies in " ++ path ++ ":\n"
99+ Right o -> return o
100+
99−getFile :: [FilePath] -> FilePath -> ErrorT String IO (FilePath,String)
101+findSrcFile :: [FilePath] -> FilePath -> ErrorT String IO FilePath
100−getFile [] path =
102+findSrcFile dirs path = foldr tryDir notFound dirs
103+ where
101− throwError $ unlines
104+ notFound = throwError $ unlines
102− [ "Could not find file: " ++ path
105+ [ "Could not find file: " ++ path
103− , " If it is not in the root directory of your project, use"
106+ , " If it is not in the root directory of your project, use"
104− , " --src-dir to declare additional locations for source files."
107+ , " --src-dir to declare additional locations for source files."
105− , " If it is part of a 3rd party library, it needs to be declared"
108+ , " If it is part of a 3rd party library, it needs to be declared"
106− , " as a dependency in the " ++ Path.dependencyFile ++ " file." ]
109+ , " as a dependency in the " ++ Path.dependencyFile ++ " file." ]
107−
110+ tryDir dir next = do
108−getFile (dir:dirs) path = do
109− let path' = dir </> path
111+ let path' = dir </> path
110− exists <- liftIO $ doesFileExist path'
112+ exists <- liftIO $ doesFileExist path'
111− case exists of
113+ if exists
112− True -> (,) path' `fmap` liftIO (readFile path')
114+ then return path'
113− False -> getFile dirs path
115+ else next
114−
116+
117+isNative :: String -> Bool
115isNative name = List.isPrefixOf "Native." name
118isNative name = List.isPrefixOf "Native." name
116
119
117toFilePath :: String -> FilePath
120toFilePath :: String -> FilePath
118toFilePath name = map swapDots name ++ ext
121toFilePath name = map swapDots name ++ ext
122+ where
119− where swapDots '.' = '/'
123+ swapDots '.' = '/'
120− swapDots c = c
124+ swapDots c = c
121− ext = if isNative name then ".js" else ".elm"
125+ ext = if isNative name then ".js" else ".elm"
compiler/Build/File.hs+129−78
@@ -1,92 +1,137 @@
1{-# OPTIONS_GHC -W #-}
1{-# OPTIONS_GHC -W #-}
2module Build.File (build) where
2module Build.File (build) where
3
3
4−import Control.Monad (when)
4+import Control.Applicative ((<$>))
5−import qualified Data.Binary as Binary
5+import Control.Monad.Error (runErrorT)
6−import qualified Data.Map as Map
6+import Control.Monad.RWS.Strict
7import System.Directory
7import System.Directory
8import System.Exit
8import System.Exit
9import System.FilePath
9import System.FilePath
10import System.IO
10import System.IO
11
11
12+import qualified Data.Binary as Binary
13+import qualified Data.Maybe as Maybe
14+import qualified Data.Map as Map
15+import qualified Data.ByteString.Lazy as L
16+
17+import qualified Build.Dependencies as Deps
18+import qualified Build.Flags as Flag
19+import qualified Build.Interface as Interface
20+import qualified Build.Print as Print
21+import qualified Build.Source as Source
22+import qualified Build.Utils as Utils
23+import qualified Generate.JavaScript as JS
24+import qualified Parse.Module as Parser
25+import qualified SourceSyntax.Module as M
12import qualified Transform.Canonicalize as Canonical
26import qualified Transform.Canonicalize as Canonical
13
27
14−import qualified Data.ByteString.Lazy as L
28+-- Reader: Runtime flags, always accessible
15−
29+-- Writer: Remember the last module to be accessed
16−import qualified Build.Utils as Utils
30+-- State: Build up a map of the module interfaces
17−import qualified Build.Flags as Flag
31+type BuildT m a = RWST Flag.Flags (Last String) BInterfaces m a
18−import qualified Build.Interface as Interface
32+type Build a = BuildT IO a
19−import qualified Build.Print as Print
33+
20−import qualified Build.Source as Source
34+-- Interfaces, remembering if something was recompiled
21−import qualified Generate.JavaScript as JS
35+type BInterfaces = Map.Map String (Bool, M.ModuleInterface)
22−import qualified Parse.Module as Parser
36+
23−import qualified SourceSyntax.Module as M
24−
25−build :: Flag.Flags -> Int -> M.Interfaces -> String -> [FilePath]
37+evalBuild :: Flag.Flags -> M.Interfaces -> Build () -> IO (Maybe String)
26− -> IO (String, M.Interfaces)
38+evalBuild flags interfaces b = do
27−build _ _ interfaces moduleName [] =
39+ (_, s) <- evalRWST b flags (fmap notUpdated interfaces)
28− return (moduleName, interfaces)
40+ return . getLast $ s
29−build flags numModules interfaces _ (filePath:rest) =
41+ where
30− do (name,interface) <-
42+ notUpdated i = (False, i)
31− build1 flags (numModules - length rest) numModules interfaces filePath
43+
32− let interfaces' = Map.insert name interface interfaces
44+-- | Builds a list of files, returning the moduleName of the last one.
33− build flags numModules interfaces' name rest
45+-- Returns \"\" if the list is empty
34−
46+build :: Flag.Flags -> M.Interfaces -> [FilePath] -> IO String
35−
47+build flags is = fmap (Maybe.fromMaybe "") . evalBuild flags is . buildAll
36−build1 :: Flag.Flags -> Int -> Int -> M.Interfaces -> FilePath
48+
37− -> IO (String, M.ModuleInterface)
49+buildAll :: [FilePath] -> Build ()
38−build1 flags moduleNum numModules interfaces filePath =
50+buildAll fs = mapM_ (uncurry build1) (zip [1..] fs)
39− do compiled <- alreadyCompiled flags filePath
51+ where build1 :: Integer -> FilePath -> Build ()
52+ build1 num fname = do
53+ shouldCompile <- shouldBeCompiled fname
54+ if shouldCompile
55+ then compile number fname
56+ else retrieve fname
57+
58+ where number = join ["[", show num, " of ", show total, "]"]
59+
60+ total = length fs
61+
62+shouldBeCompiled :: FilePath -> Build Bool
63+shouldBeCompiled filePath = do
64+ flags <- ask
65+ let alreadyCompiled = liftIO $ do
66+ existsi <- doesFileExist (Utils.elmi flags filePath)
67+ existso <- doesFileExist (Utils.elmo flags filePath)
68+ return $ existsi && existso
69+
70+ outDated = liftIO $ do
71+ tsrc <- getModificationTime filePath
72+ tint <- getModificationTime (Utils.elmo flags filePath)
73+ return (tsrc > tint)
74+
75+ dependenciesUpdated = do
76+ eDeps <- liftIO . runErrorT $ Deps.readDeps filePath
40− case compiled of
77+ case eDeps of
41− False -> compile flags number interfaces filePath
78+ -- Should never actually reach here
42− True -> retrieve flags interfaces filePath
79+ Left err -> liftIO $ Print.failure err
43− where
80+ Right (_, deps) -> anyM wasCompiled deps
44− number = "[" ++ show moduleNum ++ " of " ++ show numModules ++ "]"
81+
45−
82+
46−
83+ in (not <$> alreadyCompiled) `orM` outDated `orM` dependenciesUpdated
47−alreadyCompiled :: Flag.Flags -> FilePath -> IO Bool
84+
48−alreadyCompiled flags filePath = do
85+wasCompiled :: String -> Build Bool
49− existsi <- doesFileExist (Utils.elmi flags filePath)
86+wasCompiled modul = maybe False fst . Map.lookup modul <$> get
50− existso <- doesFileExist (Utils.elmo flags filePath)
87+
51− if not existsi || not existso
88+-- Short-circuiting monadic (||)
52− then return False
89+infixr 2 `orM`
53− else do tsrc <- getModificationTime filePath
90+orM :: (Monad m) => m Bool -> m Bool -> m Bool
54− tint <- getModificationTime (Utils.elmo flags filePath)
91+orM m1 m2 = do b1 <- m1
55− return (tsrc <= tint)
92+ if b1
56−
93+ then return b1
57−retrieve :: Flag.Flags -> Map.Map String M.ModuleInterface -> FilePath
94+ else m2
58− -> IO (String, M.ModuleInterface)
95+
59−retrieve flags interfaces filePath = do
96+anyM :: (Monad m) => (a -> m Bool) -> [a] -> m Bool
97+anyM f = foldr (orM . f) (return False)
98+
99+retrieve :: FilePath -> Build ()
100+retrieve filePath = do
101+ flags <- ask
60− iface <- Interface.load (Utils.elmi flags filePath)
102+ iface <- liftIO $ Interface.load (Utils.elmi flags filePath)
61 case Interface.isValid filePath iface of
103 case Interface.isValid filePath iface of
62 Right (name, interface) ->
104 Right (name, interface) ->
105+ do binterfaces <- get
106+ let interfaces = snd <$> binterfaces
63− do when (Flag.print_types flags) (Print.interfaceTypes interfaces interface)
107+ liftIO $ when (Flag.print_types flags) (Print.interfaceTypes interfaces interface)
64− return (name, interface)
108+ update name interface False
109+
65− Left err ->
110+ Left err -> liftIO $ Print.failure err
66− do hPutStrLn stderr err
111+
67− exitFailure
68−
69−compile :: Flag.Flags -> String -> M.Interfaces -> FilePath
112+compile :: String -> FilePath -> Build ()
70− -> IO (String, M.ModuleInterface)
71−compile flags number interfaces filePath =
113+compile number filePath =
114+ do flags <- ask
115+ binterfaces <- get
72− do source <- readFile filePath
116+ source <- liftIO $ readFile filePath
117+ let interfaces = snd <$> binterfaces
73− let name = getName source
118+ name = getName source
119+ liftIO $ do
74− printStatus name
120+ printStatus name
75−
76− createDirectoryIfMissing True (Flag.cache_dir flags)
121+ createDirectoryIfMissing True (Flag.cache_dir flags)
77− createDirectoryIfMissing True (Flag.build_dir flags)
122+ createDirectoryIfMissing True (Flag.build_dir flags)
78−
123+
79− metaModule <-
124+ metaModule <-
80− case Source.build (Flag.no_prelude flags) interfaces source of
125+ liftIO $ case Source.build (Flag.no_prelude flags) interfaces source of
81 Right modul -> return modul
126 Right modul -> return modul
82 Left errors -> do Print.errors errors
127 Left errors -> do Print.errors errors
83 exitFailure
128 exitFailure
84
129
85− when (Flag.print_types flags) $ Print.metaTypes interfaces metaModule
130+ liftIO $ when (Flag.print_types flags) $ Print.metaTypes interfaces metaModule
86−
131+
87− let intermediate = (name, Canonical.interface name $ M.metaToInterface metaModule)
132+ let newInters = Canonical.interface name $ M.metaToInterface metaModule
88− generateCache intermediate metaModule
133+ generateCache name newInters metaModule
89− return intermediate
134+ update name newInters True
90
135
91 where
136 where
92 getName source = case Parser.getModuleName source of
137 getName source = case Parser.getModuleName source of
@@ -98,8 +143,14 @@ compile flags number interfaces filePath =
98 , replicate (max 1 (20 - length name)) ' '
143 , replicate (max 1 (20 - length name)) ' '
99 , "( " ++ filePath ++ " )" ]
144 , "( " ++ filePath ++ " )" ]
100
145
101− generateCache intermediate metaModule = do
146+ generateCache name interfs metaModule = do
147+ flags <- ask
148+ liftIO $ do
102− createDirectoryIfMissing True . dropFileName $ Utils.elmi flags filePath
149+ createDirectoryIfMissing True . dropFileName $ Utils.elmi flags filePath
103− writeFile (Utils.elmo flags filePath) (JS.generate metaModule)
150+ writeFile (Utils.elmo flags filePath) (JS.generate metaModule)
104− withBinaryFile (Utils.elmi flags filePath) WriteMode $ \handle ->
151+ withBinaryFile (Utils.elmi flags filePath) WriteMode $ \handle ->
105− L.hPut handle (Binary.encode intermediate)
152+ L.hPut handle (Binary.encode (name, interfs))
153+
154+update :: String -> M.ModuleInterface -> Bool -> Build ()
155+update name inter wasUpdated = modify (Map.insert name (wasUpdated, inter))
156+ >> tell (Last . Just $ name)
compiler/Build/Print.hs+7−1
@@ -1,5 +1,8 @@
1module Build.Print where
1module Build.Print where
2
2
3+import System.IO (hPutStrLn, stderr)
4+import System.Exit (exitFailure)
5+
3import qualified Data.Map as Map
6import qualified Data.Map as Map
4import qualified Data.List as List
7import qualified Data.List as List
5import qualified SourceSyntax.Module as M
8import qualified SourceSyntax.Module as M
@@ -29,4 +32,7 @@ types interfaces types' aliases imports =
29
32
30errors :: [P.Doc] -> IO ()
33errors :: [P.Doc] -> IO ()
31errors errs =
34errors errs =
32− mapM_ print (List.intersperse (P.text " ") errs)
35+ mapM_ print (List.intersperse (P.text " ") errs)
36+
37+failure :: String -> IO a
38+failure msg = hPutStrLn stderr msg >> exitFailure
compiler/Compiler.hs+1−2
@@ -37,8 +37,7 @@ build flags rootFile =
37 then getSortedDependencies (Flag.src_dir flags) builtIns rootFile
37 then getSortedDependencies (Flag.src_dir flags) builtIns rootFile
38 else return [rootFile]
38 else return [rootFile]
39
39
40− (moduleName, _) <-
41− File.build flags (length files) builtIns "" files
40+ moduleName <- File.build flags builtIns files
42
41
43 js <- foldM appendToOutput BS.empty files
42 js <- foldM appendToOutput BS.empty files
44
43
compiler/Type/ExtraChecks.hs+13−7
@@ -56,7 +56,7 @@ portTypes rules expr =
56 T.Data ctor ts
56 T.Data ctor ts
57 | isJs ctor || isElm ctor -> mapM_ valid ts
57 | isJs ctor || isElm ctor -> mapM_ valid ts
58 | ctor == "Signal.Signal" -> handleSignal ts
58 | ctor == "Signal.Signal" -> handleSignal ts
59− | otherwise -> err "Algebraic Data Types"
59+ | otherwise -> err' True "an unsupported type"
60
60
61 T.Var _ -> err "free type variables"
61 T.Var _ -> err "free type variables"
62
62
@@ -90,16 +90,22 @@ portTypes rules expr =
90 dir inMsg outMsg = case direction of { In -> inMsg ; Out -> outMsg }
90 dir inMsg outMsg = case direction of { In -> inMsg ; Out -> outMsg }
91 txt = P.text . concat
91 txt = P.text . concat
92
92
93− err kind =
93+ err = err' False
94+ err' couldBeAlias kind =
94 throw $
95 throw $
95 [ txt [ "Type Error: the value ", dir "coming in" "sent out"
96 [ txt [ "Type Error: the value ", dir "coming in" "sent out"
96 , " through port '", name, "' is invalid." ]
97 , " through port '", name, "' is invalid." ]
97− , txt [ "Acceptable values for ", dir "incoming" "outgoing"
98+ , txt [ "It contains ", kind, ":\n" ]
98− , " ports include JavaScript values and the following Elm values:" ]
99− , txt [ "Ints, Floats, Bools, Strings, Maybes, Lists, Tuples, "
100− , dir "" "first-order functions, ", "and concrete records." ]
101− , txt [ "The values sent through this port contain ", kind, ":\n" ]
102 , (P.nest 4 . pretty $ Alias.realias rules tipe) <> P.text "\n"
99 , (P.nest 4 . pretty $ Alias.realias rules tipe) <> P.text "\n"
100+ , txt [ "Acceptable values for ", dir "incoming" "outgoing"
101+ , " ports include JavaScript values and" ]
102+ , txt [ "the following Elm values: Ints, Floats, Bools, Strings, Maybes," ]
103+ , txt [ "Lists, Tuples, ", dir "" "first-order functions, ", "and concrete records." ]
104+ ] ++ if couldBeAlias then aliasWarning else []
105+
106+ aliasWarning =
107+ [ txt [ "\nType aliases are not expanded for this check (yet) so you need to do that" ]
108+ , txt [ "manually for now (e.g. {x:Int,y:Int} instead of a type alias of that type)." ]
103 ]
109 ]
104
110
105occurs :: (String, Variable) -> StateT TS.SolverState IO ()
111occurs :: (String, Variable) -> StateT TS.SolverState IO ()
runtime/Init.js+18
@@ -205,6 +205,24 @@ function addReceivers(ports) {
205 if (v.length > 0) window.location = v;
205 if (v.length > 0) window.location = v;
206 });
206 });
207 }
207 }
208+ if ('favicon' in ports) {
209+ if (typeof ports.favicon === 'string') {
210+ changeFavicon(ports.favicon);
211+ } else {
212+ ports.favicon.subscribe(changeFavicon);
213+ }
214+ }
215+ function changeFavicon(src) {
216+ var link = document.createElement('link');
217+ var oldLink = document.getElementById('elm-favicon');
218+ link.id = 'elm-favicon';
219+ link.rel = 'shortcut icon';
220+ link.href = src;
221+ if (oldLink) {
222+ document.head.removeChild(oldLink);
223+ }
224+ document.head.appendChild(link);
225+ }
208}
226}
209
227
210function initGraphics(elm, Module) {
228function initGraphics(elm, Module) {