516f24c · rowtype-yoga/purescript-native

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

on golang help sign in

Merge branch 'srcpos'

516f24cPhil Freeman13 years ago

docgen/Main.hs+3

compare with golang

unifiedsplit

@@ -84,6 +84,7 @@ renderModule (P.Module moduleName ds exps) =

84isExported :: Maybe [P.DeclarationRef] -> P.Declaration -> Bool

85isExported Nothing _ = True

86isExported _ (P.TypeInstanceDeclaration _ _ _ _ _) = True

87+isExported exps (P.PositionedDeclaration _ d) = isExported exps d

87isExported (Just exps) decl = any (matches decl) exps

88isExported (Just exps) decl = any (matches decl) exps

88 where

89 where

89 matches (P.TypeDeclaration ident _) (P.ValueRef ident') = ident == ident'

90 matches (P.TypeDeclaration ident _) (P.ValueRef ident') = ident == ident'

@@ -130,6 +131,8 @@ renderDeclaration n _ (P.TypeInstanceDeclaration name constraints className tys

130 [] -> ""

131 [] -> ""

131 cs -> "(" ++ intercalate ", " (map (\(pn, tys') -> show pn ++ " " ++ unwords (map P.prettyPrintTypeAtom tys')) cs) ++ ") => "

132 cs -> "(" ++ intercalate ", " (map (\(pn, tys') -> show pn ++ " " ++ unwords (map P.prettyPrintTypeAtom tys')) cs) ++ ") => "

132 atIndent n $ "instance " ++ show name ++ " :: " ++ constraintsText ++ show className ++ " " ++ unwords (map P.prettyPrintTypeAtom tys)

133 atIndent n $ "instance " ++ show name ++ " :: " ++ constraintsText ++ show className ++ " " ++ unwords (map P.prettyPrintTypeAtom tys)

134+renderDeclaration n exps (P.PositionedDeclaration _ d) =

135+ renderDeclaration n exps d

133renderDeclaration _ _ _ = return ()

136renderDeclaration _ _ _ = return ()

134

137

135getName :: P.Declaration -> String

138getName :: P.Declaration -> String

src/Language/PureScript.hs+1

@@ -248,5 +248,6 @@ importPrelude m@(Module mn decls exps) =

248 where

249 prelude = ModuleName [ProperName C.prelude]

250 isPreludeImport (ImportDeclaration (ModuleName [ProperName mn']) _ _) | mn' == C.prelude = True

251+ isPreludeImport (PositionedDeclaration _ d) = isPreludeImport d

251 isPreludeImport _ = False

252 isPreludeImport _ = False

252 preludeImport = ImportDeclaration prelude Nothing Nothing

253 preludeImport = ImportDeclaration prelude Nothing Nothing

src/Language/PureScript/CodeGen/Externs.hs+1

@@ -45,6 +45,7 @@ moduleToPs (Module moduleName ds (Just exts)) env = intercalate "\n" . execWrite

45 fixityToPs :: Declaration -> Writer [String] ()

46 fixityToPs (FixityDeclaration (Fixity assoc prec) ident) =

47 tell [ unwords [ show assoc, show prec, ident ] ]

48+ fixityToPs (PositionedDeclaration _ d) = fixityToPs d

48 fixityToPs _ = return ()

49 fixityToPs _ = return ()

50 exportToPs :: DeclarationRef -> Writer [String] ()

51 exportToPs :: DeclarationRef -> Writer [String] ()

src/Language/PureScript/CodeGen/JS.hs+3

@@ -82,6 +82,7 @@ declToJs _ mp (DataDeclaration _ _ ctors) _ =

82 (JSBlock [JSReturn (go pn (index + 1) tys' (JSVar ("value" ++ show index) : values))])

83declToJs opts mp (DataBindingGroupDeclaration ds) e = Just $ concat $ mapMaybe (flip (declToJs opts mp) e) ds

84declToJs _ _ (ExternDeclaration _ _ (Just js) _) _ = Just [js]

85+declToJs opts mp (PositionedDeclaration _ d) e = declToJs opts mp d e

85declToJs _ _ _ _ = Nothing

86declToJs _ _ _ _ = Nothing

87-- |

88-- |

@@ -307,6 +308,8 @@ binderToJs m e varName done (ConsBinder headBinder tailBinder) = do

307binderToJs m e varName done (NamedBinder ident binder) = do

308binderToJs m e varName done (NamedBinder ident binder) = do

308 js <- binderToJs m e varName done binder

309 js <- binderToJs m e varName done binder

309 return (JSVariableIntroduction (identToJs ident) (Just (JSVar varName)) : js)

310 return (JSVariableIntroduction (identToJs ident) (Just (JSVar varName)) : js)

311+binderToJs m e varName done (PositionedBinder _ binder) =

312+ binderToJs m e varName done binder

310

313

311-- |

314-- |

312-- Checks whether a data constructor is the only constructor for that type, used to simplify the

315-- Checks whether a data constructor is the only constructor for that type, used to simplify the

src/Language/PureScript/DeadCodeElimination.hs+5

@@ -50,11 +50,13 @@ eliminateDeadCode entryPoints ms = map go ms

50 valueExists name (ValueDeclaration name' _ _ _ _) = name == name'

51 valueExists name (ExternDeclaration _ name' _ _) = name == name'

52 valueExists name (BindingGroupDeclaration decls) = any (\(name', _, _) -> name == name') decls

53+ valueExists name (PositionedDeclaration _ d) = valueExists name d

53 valueExists _ _ = False

54 valueExists _ _ = False

55 typeExists :: ProperName -> Declaration -> Bool

56 typeExists :: ProperName -> Declaration -> Bool

56 typeExists name (DataDeclaration name' _ _) = name == name'

57 typeExists name (DataDeclaration name' _ _) = name == name'

57 typeExists name (DataBindingGroupDeclaration decls) = any (typeExists name) decls

58 typeExists name (DataBindingGroupDeclaration decls) = any (typeExists name) decls

59+ typeExists name (PositionedDeclaration _ d) = typeExists name d

58 typeExists _ _ = False

60 typeExists _ _ = False

60type Key = (ModuleName, Either Ident ProperName)

62type Key = (ModuleName, Either Ident ProperName)

@@ -68,6 +70,7 @@ declarationsByModule (Module moduleName ds _) = concatMap go ds

68 go (ExternDeclaration _ name _ _) = [((moduleName, Left name), [])]

70 go (ExternDeclaration _ name _ _) = [((moduleName, Left name), [])]

69 go d@(BindingGroupDeclaration names') = map (\(name, _, _) -> ((moduleName, Left name), dependencies moduleName d)) names'

71 go d@(BindingGroupDeclaration names') = map (\(name, _, _) -> ((moduleName, Left name), dependencies moduleName d)) names'

70 go (DataBindingGroupDeclaration ds') = concatMap go ds'

72 go (DataBindingGroupDeclaration ds') = concatMap go ds'

73+ go (PositionedDeclaration _ d) = go d

71 go _ = []

74 go _ = []

73dependencies :: (Data d) => ModuleName -> d -> [Key]

76dependencies :: (Data d) => ModuleName -> d -> [Key]

@@ -94,4 +97,6 @@ isUsed moduleName graph vertexFor entryPointVertices (BindingGroupDeclaration ds

94 in any (\v -> path graph v v') entryPointVertices) ds

97 in any (\v -> path graph v v') entryPointVertices) ds

95isUsed moduleName graph vertexFor entryPointVertices (DataBindingGroupDeclaration ds) =

98isUsed moduleName graph vertexFor entryPointVertices (DataBindingGroupDeclaration ds) =

96 any (isUsed moduleName graph vertexFor entryPointVertices) ds

99 any (isUsed moduleName graph vertexFor entryPointVertices) ds

100+isUsed moduleName graph vertexFor entryPointVertices (PositionedDeclaration _ d) =

101+ isUsed moduleName graph vertexFor entryPointVertices d

97isUsed _ _ _ _ _ = True

102isUsed _ _ _ _ _ = True

src/Language/PureScript/Declarations.hs+45−4

@@ -41,6 +41,24 @@ instance Show Associativity where

41 show Infixr = "infixr"

42 show Infix = "infix"

44+-- |

45+-- Source position information

46+--

47+data SourcePos = SourcePos

48+ {

49+ -- |

50+ -- Line number

51+ --

52+ sourcePosLine :: Int

53+ -- |

54+ -- Column number

55+ --

56+ , sourcePosColumn :: Int

57+ } deriving (D.Data, D.Typeable)

58+

59+instance Show SourcePos where

60+ show sp = "line " ++ show (sourcePosLine sp) ++ ", column " ++ show (sourcePosColumn sp)

61+

44-- |

62-- |

45-- Fixity data for infix operators

63-- Fixity data for infix operators

46--

64--

@@ -132,6 +150,10 @@ data Declaration

132 -- declarations)

150 -- declarations)

133 --

151 --

134 | TypeInstanceDeclaration Ident [(Qualified ProperName, [Type])] (Qualified ProperName) [Type] [Declaration]

152 | TypeInstanceDeclaration Ident [(Qualified ProperName, [Type])] (Qualified ProperName) [Type] [Declaration]

153+ -- |

154+ -- A declaration with source position information

155+ --

156+ | PositionedDeclaration SourcePos Declaration

135 deriving (Show, D.Data, D.Typeable)

157 deriving (Show, D.Data, D.Typeable)

136

158

137-- |

159-- |

@@ -139,6 +161,7 @@ data Declaration

139--

161--

140isValueDecl :: Declaration -> Bool

162isValueDecl :: Declaration -> Bool

141isValueDecl ValueDeclaration{} = True

163isValueDecl ValueDeclaration{} = True

164+isValueDecl (PositionedDeclaration _ d) = isValueDecl d

142isValueDecl _ = False

165isValueDecl _ = False

143

166

144-- |

167-- |

@@ -147,6 +170,7 @@ isValueDecl _ = False

147isDataDecl :: Declaration -> Bool

170isDataDecl :: Declaration -> Bool

148isDataDecl DataDeclaration{} = True

171isDataDecl DataDeclaration{} = True

149isDataDecl TypeSynonymDeclaration{} = True

172isDataDecl TypeSynonymDeclaration{} = True

173+isDataDecl (PositionedDeclaration _ d) = isDataDecl d

150isDataDecl _ = False

174isDataDecl _ = False

151

175

152-- |

176-- |

@@ -154,6 +178,7 @@ isDataDecl _ = False

154--

178--

155isImportDecl :: Declaration -> Bool

179isImportDecl :: Declaration -> Bool

156isImportDecl ImportDeclaration{} = True

180isImportDecl ImportDeclaration{} = True

181+isImportDecl (PositionedDeclaration _ d) = isImportDecl d

157isImportDecl _ = False

182isImportDecl _ = False

158

183

159-- |

184-- |

@@ -161,6 +186,7 @@ isImportDecl _ = False

161--

186--

162isExternDataDecl :: Declaration -> Bool

187isExternDataDecl :: Declaration -> Bool

163isExternDataDecl ExternDataDeclaration{} = True

188isExternDataDecl ExternDataDeclaration{} = True

189+isExternDataDecl (PositionedDeclaration _ d) = isExternDataDecl d

164isExternDataDecl _ = False

190isExternDataDecl _ = False

165

191

166-- |

192-- |

@@ -168,6 +194,7 @@ isExternDataDecl _ = False

168--

194--

169isExternInstanceDecl :: Declaration -> Bool

195isExternInstanceDecl :: Declaration -> Bool

170isExternInstanceDecl ExternInstanceDeclaration{} = True

196isExternInstanceDecl ExternInstanceDeclaration{} = True

197+isExternInstanceDecl (PositionedDeclaration _ d) = isExternInstanceDecl d

171isExternInstanceDecl _ = False

198isExternInstanceDecl _ = False

172

199

173-- |

200-- |

@@ -175,6 +202,7 @@ isExternInstanceDecl _ = False

175--

202--

176isFixityDecl :: Declaration -> Bool

203isFixityDecl :: Declaration -> Bool

177isFixityDecl FixityDeclaration{} = True

204isFixityDecl FixityDeclaration{} = True

205+isFixityDecl (PositionedDeclaration _ d) = isFixityDecl d

178isFixityDecl _ = False

206isFixityDecl _ = False

179

207

180-- |

208-- |

@@ -182,6 +210,7 @@ isFixityDecl _ = False

182--

210--

183isExternDecl :: Declaration -> Bool

211isExternDecl :: Declaration -> Bool

184isExternDecl ExternDeclaration{} = True

212isExternDecl ExternDeclaration{} = True

213+isExternDecl (PositionedDeclaration _ d) = isExternDecl d

185isExternDecl _ = False

214isExternDecl _ = False

186

215

187-- |

216-- |

@@ -190,6 +219,7 @@ isExternDecl _ = False

190isTypeClassDeclaration :: Declaration -> Bool

219isTypeClassDeclaration :: Declaration -> Bool

191isTypeClassDeclaration TypeClassDeclaration{} = True

220isTypeClassDeclaration TypeClassDeclaration{} = True

192isTypeClassDeclaration TypeInstanceDeclaration{} = True

221isTypeClassDeclaration TypeInstanceDeclaration{} = True

222+isTypeClassDeclaration (PositionedDeclaration _ d) = isTypeClassDeclaration d

193isTypeClassDeclaration _ = False

223isTypeClassDeclaration _ = False

194

224

195-- |

225-- |

@@ -286,7 +316,11 @@ data Value

286 -- can be evaluated at runtime. The constructor arguments represent (in order): the type class name and

316 -- can be evaluated at runtime. The constructor arguments represent (in order): the type class name and

287 -- instance type, and the type class dictionaries in scope.

317 -- instance type, and the type class dictionaries in scope.

288 --

318 --

289− | TypeClassDictionary (Qualified ProperName, [Type]) [TypeClassDictionaryInScope] deriving (Show, D.Data, D.Typeable)

319+ | TypeClassDictionary (Qualified ProperName, [Type]) [TypeClassDictionaryInScope]

320+ -- |

321+ -- A value with source position information

322+ --

323+ | PositionedValue SourcePos Value deriving (Show, D.Data, D.Typeable)

290

324

291-- |

325-- |

292-- An alternative in a case statement

326-- An alternative in a case statement

@@ -328,7 +362,11 @@ data DoNotationElement

328 -- |

362 -- |

329 -- A let statement, i.e. a pure value with a binder

363 -- A let statement, i.e. a pure value with a binder

330 --

364 --

331− | DoNotationLet Binder Value deriving (Show, D.Data, D.Typeable)

365+ | DoNotationLet Binder Value

366+ -- |

367+ -- A do notation element with source position information

368+ --

369+ | PositionedDoNotationElement SourcePos DoNotationElement deriving (Show, D.Data, D.Typeable)

332

370

333-- |

371-- |

334-- Data type for binders

372-- Data type for binders

@@ -373,8 +411,11 @@ data Binder

373 -- |

411 -- |

374 -- A binder which binds its input to an identifier

412 -- A binder which binds its input to an identifier

375 --

413 --

376− | NamedBinder Ident Binder deriving (Show, D.Data, D.Typeable)

414+ | NamedBinder Ident Binder

377−

415+ -- |

416+ -- A binder with source position information

417+ --

418+ | PositionedBinder SourcePos Binder deriving (Show, D.Data, D.Typeable)

378

419

379-- |

420-- |

380-- Collect all names introduced in binders in an expression

421-- Collect all names introduced in binders in an expression

src/Language/PureScript/ModuleDependencies.hs+1

@@ -56,6 +56,7 @@ usedModules = nub . everything (++) (mkQ [] qualifiedIdents `extQ` qualifiedProp

56 qualifiedProperNames _ = []

57 imports :: Declaration -> [ModuleName]

58 imports (ImportDeclaration mn _ _) = [mn]

59+ imports (PositionedDeclaration _ d) = imports d

59 imports _ = []

60 imports _ = []

61getModuleName :: Module -> ModuleName

62getModuleName :: Module -> ModuleName

src/Language/PureScript/Parser/Common.hs+1

@@ -369,3 +369,4 @@ same = checkIndentation (==) P.<?> "no indentation"

369--

370runIndentParser :: FilePath -> P.Parsec String ParseState a -> String -> Either P.ParseError a

371runIndentParser filePath p = P.runParser p (ParseState 0) filePath

372+

src/Language/PureScript/Parser/Declarations.hs+13−4

@@ -38,6 +38,14 @@ import qualified Language.PureScript.Parser.Common as C

38import qualified Text.Parsec as P

39import qualified Text.Parsec.Expr as P

41+-- |

42+-- Read source position information

43+--

44+sourcePos :: P.Parsec s u SourcePos

45+sourcePos = toSourcePos <$> P.getPosition

46+ where

47+ toSourcePos p = SourcePos (P.sourceLine p) (P.sourceColumn p)

48+

41parseDataDeclaration :: P.Parsec String ParseState Declaration

49parseDataDeclaration :: P.Parsec String ParseState Declaration

42parseDataDeclaration = do

50parseDataDeclaration = do

43 reserved "data"

51 reserved "data"

@@ -162,7 +170,7 @@ parseTypeInstanceDeclaration = do

162-- Parse a single declaration

170-- Parse a single declaration

163--

171--

164parseDeclaration :: P.Parsec String ParseState Declaration

172parseDeclaration :: P.Parsec String ParseState Declaration

165−parseDeclaration = P.choice

173+parseDeclaration = PositionedDeclaration <$> sourcePos <*> P.choice

166 [ parseDataDeclaration

174 [ parseDataDeclaration

167 , parseTypeDeclaration

175 , parseTypeDeclaration

168 , parseTypeSynonymDeclaration

176 , parseTypeSynonymDeclaration

@@ -175,7 +183,7 @@ parseDeclaration = P.choice

175 ] P.<?> "declaration"

183 ] P.<?> "declaration"

176

184

177parseLocalDeclaration :: P.Parsec String ParseState Declaration

185parseLocalDeclaration :: P.Parsec String ParseState Declaration

178−parseLocalDeclaration = P.choice

186+parseLocalDeclaration = PositionedDeclaration <$> sourcePos <*> P.choice

179 [ parseTypeDeclaration

187 [ parseTypeDeclaration

180 , parseValueDeclaration

188 , parseValueDeclaration

181 ] P.<?> "local declaration"

189 ] P.<?> "local declaration"

@@ -313,7 +321,7 @@ parseDoNotationElement = P.choice

313-- Parse a value

321-- Parse a value

314--

322--

315parseValue :: P.Parsec String ParseState Value

323parseValue :: P.Parsec String ParseState Value

316−parseValue =

324+parseValue = PositionedValue <$> sourcePos <*>

317 (P.buildExpressionParser operators

325 (P.buildExpressionParser operators

318 . C.buildPostfixParser postfixTable2

326 . C.buildPostfixParser postfixTable2

319 $ indexersAndAccessors) P.<?> "expression"

327 $ indexersAndAccessors) P.<?> "expression"

@@ -373,7 +381,8 @@ parseIdentifierAndBinder = do

373-- Parse a binder

381-- Parse a binder

374--

382--

375parseBinder :: P.Parsec String ParseState Binder

383parseBinder :: P.Parsec String ParseState Binder

384+parseBinder = PositionedBinder <$> sourcePos <*>

376−parseBinder = P.buildExpressionParser operators parseBinderAtom P.<?> "expression"

385+ P.buildExpressionParser operators parseBinderAtom P.<?> "expression"

377 where

386 where

378 operators = [ [ P.Infix ( C.lexeme (P.try $ C.indented *> C.reservedOp ":") >> return ConsBinder) P.AssocRight ] ]

387 operators = [ [ P.Infix ( C.lexeme (P.try $ C.indented *> C.reservedOp ":") >> return ConsBinder) P.AssocRight ] ]

379 parseBinderAtom :: P.Parsec String ParseState Binder

388 parseBinderAtom :: P.Parsec String ParseState Binder

src/Language/PureScript/Pretty/Common.hs+38

@@ -15,8 +15,46 @@

16module Language.PureScript.Pretty.Common where

18+import Control.Monad.State

19+import Data.List (intercalate)

20+

18-- |

21-- |

19-- Wrap a string in parentheses

22-- Wrap a string in parentheses

20--

23--

21parens :: String -> String

24parens :: String -> String

22parens s = ('(':s) ++ ")"

25parens s = ('(':s) ++ ")"

26+

27+newtype PrinterState = PrinterState { indent :: Int } deriving (Show, Eq, Ord)

28+

29+-- |

30+-- Number of characters per identation level

31+--

32+blockIndent :: Int

33+blockIndent = 4

34+

35+-- |

36+-- Pretty print with a new indentation level

37+--

38+withIndent :: StateT PrinterState Maybe String -> StateT PrinterState Maybe String

39+withIndent action = do

40+ modify $ \st -> st { indent = indent st + blockIndent }

41+ result <- action

42+ modify $ \st -> st { indent = indent st - blockIndent }

43+ return result

44+

45+-- |

46+-- Get the current indentation level

47+--

48+currentIndent :: StateT PrinterState Maybe String

49+currentIndent = do

50+ current <- get

51+ return $ replicate (indent current) ' '

52+

53+-- |

54+-- Print many lines

55+--

56+prettyPrintMany :: (a -> StateT PrinterState Maybe String) -> [a] -> StateT PrinterState Maybe String

57+prettyPrintMany f xs = do

58+ ss <- mapM f xs

59+ indentString <- currentIndent

60+ return $ intercalate "\n" $ map (indentString ++) ss

src/Language/PureScript/Pretty/JS.hs−26

@@ -29,32 +29,6 @@ import Control.Applicative

29import Control.Monad.State

30import Numeric

32−newtype PrinterState = PrinterState { indent :: Int } deriving (Show, Eq, Ord)

33−

34−-- |

35−-- Number of characters per identation level

36−--

37−blockIndent :: Int

38−blockIndent = 4

39−

40−-- |

41−-- Pretty print with a new indentation level

42−--

43−withIndent :: StateT PrinterState Maybe String -> StateT PrinterState Maybe String

44−withIndent action = do

45− modify $ \st -> st { indent = indent st + blockIndent }

46− result <- action

47− modify $ \st -> st { indent = indent st - blockIndent }

48− return result

49−

50−-- |

51−-- Get the current indentation level

52−--

53−currentIndent :: StateT PrinterState Maybe String

54−currentIndent = do

55− current <- get

56− return $ replicate (indent current) ' '

57−

58literals :: Pattern PrinterState JS String

32literals :: Pattern PrinterState JS String

59literals = mkPattern' match

33literals = mkPattern' match

60 where

34 where

src/Language/PureScript/Pretty/Values.hs+142−67

@@ -20,132 +20,207 @@ module Language.PureScript.Pretty.Values (

21import Data.Maybe (fromMaybe)

22import Data.List (intercalate)

23+

23−import Control.Arrow ((<+>))

24+import Control.Arrow ((<+>), runKleisli)

24import Control.PatternArrows

25import Control.PatternArrows

26+import Control.Monad.State

27+import Control.Applicative

26−import Language.PureScript.Types

27import Language.PureScript.Declarations

29import Language.PureScript.Declarations

28import Language.PureScript.Pretty.Common

30import Language.PureScript.Pretty.Common

29−import Language.PureScript.Pretty.Types

31+import Language.PureScript.Pretty.Types (prettyPrintType)

31−literals :: Pattern () Value String

33+literals :: Pattern PrinterState Value String

32−literals = mkPattern match

34+literals = mkPattern' match

33 where

35 where

36+ match :: Value -> StateT PrinterState Maybe String

34− match (NumericLiteral n) = Just $ either show show n

37+ match (NumericLiteral n) = return $ either show show n

35− match (StringLiteral s) = Just $ show s

38+ match (StringLiteral s) = return $ show s

36− match (BooleanLiteral True) = Just "true"

39+ match (BooleanLiteral True) = return "true"

37− match (BooleanLiteral False) = Just "false"

40+ match (BooleanLiteral False) = return "false"

38− match (ArrayLiteral xs) = Just $ "[" ++ intercalate ", " (map prettyPrintValue xs) ++ "]"

41+ match (ArrayLiteral xs) = fmap concat $ sequence

42+ [ return "[ "

43+ , withIndent $ prettyPrintMany prettyPrintValue' xs

44+ , return " ]"

45+ ]

46+ match (ObjectLiteral []) = return "{}"

47+ match (ObjectLiteral ps) = fmap concat $ sequence

48+ [ return "{\n"

39− match (ObjectLiteral ps) = Just $ "{" ++ intercalate ", " (map (uncurry prettyPrintObjectProperty) ps) ++ "}"

49+ , withIndent $ prettyPrintMany prettyPrintObjectProperty ps

50+ , currentIndent

51+ , return "}"

52+ ]

40− match (Constructor name) = Just $ show name

53+ match (Constructor name) = return $ show name

41− match (Case values binders) = Just $ "case " ++ unwords (map prettyPrintValue values) ++

54+ match (Case values binders) = fmap concat $ sequence

55+ [ return "case "

56+ , unwords <$> forM values prettyPrintValue'

57+ , return " of\n"

42− " of { " ++ intercalate " ; " (map prettyPrintCaseAlternative binders) ++ " }"

58+ , withIndent $ prettyPrintMany prettyPrintCaseAlternative binders

59+ , currentIndent

60+ ]

61+ match (Let ds val) = fmap concat $ sequence

62+ [ return "let\n"

63+ , withIndent $ prettyPrintMany prettyPrintDeclaration ds

64+ , return "\n"

65+ , currentIndent

66+ , return "in "

43− match (Let _ val) = Just $ "let ... in " ++ prettyPrintValue val

67+ , prettyPrintValue' val

68+ ]

44− match (Var ident) = Just $ show ident

69+ match (Var ident) = return $ show ident

70+ match (Do els) = fmap concat $ sequence

71+ [ return "do "

45− match (Do els) = Just $ " do { " ++ intercalate "; " (map prettyPrintDoNotationElement els) ++ " }"

72+ , withIndent $ prettyPrintMany prettyPrintDoNotationElement els

73+ , currentIndent

74+ ]

46 match (TypeClassDictionary _ _) = error "Type class dictionary was not replaced"

75 match (TypeClassDictionary _ _) = error "Type class dictionary was not replaced"

47− match _ = Nothing

76+ match (TypedValue _ val _) = prettyPrintValue' val

48−

77+ match (PositionedValue _ val) = prettyPrintValue' val

78+ match _ = mzero

79+

80+prettyPrintDeclaration :: Declaration -> StateT PrinterState Maybe String

81+prettyPrintDeclaration (TypeDeclaration ident ty) = return $ show ident ++ " :: " ++ prettyPrintType ty

82+prettyPrintDeclaration (ValueDeclaration ident _ [] Nothing val) = fmap concat $ sequence

83+ [ return $ show ident ++ " = "

84+ , prettyPrintValue' val

85+ ]

86+prettyPrintDeclaration (PositionedDeclaration _ d) = prettyPrintDeclaration d

87+prettyPrintDeclaration _ = error "Invalid argument to prettyPrintDeclaration"

88+

49−prettyPrintCaseAlternative :: CaseAlternative -> String

89+prettyPrintCaseAlternative :: CaseAlternative -> StateT PrinterState Maybe String

50prettyPrintCaseAlternative (CaseAlternative binders grd val) =

90prettyPrintCaseAlternative (CaseAlternative binders grd val) =

91+ fmap concat $ sequence

51− "(" ++ intercalate ", " (map prettyPrintBinder binders) ++ ") " ++

92+ [ intercalate ", " <$> forM binders prettyPrintBinder'

52− maybe "" (("| " ++) . prettyPrintValue) grd ++ " -> " ++ prettyPrintValue val

93+ , maybe (return "") (fmap ("| " ++) . prettyPrintValue') grd

53−

94+ , return " -> "

95+ , prettyPrintValue' val

96+ ]

97+

98+prettyPrintDoNotationElement :: DoNotationElement -> StateT PrinterState Maybe String

99+prettyPrintDoNotationElement (DoNotationValue val) =

100+ prettyPrintValue' val

101+prettyPrintDoNotationElement (DoNotationBind binder val) =

102+ fmap concat $ sequence

103+ [ prettyPrintBinder' binder

104+ , return " <- "

105+ , prettyPrintValue' val

106+ ]

107+prettyPrintDoNotationElement (DoNotationLet binder val) =

108+ fmap concat $ sequence

109+ [ return "let "

110+ , prettyPrintBinder' binder

111+ , return " = "

112+ , prettyPrintValue' val

113+ ]

114+prettyPrintDoNotationElement (PositionedDoNotationElement _ el) = prettyPrintDoNotationElement el

115+

54−ifThenElse :: Pattern () Value ((Value, Value), Value)

116+ifThenElse :: Pattern PrinterState Value ((Value, Value), Value)

55ifThenElse = mkPattern match

117ifThenElse = mkPattern match

56 where

118 where

57 match (IfThenElse cond th el) = Just ((th, el), cond)

119 match (IfThenElse cond th el) = Just ((th, el), cond)

58 match _ = Nothing

120 match _ = Nothing

121

60−accessor :: Pattern () Value (String, Value)

122+accessor :: Pattern PrinterState Value (String, Value)

61accessor = mkPattern match

123accessor = mkPattern match

62 where

124 where

63 match (Accessor prop val) = Just (prop, val)

125 match (Accessor prop val) = Just (prop, val)

64 match _ = Nothing

126 match _ = Nothing

127

66−objectUpdate :: Pattern () Value ([String], Value)

128+objectUpdate :: Pattern PrinterState Value ([String], Value)

67objectUpdate = mkPattern match

129objectUpdate = mkPattern match

68 where

130 where

69 match (ObjectUpdate o ps) = Just (flip map ps $ \(key, val) -> key ++ " = " ++ prettyPrintValue val, o)

131 match (ObjectUpdate o ps) = Just (flip map ps $ \(key, val) -> key ++ " = " ++ prettyPrintValue val, o)

70 match _ = Nothing

132 match _ = Nothing

133

72−app :: Pattern () Value (String, Value)

134+app :: Pattern PrinterState Value (String, Value)

73app = mkPattern match

135app = mkPattern match

74 where

136 where

75 match (App val arg) = Just (prettyPrintValue arg, val)

137 match (App val arg) = Just (prettyPrintValue arg, val)

76 match _ = Nothing

138 match _ = Nothing

139

78−lam :: Pattern () Value (String, Value)

140+lam :: Pattern PrinterState Value (String, Value)

79lam = mkPattern match

141lam = mkPattern match

80 where

142 where

81 match (Abs (Left arg) val) = Just (show arg, val)

143 match (Abs (Left arg) val) = Just (show arg, val)

82 match _ = Nothing

144 match _ = Nothing

145

84−typed :: Pattern () Value (Type, Value)

85−typed = mkPattern match

86− where

87− match (TypedValue _ val ty) = Just (ty, val)

88− match _ = Nothing

89−

90−prettyPrintDoNotationElement :: DoNotationElement -> String

91−prettyPrintDoNotationElement (DoNotationValue val) = prettyPrintValue val

92−prettyPrintDoNotationElement (DoNotationBind binder val) = prettyPrintBinder binder ++ " <- " ++ prettyPrintValue val

93−prettyPrintDoNotationElement (DoNotationLet binder val) = "let " ++ prettyPrintBinder binder ++ " = " ++ prettyPrintValue val

94−

95-- |

146-- |

96−-- Generate a pretty-printed string representing a Value

147+-- Generate a pretty-printed string representing an expression

97--

148--

98prettyPrintValue :: Value -> String

149prettyPrintValue :: Value -> String

99−prettyPrintValue = fromMaybe (error "Incomplete pattern") . pattern matchValue ()

150+prettyPrintValue = fromMaybe (error "Incomplete pattern") . flip evalStateT (PrinterState 0) . prettyPrintValue'

151+

152+prettyPrintValue' :: Value -> StateT PrinterState Maybe String

153+prettyPrintValue' = runKleisli $ runPattern matchValue

100 where

154 where

101− matchValue :: Pattern () Value String

155+ matchValue :: Pattern PrinterState Value String

102 matchValue = buildPrettyPrinter operators (literals <+> fmap parens matchValue)

156 matchValue = buildPrettyPrinter operators (literals <+> fmap parens matchValue)

103− operators :: OperatorTable () Value String

157+ operators :: OperatorTable PrinterState Value String

104 operators =

158 operators =

105 OperatorTable [ [ Wrap accessor $ \prop val -> val ++ "." ++ prop ]

159 OperatorTable [ [ Wrap accessor $ \prop val -> val ++ "." ++ prop ]

106 , [ Wrap objectUpdate $ \ps val -> val ++ "{ " ++ intercalate ", " ps ++ " }" ]

160 , [ Wrap objectUpdate $ \ps val -> val ++ "{ " ++ intercalate ", " ps ++ " }" ]

107 , [ Wrap app $ \arg val -> val ++ "(" ++ arg ++ ")" ]

161 , [ Wrap app $ \arg val -> val ++ "(" ++ arg ++ ")" ]

108 , [ Split lam $ \arg val -> "\\" ++ arg ++ " -> " ++ prettyPrintValue val ]

162 , [ Split lam $ \arg val -> "\\" ++ arg ++ " -> " ++ prettyPrintValue val ]

109 , [ Wrap ifThenElse $ \(th, el) cond -> "if " ++ cond ++ " then " ++ prettyPrintValue th ++ " else " ++ prettyPrintValue el ]

163 , [ Wrap ifThenElse $ \(th, el) cond -> "if " ++ cond ++ " then " ++ prettyPrintValue th ++ " else " ++ prettyPrintValue el ]

110− , [ Wrap typed $ \ty val -> val ++ " :: " ++ prettyPrintType ty ]

111 ]

164 ]

112

165

113−prettyPrintBinderAtom :: Pattern () Binder String

166+prettyPrintBinderAtom :: Pattern PrinterState Binder String

114−prettyPrintBinderAtom = mkPattern match

167+prettyPrintBinderAtom = mkPattern' match

115 where

168 where

116− match :: Binder -> Maybe String

169+ match :: Binder -> StateT PrinterState Maybe String

117− match NullBinder = Just "_"

170+ match NullBinder = return "_"

118− match (StringBinder str) = Just $ show str

171+ match (StringBinder str) = return $ show str

119− match (NumberBinder num) = Just $ either show show num

172+ match (NumberBinder num) = return $ either show show num

120− match (BooleanBinder True) = Just "true"

173+ match (BooleanBinder True) = return "true"

121− match (BooleanBinder False) = Just "false"

174+ match (BooleanBinder False) = return "false"

122− match (VarBinder ident) = Just $ show ident

175+ match (VarBinder ident) = return $ show ident

123− match (ConstructorBinder ctor args) = Just $ show ctor ++ " " ++ unwords (map (parens . prettyPrintBinder) args)

176+ match (ConstructorBinder ctor args) = fmap concat $ sequence

177+ [ return $ show ctor ++ " "

178+ , unwords <$> forM args match

179+ ]

180+ match (ObjectBinder bs) = fmap concat $ sequence

181+ [ return "{\n"

124− match (ObjectBinder bs) = Just $ "{ " ++ intercalate ", " (map (uncurry prettyPrintObjectPropertyBinder) bs) ++ " }"

182+ , withIndent $ prettyPrintMany prettyPrintObjectPropertyBinder bs

183+ , currentIndent

184+ , return "}"

185+ ]

186+ match (ArrayBinder bs) = fmap concat $ sequence

187+ [ return "["

125− match (ArrayBinder bs) = Just $ "[ " ++ intercalate ", " (map prettyPrintBinder bs) ++ " ]"

188+ , unwords <$> mapM prettyPrintBinder' bs

189+ , return "]"

190+ ]

126− match (NamedBinder ident binder) = Just $ show ident ++ "@" ++ prettyPrintBinder binder

191+ match (NamedBinder ident binder) = ((show ident ++ "@") ++) <$> prettyPrintBinder' binder

127− match _ = Nothing

192+ match (PositionedBinder _ binder) = prettyPrintBinder' binder

193+ match _ = mzero

128

194

129-- |

195-- |

130-- Generate a pretty-printed string representing a Binder

196-- Generate a pretty-printed string representing a Binder

131--

197--

132prettyPrintBinder :: Binder -> String

198prettyPrintBinder :: Binder -> String

133−prettyPrintBinder = fromMaybe (error "Incomplete pattern") . pattern matchBinder ()

199+prettyPrintBinder = fromMaybe (error "Incomplete pattern") . flip evalStateT (PrinterState 0) . prettyPrintBinder'

200+

201+prettyPrintBinder' :: Binder -> StateT PrinterState Maybe String

202+prettyPrintBinder' = runKleisli $ runPattern matchBinder

134 where

203 where

135− matchBinder :: Pattern () Binder String

204+ matchBinder :: Pattern PrinterState Binder String

136 matchBinder = buildPrettyPrinter operators (prettyPrintBinderAtom <+> fmap parens matchBinder)

205 matchBinder = buildPrettyPrinter operators (prettyPrintBinderAtom <+> fmap parens matchBinder)

137− operators :: OperatorTable () Binder String

206+ operators :: OperatorTable PrinterState Binder String

138 operators =

207 operators =

139 OperatorTable [ [ AssocR matchConsBinder (\b1 b2 -> b1 ++ " : " ++ b2) ] ]

208 OperatorTable [ [ AssocR matchConsBinder (\b1 b2 -> b1 ++ " : " ++ b2) ] ]

140

209

141−matchConsBinder :: Pattern () Binder (Binder, Binder)

210+matchConsBinder :: Pattern PrinterState Binder (Binder, Binder)

142matchConsBinder = mkPattern match'

211matchConsBinder = mkPattern match'

143 where

212 where

144 match' (ConsBinder b1 b2) = Just (b1, b2)

213 match' (ConsBinder b1 b2) = Just (b1, b2)

145 match' _ = Nothing

214 match' _ = Nothing

146

215

147−prettyPrintObjectPropertyBinder :: String -> Binder -> String

216+prettyPrintObjectPropertyBinder :: (String, Binder) -> StateT PrinterState Maybe String

148−prettyPrintObjectPropertyBinder key binder = key ++ ": " ++ prettyPrintBinder binder

217+prettyPrintObjectPropertyBinder (key, binder) = fmap concat $ sequence

149−

218+ [ return $ key ++ ": "

219+ , prettyPrintBinder' binder

220+ ]

221+

150−prettyPrintObjectProperty :: String -> Value -> String

222+prettyPrintObjectProperty :: (String, Value) -> StateT PrinterState Maybe String

151−prettyPrintObjectProperty key value = key ++ ": " ++ prettyPrintValue value

223+prettyPrintObjectProperty (key, value) = fmap concat $ sequence

224+ [ return $ key ++ ": "

225+ , prettyPrintValue' value

226+ ]

src/Language/PureScript/Sugar/BindingGroups.hs+14−7

@@ -26,7 +26,7 @@ import Data.Graph

26import Data.Generics

27import Data.Generics.Extras

28import Data.List (nub, intersect)

29−import Data.Maybe (mapMaybe)

29+import Data.Maybe (isJust, mapMaybe)

30import Control.Applicative ((<$>), (<*>), pure)

32import Language.PureScript.Declarations

@@ -82,6 +82,7 @@ collapseBindingGroups = everywhere (mkT collapseBindingGroupsForValue) . concatM

82 where

83 go (DataBindingGroupDeclaration ds) = ds

84 go (BindingGroupDeclaration ds) = map (\(ident, nameKind, val) -> ValueDeclaration ident nameKind [] Nothing val) ds

85+ go (PositionedDeclaration pos d) = map (PositionedDeclaration pos) $ go d

85 go other = [other]

86 go other = [other]

87collapseBindingGroupsForValue :: Value -> Value

88collapseBindingGroupsForValue :: Value -> Value

@@ -109,11 +110,13 @@ usedProperNames moduleName = nub . everything (++) (mkQ [] usedNames)

109

110

110getIdent :: Declaration -> Ident

111getIdent :: Declaration -> Ident

111getIdent (ValueDeclaration ident _ _ _ _) = ident

112getIdent (ValueDeclaration ident _ _ _ _) = ident

113+getIdent (PositionedDeclaration _ d) = getIdent d

112getIdent _ = error "Expected ValueDeclaration"

114getIdent _ = error "Expected ValueDeclaration"

113

115

114getProperName :: Declaration -> ProperName

116getProperName :: Declaration -> ProperName

115getProperName (DataDeclaration pn _ _) = pn

117getProperName (DataDeclaration pn _ _) = pn

116getProperName (TypeSynonymDeclaration pn _ _) = pn

118getProperName (TypeSynonymDeclaration pn _ _) = pn

119+getProperName (PositionedDeclaration _ d) = getProperName d

117getProperName _ = error "Expected DataDeclaration"

120getProperName _ = error "Expected DataDeclaration"

118

121

119toBindingGroup :: SCC Declaration -> Declaration

122toBindingGroup :: SCC Declaration -> Declaration

@@ -123,16 +126,20 @@ toBindingGroup (CyclicSCC ds') = BindingGroupDeclaration $ map fromValueDecl ds'

123

126

124toDataBindingGroup :: SCC Declaration -> Either String Declaration

127toDataBindingGroup :: SCC Declaration -> Either String Declaration

125toDataBindingGroup (AcyclicSCC d) = return d

128toDataBindingGroup (AcyclicSCC d) = return d

129+toDataBindingGroup (CyclicSCC [d]) = case isTypeSynonym d of

126−toDataBindingGroup (CyclicSCC [TypeSynonymDeclaration pn _ _]) = Left $ "Cycle in type synonym " ++ show pn

130+ Just pn -> Left $ "Cycle in type synonym " ++ show pn

127−toDataBindingGroup (CyclicSCC [d]) = return d

131+ _ -> return d

128toDataBindingGroup (CyclicSCC ds')

132toDataBindingGroup (CyclicSCC ds')

129− | all isTypeSynonym ds' = Left "Cycle in type synonyms"

133+ | all (isJust . isTypeSynonym) ds' = Left "Cycle in type synonyms"

130 | otherwise = return $ DataBindingGroupDeclaration ds'

134 | otherwise = return $ DataBindingGroupDeclaration ds'

131− where

135+

136+isTypeSynonym :: Declaration -> Maybe ProperName

132− isTypeSynonym TypeSynonymDeclaration{} = True

137+isTypeSynonym (TypeSynonymDeclaration pn _ _) = Just pn

138+isTypeSynonym (PositionedDeclaration _ d) = isTypeSynonym d

133− isTypeSynonym _ = False

139+isTypeSynonym _ = Nothing

134

140

135fromValueDecl :: Declaration -> (Ident, NameKind, Value)

141fromValueDecl :: Declaration -> (Ident, NameKind, Value)

136fromValueDecl (ValueDeclaration ident nameKind [] Nothing val) = (ident, nameKind, val)

142fromValueDecl (ValueDeclaration ident nameKind [] Nothing val) = (ident, nameKind, val)

137fromValueDecl ValueDeclaration{} = error "Binders should have been desugared"

143fromValueDecl ValueDeclaration{} = error "Binders should have been desugared"

144+fromValueDecl (PositionedDeclaration _ d) = fromValueDecl d

138fromValueDecl _ = error "Expected ValueDeclaration"

145fromValueDecl _ = error "Expected ValueDeclaration"

src/Language/PureScript/Sugar/CaseDeclarations.hs+9

@@ -62,11 +62,16 @@ desugarCases = desugarRest <=< fmap join . mapM toDecls . groupBy inSameGroup

62 where

63 go (Let ds val') = Let <$> desugarCases ds <*> pure val'

64 go other = return other

65+ desugarRest (PositionedDeclaration pos d : ds) = do

66+ (d' : ds') <- desugarRest (d : ds)

67+ return (PositionedDeclaration pos d' : ds')

65 desugarRest (d : ds) = (:) d <$> desugarRest ds

68 desugarRest (d : ds) = (:) d <$> desugarRest ds

66 desugarRest [] = pure []

69 desugarRest [] = pure []

68inSameGroup :: Declaration -> Declaration -> Bool

71inSameGroup :: Declaration -> Declaration -> Bool

69inSameGroup (ValueDeclaration ident1 _ _ _ _) (ValueDeclaration ident2 _ _ _ _) = ident1 == ident2

72inSameGroup (ValueDeclaration ident1 _ _ _ _) (ValueDeclaration ident2 _ _ _ _) = ident1 == ident2

73+inSameGroup (PositionedDeclaration _ d1) d2 = inSameGroup d1 d2

74+inSameGroup d1 (PositionedDeclaration _ d2) = inSameGroup d1 d2

70inSameGroup _ _ = False

75inSameGroup _ _ = False

72toDecls :: [Declaration] -> Either String [Declaration]

77toDecls :: [Declaration] -> Either String [Declaration]

@@ -79,6 +84,9 @@ toDecls ds@(ValueDeclaration ident _ bs _ _ : _) = do

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

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

80 throwError $ "Argument list lengths differ in declaration " ++ show ident

85 throwError $ "Argument list lengths differ in declaration " ++ show ident

81 return [makeCaseDeclaration ident tuples]

86 return [makeCaseDeclaration ident tuples]

87+toDecls (PositionedDeclaration pos d : ds) = do

88+ (d' : ds') <- toDecls (d : ds)

89+ return (PositionedDeclaration pos d' : ds')

82toDecls ds = return ds

90toDecls ds = return ds

84isVarBinder :: Binder -> Bool

92isVarBinder :: Binder -> Bool

@@ -87,6 +95,7 @@ isVarBinder _ = False

88toTuple :: Declaration -> ([Binder], (Maybe Guard, Value))

96toTuple :: Declaration -> ([Binder], (Maybe Guard, Value))

89toTuple (ValueDeclaration _ _ bs g val) = (bs, (g, val))

97toTuple (ValueDeclaration _ _ bs g val) = (bs, (g, val))

98+toTuple (PositionedDeclaration _ d) = toTuple d

90toTuple _ = error "Not a value declaration"

99toTuple _ = error "Not a value declaration"

100

92makeCaseDeclaration :: Ident -> [([Binder], (Maybe Guard, Value))] -> Declaration

101makeCaseDeclaration :: Ident -> [([Binder], (Maybe Guard, Value))] -> Declaration

src/Language/PureScript/Sugar/DoNotation.hs+3

@@ -27,6 +27,8 @@ import Language.PureScript.Declarations

28import qualified Language.PureScript.Constants as C

30+import Control.Applicative

31+

30-- |

32-- |

31-- Replace all @DoNotationBind@ and @DoNotationValue@ constructors with applications of the Prelude.(>>=) function,

33-- Replace all @DoNotationBind@ and @DoNotationValue@ constructors with applications of the Prelude.(>>=) function,

32-- and all @DoNotationLet@ constructors with let expressions.

34-- and all @DoNotationLet@ constructors with let expressions.

@@ -60,3 +62,4 @@ desugarDo = everywhereM (mkM replace)

60 go (DoNotationLet binder val : rest) = do

62 go (DoNotationLet binder val : rest) = do

61 rest' <- go rest

63 rest' <- go rest

62 return $ Case [val] [CaseAlternative [binder] Nothing rest']

64 return $ Case [val] [CaseAlternative [binder] Nothing rest']

65+ go (PositionedDoNotationElement pos el : rest) = PositionedValue pos <$> go (el : rest)

src/Language/PureScript/Sugar/Names.hs+8−4

@@ -216,6 +216,7 @@ renameInModule imports exports (Module mn decls exps) =

216

217 letBoundVariable :: Declaration -> Ident

218 letBoundVariable (ValueDeclaration ident _ _ _ _) = ident

219+ letBoundVariable (PositionedDeclaration _ d) = letBoundVariable d

219 letBoundVariable _ = error "Invalid argument to letBoundVariable"

220 letBoundVariable _ = error "Invalid argument to letBoundVariable"

220 go (ValueDeclaration name _ _ _ _) = error $ "Binders should have been desugared in " ++ show name

221 go (ValueDeclaration name _ _ _ _) = error $ "Binders should have been desugared in " ++ show name

221 go (ExternDeclaration fit name js ty) =

222 go (ExternDeclaration fit name js ty) =

@@ -223,6 +224,7 @@ renameInModule imports exports (Module mn decls exps) =

223 go (BindingGroupDeclaration decls') = do

224 go (BindingGroupDeclaration decls') = do

224 BindingGroupDeclaration <$> mapM go' decls'

225 BindingGroupDeclaration <$> mapM go' decls'

225 where go' = \(name, nk, value) -> rethrowFor "declaration" name $ (,,) <$> pure name <*> pure nk <*> updateAll value

226 where go' = \(name, nk, value) -> rethrowFor "declaration" name $ (,,) <$> pure name <*> pure nk <*> updateAll value

227+ go (PositionedDeclaration pos d) = PositionedDeclaration pos <$> go d

226 go d = updateAll d

228 go d = updateAll d

227

229

228 rethrowFor :: (Show a) => String -> a -> Either String b -> Either String b

230 rethrowFor :: (Show a) => String -> a -> Either String b -> Either String b

@@ -230,20 +232,20 @@ renameInModule imports exports (Module mn decls exps) =

230

232

231 updateAll :: Data d => d -> Either String d

233 updateAll :: Data d => d -> Either String d

232 updateAll = everywhereM (mkM updateType `extM` updateValue `extM` updateBinder)

234 updateAll = everywhereM (mkM updateType `extM` updateValue `extM` updateBinder)

233−

235+

234 updateValue (Constructor name) = Constructor <$> updateDataConstructorName name

236 updateValue (Constructor name) = Constructor <$> updateDataConstructorName name

235 updateValue v = return v

237 updateValue v = return v

236−

238+

237 updateBinder (ConstructorBinder name b) = ConstructorBinder <$> updateDataConstructorName name <*> pure b

239 updateBinder (ConstructorBinder name b) = ConstructorBinder <$> updateDataConstructorName name <*> pure b

238 updateBinder v = return v

240 updateBinder v = return v

239−

241+

240 updateType (TypeConstructor name) = TypeConstructor <$> updateTypeName name

242 updateType (TypeConstructor name) = TypeConstructor <$> updateTypeName name

241 updateType (SaturatedTypeSynonym name tys) = SaturatedTypeSynonym <$> updateTypeName name <*> mapM updateType tys

243 updateType (SaturatedTypeSynonym name tys) = SaturatedTypeSynonym <$> updateTypeName name <*> mapM updateType tys

242 updateType (ConstrainedType cs t) = ConstrainedType <$> updateConstraints cs <*> pure t

244 updateType (ConstrainedType cs t) = ConstrainedType <$> updateConstraints cs <*> pure t

243 updateType t = return t

245 updateType t = return t

244 updateType' :: Data d => d -> Either String d

246 updateType' :: Data d => d -> Either String d

245 updateType' = everywhereM (mkM updateType)

247 updateType' = everywhereM (mkM updateType)

246−

248+

247 updateConstraints = mapM (\(name, ts) -> (,) <$> updateClassName name <*> pure ts)

249 updateConstraints = mapM (\(name, ts) -> (,) <$> updateClassName name <*> pure ts)

248

250

249 updateTypeName = update "type" importedTypes (\mes -> isJust . (`lookup` (exportedTypes mes)))

251 updateTypeName = update "type" importedTypes (\mes -> isJust . (`lookup` (exportedTypes mes)))

@@ -299,6 +301,7 @@ findExports = foldM addModule $ M.singleton (ModuleName [ProperName "Prim"]) pri

299 addDecl mn env (ExternDataDeclaration tn _) = addType env mn tn []

301 addDecl mn env (ExternDataDeclaration tn _) = addType env mn tn []

300 addDecl mn env (ValueDeclaration name _ _ _ _) = addValue env mn name

302 addDecl mn env (ValueDeclaration name _ _ _ _) = addValue env mn name

301 addDecl mn env (ExternDeclaration _ name _ _) = addValue env mn name

303 addDecl mn env (ExternDeclaration _ name _ _) = addValue env mn name

304+ addDecl mn env (PositionedDeclaration _ d) = addDecl mn env d

302 addDecl _ env _ = return env

305 addDecl _ env _ = return env

303

306

304-- |

307-- |

@@ -365,6 +368,7 @@ findImports :: [Declaration] -> M.Map ModuleName (Maybe ExplicitImports, Maybe M

365findImports = foldl findImports' M.empty

368findImports = foldl findImports' M.empty

366 where

369 where

367 findImports' result (ImportDeclaration mn expl qual) = M.insert mn (expl, qual) result

370 findImports' result (ImportDeclaration mn expl qual) = M.insert mn (expl, qual) result

371+ findImports' result (PositionedDeclaration _ d) = findImports' result d

368 findImports' result _ = result

372 findImports' result _ = result

369

373

370-- |

374-- |

src/Language/PureScript/Sugar/Operators.hs+1

@@ -76,6 +76,7 @@ collectFixities :: Module -> [(Qualified Ident, Fixity)]

76collectFixities (Module moduleName ds _) = concatMap collect ds

77 where

78 collect :: Declaration -> [(Qualified Ident, Fixity)]

79+ collect (PositionedDeclaration _ d) = collect d

79 collect (FixityDeclaration fixity name) = [(Qualified (Just moduleName) (Op name), fixity)]

80 collect (FixityDeclaration fixity name) = [(Qualified (Just moduleName) (Op name), fixity)]

80 collect _ = []

81 collect _ = []

src/Language/PureScript/Sugar/TypeClasses.hs+11

@@ -99,10 +99,14 @@ desugarDecl mn d@(TypeInstanceDeclaration name deps className ty members) = do

99 entries <- mapM (typeInstanceDictionaryEntryDeclaration name mn deps className ty) desugared

100 dictDecl <- typeInstanceDictionaryDeclaration name mn deps className ty desugared

101 return $ (Just $ TypeInstanceRef name, d : entries ++ [dictDecl])

102+desugarDecl mn (PositionedDeclaration pos d) = do

103+ (dr, ds) <- desugarDecl mn d

104+ return (dr, map (PositionedDeclaration pos) ds)

102desugarDecl _ other = return (Nothing, [other])

105desugarDecl _ other = return (Nothing, [other])

103

106

104memberToNameAndType :: Declaration -> (String, Type)

107memberToNameAndType :: Declaration -> (String, Type)

105memberToNameAndType (TypeDeclaration ident ty) = (identToJs ident, ty)

108memberToNameAndType (TypeDeclaration ident ty) = (identToJs ident, ty)

109+memberToNameAndType (PositionedDeclaration _ d) = memberToNameAndType d

106memberToNameAndType _ = error "Invalid declaration in type class definition"

110memberToNameAndType _ = error "Invalid declaration in type class definition"

107

111

108typeClassDictionaryDeclaration :: ProperName -> [String] -> [Declaration] -> Declaration

112typeClassDictionaryDeclaration :: ProperName -> [String] -> [Declaration] -> Declaration

@@ -114,6 +118,8 @@ typeClassMemberToDictionaryAccessor mn name args (TypeDeclaration ident ty) =

114 ExternDeclaration TypeClassAccessorImport ident

118 ExternDeclaration TypeClassAccessorImport ident

115 (Just (JSFunction (Just $ identToJs ident) ["dict"] (JSBlock [JSReturn (JSAccessor (identToJs ident) (JSVar "dict"))])))

119 (Just (JSFunction (Just $ identToJs ident) ["dict"] (JSBlock [JSReturn (JSAccessor (identToJs ident) (JSVar "dict"))])))

116 (quantify (ConstrainedType [(Qualified (Just mn) name, map TypeVar args)] ty))

120 (quantify (ConstrainedType [(Qualified (Just mn) name, map TypeVar args)] ty))

121+typeClassMemberToDictionaryAccessor mn name args (PositionedDeclaration pos d) =

122+ PositionedDeclaration pos $ typeClassMemberToDictionaryAccessor mn name args d

117typeClassMemberToDictionaryAccessor _ _ _ _ = error "Invalid declaration in type class definition"

123typeClassMemberToDictionaryAccessor _ _ _ _ = error "Invalid declaration in type class definition"

118

124

119typeInstanceDictionaryDeclaration :: Ident -> ModuleName -> [(Qualified ProperName, [Type])] -> Qualified ProperName -> [Type] -> [Declaration] -> Desugar Declaration

125typeInstanceDictionaryDeclaration :: Ident -> ModuleName -> [(Qualified ProperName, [Type])] -> Qualified ProperName -> [Type] -> [Declaration] -> Desugar Declaration

@@ -143,6 +149,9 @@ typeInstanceDictionaryDeclaration name mn deps className tys decls = do

143 return (identToJs ident, TypedValue False

149 return (identToJs ident, TypedValue False

144 (foldl App (Var (Qualified Nothing memberName)) (map (\n -> Var (Qualified Nothing (Ident ('_' : show n)))) [1..length deps]))

150 (foldl App (Var (Qualified Nothing memberName)) (map (\n -> Var (Qualified Nothing (Ident ('_' : show n)))) [1..length deps]))

145 (quantify memberType))

151 (quantify memberType))

152+ memberToNameAndValue tys' (PositionedDeclaration pos d) = do

153+ (ident, val) <- memberToNameAndValue tys' d

154+ return (ident, PositionedValue pos val)

146 memberToNameAndValue _ _ = error "Invalid declaration in type instance definition"

155 memberToNameAndValue _ _ = error "Invalid declaration in type instance definition"

147

156

148typeInstanceDictionaryEntryDeclaration :: Ident -> ModuleName -> [(Qualified ProperName, [Type])] -> Qualified ProperName -> [Type] -> Declaration -> Desugar Declaration

157typeInstanceDictionaryEntryDeclaration :: Ident -> ModuleName -> [(Qualified ProperName, [Type])] -> Qualified ProperName -> [Type] -> Declaration -> Desugar Declaration

@@ -157,6 +166,8 @@ typeInstanceDictionaryEntryDeclaration name mn deps className tys (ValueDeclarat

157 where

166 where

158 lookupTypeClass m = maybe (Left $ "Type class " ++ show className ++ " is undefined. Type class names must be qualified.") Right $ M.lookup (qualify mn className) m

167 lookupTypeClass m = maybe (Left $ "Type class " ++ show className ++ " is undefined. Type class names must be qualified.") Right $ M.lookup (qualify mn className) m

159 lookupIdent members = maybe (Left $ "Type class " ++ show className ++ " does not have method " ++ show ident) Right $ lookup (identToJs ident) members

168 lookupIdent members = maybe (Left $ "Type class " ++ show className ++ " does not have method " ++ show ident) Right $ lookup (identToJs ident) members

169+typeInstanceDictionaryEntryDeclaration name mn deps className tys (PositionedDeclaration pos d) =

170+ PositionedDeclaration pos <$> typeInstanceDictionaryEntryDeclaration name mn deps className tys d

160typeInstanceDictionaryEntryDeclaration _ _ _ _ _ _ = error "Invalid declaration in type instance definition"

171typeInstanceDictionaryEntryDeclaration _ _ _ _ _ _ = error "Invalid declaration in type instance definition"

161

172

162-- |

173-- |

src/Language/PureScript/Sugar/TypeDeclarations.hs+14−2

@@ -27,6 +27,8 @@ import Control.Monad.Error.Class

27import Control.Monad (forM)

29import Language.PureScript.Declarations

30+import Language.PureScript.Names

31+import Language.PureScript.Environment

31-- |

33-- |

32-- Replace all top level type declarations in a module with type annotations

34-- Replace all top level type declarations in a module with type annotations

@@ -38,9 +40,19 @@ desugarTypeDeclarationsModule ms = forM ms $ \(Module name ds exps) -> Module na

38-- Replace all top level type declarations with type annotations

40-- Replace all top level type declarations with type annotations

39--

41--

40desugarTypeDeclarations :: [Declaration] -> Either String [Declaration]

42desugarTypeDeclarations :: [Declaration] -> Either String [Declaration]

41−desugarTypeDeclarations (TypeDeclaration name ty : ValueDeclaration name' nameKind [] Nothing val : rest) | name == name' =

43+desugarTypeDeclarations (PositionedDeclaration pos d : ds) = do

44+ (d' : ds') <- desugarTypeDeclarations (d : ds)

45+ return (PositionedDeclaration pos d' : ds')

46+desugarTypeDeclarations (TypeDeclaration name ty : d : rest) = do

47+ (_, nameKind, val) <- fromValueDeclaration d

42 desugarTypeDeclarations (ValueDeclaration name nameKind [] Nothing (TypedValue True val ty) : rest)

48 desugarTypeDeclarations (ValueDeclaration name nameKind [] Nothing (TypedValue True val ty) : rest)

49+ where

50+ fromValueDeclaration :: Declaration -> Either String (Ident, NameKind, Value)

51+ fromValueDeclaration (ValueDeclaration name' nameKind [] Nothing val) | name == name' = return (name', nameKind, val)

52+ fromValueDeclaration (PositionedDeclaration pos d') = do

53+ (ident, nameKind, val) <- fromValueDeclaration d'

54+ return (ident, nameKind, PositionedValue pos val)

43−desugarTypeDeclarations (TypeDeclaration name _ : _) = throwError $ "Orphan type declaration for " ++ show name

55+ fromValueDeclaration _ = throwError $ "Orphan type declaration for " ++ show name

44desugarTypeDeclarations (ValueDeclaration name nameKind bs g val : rest) = do

56desugarTypeDeclarations (ValueDeclaration name nameKind bs g val : rest) = do

45 (:) <$> (ValueDeclaration name nameKind bs g <$> everywhereM' (mkM go) val) <*> desugarTypeDeclarations rest

57 (:) <$> (ValueDeclaration name nameKind bs g <$> everywhereM' (mkM go) val) <*> desugarTypeDeclarations rest

46 where

58 where

src/Language/PureScript/TypeChecker.hs+6

@@ -124,8 +124,10 @@ typeCheckAll mainModuleName moduleName (d@(DataBindingGroupDeclaration tys) : re

124 return $ d : ds

125 where

126 toTypeSynonym (TypeSynonymDeclaration nm args ty) = Just (nm, args, ty)

127+ toTypeSynonym (PositionedDeclaration _ d') = toTypeSynonym d'

127 toTypeSynonym _ = Nothing

128 toTypeSynonym _ = Nothing

128 toDataDecl (DataDeclaration nm args dctors) = Just (nm, args, dctors)

129 toDataDecl (DataDeclaration nm args dctors) = Just (nm, args, dctors)

130+ toDataDecl (PositionedDeclaration _ d') = toDataDecl d'

129 toDataDecl _ = Nothing

131 toDataDecl _ = Nothing

130typeCheckAll mainModuleName moduleName (d@(TypeSynonymDeclaration name args ty) : rest) = do

132typeCheckAll mainModuleName moduleName (d@(TypeSynonymDeclaration name args ty) : rest) = do

131 rethrow (strMsg ("Error in type synonym " ++ show name) <>) $ do

133 rethrow (strMsg ("Error in type synonym " ++ show name) <>) $ do

@@ -194,3 +196,7 @@ typeCheckAll mainModuleName moduleName (d@(ExternInstanceDeclaration dictName de

194 addTypeClassDictionaries [TypeClassDictionaryInScope (Qualified (Just moduleName) dictName) className tys (Just deps) TCDRegular]

196 addTypeClassDictionaries [TypeClassDictionaryInScope (Qualified (Just moduleName) dictName) className tys (Just deps) TCDRegular]

195 ds <- typeCheckAll mainModuleName moduleName rest

197 ds <- typeCheckAll mainModuleName moduleName rest

196 return $ d : ds

198 return $ d : ds

199+typeCheckAll mainModuleName moduleName (PositionedDeclaration pos d : rest) =

200+ rethrowWithPosition pos $ do

201+ (d' : rest') <- typeCheckAll mainModuleName moduleName (d : rest)

202+ return (PositionedDeclaration pos d' : rest')

src/Language/PureScript/TypeChecker/Monad.hs+35−28

@@ -63,6 +63,10 @@ data UnifyError = UnifyError {

63 -- The value where the error occurred

64 --

65 , unifyErrorValue :: Maybe UnifyErrorSource

66+ -- |

67+ -- Optional source position information

68+ --

69+ , unifyErrorPosition :: Maybe SourcePos

66 } deriving (Show)

70 } deriving (Show)

68-- |

72-- |

@@ -71,42 +75,39 @@ data UnifyError = UnifyError {

71newtype UnifyErrorStack = UnifyErrorStack { runUnifyErrorStack :: [UnifyError] } deriving (Show, Monoid)

75newtype UnifyErrorStack = UnifyErrorStack { runUnifyErrorStack :: [UnifyError] } deriving (Show, Monoid)

73instance Error UnifyErrorStack where

77instance Error UnifyErrorStack where

74− strMsg s = UnifyErrorStack [UnifyError s Nothing]

78+ strMsg s = UnifyErrorStack [UnifyError s Nothing Nothing]

75 noMsg = UnifyErrorStack []

79 noMsg = UnifyErrorStack []

77prettyPrintUnifyErrorStack :: Options -> UnifyErrorStack -> String

81prettyPrintUnifyErrorStack :: Options -> UnifyErrorStack -> String

78−prettyPrintUnifyErrorStack opts (UnifyErrorStack es) | optionsVerboseErrors opts = intercalate "\n" (map showError es)

82+prettyPrintUnifyErrorStack opts (UnifyErrorStack es) =

79−prettyPrintUnifyErrorStack _ (UnifyErrorStack es) =

83+ case mconcat $ map (Last . unifyErrorPosition) es of

80− let

84+ Last (Just sourcePos) -> "Error at " ++ show sourcePos ++ ": \n" ++ prettyPrintUnifyErrorStack'

81− errorsWithValues = filter (isJust . unifyErrorValue) es

85+ _ -> prettyPrintUnifyErrorStack'

82− mostSpecificError = last es

86+ where

83− in case (length errorsWithValues, isJust (unifyErrorValue mostSpecificError)) of

87+ prettyPrintUnifyErrorStack' :: String

84− (0, _) -> showError mostSpecificError

88+ prettyPrintUnifyErrorStack'

85− (1, True) -> showError mostSpecificError

89+ | optionsVerboseErrors opts =

86− (1, False) ->

90+ intercalate "\n" (map showError (filter isErrorNonEmpty es))

87− let errorWithValue = head errorsWithValues

91+ | otherwise =

88− in showError errorWithValue ++ "\n" ++

89− showError mostSpecificError

90− (_, True) ->

91− let errorWithValue = head errorsWithValues

92− in showError errorWithValue ++ "\n" ++

93− showError mostSpecificError

94− (_, False) ->

95 let

92 let

96− leastSpecificErrorWithValue = head errorsWithValues

93+ es' = filter isErrorNonEmpty es

97− mostSpecificErrorWithValue = last errorsWithValues

94+ in case length es' of

98− in

95+ 1 -> showError (head es')

99− showError leastSpecificErrorWithValue ++ "\n" ++

96+ _ -> showError (head es') ++ "\n" ++ showError (last es')

100− showError mostSpecificErrorWithValue ++ "\n" ++

97+

101− showError mostSpecificError

98+isErrorNonEmpty :: UnifyError -> Bool

99+isErrorNonEmpty = not . null . unifyErrorMessage

102

100

103showError :: UnifyError -> String

101showError :: UnifyError -> String

104−showError (UnifyError msg Nothing) = msg

102+showError (UnifyError msg Nothing _) = msg

105−showError (UnifyError msg (Just (ValueError val))) = "Error in value " ++ prettyPrintValue val ++ ": \n" ++ msg

103+showError (UnifyError msg (Just (ValueError val)) _) = "Error in value " ++ prettyPrintValue val ++ "\n" ++ msg

106−showError (UnifyError msg (Just (TypeError ty))) = "Error in type " ++ prettyPrintType ty ++ ": \n" ++ msg

104+showError (UnifyError msg (Just (TypeError ty)) _) = "Error in type " ++ prettyPrintType ty ++ "\n" ++ msg

107

105

108mkUnifyErrorStack :: String -> Maybe UnifyErrorSource -> UnifyErrorStack

106mkUnifyErrorStack :: String -> Maybe UnifyErrorSource -> UnifyErrorStack

109−mkUnifyErrorStack msg t = UnifyErrorStack [UnifyError msg t]

107+mkUnifyErrorStack msg t = UnifyErrorStack [UnifyError msg t Nothing]

108+

109+positionError :: SourcePos -> UnifyErrorStack

110+positionError pos = UnifyErrorStack [UnifyError "" Nothing (Just pos)]

110

111

111-- |

112-- |

112-- Temporarily bind a collection of names to values

113-- Temporarily bind a collection of names to values

@@ -254,6 +255,12 @@ guardWith e False = throwError e

254rethrow :: (MonadError e m) => (e -> e) -> m a -> m a

255rethrow :: (MonadError e m) => (e -> e) -> m a -> m a

255rethrow f = flip catchError $ \e -> throwError (f e)

256rethrow f = flip catchError $ \e -> throwError (f e)

256

257

258+-- |

259+-- Rethrow an error with source position information

260+--

261+rethrowWithPosition :: (MonadError UnifyErrorStack m) => SourcePos -> m a -> m a

262+rethrowWithPosition pos = rethrow (positionError pos <>)

263+

257-- |

264-- |

258-- Generate new type class dictionary name

265-- Generate new type class dictionary name

259--

266--

src/Language/PureScript/TypeChecker/Types.hs+10−1

@@ -238,6 +238,7 @@ typeForBindingGroupElement moduleName e@(_, (val, _)) dict untypedDict = do

238isFunction :: Value -> Bool

239isFunction (Abs _ _) = True

240isFunction (TypedValue _ val _) = isFunction val

241+isFunction (PositionedValue _ val) = isFunction val

241isFunction _ = False

242isFunction _ = False

242

243

243-- |

244-- |

@@ -576,6 +577,7 @@ infer' (TypedValue checkType val ty) = do

576 ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty

577 ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty

577 val' <- if checkType then check val ty' else return val

578 val' <- if checkType then check val ty' else return val

578 return $ TypedValue True val' ty'

579 return $ TypedValue True val' ty'

580+infer' (PositionedValue pos val) = rethrowWithPosition pos $ infer' val

579infer' _ = error "Invalid argument to infer"

581infer' _ = error "Invalid argument to infer"

580

582

581inferLetBinding :: [Declaration] -> [Declaration] -> Value -> (Value -> UnifyT Type Check Value) -> UnifyT Type Check ([Declaration], Value)

583inferLetBinding :: [Declaration] -> [Declaration] -> Value -> (Value -> UnifyT Type Check Value) -> UnifyT Type Check ([Declaration], Value)

@@ -593,7 +595,10 @@ inferLetBinding seen (BindingGroupDeclaration ds : rest) ret j = do

593 (ident, (val', _)) <- typeForBindingGroupElement moduleName e dict untypedDict

595 (ident, (val', _)) <- typeForBindingGroupElement moduleName e dict untypedDict

594 return $ (ident, LocalVariable, val')

596 return $ (ident, LocalVariable, val')

595 bindNames dict $ inferLetBinding (seen ++ [BindingGroupDeclaration ds']) rest ret j

597 bindNames dict $ inferLetBinding (seen ++ [BindingGroupDeclaration ds']) rest ret j

598+inferLetBinding seen (PositionedDeclaration pos d : ds) ret j = do

599+ ((d' : ds'), val') <- inferLetBinding seen (d : ds) ret j

600+ return (PositionedDeclaration pos d' : ds', val')

596−inferLetBinding _ _ _ _ = error "Invalid argument to fromValueDeclaration"

601+inferLetBinding _ _ _ _ = error "Invalid argument to inferLetBinding"

597

602

598-- |

603-- |

599-- Infer the type of a property inside a record with a given type

604-- Infer the type of a property inside a record with a given type

@@ -662,6 +667,8 @@ inferBinder val (ConsBinder headBinder tailBinder) = do

662inferBinder val (NamedBinder name binder) = do

667inferBinder val (NamedBinder name binder) = do

663 m <- inferBinder val binder

668 m <- inferBinder val binder

664 return $ M.insert name val m

669 return $ M.insert name val m

670+inferBinder val (PositionedBinder pos binder) =

671+ rethrowWithPosition pos $ inferBinder val binder

665

672

666-- |

673-- |

667-- Check the types of the return values in a set of binders in a case statement

674-- Check the types of the return values in a set of binders in a case statement

@@ -826,6 +833,8 @@ check' (Let ds val) ty = do

826check' val ty | containsTypeSynonyms ty = do

833check' val ty | containsTypeSynonyms ty = do

827 ty' <- introduceSkolemScope <=< expandAllTypeSynonyms $ ty

834 ty' <- introduceSkolemScope <=< expandAllTypeSynonyms $ ty

828 check val ty'

835 check val ty'

836+check' (PositionedValue pos val) ty =

837+ rethrowWithPosition pos $ check val ty

829check' val ty = throwError $ mkUnifyErrorStack ("Value does not have type " ++ prettyPrintType ty) (Just (ValueError val))

838check' val ty = throwError $ mkUnifyErrorStack ("Value does not have type " ++ prettyPrintType ty) (Just (ValueError val))

830

839

831containsTypeSynonyms :: Type -> Bool

840containsTypeSynonyms :: Type -> Bool