0c62dc8 · rowtype-yoga/purescript-native

git.iko.soy/rowtype-yoga/purescript-native

on golang help sign in

Move parseAndDesugar into the library

0c62dc8Harry Garrood12 years ago

psc-publish/ErrorsWarnings.hs+19

compare with golang

unifiedsplit

@@ -15,6 +15,9 @@ import Control.Exception (IOException)

15import Web.Bower.PackageMeta (BowerError, PackageName, runPackageName)

16import qualified Web.Bower.PackageMeta as Bower

18+import qualified Language.PureScript as P

19+import qualified Language.PureScript.Docs as D

20+

18import BoxesHelpers

21import BoxesHelpers

20-- | An error which meant that it was not possible to retrieve metadata for a

23-- | An error which meant that it was not possible to retrieve metadata for a

@@ -39,6 +42,7 @@ data UserError

39 | AmbiguousVersions [Version] -- Invariant: should contain at least two elements

42 | AmbiguousVersions [Version] -- Invariant: should contain at least two elements

40 | BadRepositoryField RepositoryFieldError

43 | BadRepositoryField RepositoryFieldError

41 | MissingDependencies (NonEmpty PackageName)

44 | MissingDependencies (NonEmpty PackageName)

45+ | ParseAndDesugarError D.ParseDesugarError

42 deriving (Show)

46 deriving (Show)

44data RepositoryFieldError

48data RepositoryFieldError

@@ -160,6 +164,21 @@ displayUserError e = case e of

160 [ "Please install ", them, " first, by running `bower install`."

164 [ "Please install ", them, " first, by running `bower install`."

161 ])

165 ])

162 ]

166 ]

167+ ParseAndDesugarError (D.ParseError err) ->

168+ vcat

169+ [ para "Parse error:"

170+ , indented (para (show err))

171+ ]

172+ ParseAndDesugarError (D.SortModulesError err) ->

173+ vcat

174+ [ para "Error in sortModules:"

175+ , indented (para (P.prettyPrintMultipleErrors False err))

176+ ]

177+ ParseAndDesugarError (D.DesugarError err) ->

178+ vcat

179+ [ para "Error while desugaring:"

180+ , indented (para (P.prettyPrintMultipleErrors False err))

181+ ]

163

182

164displayRepositoryError :: RepositoryFieldError -> Box

183displayRepositoryError :: RepositoryFieldError -> Box

165displayRepositoryError err = case err of

184displayRepositoryError err = case err of

psc-publish/Main.hs+25−5

@@ -37,7 +37,6 @@ import Web.Bower.PackageMeta (PackageMeta(..), BowerError(..), PackageName,

37import qualified Web.Bower.PackageMeta as Bower

39import qualified Language.PureScript.Docs as D

40−import Output (parseAndDesugar, getInputAndDepsFiles)

41import Utils

40import Utils

42import ErrorsWarnings

41import ErrorsWarnings

@@ -99,7 +98,7 @@ preparePackage' = do

99 >>= flip catchLeft (userError . CouldntParseBowerJSON)

98 >>= flip catchLeft (userError . CouldntParseBowerJSON)

100 pkgVersion <- getVersionFromGitTag

99 pkgVersion <- getVersionFromGitTag

101 pkgGithub <- getBowerInfo pkgMeta

100 pkgGithub <- getBowerInfo pkgMeta

102− (pkgBookmarks, pkgModules) <- liftIO getModulesAndBookmarks

101+ (pkgBookmarks, pkgModules) <- getModulesAndBookmarks

103

102

104 let declaredDeps = map fst (bowerDependencies pkgMeta ++ bowerDevDependencies pkgMeta)

103 let declaredDeps = map fst (bowerDependencies pkgMeta ++ bowerDevDependencies pkgMeta)

105 pkgResolvedDependencies <- getResolvedDependencies declaredDeps

104 pkgResolvedDependencies <- getResolvedDependencies declaredDeps

@@ -108,10 +107,13 @@ preparePackage' = do

108

107

109 return D.UploadedPackage{..}

108 return D.UploadedPackage{..}

110

109

111−getModulesAndBookmarks :: IO ([D.Bookmark], [D.RenderedModule])

110+getModulesAndBookmarks :: PrepareM ([D.Bookmark], [D.RenderedModule])

112getModulesAndBookmarks = do

111getModulesAndBookmarks = do

113− (inputFiles, depsFiles) <- getInputAndDepsFiles

112+ (inputFiles, depsFiles) <- liftIO getInputAndDepsFiles

114− parseAndDesugar inputFiles depsFiles $ \bookmarks modules ->

113+ liftIO (D.parseAndDesugar inputFiles depsFiles renderModules)

114+ >>= either (userError . ParseAndDesugarError) return

115+ where

116+ renderModules bookmarks modules =

115 return (bookmarks, map D.renderModule modules)

117 return (bookmarks, map D.renderModule modules)

116

118

117getVersionFromGitTag :: PrepareM Version

119getVersionFromGitTag :: PrepareM Version

@@ -256,3 +258,21 @@ isPureScript :: FilePath -> IO Bool

256isPureScript dir = do

258isPureScript dir = do

257 files <- Glob.globDir1 purescriptSourceFiles dir

259 files <- Glob.globDir1 purescriptSourceFiles dir

258 return (not (null files))

260 return (not (null files))

261+

262+getInputAndDepsFiles :: IO ([FilePath], [(PackageName, FilePath)])

263+getInputAndDepsFiles = do

264+ inputFiles <- globRelative purescriptSourceFiles

265+ depsFiles' <- globRelative purescriptDepsFiles

266+ return (inputFiles, mapMaybe withPackageName depsFiles')

267+

268+withPackageName :: FilePath -> Maybe (PackageName, FilePath)

269+withPackageName fp = (,fp) <$> getPackageName fp

270+

271+getPackageName :: FilePath -> Maybe PackageName

272+getPackageName fp = do

273+ let xs = splitOn "/" fp

274+ ys <- stripPrefix ["bower_components"] xs

275+ y <- headMay ys

276+ case Bower.mkPackageName y of

277+ Right name -> Just name

278+ Left _ -> Nothing

psc-publish/Output.hsdeleted−131

@@ -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

purescript.cabal+2−2

@@ -132,6 +132,7 @@ library

132 Language.PureScript.Docs.RenderedCode.Render

133 Language.PureScript.Docs.AsMarkdown

134 Language.PureScript.Docs.AsHtml

135+ Language.PureScript.Docs.ParseAndDesugar

135 Language.PureScript.Docs.Utils.HtmlHelpers

136 Language.PureScript.Docs.Utils.HtmlHelpers

136 Language.PureScript.Docs.Utils.MonoidExtras

137 Language.PureScript.Docs.Utils.MonoidExtras

137

138

@@ -203,8 +204,7 @@ executable psc-publish

203 main-is: Main.hs

204 main-is: Main.hs

204 buildable: True

205 buildable: True

205 hs-source-dirs: psc-publish

206 hs-source-dirs: psc-publish

206− other-modules: Output

207+ other-modules: Utils

207− Utils

208 ErrorsWarnings

209 BoxesHelpers

210 ghc-options: -Wall -O2

src/Language/PureScript/Docs.hs+1

@@ -10,3 +10,4 @@ import Language.PureScript.Docs.Types as Docs

10import Language.PureScript.Docs.RenderedCode.Types as Docs

11import Language.PureScript.Docs.RenderedCode.Render as Docs

12import Language.PureScript.Docs.Render as Docs

13+import Language.PureScript.Docs.ParseAndDesugar as Docs

src/Language/PureScript/Docs/ParseAndDesugar.hsnew file+124

@@ -0,0 +1,124 @@

1+{-# LANGUAGE TupleSections #-}

3+module Language.PureScript.Docs.ParseAndDesugar

4+ ( parseAndDesugar

5+ , ParseDesugarError(..)

6+ ) where

8+import qualified Data.Map as M

9+import Control.Arrow (first)

10+import Control.Monad

11+import Control.Applicative

12+

13+import Control.Monad.Trans.Except

14+import Control.Monad.Error.Class (MonadError(..))

15+import Control.Monad.IO.Class (MonadIO(..))

16+

17+import Web.Bower.PackageMeta (PackageName)

18+

19+import qualified Text.Parsec as Parsec

20+import qualified Language.PureScript as P

21+import qualified Language.PureScript.Constants as C

22+import Language.PureScript.Docs.Types

23+import Language.PureScript.Docs.Render

24+

25+data ParseDesugarError

26+ = ParseError Parsec.ParseError

27+ | SortModulesError P.MultipleErrors

28+ | DesugarError P.MultipleErrors

29+ deriving (Show)

30+

31+-- |

32+-- Given:

33+--

34+-- * A list of local source files

35+-- * A list of source files from external dependencies, together with their

36+-- package names

37+-- * A callback, taking a list of bookmarks, and a list of desugared modules

38+--

39+-- This function does the following:

40+--

41+-- * Parse all of the input and dependency source files

42+-- * Partially desugar all of the resulting modules

43+-- * Collect a list of bookmarks from the whole set of source files

44+-- * Collect a list of desugared modules from just the input source files (not

45+-- dependencies)

46+-- * Call the callback with the bookmarks and desugared module list.

47+parseAndDesugar ::

48+ [FilePath]

49+ -> [(PackageName, FilePath)]

50+ -> ([Bookmark] -> [P.Module] -> IO a)

51+ -> IO (Either ParseDesugarError a)

52+parseAndDesugar inputFiles depsFiles callback = do

53+ inputFiles' <- mapM (parseAs Local) inputFiles

54+ depsFiles' <- mapM (\(pkgName, f) -> parseAs (FromDep pkgName) f) depsFiles

55+

56+ runExceptT $ do

57+ let eParsed = P.parseModulesFromFiles fileInfoToString (inputFiles' ++ depsFiles')

58+ ms <- throwLeft ParseError eParsed

59+

60+ let depsModules = getDepsModuleNames (map (\(fp, m) -> (,m) <$> fp) ms)

61+ let eSorted = P.sortModules . map (importPrim . importPrelude . snd) $ ms

62+ (ms', _) <- throwLeft SortModulesError eSorted

63+

64+ modules <- throwLeft DesugarError (desugar ms')

65+ let modules' = map (addPackage depsModules) modules

66+ bookmarks = concatMap collectBookmarks modules'

67+ liftIO (callback bookmarks (takeLocals modules'))

68+

69+ where

70+ throwLeft f = either (throwError . f) return

71+

72+-- | Specifies whether a PureScript source file is considered as:

73+--

74+-- 1) with the `Local` constructor, a target source file, i.e., we want to see

75+-- its modules in the output

76+-- 2) with the `FromDep` constructor, a dependencies source file, i.e. we do

77+-- not want its modules in the output; it is there to enable desugaring, and

78+-- to ensure that links between modules are constructed correctly.

79+type FileInfo = InPackage FilePath

80+

81+fileInfoToString :: FileInfo -> FilePath

82+fileInfoToString (Local fn) = fn

83+fileInfoToString (FromDep _ fn) = fn

84+

85+addDefaultImport :: P.ModuleName -> P.Module -> P.Module

86+addDefaultImport toImport m@(P.Module coms mn decls exps) =

87+ if isExistingImport `any` decls || mn == toImport then m

88+ else P.Module coms mn (P.ImportDeclaration toImport P.Implicit Nothing : decls) exps

89+ where

90+ isExistingImport (P.ImportDeclaration mn' _ _) | mn' == toImport = True

91+ isExistingImport (P.PositionedDeclaration _ _ d) = isExistingImport d

92+ isExistingImport _ = False

93+

94+importPrim :: P.Module -> P.Module

95+importPrim = addDefaultImport (P.ModuleName [P.ProperName C.prim])

96+

97+importPrelude :: P.Module -> P.Module

98+importPrelude = addDefaultImport (P.ModuleName [P.ProperName C.prelude])

99+

100+desugar :: [P.Module] -> Either P.MultipleErrors [P.Module]

101+desugar = P.evalSupplyT 0 . desugar'

102+ where

103+ desugar' :: [P.Module] -> P.SupplyT (Either P.MultipleErrors) [P.Module]

104+ desugar' = mapM P.desugarDoModule >=> P.desugarCasesModule >=> P.desugarImports

105+

106+parseFile :: FilePath -> IO (FilePath, String)

107+parseFile input' = (,) input' <$> readFile input'

108+

109+parseAs :: (FilePath -> a) -> FilePath -> IO (a, String)

110+parseAs g = fmap (first g) . parseFile

111+

112+getDepsModuleNames :: [InPackage (FilePath, P.Module)] -> M.Map P.ModuleName PackageName

113+getDepsModuleNames = foldl go M.empty

114+ where

115+ go deps p = deps # case p of

116+ Local _ -> id

117+ FromDep pkgName (_, m) -> M.insert (P.getModuleName m) pkgName

118+ (#) = flip ($)

119+

120+addPackage :: M.Map P.ModuleName PackageName -> P.Module -> InPackage P.Module

121+addPackage depsModules m =

122+ case M.lookup (P.getModuleName m) depsModules of

123+ Just pkgName -> FromDep pkgName m

124+ Nothing -> Local m