29bbd33 · rowtype-yoga/purescript-native

psc-make/Main.hs+8−5

compare with golang

unifiedsplit

@@ -19,6 +19,7 @@ module Main where

19import Control.Applicative

20import Control.Monad.Except

21import Control.Monad.Reader

22+import Control.Monad.Writer

22

23

23import Data.Version (showVersion)

24import Data.Version (showVersion)

24import Data.Traversable (traverse)

25import Data.Traversable (traverse)

@@ -52,11 +53,11 @@ readInput InputOptions{..} = do

52 content <- forM ioInputFiles $ \inFile -> (Right inFile, ) <$> readFile inFile

53 content <- forM ioInputFiles $ \inFile -> (Right inFile, ) <$> readFile inFile

53 return (if ioNoPrelude then content else (Left P.RebuildNever, P.prelude) : content)

54 return (if ioNoPrelude then content else (Left P.RebuildNever, P.prelude) : content)

54

55

55−newtype Make a = Make { unMake :: ReaderT (P.Options P.Make) (ExceptT P.MultipleErrors IO) a }

56+newtype Make a = Make { unMake :: ReaderT (P.Options P.Make) (WriterT P.MultipleErrors (ExceptT P.MultipleErrors IO)) a }

56− deriving (Functor, Applicative, Monad, MonadIO, MonadError P.MultipleErrors, MonadReader (P.Options P.Make))

57+ deriving (Functor, Applicative, Monad, MonadIO, MonadError P.MultipleErrors, MonadWriter P.MultipleErrors, MonadReader (P.Options P.Make))

57

58

58−runMake :: P.Options P.Make -> Make a -> IO (Either P.MultipleErrors a)

59+runMake :: P.Options P.Make -> Make a -> IO (Either P.MultipleErrors (a, P.MultipleErrors))

59−runMake opts = runExceptT . flip runReaderT opts . unMake

60+runMake opts = runExceptT . runWriterT . flip runReaderT opts . unMake

60

61

61makeIO :: (IOError -> P.ErrorMessage) -> IO a -> Make a

62makeIO :: (IOError -> P.ErrorMessage) -> IO a -> Make a

62makeIO f io = do

63makeIO f io = do

@@ -89,7 +90,9 @@ compile (PSCMakeOptions input outputDir opts usePrefix) = do

89 Left errs -> do

90 Left errs -> do

90 putStrLn (P.prettyPrintMultipleErrors (P.optionsVerboseErrors opts) errs)

91 putStrLn (P.prettyPrintMultipleErrors (P.optionsVerboseErrors opts) errs)

91 exitFailure

92 exitFailure

92− Right _ -> do

93+ Right (_, warnings) -> do

94+ when (P.nonEmpty warnings) $

95+ putStrLn (P.prettyPrintMultipleWarnings (P.optionsVerboseErrors opts) warnings)

93 exitSuccess

96 exitSuccess

94 where

97 where

95 prefix = if usePrefix

98 prefix = if usePrefix

psc/Main.hs+10−3

@@ -19,6 +19,7 @@ module Main where

19import Control.Applicative

20import Control.Monad.Except

21import Control.Monad.Reader

22+import Control.Monad.Writer

22

23

23import Data.Maybe (fromMaybe)

24import Data.Maybe (fromMaybe)

24import Data.Version (showVersion)

25import Data.Version (showVersion)

@@ -32,7 +33,6 @@ import System.IO (hPutStrLn, stderr)

32import qualified Language.PureScript as P

33import qualified Language.PureScript as P

33import qualified Paths_purescript as Paths

34import qualified Paths_purescript as Paths

34

35

35−

36data PSCOptions = PSCOptions

37 { pscInput :: [FilePath]

38 , pscOpts :: P.Options P.Compile

@@ -54,6 +54,11 @@ readInput InputOptions{..}

54 | otherwise = do content <- forM ioInputFiles $ \inFile -> (Just inFile, ) <$> readFile inFile

55 return (if ioNoPrelude then content else (Nothing, P.prelude) : content)

56

57+type PSC = ReaderT (P.Options P.Compile) (WriterT P.MultipleErrors (Either P.MultipleErrors))

58+

59+runPSC :: P.Options P.Compile -> PSC a -> Either P.MultipleErrors (a, P.MultipleErrors)

60+runPSC opts rwe = runWriterT (runReaderT rwe opts)

61+

57compile :: PSCOptions -> IO ()

62compile :: PSCOptions -> IO ()

58compile (PSCOptions input opts stdin output externs usePrefix) = do

63compile (PSCOptions input opts stdin output externs usePrefix) = do

59 modules <- P.parseModulesFromFiles (fromMaybe "") <$> readInput (InputOptions (P.optionsNoPrelude opts) stdin input)

64 modules <- P.parseModulesFromFiles (fromMaybe "") <$> readInput (InputOptions (P.optionsNoPrelude opts) stdin input)

@@ -62,11 +67,13 @@ compile (PSCOptions input opts stdin output externs usePrefix) = do

62 hPutStrLn stderr $ show err

67 hPutStrLn stderr $ show err

63 exitFailure

68 exitFailure

64 Right ms -> do

69 Right ms -> do

65− case P.compile (map snd ms) prefix `runReaderT` opts of

70+ case runPSC opts (P.compile (map snd ms) prefix) of

66 Left errs -> do

71 Left errs -> do

67 hPutStrLn stderr (P.prettyPrintMultipleErrors (P.optionsVerboseErrors opts) errs)

72 hPutStrLn stderr (P.prettyPrintMultipleErrors (P.optionsVerboseErrors opts) errs)

68 exitFailure

73 exitFailure

69− Right (js, exts, _) -> do

74+ Right ((js, exts, _), warnings) -> do

75+ when (P.nonEmpty warnings) $

76+ hPutStrLn stderr (P.prettyPrintMultipleWarnings (P.optionsVerboseErrors opts) warnings)

70 case output of

77 case output of

71 Just path -> mkdirp path >> writeFile path js

78 Just path -> mkdirp path >> writeFile path js

72 Nothing -> putStrLn js

79 Nothing -> putStrLn js

psci/PSCi.hs+4−3

@@ -33,6 +33,7 @@ import Control.Monad.IO.Class (MonadIO, liftIO)

33import Control.Monad.Error.Class (throwError)

34import Control.Monad.Except (ExceptT(..), MonadError, runExceptT)

35import Control.Monad.Reader (MonadReader, ReaderT, runReaderT)

36+import Control.Monad.Writer (MonadWriter, WriterT, runWriterT)

36import Control.Monad.Trans.Class

37import Control.Monad.Trans.Class

37import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT)

38import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT)

38import Control.Monad.Trans.State.Strict

39import Control.Monad.Trans.State.Strict

@@ -182,11 +183,11 @@ newtype PSCI a = PSCI { runPSCI :: InputT (StateT PSCiState IO) a } deriving (Fu

182psciIO :: IO a -> PSCI a

183psciIO :: IO a -> PSCI a

183psciIO io = PSCI . lift $ lift io

184psciIO io = PSCI . lift $ lift io

184

185

185−newtype Make a = Make { unMake :: ReaderT (P.Options P.Make) (ExceptT P.MultipleErrors IO) a }

186+newtype Make a = Make { unMake :: ReaderT (P.Options P.Make) (WriterT P.MultipleErrors (ExceptT P.MultipleErrors IO)) a }

186− deriving (Functor, Applicative, Monad, MonadIO, MonadError P.MultipleErrors, MonadReader (P.Options P.Make))

187+ deriving (Functor, Applicative, Monad, MonadIO, MonadError P.MultipleErrors, MonadWriter P.MultipleErrors, MonadReader (P.Options P.Make))

187

188

188runMake :: Make a -> IO (Either P.MultipleErrors a)

189runMake :: Make a -> IO (Either P.MultipleErrors a)

189−runMake = runExceptT . flip runReaderT options . unMake

190+runMake = runExceptT . fmap fst . runWriterT . flip runReaderT options . unMake

190

191

191makeIO :: (IOError -> P.ErrorMessage) -> IO a -> Make a

192makeIO :: (IOError -> P.ErrorMessage) -> IO a -> Make a

192makeIO f io = do

193makeIO f io = do

purescript.cabal+1

@@ -71,6 +71,7 @@ library

71 Language.PureScript.Environment

72 Language.PureScript.Errors

73 Language.PureScript.Kinds

74+ Language.PureScript.Linter

74 Language.PureScript.ModuleDependencies

75 Language.PureScript.ModuleDependencies

75 Language.PureScript.Names

76 Language.PureScript.Names

76 Language.PureScript.Options

77 Language.PureScript.Options

src/Language/PureScript.hs+15−10

@@ -45,6 +45,7 @@ import Control.Applicative

45import Control.Arrow ((&&&))

46import Control.Monad.Except

47import Control.Monad.Reader

48+import Control.Monad.Writer

48

49

49import System.FilePath ((</>))

50import System.FilePath ((</>))

50

51

@@ -55,6 +56,7 @@ import Language.PureScript.DeadCodeElimination as P

55import Language.PureScript.Environment as P

56import Language.PureScript.Environment as P

56import Language.PureScript.Errors as P

57import Language.PureScript.Errors as P

57import Language.PureScript.Kinds as P

58import Language.PureScript.Kinds as P

59+import Language.PureScript.Linter as P

58import Language.PureScript.ModuleDependencies as P

60import Language.PureScript.ModuleDependencies as P

59import Language.PureScript.Names as P

61import Language.PureScript.Names as P

60import Language.PureScript.Options as P

62import Language.PureScript.Options as P

@@ -89,26 +91,27 @@ import qualified Paths_purescript as Paths

89--

91--

90-- * Pretty-print the generated Javascript

92-- * Pretty-print the generated Javascript

91--

93--

92−compile :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadReader (Options Compile) m)

94+compile :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m, MonadReader (Options Compile) m)

93 => [Module] -> [String] -> m (String, String, Environment)

95 => [Module] -> [String] -> m (String, String, Environment)

94compile = compile' initEnvironment

96compile = compile' initEnvironment

95

97

96−compile' :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadReader (Options Compile) m)

98+compile' :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m, MonadReader (Options Compile) m)

97 => Environment -> [Module] -> [String] -> m (String, String, Environment)

99 => Environment -> [Module] -> [String] -> m (String, String, Environment)

98compile' env ms prefix = do

100compile' env ms prefix = do

99 noPrelude <- asks optionsNoPrelude

101 noPrelude <- asks optionsNoPrelude

100 additional <- asks optionsAdditional

102 additional <- asks optionsAdditional

101 mainModuleIdent <- asks (fmap moduleNameFromString . optionsMain)

103 mainModuleIdent <- asks (fmap moduleNameFromString . optionsMain)

102 (sorted, _) <- sortModules $ map importPrim $ if noPrelude then ms else map importPrelude ms

104 (sorted, _) <- sortModules $ map importPrim $ if noPrelude then ms else map importPrelude ms

105+ mapM_ lint sorted

103 (desugared, nextVar) <- runSupplyT 0 $ desugar sorted

106 (desugared, nextVar) <- runSupplyT 0 $ desugar sorted

104 (elaborated, env') <- runCheck' env $ forM desugared $ typeCheckModule mainModuleIdent

107 (elaborated, env') <- runCheck' env $ forM desugared $ typeCheckModule mainModuleIdent

105 regrouped <- createBindingGroupsModule . collapseBindingGroupsModule $ elaborated

108 regrouped <- createBindingGroupsModule . collapseBindingGroupsModule $ elaborated

106 let corefn = map (CoreFn.moduleToCoreFn env') regrouped

109 let corefn = map (CoreFn.moduleToCoreFn env') regrouped

107− let entryPoints = moduleNameFromString `map` entryPointModules additional

110+ entryPoints = moduleNameFromString `map` entryPointModules additional

108− let elim = if null entryPoints then corefn else eliminateDeadCode entryPoints corefn

111+ elim = if null entryPoints then corefn else eliminateDeadCode entryPoints corefn

109− let renamed = renameInModules elim

112+ renamed = renameInModules elim

110− let codeGenModuleNames = moduleNameFromString `map` codeGenModules additional

113+ codeGenModuleNames = moduleNameFromString `map` codeGenModules additional

111− let modulesToCodeGen = if null codeGenModuleNames then renamed else filter (\(CoreFn.Module _ mn _ _ _ _) -> mn `elem` codeGenModuleNames) renamed

114+ modulesToCodeGen = if null codeGenModuleNames then renamed else filter (\(CoreFn.Module _ mn _ _ _ _) -> mn `elem` codeGenModuleNames) renamed

112 js <- concat <$> (evalSupplyT nextVar $ T.traverse moduleToJs modulesToCodeGen)

115 js <- concat <$> (evalSupplyT nextVar $ T.traverse moduleToJs modulesToCodeGen)

113 let exts = intercalate "\n" . map (`moduleToPs` env') $ regrouped

116 let exts = intercalate "\n" . map (`moduleToPs` env') $ regrouped

114 js' <- generateMain env' js

117 js' <- generateMain env' js

@@ -129,7 +132,7 @@ generateMain env js = do

129-- |

132-- |

130-- A type class which collects the IO actions we need to be able to run in "make" mode

133-- A type class which collects the IO actions we need to be able to run in "make" mode

131--

134--

132−class (MonadReader (P.Options P.Make) m, MonadError MultipleErrors m) => MonadMake m where

135+class (MonadReader (P.Options P.Make) m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => MonadMake m where

133 -- |

136 -- |

134 -- Get a file timestamp

137 -- Get a file timestamp

135 --

138 --

@@ -178,6 +181,8 @@ make outputDir ms prefix = do

178

181

179 (sorted, graph) <- sortModules $ map importPrim $ if noPrelude then map snd ms else map (importPrelude . snd) ms

182 (sorted, graph) <- sortModules $ map importPrim $ if noPrelude then map snd ms else map (importPrelude . snd) ms

180

183

184+ mapM_ lint sorted

185+

181 toRebuild <- foldM (\s (Module _ moduleName' _ _) -> do

186 toRebuild <- foldM (\s (Module _ moduleName' _ _) -> do

182 let filePath = runModuleName moduleName'

187 let filePath = runModuleName moduleName'

183

188

@@ -219,8 +224,8 @@ make outputDir ms prefix = do

219 regrouped <- createBindingGroups moduleName' . collapseBindingGroups $ elaborated

224 regrouped <- createBindingGroups moduleName' . collapseBindingGroups $ elaborated

220

225

221 let mod' = Module coms moduleName' regrouped exps

226 let mod' = Module coms moduleName' regrouped exps

222− let corefn = CoreFn.moduleToCoreFn env' mod'

227+ corefn = CoreFn.moduleToCoreFn env' mod'

223− let [renamed] = renameInModules [corefn]

228+ [renamed] = renameInModules [corefn]

224

229

225 pjs <- prettyPrintJS <$> moduleToJs renamed

230 pjs <- prettyPrintJS <$> moduleToJs renamed

226 let js = unlines $ map ("// " ++) prefix ++ [pjs]

231 let js = unlines $ map ("// " ++) prefix ++ [pjs]

src/Language/PureScript/Errors.hs+22−4

@@ -107,6 +107,7 @@ data ErrorMessage

107 | InvalidNewtype

108 | InvalidInstanceHead Type

109 | TransitiveExportError DeclarationRef [DeclarationRef]

110+ | ShadowedName Ident

110 | ErrorInExpression Expr ErrorMessage

111 | ErrorInExpression Expr ErrorMessage

111 | ErrorInModule ModuleName ErrorMessage

112 | ErrorInModule ModuleName ErrorMessage

112 | ErrorInInstance (Qualified ProperName) [Type] ErrorMessage

113 | ErrorInInstance (Qualified ProperName) [Type] ErrorMessage

@@ -198,6 +199,7 @@ errorCode TypeSynonymInstance = "TypeSynonymInstance"

198errorCode InvalidNewtype = "InvalidNewtype"

199errorCode InvalidNewtype = "InvalidNewtype"

199errorCode (InvalidInstanceHead _) = "InvalidInstanceHead"

200errorCode (InvalidInstanceHead _) = "InvalidInstanceHead"

200errorCode (TransitiveExportError _ _) = "TransitiveExportError"

201errorCode (TransitiveExportError _ _) = "TransitiveExportError"

202+errorCode (ShadowedName _) = "ShadowedName"

201errorCode (NotYetDefined _ e) = errorCode e

203errorCode (NotYetDefined _ e) = errorCode e

202errorCode (ErrorUnifyingTypes _ _ e) = errorCode e

204errorCode (ErrorUnifyingTypes _ _ e) = errorCode e

203errorCode (ErrorInExpression _ e) = errorCode e

205errorCode (ErrorInExpression _ e) = errorCode e

@@ -229,6 +231,10 @@ instance UnificationError Type MultipleErrors where

229instance UnificationError Kind MultipleErrors where

231instance UnificationError Kind MultipleErrors where

230 occursCheckFailed = errorMessage . occursCheckFailed

232 occursCheckFailed = errorMessage . occursCheckFailed

231

233

234+-- | Check whether a collection of errors is empty or not.

235+nonEmpty :: MultipleErrors -> Bool

236+nonEmpty = not . null . runMultipleErrors

237+

232-- |

238-- |

233-- Create an error set from a single error message

239-- Create an error set from a single error message

234--

240--

@@ -374,6 +380,7 @@ prettyPrintSingleError full e = prettyPrintErrorMessage (if full then e else sim

374 ]

380 ]

375 go (TransitiveExportError x ys) = paras $ (line $ "An export for " ++ prettyPrintExport x ++ " requires the following to also be exported: ")

381 go (TransitiveExportError x ys) = paras $ (line $ "An export for " ++ prettyPrintExport x ++ " requires the following to also be exported: ")

376 : map (line . prettyPrintExport) ys

382 : map (line . prettyPrintExport) ys

383+ go (ShadowedName nm) = line $ "Name '" ++ show nm ++ "' was shadowed."

377 go (ErrorUnifyingTypes t1 t2 err) = paras [ line "Error unifying type "

384 go (ErrorUnifyingTypes t1 t2 err) = paras [ line "Error unifying type "

378 , indent $ line $ prettyPrintType t1

385 , indent $ line $ prettyPrintType t1

379 , line "with type"

386 , line "with type"

@@ -510,10 +517,21 @@ prettyPrintSingleError full e = prettyPrintErrorMessage (if full then e else sim

510-- Pretty print multiple errors

517-- Pretty print multiple errors

511--

518--

512prettyPrintMultipleErrors :: Bool -> MultipleErrors -> String

519prettyPrintMultipleErrors :: Bool -> MultipleErrors -> String

520+prettyPrintMultipleErrors = prettyPrintMultipleErrorsWith "Error:" "Multiple errors:"

521+

522+-- |

523+-- Pretty print multiple warnings

524+--

525+prettyPrintMultipleWarnings :: Bool -> MultipleErrors -> String

526+prettyPrintMultipleWarnings = prettyPrintMultipleErrorsWith "Warning:" "Multiple warnings:"

527+

528+prettyPrintMultipleErrorsWith :: String -> String -> Bool -> MultipleErrors -> String

513−prettyPrintMultipleErrors full (MultipleErrors [e]) = renderBox $

529+prettyPrintMultipleErrorsWith intro _ full (MultipleErrors [e]) = renderBox $

530+ Box.vcat Box.left [ Box.text intro

514− prettyPrintSingleError full e

531+ , prettyPrintSingleError full e

532+ ]

515−prettyPrintMultipleErrors full (MultipleErrors es) = renderBox $

533+prettyPrintMultipleErrorsWith _ intro full (MultipleErrors es) = renderBox $

516− Box.vcat Box.left [ Box.text "Multiple errors:"

534+ Box.vcat Box.left [ Box.text intro

517 , Box.vsep 1 Box.left $ map (Box.moveRight 2 . prettyPrintSingleError full) es

535 , Box.vsep 1 Box.left $ map (Box.moveRight 2 . prettyPrintSingleError full) es

518 ]

536 ]

519

537

src/Language/PureScript/Linter.hsnew file+73

@@ -0,0 +1,73 @@

1+-----------------------------------------------------------------------------

2+--

3+-- Module : Language.PureScript.Linter

5+-- License : MIT

6+--

7+-- Maintainer : Phil Freeman <paf31@cantab.net>

8+-- Stability : experimental

9+-- Portability :

10+--

11+-- | This module implements a simple linting pass on the PureScript AST.

12+--

13+-----------------------------------------------------------------------------

14+

15+{-# LANGUAGE GeneralizedNewtypeDeriving #-}

16+{-# LANGUAGE FlexibleContexts #-}

17+{-# LANGUAGE ScopedTypeVariables #-}

18+

19+module Language.PureScript.Linter (lint) where

20+

21+import Data.List (mapAccumL, nub)

22+import Data.Maybe (mapMaybe)

23+import Data.Monoid

24+

25+import qualified Data.Set as S

26+

27+import Control.Applicative

28+import Control.Monad.Writer.Class

29+

30+import Language.PureScript.AST

31+import Language.PureScript.Names

32+import Language.PureScript.Errors

33+

34+-- | Lint the PureScript AST.

35+-- |

36+-- | Right now, this pass only performs a shadowing check.

37+lint :: forall m. (Applicative m, MonadWriter MultipleErrors m) => Module -> m ()

38+lint (Module _ mn ds _) = censor (onErrorMessages (ErrorInModule mn)) $ mapM_ lintDeclaration ds

39+ where

40+ moduleNames :: S.Set Ident

41+ moduleNames = S.fromList (nub (mapMaybe getDeclIdent ds))

42+

43+ getDeclIdent :: Declaration -> Maybe Ident

44+ getDeclIdent (PositionedDeclaration _ _ d) = getDeclIdent d

45+ getDeclIdent (ValueDeclaration ident _ _ _) = Just ident

46+ getDeclIdent (ExternDeclaration _ ident _ _) = Just ident

47+ getDeclIdent (ExternInstanceDeclaration ident _ _ _) = Just ident

48+ getDeclIdent (TypeInstanceDeclaration ident _ _ _ _) = Just ident

49+ getDeclIdent (BindingGroupDeclaration _) = error "lint: binding groups should not be desugared yet."

50+ getDeclIdent _ = Nothing

51+

52+ lintDeclaration :: Declaration -> m ()

53+ lintDeclaration d =

54+ let (f, _, _, _, _) = everythingWithContextOnValues moduleNames mempty mappend def stepE stepB def def

55+ in tell (f d)

56+ where

57+ def s _ = (s, mempty)

58+

59+ stepE :: S.Set Ident -> Expr -> (S.Set Ident, MultipleErrors)

60+ stepE s (Abs (Left name) _) = bind s name

61+ stepE s (Let ds' _) =

62+ case mapAccumL bind s (nub (mapMaybe getDeclIdent ds')) of

63+ (s', es) -> (s', mconcat es)

64+ stepE s _ = (s, mempty)

65+

66+ stepB :: S.Set Ident -> Binder -> (S.Set Ident, MultipleErrors)

67+ stepB s (VarBinder name) = bind s name

68+ stepB s (NamedBinder name _) = bind s name

69+ stepB s _ = (s, mempty)

70+

71+ bind :: S.Set Ident -> Ident -> (S.Set Ident, MultipleErrors)

72+ bind s name | name `S.member` s = (s, errorMessage (ShadowedName name))

73+ | otherwise = (S.insert name s, mempty)

src/Language/PureScript/Renamer.hs+11−9

@@ -14,6 +14,8 @@

14--

15-----------------------------------------------------------------------------

16

17+{-# LANGUAGE FlexibleContexts, ScopedTypeVariables #-}

18+

17module Language.PureScript.Renamer (renameInModules) where

19module Language.PureScript.Renamer (renameInModules) where

18

20

19import Control.Applicative

21import Control.Applicative

@@ -74,13 +76,12 @@ updateScope :: Ident -> Rename Ident

74updateScope i@(Ident name) | name == C.__unused = return i

76updateScope i@(Ident name) | name == C.__unused = return i

75updateScope name = do

77updateScope name = do

76 scope <- get

78 scope <- get

77− let name' = case name `S.member` rsUsedNames scope of

79+ name' <- case name `S.member` rsUsedNames scope of

78− True ->

80+ True -> do

79− let

80− newNames = [ Ident (runIdent name ++ "_" ++ show (i :: Int)) | i <- [1..] ]

81+ let newNames = [ Ident (runIdent name ++ "_" ++ show (i :: Int)) | i <- [1..] ]

81− Just newName = find (`S.notMember` rsUsedNames scope) newNames

82+ Just newName = find (`S.notMember` rsUsedNames scope) newNames

82− in newName

83+ return newName

83− False -> name

84+ False -> return name

84 modify $ \s -> s { rsBoundNames = M.insert name name' (rsBoundNames s)

85 modify $ \s -> s { rsBoundNames = M.insert name name' (rsBoundNames s)

85 , rsUsedNames = S.insert name' (rsUsedNames s)

86 , rsUsedNames = S.insert name' (rsUsedNames s)

86 }

87 }

@@ -113,7 +114,8 @@ renameInModules :: [Module Ann] -> [Module Ann]

113renameInModules = map go

114renameInModules = map go

114 where

115 where

115 go :: Module Ann -> Module Ann

116 go :: Module Ann -> Module Ann

116− go m@(Module _ _ _ _ _ decls) = m { moduleDecls = renameInDecl' (findDeclIdents decls) `map` decls }

117+ go m@(Module _ _ _ _ _ decls) = m { moduleDecls = map (renameInDecl' (findDeclIdents decls)) decls }

118+

117 renameInDecl' :: [Ident] -> Bind Ann -> Bind Ann

119 renameInDecl' :: [Ident] -> Bind Ann -> Bind Ann

118 renameInDecl' scope = runRename scope . renameInDecl True

120 renameInDecl' scope = runRename scope . renameInDecl True

119

121

@@ -175,7 +177,7 @@ renameInLiteral _ l = return l

175-- Renames within case alternatives.

177-- Renames within case alternatives.

176--

178--

177renameInCaseAlternative :: CaseAlternative Ann -> Rename (CaseAlternative Ann)

179renameInCaseAlternative :: CaseAlternative Ann -> Rename (CaseAlternative Ann)

178−renameInCaseAlternative (CaseAlternative bs v) =

180+renameInCaseAlternative (CaseAlternative bs v) = newScope $

179 CaseAlternative <$> mapM renameInBinder bs

181 CaseAlternative <$> mapM renameInBinder bs

180 <*> eitherM (mapM (pairM renameInValue renameInValue)) renameInValue v

182 <*> eitherM (mapM (pairM renameInValue renameInValue)) renameInValue v

181

183

src/Language/PureScript/Sugar/CaseDeclarations.hs+19−11

@@ -14,7 +14,7 @@

14--

15-----------------------------------------------------------------------------

16

17−{-# LANGUAGE FlexibleContexts #-}

17+{-# LANGUAGE FlexibleContexts, ScopedTypeVariables #-}

18

19module Language.PureScript.Sugar.CaseDeclarations (

20 desugarCases,

@@ -90,12 +90,24 @@ inSameGroup (PositionedDeclaration _ _ d1) d2 = inSameGroup d1 d2

90inSameGroup d1 (PositionedDeclaration _ _ d2) = inSameGroup d1 d2

91inSameGroup _ _ = False

92

93−toDecls :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => [Declaration] -> m [Declaration]

93+toDecls :: forall m. (Functor m, Applicative m, Monad m, MonadSupply m, MonadError MultipleErrors m) => [Declaration] -> m [Declaration]

94toDecls [ValueDeclaration ident nameKind bs (Right val)] | all isVarBinder bs = do

95− let args = map (\(VarBinder arg) -> arg) bs

95+ args <- mapM fromVarBinder bs

96− body = foldr (Abs . Left) val args

96+ let body = foldr (Abs . Left) val args

97 guardWith (errorMessage (OverlappingArgNames (Just ident))) $ length (nub args) == length args

98 return [ValueDeclaration ident nameKind [] (Right body)]

99+ where

100+ isVarBinder :: Binder -> Bool

101+ isVarBinder NullBinder = True

102+ isVarBinder (VarBinder _) = True

103+ isVarBinder (PositionedBinder _ _ b) = isVarBinder b

104+ isVarBinder _ = False

105+

106+ fromVarBinder :: Binder -> m Ident

107+ fromVarBinder NullBinder = Ident <$> freshName

108+ fromVarBinder (VarBinder name) = return name

109+ fromVarBinder (PositionedBinder _ _ b) = fromVarBinder b

110+ fromVarBinder _ = error "fromVarBinder: Invalid argument"

99toDecls ds@(ValueDeclaration ident _ bs result : _) = do

111toDecls ds@(ValueDeclaration ident _ bs result : _) = do

100 let tuples = map toTuple ds

112 let tuples = map toTuple ds

101 unless (all ((== length bs) . length . fst) tuples) $

113 unless (all ((== length bs) . length . fst) tuples) $

@@ -109,16 +121,12 @@ toDecls (PositionedDeclaration pos com d : ds) = do

109 return (PositionedDeclaration pos com d' : ds')

121 return (PositionedDeclaration pos com d' : ds')

110toDecls ds = return ds

122toDecls ds = return ds

111

123

112−isVarBinder :: Binder -> Bool

113−isVarBinder (VarBinder _) = True

114−isVarBinder _ = False

115−

116toTuple :: Declaration -> ([Binder], Either [(Guard, Expr)] Expr)

124toTuple :: Declaration -> ([Binder], Either [(Guard, Expr)] Expr)

117toTuple (ValueDeclaration _ _ bs result) = (bs, result)

125toTuple (ValueDeclaration _ _ bs result) = (bs, result)

118toTuple (PositionedDeclaration _ _ d) = toTuple d

126toTuple (PositionedDeclaration _ _ d) = toTuple d

119toTuple _ = error "Not a value declaration"

127toTuple _ = error "Not a value declaration"

120

128

121−makeCaseDeclaration :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => Ident -> [([Binder], Either [(Guard, Expr)] Expr)] -> m Declaration

129+makeCaseDeclaration :: forall m. (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => Ident -> [([Binder], Either [(Guard, Expr)] Expr)] -> m Declaration

122makeCaseDeclaration ident alternatives = do

130makeCaseDeclaration ident alternatives = do

123 let namedArgs = map findName . fst <$> alternatives

131 let namedArgs = map findName . fst <$> alternatives

124 argNames = map join $ foldl1 resolveNames namedArgs

132 argNames = map join $ foldl1 resolveNames namedArgs

@@ -135,7 +143,7 @@ makeCaseDeclaration ident alternatives = do

135 -- NullBinder will become Just Nothing, which indicates that we may

143 -- NullBinder will become Just Nothing, which indicates that we may

136 -- have to generate a name.

144 -- have to generate a name.

137 -- Everything else becomes Nothing, which indicates that we definitely

145 -- Everything else becomes Nothing, which indicates that we definitely

138− --have to generate a name.

146+ -- have to generate a name.

139 findName :: Binder -> Maybe (Maybe Ident)

147 findName :: Binder -> Maybe (Maybe Ident)

140 findName NullBinder = Just Nothing

148 findName NullBinder = Just Nothing

141 findName (VarBinder name) = Just (Just name)

149 findName (VarBinder name) = Just (Just name)

@@ -147,7 +155,7 @@ makeCaseDeclaration ident alternatives = do

147 allUnique :: (Eq a) => [a] -> Bool

155 allUnique :: (Eq a) => [a] -> Bool

148 allUnique xs = length xs == length (nub xs)

156 allUnique xs = length xs == length (nub xs)

149

157

150− argName :: (MonadSupply m) => Maybe Ident -> m Ident

158+ argName :: Maybe Ident -> m Ident

151 argName (Just name) = return name

159 argName (Just name) = return name

152 argName _ = do

160 argName _ = do

153 name <- freshName

161 name <- freshName

tests/Main.hs+3−2

@@ -23,6 +23,7 @@ import Data.Traversable (traverse)

23import Control.Monad

24import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT)

25import Control.Monad.Reader (runReaderT)

26+import Control.Monad.Writer (runWriterT)

26import Control.Applicative

27import Control.Applicative

27import System.Exit

28import System.Exit

28import System.Process

29import System.Process

@@ -39,7 +40,7 @@ loadPrelude :: Either P.MultipleErrors (String, String, P.Environment)

39loadPrelude =

40loadPrelude =

40 case P.parseModulesFromFiles id [("", P.prelude)] of

41 case P.parseModulesFromFiles id [("", P.prelude)] of

41 Left parseError -> Left . P.errorMessage . P.ErrorParsingPrelude $ parseError

42 Left parseError -> Left . P.errorMessage . P.ErrorParsingPrelude $ parseError

42− Right ms -> runReaderT (P.compile (map snd ms) []) $ P.defaultCompileOptions { P.optionsAdditional = P.CompileOptions "Tests" [] [] }

43+ Right ms -> fmap fst . runWriterT $ runReaderT (P.compile (map snd ms) []) (P.defaultCompileOptions { P.optionsAdditional = P.CompileOptions "Tests" [] [] })

43

44

44compile :: P.Options P.Compile -> [FilePath] -> IO (Either P.MultipleErrors (String, String, P.Environment))

45compile :: P.Options P.Compile -> [FilePath] -> IO (Either P.MultipleErrors (String, String, P.Environment))

45compile opts inputFiles = do

46compile opts inputFiles = do

@@ -47,7 +48,7 @@ compile opts inputFiles = do

47 case modules of

48 case modules of

48 Left parseError ->

49 Left parseError ->

49 return . Left . P.errorMessage . P.ErrorParsingPrelude $ parseError

50 return . Left . P.errorMessage . P.ErrorParsingPrelude $ parseError

50− Right ms -> return $ runReaderT (P.compile (map snd ms) []) opts

51+ Right ms -> return $ fmap fst . runWriterT $ runReaderT (P.compile (map snd ms) []) opts

51

52

52assert :: FilePath -> P.Options P.Compile -> FilePath -> (Either P.MultipleErrors (String, String, P.Environment) -> IO (Maybe String)) -> IO ()

53assert :: FilePath -> P.Options P.Compile -> FilePath -> (Either P.MultipleErrors (String, String, P.Environment) -> IO (Maybe String)) -> IO ()

53assert preludeExterns opts inputFile f = do

54assert preludeExterns opts inputFile f = do