4c1d5af · rowtype-yoga/purescript-native

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

Refactor parseAndDesugar

* Generalised to work with any Monad which has both MonadIO and MonadError MultipleErrors instances * Remove the useless callback parameter; now, just return the modules and bookmarks instead.

commit4c1d5affe1ed5db1c5ab48fb5776685f517e5602 authorHarry Garrood <harry@garrood.me> dateTue 29 Dec 2015, 08:36 (11 years ago) parent2d5f547

4 files changed+44−28

compare with golang

unifiedsplit

psc-docs/Main.hs+3−2 purescript.cabal+2−1 src/Language/PureScript/Docs/ParseAndDesugar.hs+28−21 src/Language/PureScript/Publish.hs+11−4

psc-docs/Main.hs+3−2

@@ -16,6 +16,7 @@

1616module Main where

1717

1818import Control.Applicative

19+import Control.Monad.Trans.Except (runExceptT)

1920import Control.Arrow (first, second)

2021import Control.Category ((>>>))

2122import Control.Monad.Writer

@@ -68,12 +69,12 @@ docgen (PSCDocsOptions fmt inputGlob output) = do

6869 Etags -> dumpTags input dumpEtags

6970 Ctags -> dumpTags input dumpCtags

7071 Markdown -> do

71− e <- D.parseAndDesugar input [] (\_ ms -> return ms)

72+ e <- liftIO . runExceptT $ D.parseAndDesugar input []

7273 case e of

7374 Left err -> do

7475 hPutStrLn stderr $ P.prettyPrintMultipleErrors False err

7576 exitFailure

76− Right ms' ->

77+ Right (ms', _) ->

7778 case output of

7879 EverythingToStdOut ->

7980 putStrLn (D.renderModulesAsMarkdown ms')

purescript.cabal+2−1

@@ -220,7 +220,8 @@ executable psc-docs

220220 build-depends: base >=4 && <5, purescript -any,

221221 optparse-applicative >= 0.10.0, process -any, mtl -any,

222222 split -any, ansi-wl-pprint -any, directory -any,

223− filepath -any, Glob -any

223+ filepath -any, Glob -any, transformers -any,

224+ transformers-compat -any

224225 main-is: Main.hs

225226 buildable: True

226227 hs-source-dirs: psc-docs

src/Language/PureScript/Docs/ParseAndDesugar.hs+28−21

@@ -1,4 +1,5 @@

11{-# LANGUAGE TupleSections #-}

2+{-# LANGUAGE FlexibleContexts #-}

34module Language.PureScript.Docs.ParseAndDesugar

45 ( parseAndDesugar

@@ -11,7 +12,6 @@ import qualified Data.Map as M

1112import Control.Arrow (first)

1213import Control.Monad

1314

14−import Control.Monad.Trans.Except

1515import Control.Monad.Writer.Strict (runWriterT)

1616import Control.Monad.Error.Class (MonadError(..))

1717import Control.Monad.IO.Class (MonadIO(..))

@@ -29,40 +29,40 @@ import Language.PureScript.Docs.Convert (collectBookmarks)

2929-- * A list of local source files

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

3131-- package names

32−-- * A callback, taking a list of bookmarks, and a list of desugared modules

3332--

3433-- This function does the following:

3534--

3635-- * Parse all of the input and dependency source files

37−-- * Partially desugar all of the resulting modules

36+-- * Partially desugar all of the resulting modules (just enough for

37+-- producing documentation from them)

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

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

4040-- dependencies)

41−-- * Call the callback with the bookmarks and desugared module list.

41+-- * Return the desugared modules and the bookmarks.

4242parseAndDesugar ::

43+ (Functor m, Applicative m, MonadError P.MultipleErrors m, MonadIO m) =>

4344 [FilePath]

4445 -> [(PackageName, FilePath)]

45− -> ([Bookmark] -> [P.Module] -> IO a)

46− -> IO (Either P.MultipleErrors a)

47−parseAndDesugar inputFiles depsFiles callback = do

46+ -> m ([P.Module], [Bookmark])

47+parseAndDesugar inputFiles depsFiles = do

4848 inputFiles' <- traverse (parseAs Local) inputFiles

4949 depsFiles' <- traverse (\(pkgName, f) -> parseAs (FromDep pkgName) f) depsFiles

5050

51− runExceptT $ do

52− ms <- parseFiles (inputFiles' ++ depsFiles')

53− ms' <- sortModules (map snd ms)

54− (bs, ms'') <- desugarWithBookmarks ms ms'

55− liftIO $ callback bs ms''

51+ ms <- parseFiles (inputFiles' ++ depsFiles')

52+ ms' <- sortModules (map snd ms)

53+ desugarWithBookmarks ms ms'

5654

5755parseFiles ::

56+ (MonadError P.MultipleErrors m, MonadIO m) =>

5857 [(FileInfo, FilePath)]

59− -> ExceptT P.MultipleErrors IO [(FileInfo, P.Module)]

58+ -> m [(FileInfo, P.Module)]

6059parseFiles =

6160 throwLeft . P.parseModulesFromFiles fileInfoToString

6261

6362sortModules ::

63+ (Functor m, MonadError P.MultipleErrors m, MonadIO m) =>

6464 [P.Module]

65− -> ExceptT P.MultipleErrors IO [P.Module]

65+ -> m [P.Module]

6666sortModules =

6767 fmap fst . throwLeft . sortModules' . map importPrim

6868 where

@@ -70,9 +70,10 @@ sortModules =

7070 sortModules' = P.sortModules

7171

7272desugarWithBookmarks ::

73+ (MonadError P.MultipleErrors m, MonadIO m) =>

7374 [(FileInfo, P.Module)]

7475 -> [P.Module]

75− -> ExceptT P.MultipleErrors IO ([Bookmark], [P.Module])

76+ -> m ([P.Module], [Bookmark])

7677desugarWithBookmarks msInfo msSorted = do

7778 msDesugared <- throwLeft (desugar msSorted)

7879

@@ -80,7 +81,7 @@ desugarWithBookmarks msInfo msSorted = do

8081 msPackages = map (addPackage msDeps) msDesugared

8182 bookmarks = concatMap collectBookmarks msPackages

8283

83− return (bookmarks, takeLocals msPackages)

84+ return (takeLocals msPackages, bookmarks)

8485

8586throwLeft :: (MonadError l m) => Either l r -> m r

8687throwLeft = either throwError return

@@ -101,18 +102,24 @@ fileInfoToString (FromDep _ fn) = fn

101102importPrim :: P.Module -> P.Module

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

103104

104−desugar :: [P.Module] -> Either P.MultipleErrors [P.Module]

105+desugar ::

106+ (Functor m, Applicative m, MonadError P.MultipleErrors m) =>

107+ [P.Module]

108+ -> m [P.Module]

105109desugar = P.evalSupplyT 0 . desugar'

106110 where

107− desugar' :: [P.Module] -> P.SupplyT (Either P.MultipleErrors) [P.Module]

108− desugar' = traverse P.desugarDoModule >=> P.desugarCasesModule >=> ignoreWarnings . P.desugarImports []

111+ desugar' =

112+ traverse P.desugarDoModule

113+ >=> P.desugarCasesModule

114+ >=> ignoreWarnings . P.desugarImports []

115+

109116 ignoreWarnings m = liftM fst (runWriterT m)

110117

111118parseFile :: FilePath -> IO (FilePath, String)

112119parseFile input' = (,) input' <$> readFile input'

113120

114−parseAs :: (FilePath -> a) -> FilePath -> IO (a, String)

115−parseAs g = fmap (first g) . parseFile

121+parseAs :: (Functor m, MonadIO m) => (FilePath -> a) -> FilePath -> m (a, String)

122+parseAs g = fmap (first g) . liftIO . parseFile

116123

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

118125getDepsModuleNames = foldl go M.empty

src/Language/PureScript/Publish.hs+11−4

@@ -146,11 +146,18 @@ preparePackage' opts = do

146146getModulesAndBookmarks :: PrepareM ([D.Bookmark], [D.Module])

147147getModulesAndBookmarks = do

148148 (inputFiles, depsFiles) <- liftIO getInputAndDepsFiles

149− liftIO (D.parseAndDesugar inputFiles depsFiles renderModules)

150− >>= either (userError . CompileError) return

149+ (modules', bookmarks) <- parseAndDesugar inputFiles depsFiles

150+

151+ return (bookmarks, map D.convertModule modules')

152+

151153 where

152− renderModules bookmarks modules =

153− return (bookmarks, map D.convertModule modules)

154+ parseAndDesugar inputFiles depsFiles = do

155+ r <- liftIO . runExceptT $ D.parseAndDesugar inputFiles depsFiles

156+ case r of

157+ Right r' ->

158+ return r'

159+ Left err ->

160+ userError (CompileError err)

154161

155162data TreeStatus = Clean | Dirty deriving (Show, Read, Eq, Ord, Enum)

156163