29bbd33 · rowtype-yoga/purescript-native

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

Add warnings and linter module

commit29bbd33e0fbdc7815ba86b540e3d1382b72816da authorPhil Freeman <paf31@cantab.net> dateSat 28 Mar 2015, 21:01 (12 years ago) parent14df551

10 files changed+166−47

compare with golang

unifiedsplit

psc-make/Main.hs+8−5 psc/Main.hs+10−3 psci/PSCi.hs+4−3 purescript.cabal+1 src/Language/PureScript.hs+15−10 src/Language/PureScript/Errors.hs+22−4 src/Language/PureScript/Linter.hs+73 src/Language/PureScript/Renamer.hs+11−9 src/Language/PureScript/Sugar/CaseDeclarations.hs+19−11 tests/Main.hs+3−2

psc-make/Main.hs+8−5

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

1919import Control.Applicative

2020import Control.Monad.Except

2121import Control.Monad.Reader

22+import Control.Monad.Writer

2223

2324import Data.Version (showVersion)

2425import Data.Traversable (traverse)

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

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

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

5455

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

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

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

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

5758

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

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

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

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

6061

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

6263makeIO f io = do

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

8990 Left errs -> do

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

9192 exitFailure

92− Right _ -> do

93+ Right (_, warnings) -> do

94+ when (P.nonEmpty warnings) $

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

9396 exitSuccess

9497 where

9598 prefix = if usePrefix

psc/Main.hs+10−3

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

1919import Control.Applicative

2020import Control.Monad.Except

2121import Control.Monad.Reader

22+import Control.Monad.Writer

2223

2324import Data.Maybe (fromMaybe)

2425import Data.Version (showVersion)

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

3233import qualified Language.PureScript as P

3334import qualified Paths_purescript as Paths

3435

35−

3636data PSCOptions = PSCOptions

3737 { pscInput :: [FilePath]

3838 , pscOpts :: P.Options P.Compile

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

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

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

5656

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+

5762compile :: PSCOptions -> IO ()

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

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

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

6267 hPutStrLn stderr $ show err

6368 exitFailure

6469 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

6671 Left errs -> do

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

6873 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)

7077 case output of

7178 Just path -> mkdirp path >> writeFile path js

7279 Nothing -> putStrLn js

psci/PSCi.hs+4−3

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

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

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

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

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

3637import Control.Monad.Trans.Class

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

3839import Control.Monad.Trans.State.Strict

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

182183psciIO :: IO a -> PSCI a

183184psciIO io = PSCI . lift $ lift io

184185

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

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

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

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

187188

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

189−runMake = runExceptT . flip runReaderT options . unMake

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

190191

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

192193makeIO f io = do

purescript.cabal+1

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

7171 Language.PureScript.Environment

7272 Language.PureScript.Errors

7373 Language.PureScript.Kinds

74+ Language.PureScript.Linter

7475 Language.PureScript.ModuleDependencies

7576 Language.PureScript.Names

7677 Language.PureScript.Options

src/Language/PureScript.hs+15−10

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

4545import Control.Arrow ((&&&))

4646import Control.Monad.Except

4747import Control.Monad.Reader

48+import Control.Monad.Writer

4849

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

5051

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

5556import Language.PureScript.Environment as P

5657import Language.PureScript.Errors as P

5758import Language.PureScript.Kinds as P

59+import Language.PureScript.Linter as P

5860import Language.PureScript.ModuleDependencies as P

5961import Language.PureScript.Names as P

6062import Language.PureScript.Options as P

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

8991--

9092-- * Pretty-print the generated Javascript

9193--

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)

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

9496compile = compile' initEnvironment

9597

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)

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

98100compile' env ms prefix = do

99101 noPrelude <- asks optionsNoPrelude

100102 additional <- asks optionsAdditional

101103 mainModuleIdent <- asks (fmap moduleNameFromString . optionsMain)

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

105+ mapM_ lint sorted

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

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

105108 regrouped <- createBindingGroupsModule . collapseBindingGroupsModule $ elaborated

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

107− let entryPoints = moduleNameFromString `map` entryPointModules additional

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

109− let renamed = renameInModules elim

110− let codeGenModuleNames = moduleNameFromString `map` codeGenModules additional

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

110+ entryPoints = moduleNameFromString `map` entryPointModules additional

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

112+ renamed = renameInModules elim

113+ codeGenModuleNames = moduleNameFromString `map` codeGenModules additional

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

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

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

114117 js' <- generateMain env' js

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

129132-- |

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

131134--

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

133136 -- |

134137 -- Get a file timestamp

135138 --

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

178181

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

180183

184+ mapM_ lint sorted

185+

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

182187 let filePath = runModuleName moduleName'

183188

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

219224 regrouped <- createBindingGroups moduleName' . collapseBindingGroups $ elaborated

220225

221226 let mod' = Module coms moduleName' regrouped exps

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

223− let [renamed] = renameInModules [corefn]

227+ corefn = CoreFn.moduleToCoreFn env' mod'

228+ [renamed] = renameInModules [corefn]

224229

225230 pjs <- prettyPrintJS <$> moduleToJs renamed

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

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

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

107107 | InvalidNewtype

108108 | InvalidInstanceHead Type

109109 | TransitiveExportError DeclarationRef [DeclarationRef]

110+ | ShadowedName Ident

110111 | ErrorInExpression Expr ErrorMessage

111112 | ErrorInModule ModuleName ErrorMessage

112113 | ErrorInInstance (Qualified ProperName) [Type] ErrorMessage

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

198199errorCode InvalidNewtype = "InvalidNewtype"

199200errorCode (InvalidInstanceHead _) = "InvalidInstanceHead"

200201errorCode (TransitiveExportError _ _) = "TransitiveExportError"

202+errorCode (ShadowedName _) = "ShadowedName"

201203errorCode (NotYetDefined _ e) = errorCode e

202204errorCode (ErrorUnifyingTypes _ _ e) = errorCode e

203205errorCode (ErrorInExpression _ e) = errorCode e

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

229231instance UnificationError Kind MultipleErrors where

230232 occursCheckFailed = errorMessage . occursCheckFailed

231233

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

235+nonEmpty :: MultipleErrors -> Bool

236+nonEmpty = not . null . runMultipleErrors

237+

232238-- |

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

234240--

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

374380 ]

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

376382 : map (line . prettyPrintExport) ys

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

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

378385 , indent $ line $ prettyPrintType t1

379386 , line "with type"

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

510517-- Pretty print multiple errors

511518--

512519prettyPrintMultipleErrors :: Bool -> MultipleErrors -> String

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

514− prettyPrintSingleError full e

515−prettyPrintMultipleErrors full (MultipleErrors es) = renderBox $

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

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

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

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

531+ , prettyPrintSingleError full e

532+ ]

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

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

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

518536 ]

519537

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

1414--

1515-----------------------------------------------------------------------------

1616

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

18+

1719module Language.PureScript.Renamer (renameInModules) where

1820

1921import Control.Applicative

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

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

7577updateScope name = do

7678 scope <- get

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

78− True ->

79− let

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

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

82− in newName

83− False -> name

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

80+ True -> do

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

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

83+ return newName

84+ False -> return name

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

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

8687 }

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

113114renameInModules = map go

114115 where

115116 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+

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

118120 renameInDecl' scope = runRename scope . renameInDecl True

119121

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

175177-- Renames within case alternatives.

176178--

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

178−renameInCaseAlternative (CaseAlternative bs v) =

180+renameInCaseAlternative (CaseAlternative bs v) = newScope $

179181 CaseAlternative <$> mapM renameInBinder bs

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

181183

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

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

1414--

1515-----------------------------------------------------------------------------

1616

17−{-# LANGUAGE FlexibleContexts #-}

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

1818

1919module Language.PureScript.Sugar.CaseDeclarations (

2020 desugarCases,

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

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

9191inSameGroup _ _ = False

9292

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]

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

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

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

95+ args <- mapM fromVarBinder bs

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

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

9898 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"

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

100112 let tuples = map toTuple ds

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

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

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

110122toDecls ds = return ds

111123

112−isVarBinder :: Binder -> Bool

113−isVarBinder (VarBinder _) = True

114−isVarBinder _ = False

115−

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

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

118126toTuple (PositionedDeclaration _ _ d) = toTuple d

119127toTuple _ = error "Not a value declaration"

120128

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

122130makeCaseDeclaration ident alternatives = do

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

124132 argNames = map join $ foldl1 resolveNames namedArgs

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

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

136144 -- have to generate a name.

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

138− --have to generate a name.

146+ -- have to generate a name.

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

140148 findName NullBinder = Just Nothing

141149 findName (VarBinder name) = Just (Just name)

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

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

148156 allUnique xs = length xs == length (nub xs)

149157

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

158+ argName :: Maybe Ident -> m Ident

151159 argName (Just name) = return name

152160 argName _ = do

153161 name <- freshName

tests/Main.hs+3−2

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

2323import Control.Monad

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

2525import Control.Monad.Reader (runReaderT)

26+import Control.Monad.Writer (runWriterT)

2627import Control.Applicative

2728import System.Exit

2829import System.Process

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

3940loadPrelude =

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

4142 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" [] [] })

4344

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

4546compile opts inputFiles = do

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

4748 case modules of

4849 Left parseError ->

4950 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

5152

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

5354assert preludeExterns opts inputFile f = do