@@ -1,5 +1,5 @@
11{-# OPTIONS_GHC -Wno-unused-do-bind #-}
2−{-# LANGUAGE BangPatterns, OverloadedStrings #-}
2+{-# LANGUAGE BangPatterns, GADTs, OverloadedStrings #-}
33module Build
44 ( fromExposed
55 , fromMains
@@ -7,6 +7,7 @@ module Build
77 , Main(..)
88 , Module(..)
99 , CachedInterface(..)
10+ , DocsGoal(..)
1011 )
1112 where
1213
@@ -31,15 +32,18 @@ import qualified System.Directory as Dir
3132import qualified System.FilePath as FP
3233import System.FilePath ((</>), (<.>))
3334
35+import qualified AST.Canonical as Can
3436import qualified AST.Source as Src
3537import qualified AST.Optimized as Opt
3638import qualified Compile
3739import qualified Elm.Details as Details
40+import qualified Elm.Docs as Docs
3841import qualified Elm.Interface as I
3942import qualified Elm.ModuleName as ModuleName
4043import qualified Elm.Outline as Outline
4144import qualified Elm.Package as Pkg
4245import qualified File
46+import qualified Json.Encode as E
4347import qualified Parse.Module as Parse
4448import qualified Reporting
4549import qualified Reporting.Annotation as A
@@ -96,15 +100,16 @@ forkWithKey func dict =
96100-- FROM EXPOSED
97101
98102
99−fromExposed :: Reporting.Style -> FilePath -> Details.Details -> NE.List ModuleName.Raw -> IO (Either Exit.BuildProblem ())
100−fromExposed style root details exposed@(NE.List e es) =
103+fromExposed :: Reporting.Style -> FilePath -> Details.Details -> DocsGoal docs -> NE.List ModuleName.Raw -> IO (Either Exit.BuildProblem docs)
104+fromExposed style root details docsGoal exposed@(NE.List e es) =
101105 Reporting.trackBuild style $ \key ->
102106 do let env = makeEnv key root details
103107 dmvar <- Details.loadInterfaces root details
104108
105109 -- crawl
106110 mvar <- newEmptyMVar
107− roots <- Map.fromKeysA (fork . crawlModule env mvar) (e:es)
111+ let docsNeed = toDocsNeed docsGoal
112+ roots <- Map.fromKeysA (fork . crawlModule env mvar docsNeed) (e:es)
108113 putMVar mvar roots
109114 mapM_ readMVar roots
110115 statuses <- traverse readMVar =<< readMVar mvar
@@ -121,7 +126,7 @@ fromExposed style root details exposed@(NE.List e es) =
121126 putMVar rmvar resultMVars
122127 results <- traverse readMVar resultMVars
123128 writeDetails root details results
124− return (detectExposedProblems exposed results)
129+ finalizeExposed docsGoal exposed results
125130
126131
127132
@@ -190,7 +195,7 @@ type StatusDict =
190195
191196data Status
192197 = SCached Details.Local
193− | SChanged Details.Local B.ByteString Src.Module
198+ | SChanged Details.Local B.ByteString Src.Module DocsNeed
194199 | SBadImport Import.Problem
195200 | SBadSyntax FilePath File.Time B.ByteString Syntax.Error
196201 | SForeign Pkg.Name
@@ -207,11 +212,11 @@ crawlDeps env mvar deps blockedValue =
207212 mapM_ readMVar statuses
208213 return blockedValue
209214 where
210− crawlNew name () = fork (crawlModule env mvar name)
215+ crawlNew name () = fork (crawlModule env mvar (DocsNeed False) name)
211216
212217
213−crawlModule :: Env -> MVar StatusDict -> ModuleName.Raw -> IO Status
214−crawlModule env@(Env _ root pkg srcDirs locals foreigns) mvar name =
218+crawlModule :: Env -> MVar StatusDict -> DocsNeed -> ModuleName.Raw -> IO Status
219+crawlModule env@(Env _ root pkg srcDirs locals foreigns) mvar docsNeed name =
215220 do let fileName = ModuleName.toFilePath name <.> "elm"
216221 let inRoot path = File.exists (root </> path)
217222
@@ -226,15 +231,15 @@ crawlModule env@(Env _ root pkg srcDirs locals foreigns) mvar name =
226231 Nothing ->
227232 case Map.lookup name locals of
228233 Nothing ->
229− crawlFile env mvar name path
234+ crawlFile env mvar docsNeed name path
230235
231236 Just local@(Details.Local oldPath oldTime deps _) ->
232237 if path /= oldPath
233− then crawlFile env mvar name path
238+ then crawlFile env mvar docsNeed name path
234239 else
235240 do newTime <- File.getTime path
236− if oldTime < newTime
237− then crawlFile env mvar name path
241+ if oldTime < newTime || needsDocs docsNeed
242+ then crawlFile env mvar docsNeed name path
238243 else crawlDeps env mvar deps (SCached local)
239244
240245 p1:p2:ps ->
@@ -258,8 +263,8 @@ crawlModule env@(Env _ root pkg srcDirs locals foreigns) mvar name =
258263 return $ SBadImport Import.NotFound
259264
260265
261−crawlFile :: Env -> MVar StatusDict -> ModuleName.Raw -> FilePath -> IO Status
262−crawlFile env@(Env _ root pkg _ _ _) mvar expectedName path =
266+crawlFile :: Env -> MVar StatusDict -> DocsNeed -> ModuleName.Raw -> FilePath -> IO Status
267+crawlFile env@(Env _ root pkg _ _ _) mvar docsNeed expectedName path =
263268 do time <- File.getTime path
264269 source <- File.readUtf8 (root </> path)
265270
@@ -278,7 +283,7 @@ crawlFile env@(Env _ root pkg _ _ _) mvar expectedName path =
278283 deps = map Src.getImportName imports
279284 local = Details.Local path time deps (any isMain values)
280285 in
281− crawlDeps env mvar deps (SChanged local source modul)
286+ crawlDeps env mvar deps (SChanged local source modul docsNeed)
282287 else
283288 return $ SBadSyntax path time source (Syntax.ModuleNameMismatch expectedName name)
284289
@@ -297,8 +302,8 @@ type ResultDict =
297302
298303
299304data Result
300− = RNew Details.Local I.Interface Opt.LocalGraph
301− | RSame Details.Local I.Interface Opt.LocalGraph
305+ = RNew !Details.Local !I.Interface !Opt.LocalGraph !(Maybe Docs.Module)
306+ | RSame !Details.Local !I.Interface !Opt.LocalGraph !(Maybe Docs.Module)
302307 | RCached Bool (MVar CachedInterface)
303308 | RNotFound Import.Problem
304309 | RProblem Error.Module
@@ -323,7 +328,7 @@ checkModule env@(Env _ root pkg _ _ _) foreigns resultsMVar name status =
323328 DepsChange ifaces ->
324329 do source <- File.readUtf8 path
325330 case Parse.fromByteString pkg source of
326− Right modul -> compile env local source ifaces modul
331+ Right modul -> compile env (DocsNeed False) local source ifaces modul
327332 Left err ->
328333 return $ RProblem $
329334 Error.Module name path time source (Error.BadSyntax err)
@@ -345,12 +350,12 @@ checkModule env@(Env _ root pkg _ _ _) foreigns resultsMVar name status =
345350 Left err ->
346351 Error.BadSyntax err
347352
348− SChanged local@(Details.Local path time deps _) source modul@(Src.Module _ _ _ imports _ _ _ _ _) ->
353+ SChanged local@(Details.Local path time deps _) source modul@(Src.Module _ _ _ imports _ _ _ _ _) docsNeed ->
349354 do results <- readMVar resultsMVar
350355 depsStatus <- checkDeps root results deps
351356 case depsStatus of
352357 DepsChange ifaces ->
353− compile env local source ifaces modul
358+ compile env docsNeed local source ifaces modul
354359
355360 DepsSame same cached ->
356361 do maybeLoaded <- checkCachedInterfaces root cached
@@ -360,7 +365,7 @@ checkModule env@(Env _ root pkg _ _ _) foreigns resultsMVar name status =
360365
361366 Just loaded ->
362367 do let ifaces = Map.union loaded (Map.fromList same)
363− compile env local source ifaces modul
368+ compile env docsNeed local source ifaces modul
364369
365370 DepsBlock ->
366371 return RBlocked
@@ -411,14 +416,14 @@ checkDepsHelp root results deps new same cached importProblems isBlocked =
411416 dep:otherDeps ->
412417 do result <- readMVar (results ! dep)
413418 case result of
414− RNew _ iface _ -> checkDepsHelp root results otherDeps ((dep,iface) : new) same cached importProblems isBlocked
415− RSame _ iface _ -> checkDepsHelp root results otherDeps new ((dep,iface) : same) cached importProblems isBlocked
416− RCached _ mvar -> checkDepsHelp root results otherDeps new same ((dep,mvar) : cached) importProblems isBlocked
417− RNotFound prob -> checkDepsHelp root results otherDeps new same cached ((dep,prob) : importProblems) True
418− RProblem _ -> checkDepsHelp root results otherDeps new same cached importProblems True
419− RBlocked -> checkDepsHelp root results otherDeps new same cached importProblems True
420− RForeign iface -> checkDepsHelp root results otherDeps new ((dep,iface) : same) cached importProblems isBlocked
421− RKernel -> checkDepsHelp root results otherDeps new same cached importProblems isBlocked
419+ RNew _ iface _ _ -> checkDepsHelp root results otherDeps ((dep,iface) : new) same cached importProblems isBlocked
420+ RSame _ iface _ _ -> checkDepsHelp root results otherDeps new ((dep,iface) : same) cached importProblems isBlocked
421+ RCached _ mvar -> checkDepsHelp root results otherDeps new same ((dep,mvar) : cached) importProblems isBlocked
422+ RNotFound prob -> checkDepsHelp root results otherDeps new same cached ((dep,prob) : importProblems) True
423+ RProblem _ -> checkDepsHelp root results otherDeps new same cached importProblems True
424+ RBlocked -> checkDepsHelp root results otherDeps new same cached importProblems True
425+ RForeign iface -> checkDepsHelp root results otherDeps new ((dep,iface) : same) cached importProblems isBlocked
426+ RKernel -> checkDepsHelp root results otherDeps new same cached importProblems isBlocked
422427
423428 [] ->
424429 case importProblems of
@@ -577,12 +582,12 @@ addToGraph name status graph =
577582 let
578583 dependencies =
579584 case status of
580− SCached (Details.Local _ _ deps _) -> deps
581− SChanged (Details.Local _ _ deps _) _ _ -> deps
582− SBadImport _ -> []
583− SBadSyntax _ _ _ _ -> []
584− SForeign _ -> []
585− SKernel -> []
585+ SCached (Details.Local _ _ deps _) -> deps
586+ SChanged (Details.Local _ _ deps _) _ _ _ -> deps
587+ SBadImport _ -> []
588+ SBadSyntax _ _ _ _ -> []
589+ SForeign _ -> []
590+ SKernel -> []
586591 in
587592 (name, name, dependencies) : graph
588593
@@ -625,38 +630,39 @@ checkOutside name paths =
625630checkInside :: ModuleName.Raw -> FilePath -> Status -> Either Exit.BuildProjectProblem ()
626631checkInside name p1 status =
627632 case status of
628− SCached (Details.Local p2 _ _ _) -> Left (Exit.BP_MainNameDuplicate name p1 p2)
629− SChanged (Details.Local p2 _ _ _) _ _ -> Left (Exit.BP_MainNameDuplicate name p1 p2)
630− SBadImport _ -> Right ()
631− SBadSyntax _ _ _ _ -> Right ()
632− SForeign _ -> Right ()
633− SKernel -> Right ()
633+ SCached (Details.Local p2 _ _ _) -> Left (Exit.BP_MainNameDuplicate name p1 p2)
634+ SChanged (Details.Local p2 _ _ _) _ _ _ -> Left (Exit.BP_MainNameDuplicate name p1 p2)
635+ SBadImport _ -> Right ()
636+ SBadSyntax _ _ _ _ -> Right ()
637+ SForeign _ -> Right ()
638+ SKernel -> Right ()
634639
635640
636641
637642-- COMPILE MODULE
638643
639644
640−compile :: Env -> Details.Local -> B.ByteString -> Map.Map ModuleName.Raw I.Interface -> Src.Module -> IO Result
641−compile (Env key root pkg _ _ _) local@(Details.Local path time _ _) source ifaces modul =
645+compile :: Env -> DocsNeed -> Details.Local -> B.ByteString -> Map.Map ModuleName.Raw I.Interface -> Src.Module -> IO Result
646+compile (Env key root pkg _ _ _) docsNeed local@(Details.Local path time _ _) source ifaces modul =
642647 case Compile.compile pkg ifaces modul of
643648 Right (Compile.Artifacts canonical annotations objects) ->
644649 do let name = Src.getName modul
645650 let iface = I.fromModule pkg canonical annotations
651+ let docs = makeDocs docsNeed canonical
646652 File.writeBinary (Stuff.elmo root name) objects
647653 maybeOldi <- File.readBinary (Stuff.elmi root name)
648654 case maybeOldi of
649655 Just oldi | oldi == iface ->
650656 do -- iface should be fully forced by equality check
651657 Reporting.report key Reporting.BDone
652− return (RSame local iface objects)
658+ return (RSame local iface objects docs)
653659
654660 _ ->
655661 do -- iface may be lazy still
656662 -- TODO try adding forkIO here
657663 File.writeBinary (Stuff.elmi root name) iface
658664 Reporting.report key Reporting.BDone
659− return (RNew local iface objects)
665+ return (RNew local iface objects docs)
660666
661667 Left err ->
662668 do Reporting.report key Reporting.BDone
@@ -677,56 +683,114 @@ writeDetails root (Details.Details time outline locals foreigns extras) results
677683addNewLocal :: ModuleName.Raw -> Result -> Map.Map ModuleName.Raw Details.Local -> Map.Map ModuleName.Raw Details.Local
678684addNewLocal name result locals =
679685 case result of
680− RNew local _ _ -> Map.insert name local locals
681− RSame local _ _ -> Map.insert name local locals
682− RCached _ _ -> locals
683− RNotFound _ -> locals
684− RProblem _ -> locals
685− RBlocked -> locals
686− RForeign _ -> locals
687− RKernel -> locals
686+ RNew local _ _ _ -> Map.insert name local locals
687+ RSame local _ _ _ -> Map.insert name local locals
688+ RCached _ _ -> locals
689+ RNotFound _ -> locals
690+ RProblem _ -> locals
691+ RBlocked -> locals
692+ RForeign _ -> locals
693+ RKernel -> locals
688694
689695
690696
691−-- DETECT EXPOSED PROBLEMS
697+-- FINALIZE EXPOSED
692698
693699
694−detectExposedProblems :: NE.List ModuleName.Raw -> Map.Map ModuleName.Raw Result -> Either Exit.BuildProblem ()
695−detectExposedProblems exposed results =
700+finalizeExposed :: DocsGoal docs -> NE.List ModuleName.Raw -> Map.Map ModuleName.Raw Result -> IO (Either Exit.BuildProblem docs)
701+finalizeExposed docsGoal exposed results =
696702 case foldr (addImportProblems results) [] (NE.toList exposed) of
697703 p:ps ->
698− Left (Exit.BuildProjectProblem (Exit.BP_MissingExposed (NE.List p ps)))
704+ return $ Left $ Exit.BuildProjectProblem (Exit.BP_MissingExposed (NE.List p ps))
699705
700706 [] ->
701707 case Map.foldr addErrors [] results of
702− [] -> Right ()
703− e:es -> Left (Exit.BuildModuleProblems e es)
708+ [] -> Right <$> finalizeDocs docsGoal results
709+ e:es -> return $ Left $ Exit.BuildModuleProblems e es
704710
705711
706712addErrors :: Result -> [Error.Module] -> [Error.Module]
707713addErrors result errors =
708714 case result of
709− RNew _ _ _ -> errors
710− RSame _ _ _ -> errors
711− RCached _ _ -> errors
712− RNotFound _ -> errors
713− RProblem e -> e:errors
714− RBlocked -> errors
715− RForeign _ -> errors
716− RKernel -> errors
715+ RNew _ _ _ _ -> errors
716+ RSame _ _ _ _ -> errors
717+ RCached _ _ -> errors
718+ RNotFound _ -> errors
719+ RProblem e -> e:errors
720+ RBlocked -> errors
721+ RForeign _ -> errors
722+ RKernel -> errors
717723
718724
719725addImportProblems :: Map.Map ModuleName.Raw Result -> ModuleName.Raw -> [(ModuleName.Raw, Import.Problem)] -> [(ModuleName.Raw, Import.Problem)]
720726addImportProblems results name problems =
721727 case results ! name of
722− RNew _ _ _ -> problems
723− RSame _ _ _ -> problems
724− RCached _ _ -> problems
725− RNotFound p -> (name, p) : problems
726− RProblem _ -> problems
727− RBlocked -> problems
728− RForeign _ -> problems
729− RKernel -> problems
728+ RNew _ _ _ _ -> problems
729+ RSame _ _ _ _ -> problems
730+ RCached _ _ -> problems
731+ RNotFound p -> (name, p) : problems
732+ RProblem _ -> problems
733+ RBlocked -> problems
734+ RForeign _ -> problems
735+ RKernel -> problems
736+
737+
738+
739+-- DOCS
740+
741+
742+data DocsGoal a where
743+ KeepDocs :: DocsGoal Docs.Documentation
744+ WriteDocs :: FilePath -> DocsGoal ()
745+ IgnoreDocs :: DocsGoal ()
746+
747+
748+newtype DocsNeed =
749+ DocsNeed { needsDocs :: Bool }
750+
751+
752+toDocsNeed :: DocsGoal a -> DocsNeed
753+toDocsNeed goal =
754+ case goal of
755+ IgnoreDocs -> DocsNeed False
756+ WriteDocs _ -> DocsNeed True
757+ KeepDocs -> DocsNeed True
758+
759+
760+makeDocs :: DocsNeed -> Can.Module -> Maybe Docs.Module
761+makeDocs (DocsNeed isNeeded) modul =
762+ if isNeeded then
763+ case Docs.fromModule modul of
764+ Right docs -> Just docs
765+ Left _ -> Nothing
766+ else
767+ Nothing
768+
769+
770+finalizeDocs :: DocsGoal docs -> Map.Map ModuleName.Raw Result -> IO docs
771+finalizeDocs goal results =
772+ case goal of
773+ KeepDocs ->
774+ return $ Map.mapMaybe toDocs results
775+
776+ WriteDocs path ->
777+ E.writeUgly path $ Docs.encode $ Map.mapMaybe toDocs results
778+
779+ IgnoreDocs ->
780+ return ()
781+
782+
783+toDocs :: Result -> Maybe Docs.Module
784+toDocs result =
785+ case result of
786+ RNew _ _ _ d -> d
787+ RSame _ _ _ d -> d
788+ RCached _ _ -> Nothing
789+ RNotFound _ -> Nothing
790+ RProblem _ -> Nothing
791+ RBlocked -> Nothing
792+ RForeign _ -> Nothing
793+ RKernel -> Nothing
730794
731795
732796
@@ -870,7 +934,7 @@ crawlMain env@(Env _ _ pkg _ _ _) mvar given =
870934 do statusMVar <- newEmptyMVar
871935 statusDict <- takeMVar mvar
872936 putMVar mvar (Map.insert name statusMVar statusDict)
873− putMVar statusMVar =<< crawlModule env mvar name
937+ putMVar statusMVar =<< crawlModule env mvar (DocsNeed False) name
874938 return (SInside name)
875939
876940 LOutside path ->
@@ -990,14 +1054,14 @@ gatherProblemsOrMains results (NE.List mainResult mainResults) =
9901054addInside :: ModuleName.Raw -> Result -> [Module] -> [Module]
9911055addInside name result modules =
9921056 case result of
993− RNew _ iface objs -> Fresh name iface objs : modules
994− RSame _ iface objs -> Fresh name iface objs : modules
995− RCached main mvar -> Cached name main mvar : modules
996− RNotFound _ -> error (badInside name)
997− RProblem _ -> error (badInside name)
998− RBlocked -> error (badInside name)
999− RForeign _ -> modules
1000− RKernel -> modules
1057+ RNew _ iface objs _ -> Fresh name iface objs : modules
1058+ RSame _ iface objs _ -> Fresh name iface objs : modules
1059+ RCached main mvar -> Cached name main mvar : modules
1060+ RNotFound _ -> error (badInside name)
1061+ RProblem _ -> error (badInside name)
1062+ RBlocked -> error (badInside name)
1063+ RForeign _ -> modules
1064+ RKernel -> modules
10011065
10021066
10031067badInside :: ModuleName.Raw -> [Char]