@@ -1,131 +0,0 @@
1−{-# LANGUAGE TupleSections #-}
2−
3−-- | Functions and types relevant to producing some form of output after
4−-- rendering documentation.
5−
6−module Output where
7−
8−import qualified Data.Map as M
9−import Data.Maybe (mapMaybe)
10−import Data.List.Split (splitOn)
11−import Data.List (stripPrefix)
12−
13−import Control.Applicative
14−import Control.Monad
15−import Control.Arrow (first)
16−
17−import qualified Language.PureScript as P
18−import qualified Language.PureScript.Constants as C
19−
20−import System.Exit (exitFailure)
21−import System.IO (hPutStrLn, stderr)
22−
23−import Language.PureScript.Docs
24−import Web.Bower.PackageMeta hiding (Version)
25−
26−import Utils
27−
28−-- | Specifies whether a PureScript source file is considered as:
29−--
30−-- 1) with the `Local` constructor, a target source file, i.e., we want to see
31−-- its modules in the output
32−-- 2) with the `FromDep` constructor, a dependencies source file, i.e. we do
33−-- not want its modules in the output; it is there to enable desugaring, and
34−-- to ensure that links between modules are constructed correctly.
35−type FileInfo = InPackage FilePath
36−
37−fileInfoToString :: FileInfo -> FilePath
38−fileInfoToString (Local fn) = fn
39−fileInfoToString (FromDep _ fn) = fn
40−
41−addDefaultImport :: P.ModuleName -> P.Module -> P.Module
42−addDefaultImport toImport m@(P.Module coms mn decls exps) =
43− if isExistingImport `any` decls || mn == toImport then m
44− else P.Module coms mn (P.ImportDeclaration toImport P.Implicit Nothing : decls) exps
45− where
46− isExistingImport (P.ImportDeclaration mn' _ _) | mn' == toImport = True
47− isExistingImport (P.PositionedDeclaration _ _ d) = isExistingImport d
48− isExistingImport _ = False
49−
50−importPrim :: P.Module -> P.Module
51−importPrim = addDefaultImport (P.ModuleName [P.ProperName C.prim])
52−
53−importPrelude :: P.Module -> P.Module
54−importPrelude = addDefaultImport (P.ModuleName [P.ProperName C.prelude])
55−
56−desugar :: [P.Module] -> Either P.MultipleErrors [P.Module]
57−desugar = P.evalSupplyT 0 . desugar'
58− where
59− desugar' :: [P.Module] -> P.SupplyT (Either P.MultipleErrors) [P.Module]
60− desugar' = mapM P.desugarDoModule >=> P.desugarCasesModule >=> P.desugarImports
61−
62−parseFile :: FilePath -> IO (FilePath, String)
63−parseFile input' = (,) input' <$> readFile input'
64−
65−parseAndDesugar ::
66− [FilePath]
67− -> [(PackageName, FilePath)]
68− -> ([Bookmark] -> [P.Module] -> IO a)
69− -> IO a
70−parseAndDesugar inputFiles depsFiles callback = do
71− inputFiles' <- mapM (parseAs Local) inputFiles
72− depsFiles' <- mapM (\(pkgName, f) -> parseAs (FromDep pkgName) f) depsFiles
73−
74− case P.parseModulesFromFiles fileInfoToString (inputFiles' ++ depsFiles') of
75− Left err -> do
76− hPutStrLn stderr "parse failed:"
77− hPutStrLn stderr $ show err
78− exitFailure
79− Right ms -> do
80− let depsModules = getDepsModuleNames (map (\(fp, m) -> (,m) <$> fp) ms)
81− case P.sortModules . map (importPrim . importPrelude . snd) $ ms of
82− Left e' -> do
83− hPutStrLn stderr "sortModules failed:"
84− hPutStrLn stderr (P.prettyPrintMultipleErrors False e')
85− exitFailure
86− Right (ms', _) ->
87− case desugar ms' of
88− Left err -> do
89− hPutStrLn stderr "desugar failed:"
90− hPutStrLn stderr (P.prettyPrintMultipleErrors False err)
91− exitFailure
92− Right modules ->
93− let modules' = map (addPackage depsModules) modules
94− bookmarks = concatMap collectBookmarks modules'
95− in callback bookmarks (takeLocals modules')
96−
97− where
98− parseAs :: (FilePath -> a) -> FilePath -> IO (a, String)
99− parseAs g = fmap (first g) . parseFile
100−
101− getDepsModuleNames :: [InPackage (FilePath, P.Module)] -> M.Map P.ModuleName PackageName
102− getDepsModuleNames = foldl go M.empty
103− where
104− go deps p = deps # case p of
105− Local _ -> id
106− FromDep pkgName (_, m) -> M.insert (P.getModuleName m) pkgName
107− (#) = flip ($)
108−
109− addPackage :: M.Map P.ModuleName PackageName -> P.Module -> InPackage P.Module
110− addPackage depsModules m =
111− case M.lookup (P.getModuleName m) depsModules of
112− Just pkgName -> FromDep pkgName m
113− Nothing -> Local m
114−
115−getInputAndDepsFiles :: IO ([FilePath], [(PackageName, FilePath)])
116−getInputAndDepsFiles = do
117− inputFiles <- globRelative purescriptSourceFiles
118− depsFiles' <- globRelative purescriptDepsFiles
119− return (inputFiles, mapMaybe withPackageName depsFiles')
120−
121−withPackageName :: FilePath -> Maybe (PackageName, FilePath)
122−withPackageName fp = (,fp) <$> getPackageName fp
123−
124−getPackageName :: FilePath -> Maybe PackageName
125−getPackageName fp = do
126− let xs = splitOn "/" fp
127− ys <- stripPrefix ["bower_components"] xs
128− y <- headMay ys
129− case mkPackageName y of
130− Right name -> Just name
131− Left _ -> Nothing