4eb7696 · rowtype-yoga/purescript-native

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

Rename Value to Expr, resolves #494

commit4eb7696b6043cfcb75f30613f0ecb39bdeddca58 authorGary Burgess <gary.burgess@gmail.com> dateMon 4 Aug 2014, 21:35 (12 years ago) parent5299aa1

16 files changed+135−135

compare with golang

unifiedsplit

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

@@ -83,7 +83,7 @@ imports other =

8383 let (f, _, _, _, _) = everythingOnValues (++) (const []) collectV collectB (const []) (const [])

8484 in f other

8585 where

86− collectV :: Value -> [ModuleName]

86+ collectV :: Expr -> [ModuleName]

8787 collectV (Var (Qualified (Just mn) _)) = [mn]

8888 collectV (Constructor (Qualified (Just mn) _)) = [mn]

8989 collectV (TypeClassDictionaryConstructorApp (Qualified (Just mn) _) _) = [mn]

@@ -190,7 +190,7 @@ accessorString prop | identNeedsEscaping prop = JSIndexer (JSStringLiteral prop)

190190-- |

191191-- Generate code in the simplified Javascript intermediate representation for a value or expression.

192192--

193−valueToJs :: (Functor m, Applicative m, Monad m) => Options -> ModuleName -> Environment -> Value -> SupplyT m JS

193+valueToJs :: (Functor m, Applicative m, Monad m) => Options -> ModuleName -> Environment -> Expr -> SupplyT m JS

194194valueToJs _ _ _ (NumericLiteral n) = return $ JSNumericLiteral n

195195valueToJs _ _ _ (StringLiteral s) = return $ JSStringLiteral s

196196valueToJs _ _ _ (BooleanLiteral b) = return $ JSBooleanLiteral b

@@ -221,7 +221,7 @@ valueToJs opts m e v@App{} = do

221221 return $ JSUnary JSNew $ JSApp (qualifiedToJS m (Ident . runProperName) name) args'

222222 _ -> flip (foldl (\fn a -> JSApp fn [a])) args' <$> valueToJs opts m e f

223223 where

224− unApp :: Value -> [Value] -> (Value, [Value])

224+ unApp :: Expr -> [Expr] -> (Expr, [Expr])

225225 unApp (App val arg) args = unApp val (arg : args)

226226 unApp (PositionedValue _ val) args = unApp val args

227227 unApp (TypedValue _ val _) args = unApp val args

src/Language/PureScript/DeadCodeElimination.hs+1−1

@@ -79,7 +79,7 @@ dependencies moduleName =

7979 let (f, _, _, _, _) = everythingOnValues (++) (const []) values (const []) (const []) (const [])

8080 in nub . f

8181 where

82− values :: Value -> [Key]

82+ values :: Expr -> [Key]

8383 values (Var ident) = let (mn, name) = qualify moduleName ident in [(mn, Left name)]

8484 values (Constructor (Qualified (Just mn) name)) = [(mn, Right name)]

8585 values (Constructor (Qualified Nothing _)) = error "Found unqualified data constructor"

src/Language/PureScript/Declarations.hs+37−37

@@ -154,11 +154,11 @@ data Declaration

154154 -- |

155155 -- A value declaration (name, top-level binders, optional guard, value)

156156 --

157− | ValueDeclaration Ident NameKind [Binder] (Maybe Guard) Value

157+ | ValueDeclaration Ident NameKind [Binder] (Maybe Guard) Expr

158158 -- |

159159 -- A minimal mutually recursive set of value declarations

160160 --

161− | BindingGroupDeclaration [(Ident, NameKind, Value)]

161+ | BindingGroupDeclaration [(Ident, NameKind, Expr)]

162162 -- |

163163 -- A foreign import declaration (type, name, optional inline Javascript, type)

164164 --

@@ -264,12 +264,12 @@ isTypeClassDeclaration _ = False

264264-- |

265265-- A guard is just a boolean-valued expression that appears alongside a set of binders

266266--

267−type Guard = Value

267+type Guard = Expr

268268

269269-- |

270−-- Data type for values

270+-- Data type for expressions and terms

271271--

272−data Value

272+data Expr

273273 -- |

274274 -- A numeric literal

275275 --

@@ -285,41 +285,41 @@ data Value

285285 -- |

286286 -- A prefix -, will be desugared

287287 --

288− | UnaryMinus Value

288+ | UnaryMinus Expr

289289 -- |

290290 -- Binary operator application. During the rebracketing phase of desugaring, this data constructor

291291 -- will be removed.

292292 --

293− | BinaryNoParens (Qualified Ident) Value Value

293+ | BinaryNoParens (Qualified Ident) Expr Expr

294294 -- |

295295 -- Explicit parentheses. During the rebracketing phase of desugaring, this data constructor

296296 -- will be removed.

297297 --

298− | Parens Value

298+ | Parens Expr

299299 -- |

300300 -- An array literal

301301 --

302− | ArrayLiteral [Value]

302+ | ArrayLiteral [Expr]

303303 -- |

304304 -- An object literal

305305 --

306− | ObjectLiteral [(String, Value)]

306+ | ObjectLiteral [(String, Expr)]

307307 -- |

308308 -- An record property accessor expression

309309 --

310− | Accessor String Value

310+ | Accessor String Expr

311311 -- |

312312 -- Partial record update

313313 --

314− | ObjectUpdate Value [(String, Value)]

314+ | ObjectUpdate Expr [(String, Expr)]

315315 -- |

316316 -- Function introduction

317317 --

318− | Abs (Either Ident Binder) Value

318+ | Abs (Either Ident Binder) Expr

319319 -- |

320320 -- Function application

321321 --

322− | App Value Value

322+ | App Expr Expr

323323 -- |

324324 -- Variable

325325 --

@@ -327,7 +327,7 @@ data Value

327327 -- |

328328 -- Conditional (if-then-else expression)

329329 --

330− | IfThenElse Value Value Value

330+ | IfThenElse Expr Expr Expr

331331 -- |

332332 -- A data constructor

333333 --

@@ -336,15 +336,15 @@ data Value

336336 -- A case expression. During the case expansion phase of desugaring, top-level binders will get

337337 -- desugared into case expressions, hence the need for guards and multiple binders per branch here.

338338 --

339− | Case [Value] [CaseAlternative]

339+ | Case [Expr] [CaseAlternative]

340340 -- |

341341 -- A value with a type annotation

342342 --

343− | TypedValue Bool Value Type

343+ | TypedValue Bool Expr Type

344344 -- |

345345 -- A let binding

346346 --

347− | Let [Declaration] Value

347+ | Let [Declaration] Expr

348348 -- |

349349 -- A do-notation block

350350 --

@@ -353,7 +353,7 @@ data Value

353353 -- An application of a typeclass dictionary constructor. The value should be

354354 -- an ObjectLiteral.

355355 --

356− | TypeClassDictionaryConstructorApp (Qualified ProperName) Value

356+ | TypeClassDictionaryConstructorApp (Qualified ProperName) Expr

357357 -- |

358358 -- A placeholder for a type class dictionary to be inserted later. At the end of type checking, these

359359 -- placeholders will be replaced with actual expressions representing type classes dictionaries which

@@ -369,7 +369,7 @@ data Value

369369 -- |

370370 -- A value with source position information

371371 --

372− | PositionedValue SourcePos Value deriving (Show, D.Data, D.Typeable)

372+ | PositionedValue SourcePos Expr deriving (Show, D.Data, D.Typeable)

373373

374374-- |

375375-- An alternative in a case statement

@@ -386,7 +386,7 @@ data CaseAlternative = CaseAlternative

386386 -- |

387387 -- The result expression

388388 --

389− , caseAlternativeResult :: Value

389+ , caseAlternativeResult :: Expr

390390 } deriving (Show, D.Data, D.Typeable)

391391

392392-- |

@@ -403,11 +403,11 @@ data DoNotationElement

403403 -- |

404404 -- A monadic value without a binder

405405 --

406− = DoNotationValue Value

406+ = DoNotationValue Expr

407407 -- |

408408 -- A monadic value with a binder

409409 --

410− | DoNotationBind Binder Value

410+ | DoNotationBind Binder Expr

411411 -- |

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

413413 --

@@ -486,9 +486,9 @@ binderNames = go []

486486--

487487

488488everywhereOnValues :: (Declaration -> Declaration) ->

489− (Value -> Value) ->

489+ (Expr -> Expr) ->

490490 (Binder -> Binder) ->

491− (Declaration -> Declaration, Value -> Value, Binder -> Binder)

491+ (Declaration -> Declaration, Expr -> Expr, Binder -> Binder)

492492everywhereOnValues f g h = (f', g', h')

493493 where

494494 f' :: Declaration -> Declaration

@@ -500,7 +500,7 @@ everywhereOnValues f g h = (f', g', h')

500500 f' (PositionedDeclaration pos d) = f (PositionedDeclaration pos (f' d))

501501 f' other = f other

502502

503− g' :: Value -> Value

503+ g' :: Expr -> Expr

504504 g' (UnaryMinus v) = g (UnaryMinus (g' v))

505505 g' (BinaryNoParens op v1 v2) = g (BinaryNoParens op (g' v1) (g' v2))

506506 g' (Parens v) = g (Parens (g' v))

@@ -544,9 +544,9 @@ everywhereOnValues f g h = (f', g', h')

544544

545545everywhereOnValuesTopDownM :: (Functor m, Applicative m, Monad m) =>

546546 (Declaration -> m Declaration) ->

547− (Value -> m Value) ->

547+ (Expr -> m Expr) ->

548548 (Binder -> m Binder) ->

549− (Declaration -> m Declaration, Value -> m Value, Binder -> m Binder)

549+ (Declaration -> m Declaration, Expr -> m Expr, Binder -> m Binder)

550550everywhereOnValuesTopDownM f g h = (f' <=< f, g' <=< g, h' <=< h)

551551 where

552552 f' (DataBindingGroupDeclaration ds) = DataBindingGroupDeclaration <$> mapM (f' <=< f) ds

@@ -594,9 +594,9 @@ everywhereOnValuesTopDownM f g h = (f' <=< f, g' <=< g, h' <=< h)

594594

595595everywhereOnValuesM :: (Functor m, Applicative m, Monad m) =>

596596 (Declaration -> m Declaration) ->

597− (Value -> m Value) ->

597+ (Expr -> m Expr) ->

598598 (Binder -> m Binder) ->

599− (Declaration -> m Declaration, Value -> m Value, Binder -> m Binder)

599+ (Declaration -> m Declaration, Expr -> m Expr, Binder -> m Binder)

600600everywhereOnValuesM f g h = (f' <=< f, g' <=< g, h' <=< h)

601601 where

602602 f' (DataBindingGroupDeclaration ds) = (DataBindingGroupDeclaration <$> mapM f' ds) >>= f

@@ -644,11 +644,11 @@ everywhereOnValuesM f g h = (f' <=< f, g' <=< g, h' <=< h)

644644

645645everythingOnValues :: (r -> r -> r) ->

646646 (Declaration -> r) ->

647− (Value -> r) ->

647+ (Expr -> r) ->

648648 (Binder -> r) ->

649649 (CaseAlternative -> r) ->

650650 (DoNotationElement -> r) ->

651− (Declaration -> r, Value -> r, Binder -> r, CaseAlternative -> r, DoNotationElement -> r)

651+ (Declaration -> r, Expr -> r, Binder -> r, CaseAlternative -> r, DoNotationElement -> r)

652652everythingOnValues (<>) f g h i j = (f', g', h', i', j')

653653 where

654654 f' d@(DataBindingGroupDeclaration ds) = foldl (<>) (f d) (map f' ds)

@@ -700,12 +700,12 @@ everythingWithContextOnValues ::

700700 r ->

701701 (r -> r -> r) ->

702702 (s -> Declaration -> (s, r)) ->

703− (s -> Value -> (s, r)) ->

703+ (s -> Expr -> (s, r)) ->

704704 (s -> Binder -> (s, r)) ->

705705 (s -> CaseAlternative -> (s, r)) ->

706706 (s -> DoNotationElement -> (s, r)) ->

707707 ( Declaration -> r

708− , Value -> r

708+ , Expr -> r

709709 , Binder -> r

710710 , CaseAlternative -> r

711711 , DoNotationElement -> r)

@@ -767,12 +767,12 @@ everythingWithContextOnValues s0 r0 (<>) f g h i j = (f'' s0, g'' s0, h'' s0, i'

767767everywhereWithContextOnValuesM :: (Functor m, Applicative m, Monad m) =>

768768 s ->

769769 (s -> Declaration -> m (s, Declaration)) ->

770− (s -> Value -> m (s, Value)) ->

770+ (s -> Expr -> m (s, Expr)) ->

771771 (s -> Binder -> m (s, Binder)) ->

772772 (s -> CaseAlternative -> m (s, CaseAlternative)) ->

773773 (s -> DoNotationElement -> m (s, DoNotationElement)) ->

774774 ( Declaration -> m Declaration

775− , Value -> m Value

775+ , Expr -> m Expr

776776 , Binder -> m Binder

777777 , CaseAlternative -> m CaseAlternative

778778 , DoNotationElement -> m DoNotationElement)

@@ -829,7 +829,7 @@ everywhereWithContextOnValuesM s0 f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j

829829 j' s (DoNotationLet ds) = DoNotationLet <$> mapM (f'' s) ds

830830 j' s (PositionedDoNotationElement pos e1) = PositionedDoNotationElement pos <$> j'' s e1

831831

832−accumTypes :: (Monoid r) => (Type -> r) -> (Declaration -> r, Value -> r, Binder -> r, CaseAlternative -> r, DoNotationElement -> r)

832+accumTypes :: (Monoid r) => (Type -> r) -> (Declaration -> r, Expr -> r, Binder -> r, CaseAlternative -> r, DoNotationElement -> r)

833833accumTypes f = everythingOnValues mappend forDecls forValues (const mempty) (const mempty) (const mempty)

834834 where

835835 forDecls (DataDeclaration _ _ _ dctors) = mconcat (concatMap (map f . snd) dctors)

src/Language/PureScript/Errors.hs+3−3

@@ -30,9 +30,9 @@ import Language.PureScript.Types

3030--

3131data ErrorSource

3232 -- |

33− -- An error which originated at a Value

33+ -- An error which originated at a Expr

3434 --

35− = ValueError Value

35+ = ExprError Expr

3636 -- |

3737 -- An error which originated at a Type

3838 --

@@ -89,7 +89,7 @@ isErrorNonEmpty = not . null . compileErrorMessage

8989

9090showError :: CompileError -> String

9191showError (CompileError msg Nothing _) = msg

92−showError (CompileError msg (Just (ValueError val)) _) = "Error in value " ++ prettyPrintValue val ++ ":\n" ++ msg

92+showError (CompileError msg (Just (ExprError val)) _) = "Error in expression " ++ prettyPrintValue val ++ ":\n" ++ msg

9393showError (CompileError msg (Just (TypeError ty)) _) = "Error in type " ++ prettyPrintType ty ++ ":\n" ++ msg

9494

9595mkErrorStack :: String -> Maybe ErrorSource -> ErrorStack

src/Language/PureScript/ModuleDependencies.hs+1−1

@@ -52,7 +52,7 @@ usedModules = let (f, _, _, _, _) = everythingOnValues (++) forDecls forValues (

5252 forDecls (ImportDeclaration mn _ _) = [mn]

5353 forDecls _ = []

5454

55− forValues :: Value -> [ModuleName]

55+ forValues :: Expr -> [ModuleName]

5656 forValues (Var (Qualified (Just mn) _)) = [mn]

5757 forValues (BinaryNoParens (Qualified (Just mn) _) _ _) = [mn]

5858 forValues (Constructor (Qualified (Just mn) _)) = [mn]

src/Language/PureScript/Parser/Declarations.hs+18−18

@@ -230,26 +230,26 @@ parseModules = whiteSpace *> mark (P.many (same *> parseModule)) <* P.eof

230230booleanLiteral :: P.Parsec String ParseState Bool

231231booleanLiteral = (C.reserved "true" >> return True) P.<|> (C.reserved "false" >> return False)

232232

233−parseNumericLiteral :: P.Parsec String ParseState Value

233+parseNumericLiteral :: P.Parsec String ParseState Expr

234234parseNumericLiteral = NumericLiteral <$> C.integerOrFloat

235235

236−parseStringLiteral :: P.Parsec String ParseState Value

236+parseStringLiteral :: P.Parsec String ParseState Expr

237237parseStringLiteral = StringLiteral <$> C.stringLiteral

238238

239−parseBooleanLiteral :: P.Parsec String ParseState Value

239+parseBooleanLiteral :: P.Parsec String ParseState Expr

240240parseBooleanLiteral = BooleanLiteral <$> booleanLiteral

241241

242−parseArrayLiteral :: P.Parsec String ParseState Value

242+parseArrayLiteral :: P.Parsec String ParseState Expr

243243parseArrayLiteral = ArrayLiteral <$> C.squares (C.commaSep parseValue)

244244

245−parseObjectLiteral :: P.Parsec String ParseState Value

245+parseObjectLiteral :: P.Parsec String ParseState Expr

246246parseObjectLiteral = ObjectLiteral <$> C.braces (C.commaSep parseIdentifierAndValue)

247247

248−parseIdentifierAndValue :: P.Parsec String ParseState (String, Value)

248+parseIdentifierAndValue :: P.Parsec String ParseState (String, Expr)

249249parseIdentifierAndValue = (,) <$> (C.indented *> (C.identifier <|> C.stringLiteral) <* C.indented <* C.colon)

250250 <*> (C.indented *> parseValue)

251251

252−parseAbs :: P.Parsec String ParseState Value

252+parseAbs :: P.Parsec String ParseState Expr

253253parseAbs = do

254254 C.reservedOp "\\"

255255 args <- P.many1 (C.indented *> (Abs <$> (Left <$> P.try C.parseIdent <|> Right <$> parseBinderNoParens)))

@@ -257,16 +257,16 @@ parseAbs = do

257257 value <- parseValue

258258 return $ toFunction args value

259259 where

260− toFunction :: [Value -> Value] -> Value -> Value

260+ toFunction :: [Expr -> Expr] -> Expr -> Expr

261261 toFunction args value = foldr ($) value args

262262

263−parseVar :: P.Parsec String ParseState Value

263+parseVar :: P.Parsec String ParseState Expr

264264parseVar = Var <$> C.parseQualified C.parseIdent

265265

266−parseConstructor :: P.Parsec String ParseState Value

266+parseConstructor :: P.Parsec String ParseState Expr

267267parseConstructor = Constructor <$> C.parseQualified C.properName

268268

269−parseCase :: P.Parsec String ParseState Value

269+parseCase :: P.Parsec String ParseState Expr

270270parseCase = Case <$> P.between (P.try (C.reserved "case")) (C.indented *> C.reserved "of") (return <$> parseValue)

271271 <*> (C.indented *> C.mark (P.many (C.same *> C.mark parseCaseAlternative)))

272272

@@ -276,12 +276,12 @@ parseCaseAlternative = CaseAlternative <$> (return <$> parseBinder)

276276 <*> (C.indented *> C.reservedOp "->" *> parseValue)

277277 P.<?> "case alternative"

278278

279−parseIfThenElse :: P.Parsec String ParseState Value

279+parseIfThenElse :: P.Parsec String ParseState Expr

280280parseIfThenElse = IfThenElse <$> (P.try (C.reserved "if") *> C.indented *> parseValue)

281281 <*> (C.indented *> C.reserved "then" *> C.indented *> parseValue)

282282 <*> (C.indented *> C.reserved "else" *> C.indented *> parseValue)

283283

284−parseLet :: P.Parsec String ParseState Value

284+parseLet :: P.Parsec String ParseState Expr

285285parseLet = do

286286 C.reserved "let"

287287 C.indented

@@ -291,7 +291,7 @@ parseLet = do

291291 result <- parseValue

292292 return $ Let ds result

293293

294−parseValueAtom :: P.Parsec String ParseState Value

294+parseValueAtom :: P.Parsec String ParseState Expr

295295parseValueAtom = P.choice

296296 [ P.try parseNumericLiteral

297297 , P.try parseStringLiteral

@@ -307,18 +307,18 @@ parseValueAtom = P.choice

307307 , parseLet

308308 , Parens <$> C.parens parseValue ]

309309

310−parsePropertyUpdate :: P.Parsec String ParseState (String, Value)

310+parsePropertyUpdate :: P.Parsec String ParseState (String, Expr)

311311parsePropertyUpdate = do

312312 name <- C.lexeme (C.identifier <|> C.stringLiteral)

313313 _ <- C.lexeme $ C.indented *> P.char '='

314314 value <- C.indented *> parseValue

315315 return (name, value)

316316

317−parseAccessor :: Value -> P.Parsec String ParseState Value

317+parseAccessor :: Expr -> P.Parsec String ParseState Expr

318318parseAccessor (Constructor _) = P.unexpected "constructor"

319319parseAccessor obj = P.try $ Accessor <$> (C.indented *> C.dot *> P.notFollowedBy C.opLetter *> C.indented *> (C.identifier <|> C.stringLiteral)) <*> pure obj

320320

321−parseDo :: P.Parsec String ParseState Value

321+parseDo :: P.Parsec String ParseState Expr

322322parseDo = do

323323 C.reserved "do"

324324 C.indented

@@ -339,7 +339,7 @@ parseDoNotationElement = P.choice

339339-- |

340340-- Parse a value

341341--

342−parseValue :: P.Parsec String ParseState Value

342+parseValue :: P.Parsec String ParseState Expr

343343parseValue = PositionedValue <$> sourcePos <*>

344344 (P.buildExpressionParser operators

345345 . C.buildPostfixParser postfixTable2

src/Language/PureScript/Pretty/Values.hs+12−12

@@ -30,10 +30,10 @@ import Language.PureScript.Declarations

3030import Language.PureScript.Pretty.Common

3131import Language.PureScript.Pretty.Types (prettyPrintType)

3232

33−literals :: Pattern PrinterState Value String

33+literals :: Pattern PrinterState Expr String

3434literals = mkPattern' match

3535 where

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

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

3737 match (NumericLiteral n) = return $ either show show n

3838 match (StringLiteral s) = return $ show s

3939 match (BooleanLiteral True) = return "true"

@@ -118,31 +118,31 @@ prettyPrintDoNotationElement (DoNotationLet ds) =

118118 ]

119119prettyPrintDoNotationElement (PositionedDoNotationElement _ el) = prettyPrintDoNotationElement el

120120

121−ifThenElse :: Pattern PrinterState Value ((Value, Value), Value)

121+ifThenElse :: Pattern PrinterState Expr ((Expr, Expr), Expr)

122122ifThenElse = mkPattern match

123123 where

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

125125 match _ = Nothing

126126

127−accessor :: Pattern PrinterState Value (String, Value)

127+accessor :: Pattern PrinterState Expr (String, Expr)

128128accessor = mkPattern match

129129 where

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

131131 match _ = Nothing

132132

133−objectUpdate :: Pattern PrinterState Value ([String], Value)

133+objectUpdate :: Pattern PrinterState Expr ([String], Expr)

134134objectUpdate = mkPattern match

135135 where

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

137137 match _ = Nothing

138138

139−app :: Pattern PrinterState Value (String, Value)

139+app :: Pattern PrinterState Expr (String, Expr)

140140app = mkPattern match

141141 where

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

143143 match _ = Nothing

144144

145−lam :: Pattern PrinterState Value (String, Value)

145+lam :: Pattern PrinterState Expr (String, Expr)

146146lam = mkPattern match

147147 where

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

@@ -151,15 +151,15 @@ lam = mkPattern match

151151-- |

152152-- Generate a pretty-printed string representing an expression

153153--

154−prettyPrintValue :: Value -> String

154+prettyPrintValue :: Expr -> String

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

156156

157−prettyPrintValue' :: Value -> StateT PrinterState Maybe String

157+prettyPrintValue' :: Expr -> StateT PrinterState Maybe String

158158prettyPrintValue' = runKleisli $ runPattern matchValue

159159 where

160− matchValue :: Pattern PrinterState Value String

160+ matchValue :: Pattern PrinterState Expr String

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

162− operators :: OperatorTable PrinterState Value String

162+ operators :: OperatorTable PrinterState Expr String

163163 operators =

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

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

@@ -224,7 +224,7 @@ prettyPrintObjectPropertyBinder (key, binder) = fmap concat $ sequence

224224 , prettyPrintBinder' binder

225225 ]

226226

227−prettyPrintObjectProperty :: (String, Value) -> StateT PrinterState Maybe String

227+prettyPrintObjectProperty :: (String, Expr) -> StateT PrinterState Maybe String

228228prettyPrintObjectProperty (key, value) = fmap concat $ sequence

229229 [ return $ prettyPrintObjectKey key ++ ": "

230230 , prettyPrintValue' value

src/Language/PureScript/Renamer.hs+3−3

@@ -132,11 +132,11 @@ renameInDecl isTopLevel (BindingGroupDeclaration ds) = do

132132 ds' <- mapM updateNames ds

133133 BindingGroupDeclaration <$> mapM updateValues ds'

134134 where

135− updateNames :: (Ident, NameKind, Value) -> Rename (Ident, NameKind, Value)

135+ updateNames :: (Ident, NameKind, Expr) -> Rename (Ident, NameKind, Expr)

136136 updateNames (name, nameKind, val) = do

137137 name' <- if isTopLevel then return name else updateScope name

138138 return (name', nameKind, val)

139− updateValues :: (Ident, NameKind, Value) -> Rename (Ident, NameKind, Value)

139+ updateValues :: (Ident, NameKind, Expr) -> Rename (Ident, NameKind, Expr)

140140 updateValues (name, nameKind, val) =

141141 (,,) name nameKind <$> renameInValue val

142142renameInDecl _ (TypeInstanceDeclaration name cs className args ds) =

@@ -148,7 +148,7 @@ renameInDecl _ other = return other

148148-- |

149149-- Renames within a value.

150150--

151−renameInValue :: Value -> Rename Value

151+renameInValue :: Expr -> Rename Expr

152152renameInValue (UnaryMinus v) =

153153 UnaryMinus <$> renameInValue v

154154renameInValue (ArrayLiteral vs) =

src/Language/PureScript/Sugar/BindingGroups.hs+3−3

@@ -85,7 +85,7 @@ collapseBindingGroups = let (f, _, _) = everywhereOnValues id collapseBindingGro

8585 go (PositionedDeclaration pos d) = map (PositionedDeclaration pos) $ go d

8686 go other = [other]

8787

88−collapseBindingGroupsForValue :: Value -> Value

88+collapseBindingGroupsForValue :: Expr -> Expr

8989collapseBindingGroupsForValue (Let ds val) = Let (collapseBindingGroups ds) val

9090collapseBindingGroupsForValue other = other

9191

@@ -94,7 +94,7 @@ usedIdents moduleName =

9494 let (f, _, _, _, _) = everythingOnValues (++) (const []) usedNames (const []) (const []) (const [])

9595 in nub . f

9696 where

97− usedNames :: Value -> [Ident]

97+ usedNames :: Expr -> [Ident]

9898 usedNames (Var (Qualified Nothing name)) = [name]

9999 usedNames (Var (Qualified (Just moduleName') name)) | moduleName == moduleName' = [name]

100100 usedNames _ = []

@@ -142,7 +142,7 @@ isTypeSynonym (TypeSynonymDeclaration pn _ _) = Just pn

142142isTypeSynonym (PositionedDeclaration _ d) = isTypeSynonym d

143143isTypeSynonym _ = Nothing

144144

145−fromValueDecl :: Declaration -> (Ident, NameKind, Value)

145+fromValueDecl :: Declaration -> (Ident, NameKind, Expr)

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

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

148148fromValueDecl (PositionedDeclaration _ d) = fromValueDecl d

src/Language/PureScript/Sugar/CaseDeclarations.hs+3−3

@@ -45,7 +45,7 @@ desugarAbs = mapM f

4545 where

4646 (f, _, _) = everywhereOnValuesM return replace return

4747

48− replace :: Value -> SupplyT (Either ErrorStack) Value

48+ replace :: Expr -> SupplyT (Either ErrorStack) Expr

4949 replace (Abs (Right binder) val) = do

5050 ident <- Ident <$> freshName

5151 return $ Abs (Left ident) $ Case [Var (Qualified Nothing ident)] [CaseAlternative [binder] Nothing val]

@@ -98,12 +98,12 @@ isVarBinder :: Binder -> Bool

9898isVarBinder (VarBinder _) = True

9999isVarBinder _ = False

100100

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

101+toTuple :: Declaration -> ([Binder], (Maybe Guard, Expr))

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

103103toTuple (PositionedDeclaration _ d) = toTuple d

104104toTuple _ = error "Not a value declaration"

105105

106−makeCaseDeclaration :: Ident -> [([Binder], (Maybe Guard, Value))] -> SupplyT (Either ErrorStack) Declaration

106+makeCaseDeclaration :: Ident -> [([Binder], (Maybe Guard, Expr))] -> SupplyT (Either ErrorStack) Declaration

107107makeCaseDeclaration ident alternatives = do

108108 let argPattern = length . fst . head $ alternatives

109109 args <- map Ident <$> replicateM argPattern freshName

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

@@ -44,15 +44,15 @@ desugarDo d =

4444 prelude :: ModuleName

4545 prelude = ModuleName [ProperName C.prelude]

4646

47− bind :: Value

47+ bind :: Expr

4848 bind = Var (Qualified (Just prelude) (Op (C.>>=)))

4949

50− replace :: Value -> SupplyT (Either ErrorStack) Value

50+ replace :: Expr -> SupplyT (Either ErrorStack) Expr

5151 replace (Do els) = go els

5252 replace (PositionedValue pos v) = PositionedValue pos <$> rethrowWithPosition pos (replace v)

5353 replace other = return other

5454

55− go :: [DoNotationElement] -> SupplyT (Either ErrorStack) Value

55+ go :: [DoNotationElement] -> SupplyT (Either ErrorStack) Expr

5656 go [] = error "The impossible happened in desugarDo"

5757 go [DoNotationValue val] = return val

5858 go (DoNotationValue val : rest) = do

src/Language/PureScript/Sugar/Names.hs+1−1

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

198198 (,) (pos, name : bound) <$> (ExternDeclaration fit name js <$> updateTypesEverywhere pos ty)

199199 updateDecl s d = return (s, d)

200200

201− updateValue :: (Maybe SourcePos, [Ident]) -> Value -> Either ErrorStack ((Maybe SourcePos, [Ident]), Value)

201+ updateValue :: (Maybe SourcePos, [Ident]) -> Expr -> Either ErrorStack ((Maybe SourcePos, [Ident]), Expr)

202202 updateValue (_, bound) v@(PositionedValue pos' _) = return ((Just pos', bound), v)

203203 updateValue (pos, bound) (Abs (Left arg) val') = return ((pos, arg : bound), Abs (Left arg) val')

204204 updateValue (pos, bound) (Let ds val') =

src/Language/PureScript/Sugar/Operators.hs+8−8

@@ -63,7 +63,7 @@ removeSignedLiterals (Module mn ds exts) = Module mn (map f' ds) exts

6363 go (UnaryMinus val) = App (Var (Qualified (Just (ModuleName [ProperName C.prelude])) (Ident C.negate))) val

6464 go other = other

6565

66−rebracketModule :: [[(Qualified Ident, Value -> Value -> Value, Associativity)]] -> Module -> Either ErrorStack Module

66+rebracketModule :: [[(Qualified Ident, Expr -> Expr -> Expr, Associativity)]] -> Module -> Either ErrorStack Module

6767rebracketModule opTable (Module mn ds exts) =

6868 let (f, _, _) = everywhereOnValuesTopDownM return (matchOperators opTable) return

6969 in Module mn <$> (map removeParens <$> mapM f ds) <*> pure exts

@@ -95,7 +95,7 @@ ensureNoDuplicates m = go $ sortBy (compare `on` fst) m

9595 throwError $ mkErrorStack ("Redefined fixity for " ++ show name) Nothing

9696 go (_ : rest) = go rest

9797

98−customOperatorTable :: [(Qualified Ident, Fixity)] -> [[(Qualified Ident, Value -> Value -> Value, Associativity)]]

98+customOperatorTable :: [(Qualified Ident, Fixity)] -> [[(Qualified Ident, Expr -> Expr -> Expr, Associativity)]]

9999customOperatorTable fixities =

100100 let

101101 applyUserOp ident t1 = App (App (Var ident) t1)

@@ -105,18 +105,18 @@ customOperatorTable fixities =

105105 in

106106 map (map (\(name, f, _, a) -> (name, f, a))) groups

107107

108−type Chain = [Either Value (Qualified Ident)]

108+type Chain = [Either Expr (Qualified Ident)]

109109

110−matchOperators :: [[(Qualified Ident, Value -> Value -> Value, Associativity)]] -> Value -> Either ErrorStack Value

110+matchOperators :: [[(Qualified Ident, Expr -> Expr -> Expr, Associativity)]] -> Expr -> Either ErrorStack Expr

111111matchOperators ops = parseChains

112112 where

113− parseChains :: Value -> Either ErrorStack Value

113+ parseChains :: Expr -> Either ErrorStack Expr

114114 parseChains b@BinaryNoParens{} = bracketChain (extendChain b)

115115 parseChains other = return other

116− extendChain :: Value -> Chain

116+ extendChain :: Expr -> Chain

117117 extendChain (BinaryNoParens name l r) = Left l : Right name : extendChain r

118118 extendChain other = [Left other]

119− bracketChain :: Chain -> Either ErrorStack Value

119+ bracketChain :: Chain -> Either ErrorStack Expr

120120 bracketChain = either (Left . (`mkErrorStack` Nothing) . show) Right . P.parse (P.buildExpressionParser opTable parseValue <* P.eof) "operator expression"

121121 opTable = [P.Infix (P.try (parseTicks >>= \ident -> return (\t1 t2 -> App (App (Var ident) t1) t2))) P.AssocLeft]

122122 : map (map (\(name, f, a) -> P.Infix (P.try (matchOp name) >> return f) (toAssoc a))) ops

@@ -130,7 +130,7 @@ toAssoc Infix = P.AssocNone

130130token :: (P.Stream s Identity t, Show t) => (t -> Maybe a) -> P.Parsec s u a

131131token = P.token show (const (P.initialPos ""))

132132

133−parseValue :: P.Parsec Chain () Value

133+parseValue :: P.Parsec Chain () Expr

134134parseValue = token (either Just (const Nothing)) P.<?> "expression"

135135

136136parseOp :: P.Parsec Chain () (Qualified Ident)

src/Language/PureScript/Sugar/TypeClasses.hs+2−2

@@ -261,7 +261,7 @@ typeInstanceDictionaryDeclaration name mn deps className tys decls =

261261 declName (TypeDeclaration ident _) = Just ident

262262 declName _ = Nothing

263263

264− memberToNameAndValue :: [(Ident, Type)] -> Declaration -> Desugar (Ident, Value)

264+ memberToNameAndValue :: [(Ident, Type)] -> Declaration -> Desugar (Ident, Expr)

265265 memberToNameAndValue tys' d@(ValueDeclaration ident _ _ _ _) = do

266266 _ <- lift . lift . maybe (Left $ mkErrorStack ("Type class does not define member '" ++ show ident ++ "'") Nothing) Right $ lookup ident tys'

267267 let memberValue = typeInstanceDictionaryEntryValue d

@@ -271,7 +271,7 @@ typeInstanceDictionaryDeclaration name mn deps className tys decls =

271271 return (ident, PositionedValue pos val)

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

273273

274− typeInstanceDictionaryEntryValue :: Declaration -> Value

274+ typeInstanceDictionaryEntryValue :: Declaration -> Expr

275275 typeInstanceDictionaryEntryValue (ValueDeclaration _ _ [] _ val) = val

276276 typeInstanceDictionaryEntryValue (PositionedDeclaration pos d) = PositionedValue pos (typeInstanceDictionaryEntryValue d)

277277 typeInstanceDictionaryEntryValue _ = error "Invalid declaration in type instance definition"

src/Language/PureScript/Sugar/TypeDeclarations.hs+1−1

@@ -49,7 +49,7 @@ desugarTypeDeclarations (TypeDeclaration name ty : d : rest) = do

4949 (_, nameKind, val) <- fromValueDeclaration d

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

5151 where

52− fromValueDeclaration :: Declaration -> Either ErrorStack (Ident, NameKind, Value)

52+ fromValueDeclaration :: Declaration -> Either ErrorStack (Ident, NameKind, Expr)

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

5454 fromValueDeclaration (PositionedDeclaration pos d') = do

5555 (ident, nameKind, val) <- rethrowWithPosition pos $ fromValueDeclaration d'

src/Language/PureScript/TypeChecker/Types.hs+36−36

@@ -168,7 +168,7 @@ unifyRows r1 r2 =

168168-- Infer the types of multiple mutually-recursive values, and return elaborated values including

169169-- type class dictionaries and type annotations.

170170--

171−typesOf :: Maybe ModuleName -> ModuleName -> [(Ident, Value)] -> Check [(Ident, (Value, Type))]

171+typesOf :: Maybe ModuleName -> ModuleName -> [(Ident, Expr)] -> Check [(Ident, (Expr, Type))]

172172typesOf mainModuleName moduleName vals = do

173173 tys <- fmap tidyUp . liftUnify $ do

174174 (es, dict, untypedDict) <- typeDictionaryForBindingGroup moduleName vals

@@ -194,7 +194,7 @@ typesOf mainModuleName moduleName vals = do

194194 -- Apply the substitution that was returned from runUnify to both types and (type-annotated) values

195195 tidyUp (ts, sub) = map (\(i, (val, ty)) -> (i, (overTypes (sub $?) val, sub $? ty))) ts

196196

197−typeDictionaryForBindingGroup :: ModuleName -> [(Ident, Value)] -> UnifyT Type Check ([(Ident, (Value, Maybe (Type, Bool)))], M.Map (ModuleName, Ident) (Type, NameKind, NameVisibility), [(Ident, Type)])

197+typeDictionaryForBindingGroup :: ModuleName -> [(Ident, Expr)] -> UnifyT Type Check ([(Ident, (Expr, Maybe (Type, Bool)))], M.Map (ModuleName, Ident) (Type, NameKind, NameVisibility), [(Ident, Type)])

198198typeDictionaryForBindingGroup moduleName vals = do

199199 let

200200 -- Map each declaration to a name/value pair, with an optional type, if the declaration is typed

@@ -215,7 +215,7 @@ typeDictionaryForBindingGroup moduleName vals = do

215215 dict = M.fromList (map (\(ident, ty) -> ((moduleName, ident), (ty, LocalVariable, Undefined))) $ typedDict ++ untypedDict)

216216 return (es, dict, untypedDict)

217217

218−typeForBindingGroupElement :: ModuleName -> (Ident, (Value, Maybe (Type, Bool))) -> M.Map (ModuleName, Ident) (Type, NameKind, NameVisibility) -> [(Ident, Type)] -> UnifyT Type Check (Ident, (Value, Type))

218+typeForBindingGroupElement :: ModuleName -> (Ident, (Expr, Maybe (Type, Bool))) -> M.Map (ModuleName, Ident) (Type, NameKind, NameVisibility) -> [(Ident, Type)] -> UnifyT Type Check (Ident, (Expr, Type))

219219typeForBindingGroupElement moduleName el dict untypedDict =

220220 -- If the declaration is a function, it has access to other values in the binding group.

221221 -- If not, the generated code might fail at runtime since those values might be undefined.

@@ -241,17 +241,17 @@ typeForBindingGroupElement moduleName el dict untypedDict =

241241-- |

242242-- Check if a value contains a type annotation

243243--

244−isTyped :: (Ident, Value) -> (Ident, (Value, Maybe (Type, Bool)))

244+isTyped :: (Ident, Expr) -> (Ident, (Expr, Maybe (Type, Bool)))

245245isTyped (name, TypedValue checkType value ty) = (name, (value, Just (ty, checkType)))

246246isTyped (name, value) = (name, (value, Nothing))

247247

248248-- |

249249-- Map a function over type annotations appearing inside a value

250250--

251−overTypes :: (Type -> Type) -> Value -> Value

251+overTypes :: (Type -> Type) -> Expr -> Expr

252252overTypes f = let (_, f', _) = everywhereOnValues id g id in f'

253253 where

254− g :: Value -> Value

254+ g :: Expr -> Expr

255255 g (TypedValue checkTy val t) = TypedValue checkTy val (f t)

256256 g (TypeClassDictionary b (nm, tys) sco) = TypeClassDictionary b (nm, map f tys) sco

257257 g other = other

@@ -259,7 +259,7 @@ overTypes f = let (_, f', _) = everywhereOnValues id g id in f'

259259-- |

260260-- Replace type class dictionary placeholders with inferred type class dictionaries

261261--

262−replaceTypeClassDictionaries :: ModuleName -> Value -> Check Value

262+replaceTypeClassDictionaries :: ModuleName -> Expr -> Check Expr

263263replaceTypeClassDictionaries mn =

264264 let (_, f, _) = everywhereOnValuesTopDownM return go return

265265 in f

@@ -296,7 +296,7 @@ data DictionaryValue

296296-- Check that the current set of type class dictionaries entail the specified type class goal, and, if so,

297297-- return a type class dictionary reference.

298298--

299−entails :: Environment -> ModuleName -> [TypeClassDictionaryInScope] -> (Qualified ProperName, [Type]) -> Bool -> Check Value

299+entails :: Environment -> ModuleName -> [TypeClassDictionaryInScope] -> (Qualified ProperName, [Type]) -> Bool -> Check Expr

300300entails env moduleName context = solve (sortedNubBy canonicalizeDictionary (filter filterModule context))

301301 where

302302 sortedNubBy :: (Ord k) => (v -> k) -> [v] -> [v]

@@ -354,8 +354,8 @@ entails env moduleName context = solve (sortedNubBy canonicalizeDictionary (filt

354354 mkDictionary fnName Nothing = LocalDictionaryValue fnName

355355 mkDictionary fnName (Just []) = GlobalDictionaryValue fnName

356356 mkDictionary fnName (Just dicts) = DependentDictionaryValue fnName dicts

357− -- Turn a DictionaryValue into a Value

358− dictionaryValueToValue :: DictionaryValue -> Value

357+ -- Turn a DictionaryValue into a Expr

358+ dictionaryValueToValue :: DictionaryValue -> Expr

359359 dictionaryValueToValue (LocalDictionaryValue fnName) = Var fnName

360360 dictionaryValueToValue (GlobalDictionaryValue fnName) = App (Var fnName) (ObjectLiteral [])

361361 dictionaryValueToValue (DependentDictionaryValue fnName dicts) = foldl App (Var fnName) (map dictionaryValueToValue dicts)

@@ -434,7 +434,7 @@ typeHeadsAreEqual _ _ _ _ = Nothing

434434-- |

435435-- Ensure skolem variables do not escape their scope

436436--

437−skolemEscapeCheck :: Value -> Check ()

437+skolemEscapeCheck :: Expr -> Check ()

438438skolemEscapeCheck (TypedValue False _ _) = return ()

439439skolemEscapeCheck root@TypedValue{} =

440440 -- Every skolem variable is created when a ForAll type is skolemized.

@@ -446,11 +446,11 @@ skolemEscapeCheck root@TypedValue{} =

446446 let (_, f, _, _, _) = everythingWithContextOnValues [] [] (++) def go def def def

447447 in case f root of

448448 [] -> return ()

449− ((binding, val) : _) -> throwError $ mkErrorStack ("Rigid/skolem type variable " ++ maybe "" (("bound by " ++) . prettyPrintValue) binding ++ " has escaped.") (Just (ValueError val))

449+ ((binding, val) : _) -> throwError $ mkErrorStack ("Rigid/skolem type variable " ++ maybe "" (("bound by " ++) . prettyPrintValue) binding ++ " has escaped.") (Just (ExprError val))

450450 where

451451 def s _ = (s, [])

452452

453− go :: [(SkolemScope, Value)] -> Value -> ([(SkolemScope, Value)], [(Maybe Value, Value)])

453+ go :: [(SkolemScope, Expr)] -> Expr -> ([(SkolemScope, Expr)], [(Maybe Expr, Expr)])

454454 go scos val@(TypedValue _ _ (ForAll _ _ (Just sco))) = ((sco, val) : scos, [])

455455 go scos val@(TypedValue _ _ ty) = case collectSkolems ty \\ map fst scos of

456456 (sco : _) -> (scos, [(findBindingScope sco, val)])

@@ -462,14 +462,14 @@ skolemEscapeCheck root@TypedValue{} =

462462 collect (Skolem _ _ scope) = [scope]

463463 collect _ = []

464464 go scos _ = (scos, [])

465− findBindingScope :: SkolemScope -> Maybe Value

465+ findBindingScope :: SkolemScope -> Maybe Expr

466466 findBindingScope sco =

467467 let (_, f, _, _, _) = everythingOnValues mappend (const mempty) go' (const mempty) (const mempty) (const mempty)

468468 in getFirst $ f root

469469 where

470470 go' val@(TypedValue _ _ (ForAll _ _ (Just sco'))) | sco == sco' = First (Just val)

471471 go' _ = mempty

472−skolemEscapeCheck val = throwError $ mkErrorStack "Untyped value passed to skolemEscapeCheck" (Just (ValueError val))

472+skolemEscapeCheck val = throwError $ mkErrorStack "Untyped value passed to skolemEscapeCheck" (Just (ExprError val))

473473

474474-- |

475475-- Ensure a row contains no duplicate labels

@@ -503,7 +503,7 @@ varIfUnknown ty =

503503-- This is necessary during type checking to avoid unifying a polymorphic type with a

504504-- unification variable.

505505--

506−instantiatePolyTypeWithUnknowns :: Value -> Type -> UnifyT Type Check (Value, Type)

506+instantiatePolyTypeWithUnknowns :: Expr -> Type -> UnifyT Type Check (Expr, Type)

507507instantiatePolyTypeWithUnknowns val (ForAll ident ty _) = do

508508 ty' <- replaceVarWithUnknown ident ty

509509 instantiatePolyTypeWithUnknowns val ty'

@@ -571,19 +571,19 @@ expandAllTypeSynonyms = everywhereOnTypesTopDownM go

571571-- |

572572-- Ensure a set of property names and value does not contain duplicate labels

573573--

574−ensureNoDuplicateProperties :: (Error e, MonadError e m) => [(String, Value)] -> m ()

574+ensureNoDuplicateProperties :: (Error e, MonadError e m) => [(String, Expr)] -> m ()

575575ensureNoDuplicateProperties ps = guardWith (strMsg "Duplicate property names") $ length (nub . map fst $ ps) == length ps

576576

577577-- |

578578-- Infer a type for a value, rethrowing any error to provide a more useful error message

579579--

580−infer :: Value -> UnifyT Type Check Value

581−infer val = rethrow (mkErrorStack "Error inferring type of value" (Just (ValueError val)) <>) $ infer' val

580+infer :: Expr -> UnifyT Type Check Expr

581+infer val = rethrow (mkErrorStack "Error inferring type of value" (Just (ExprError val)) <>) $ infer' val

582582

583583-- |

584584-- Infer a type for a value

585585--

586−infer' :: Value -> UnifyT Type Check Value

586+infer' :: Expr -> UnifyT Type Check Expr

587587infer' v@(NumericLiteral _) = return $ TypedValue True v tyNumber

588588infer' v@(StringLiteral _) = return $ TypedValue True v tyString

589589infer' v@(BooleanLiteral _) = return $ TypedValue True v tyBoolean

@@ -670,7 +670,7 @@ infer' (TypedValue checkType val ty) = do

670670infer' (PositionedValue pos val) = rethrowWithPosition pos $ infer' val

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

672672

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

673+inferLetBinding :: [Declaration] -> [Declaration] -> Expr -> (Expr -> UnifyT Type Check Expr) -> UnifyT Type Check ([Declaration], Expr)

674674inferLetBinding seen [] ret j = (,) seen <$> makeBindingGroupVisible (j ret)

675675inferLetBinding seen (ValueDeclaration ident nameKind [] Nothing tv@(TypedValue checkType val ty) : rest) ret j = do

676676 Just moduleName <- checkCurrentModule <$> get

@@ -810,7 +810,7 @@ skolemize ident sko scope = replaceTypeVars ident (Skolem ident sko scope)

810810-- SuperClassDictionary placeholder. These type variables are somewhat unique since they are the

811811-- only example of scoped type variables.

812812--

813−skolemizeTypesInValue :: String -> Int -> SkolemScope -> Value -> Value

813+skolemizeTypesInValue :: String -> Int -> SkolemScope -> Expr -> Expr

814814skolemizeTypesInValue ident sko scope = let (_, f, _) = everywhereOnValues id go id in f

815815 where

816816 go (SuperClassDictionary c ts) = SuperClassDictionary c (map (skolemize ident sko scope) ts)

@@ -828,8 +828,8 @@ introduceSkolemScope = everywhereOnTypesM go

828828-- |

829829-- Check the type of a value, rethrowing errors to provide a better error message

830830--

831−check :: Value -> Type -> UnifyT Type Check Value

832−check val ty = rethrow (mkErrorStack errorMessage (Just (ValueError val)) <>) $ check' val ty

831+check :: Expr -> Type -> UnifyT Type Check Expr

832+check val ty = rethrow (mkErrorStack errorMessage (Just (ExprError val)) <>) $ check' val ty

833833 where

834834 errorMessage =

835835 "Error checking type of term " ++

@@ -840,7 +840,7 @@ check val ty = rethrow (mkErrorStack errorMessage (Just (ValueError val)) <>) $

840840-- |

841841-- Check the type of a value

842842--

843−check' :: Value -> Type -> UnifyT Type Check Value

843+check' :: Expr -> Type -> UnifyT Type Check Expr

844844check' val (ForAll ident ty _) = do

845845 scope <- newSkolemScope

846846 sko <- newSkolemConstant

@@ -963,7 +963,7 @@ check' val ty | containsTypeSynonyms ty = do

963963 check val ty'

964964check' (PositionedValue pos val) ty =

965965 rethrowWithPosition pos $ check val ty

966−check' val ty = throwError $ mkErrorStack ("Value does not have type " ++ prettyPrintType ty) (Just (ValueError val))

966+check' val ty = throwError $ mkErrorStack ("Expr does not have type " ++ prettyPrintType ty) (Just (ExprError val))

967967

968968containsTypeSynonyms :: Type -> Bool

969969containsTypeSynonyms = everythingOnTypes (||) go where

@@ -975,15 +975,15 @@ containsTypeSynonyms = everythingOnTypes (||) go where

975975--

976976-- The @lax@ parameter controls whether or not every record member has to be provided. For object updates, this is not the case.

977977--

978−checkProperties :: [(String, Value)] -> Type -> Bool -> UnifyT Type Check [(String, Value)]

978+checkProperties :: [(String, Expr)] -> Type -> Bool -> UnifyT Type Check [(String, Expr)]

979979checkProperties ps row lax = let (ts, r') = rowToList row in go ps ts r' where

980980 go [] [] REmpty = return []

981981 go [] [] u@(TUnknown _) = do u =?= REmpty

982982 return []

983983 go [] [] (Skolem _ _ _) | lax = return []

984984 go [] ((p, _): _) _ | lax = return []

985− | otherwise = throwError $ mkErrorStack ("Object does not have property " ++ p) (Just (ValueError (ObjectLiteral ps)))

986− go ((p,_):_) [] REmpty = throwError $ mkErrorStack ("Property " ++ p ++ " is not present in closed object type " ++ prettyPrintRow row) (Just (ValueError (ObjectLiteral ps)))

985+ | otherwise = throwError $ mkErrorStack ("Object does not have property " ++ p) (Just (ExprError (ObjectLiteral ps)))

986+ go ((p,_):_) [] REmpty = throwError $ mkErrorStack ("Property " ++ p ++ " is not present in closed object type " ++ prettyPrintRow row) (Just (ExprError (ObjectLiteral ps)))

987987 go ((p,v):ps') [] u@(TUnknown _) = do

988988 v'@(TypedValue _ _ ty) <- infer v

989989 rest <- fresh

@@ -1002,13 +1002,13 @@ checkProperties ps row lax = let (ts, r') = rowToList row in go ps ts r' where

10021002 v' <- check v ty

10031003 ps'' <- go ps' (delete (p, ty) ts) r

10041004 return $ (p, v') : ps''

1005− go _ _ _ = throwError $ mkErrorStack ("Object does not have type " ++ prettyPrintType (TypeApp tyObject row)) (Just (ValueError (ObjectLiteral ps)))

1005+ go _ _ _ = throwError $ mkErrorStack ("Object does not have type " ++ prettyPrintType (TypeApp tyObject row)) (Just (ExprError (ObjectLiteral ps)))

10061006

10071007-- |

10081008-- Check the type of a function application, rethrowing errors to provide a better error message

10091009--

1010−checkFunctionApplication :: Value -> Type -> Value -> Maybe Type -> UnifyT Type Check (Type, Value)

1011−checkFunctionApplication fn fnTy arg ret = rethrow (mkErrorStack errorMessage (Just (ValueError fn)) <>) $ do

1010+checkFunctionApplication :: Expr -> Type -> Expr -> Maybe Type -> UnifyT Type Check (Type, Expr)

1011+checkFunctionApplication fn fnTy arg ret = rethrow (mkErrorStack errorMessage (Just (ExprError fn)) <>) $ do

10121012 subst <- unifyCurrentSubstitution <$> UnifyT get

10131013 checkFunctionApplication' fn (subst $? fnTy) arg (($?) subst <$> ret)

10141014 where

@@ -1019,7 +1019,7 @@ checkFunctionApplication fn fnTy arg ret = rethrow (mkErrorStack errorMessage (J

10191019-- |

10201020-- Check the type of a function application

10211021--

1022−checkFunctionApplication' :: Value -> Type -> Value -> Maybe Type -> UnifyT Type Check (Type, Value)

1022+checkFunctionApplication' :: Expr -> Type -> Expr -> Maybe Type -> UnifyT Type Check (Type, Expr)

10231023checkFunctionApplication' fn (TypeApp (TypeApp tyFunction' argTy) retTy) arg ret = do

10241024 tyFunction' =?= tyFunction

10251025 arg' <- check arg argTy

@@ -1053,8 +1053,8 @@ checkFunctionApplication' _ fnTy arg _ = throwError . strMsg $ "Cannot apply a f

10531053-- |

10541054-- Check whether one type subsumes another, rethrowing errors to provide a better error message

10551055--

1056−subsumes :: Maybe Value -> Type -> Type -> UnifyT Type Check (Maybe Value)

1057−subsumes val ty1 ty2 = rethrow (mkErrorStack errorMessage (ValueError <$> val) <>) $ subsumes' val ty1 ty2

1056+subsumes :: Maybe Expr -> Type -> Type -> UnifyT Type Check (Maybe Expr)

1057+subsumes val ty1 ty2 = rethrow (mkErrorStack errorMessage (ExprError <$> val) <>) $ subsumes' val ty1 ty2

10581058 where

10591059 errorMessage = "Error checking that type "

10601060 ++ prettyPrintType ty1

@@ -1064,7 +1064,7 @@ subsumes val ty1 ty2 = rethrow (mkErrorStack errorMessage (ValueError <$> val) <

10641064-- |

10651065-- Check whether one type subsumes another

10661066--

1067−subsumes' :: Maybe Value -> Type -> Type -> UnifyT Type Check (Maybe Value)

1067+subsumes' :: Maybe Expr -> Type -> Type -> UnifyT Type Check (Maybe Expr)

10681068subsumes' val (ForAll ident ty1 _) ty2 = do

10691069 replaced <- replaceVarWithUnknown ident ty1

10701070 subsumes val replaced ty2