git.iko.soy/rowtype-yoga/purescript-native
on golang help sign in
Rename Value to Expr, resolves #494
4eb7696Gary Burgess
src/Language/PureScript/CodeGen/JS.hs+3−3
compare with golang
unifiedsplit
@@ -83,7 +83,7 @@ imports other =
83 let (f, _, _, _, _) = everythingOnValues (++) (const []) collectV collectB (const []) (const [])
83 let (f, _, _, _, _) = everythingOnValues (++) (const []) collectV collectB (const []) (const [])
84 in f other
84 in f other
85 where
85 where
86− collectV :: Value -> [ModuleName]
86+ collectV :: Expr -> [ModuleName]
87 collectV (Var (Qualified (Just mn) _)) = [mn]
87 collectV (Var (Qualified (Just mn) _)) = [mn]
88 collectV (Constructor (Qualified (Just mn) _)) = [mn]
88 collectV (Constructor (Qualified (Just mn) _)) = [mn]
89 collectV (TypeClassDictionaryConstructorApp (Qualified (Just mn) _) _) = [mn]
89 collectV (TypeClassDictionaryConstructorApp (Qualified (Just mn) _) _) = [mn]
@@ -190,7 +190,7 @@ accessorString prop | identNeedsEscaping prop = JSIndexer (JSStringLiteral prop)
190-- |
190-- |
191-- Generate code in the simplified Javascript intermediate representation for a value or expression.
191-- Generate code in the simplified Javascript intermediate representation for a value or expression.
192--
192--
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
194valueToJs _ _ _ (NumericLiteral n) = return $ JSNumericLiteral n
194valueToJs _ _ _ (NumericLiteral n) = return $ JSNumericLiteral n
195valueToJs _ _ _ (StringLiteral s) = return $ JSStringLiteral s
195valueToJs _ _ _ (StringLiteral s) = return $ JSStringLiteral s
196valueToJs _ _ _ (BooleanLiteral b) = return $ JSBooleanLiteral b
196valueToJs _ _ _ (BooleanLiteral b) = return $ JSBooleanLiteral b
@@ -221,7 +221,7 @@ valueToJs opts m e v@App{} = do
221 return $ JSUnary JSNew $ JSApp (qualifiedToJS m (Ident . runProperName) name) args'
221 return $ JSUnary JSNew $ JSApp (qualifiedToJS m (Ident . runProperName) name) args'
222 _ -> flip (foldl (\fn a -> JSApp fn [a])) args' <$> valueToJs opts m e f
222 _ -> flip (foldl (\fn a -> JSApp fn [a])) args' <$> valueToJs opts m e f
223 where
223 where
224− unApp :: Value -> [Value] -> (Value, [Value])
224+ unApp :: Expr -> [Expr] -> (Expr, [Expr])
225 unApp (App val arg) args = unApp val (arg : args)
225 unApp (App val arg) args = unApp val (arg : args)
226 unApp (PositionedValue _ val) args = unApp val args
226 unApp (PositionedValue _ val) args = unApp val args
227 unApp (TypedValue _ val _) args = unApp val args
227 unApp (TypedValue _ val _) args = unApp val args
src/Language/PureScript/DeadCodeElimination.hs+1−1
@@ -79,7 +79,7 @@ dependencies moduleName =
79 let (f, _, _, _, _) = everythingOnValues (++) (const []) values (const []) (const []) (const [])
79 let (f, _, _, _, _) = everythingOnValues (++) (const []) values (const []) (const []) (const [])
80 in nub . f
80 in nub . f
81 where
81 where
82− values :: Value -> [Key]
82+ values :: Expr -> [Key]
83 values (Var ident) = let (mn, name) = qualify moduleName ident in [(mn, Left name)]
83 values (Var ident) = let (mn, name) = qualify moduleName ident in [(mn, Left name)]
84 values (Constructor (Qualified (Just mn) name)) = [(mn, Right name)]
84 values (Constructor (Qualified (Just mn) name)) = [(mn, Right name)]
85 values (Constructor (Qualified Nothing _)) = error "Found unqualified data constructor"
85 values (Constructor (Qualified Nothing _)) = error "Found unqualified data constructor"
src/Language/PureScript/Declarations.hs+37−37
@@ -154,11 +154,11 @@ data Declaration
154 -- |
154 -- |
155 -- A value declaration (name, top-level binders, optional guard, value)
155 -- A value declaration (name, top-level binders, optional guard, value)
156 --
156 --
157− | ValueDeclaration Ident NameKind [Binder] (Maybe Guard) Value
157+ | ValueDeclaration Ident NameKind [Binder] (Maybe Guard) Expr
158 -- |
158 -- |
159 -- A minimal mutually recursive set of value declarations
159 -- A minimal mutually recursive set of value declarations
160 --
160 --
161− | BindingGroupDeclaration [(Ident, NameKind, Value)]
161+ | BindingGroupDeclaration [(Ident, NameKind, Expr)]
162 -- |
162 -- |
163 -- A foreign import declaration (type, name, optional inline Javascript, type)
163 -- A foreign import declaration (type, name, optional inline Javascript, type)
164 --
164 --
@@ -264,12 +264,12 @@ isTypeClassDeclaration _ = False
264-- |
264-- |
265-- A guard is just a boolean-valued expression that appears alongside a set of binders
265-- A guard is just a boolean-valued expression that appears alongside a set of binders
266--
266--
267−type Guard = Value
267+type Guard = Expr
268
268
269-- |
269-- |
270−-- Data type for values
270+-- Data type for expressions and terms
271--
271--
272−data Value
272+data Expr
273 -- |
273 -- |
274 -- A numeric literal
274 -- A numeric literal
275 --
275 --
@@ -285,41 +285,41 @@ data Value
285 -- |
285 -- |
286 -- A prefix -, will be desugared
286 -- A prefix -, will be desugared
287 --
287 --
288− | UnaryMinus Value
288+ | UnaryMinus Expr
289 -- |
289 -- |
290 -- Binary operator application. During the rebracketing phase of desugaring, this data constructor
290 -- Binary operator application. During the rebracketing phase of desugaring, this data constructor
291 -- will be removed.
291 -- will be removed.
292 --
292 --
293− | BinaryNoParens (Qualified Ident) Value Value
293+ | BinaryNoParens (Qualified Ident) Expr Expr
294 -- |
294 -- |
295 -- Explicit parentheses. During the rebracketing phase of desugaring, this data constructor
295 -- Explicit parentheses. During the rebracketing phase of desugaring, this data constructor
296 -- will be removed.
296 -- will be removed.
297 --
297 --
298− | Parens Value
298+ | Parens Expr
299 -- |
299 -- |
300 -- An array literal
300 -- An array literal
301 --
301 --
302− | ArrayLiteral [Value]
302+ | ArrayLiteral [Expr]
303 -- |
303 -- |
304 -- An object literal
304 -- An object literal
305 --
305 --
306− | ObjectLiteral [(String, Value)]
306+ | ObjectLiteral [(String, Expr)]
307 -- |
307 -- |
308 -- An record property accessor expression
308 -- An record property accessor expression
309 --
309 --
310− | Accessor String Value
310+ | Accessor String Expr
311 -- |
311 -- |
312 -- Partial record update
312 -- Partial record update
313 --
313 --
314− | ObjectUpdate Value [(String, Value)]
314+ | ObjectUpdate Expr [(String, Expr)]
315 -- |
315 -- |
316 -- Function introduction
316 -- Function introduction
317 --
317 --
318− | Abs (Either Ident Binder) Value
318+ | Abs (Either Ident Binder) Expr
319 -- |
319 -- |
320 -- Function application
320 -- Function application
321 --
321 --
322− | App Value Value
322+ | App Expr Expr
323 -- |
323 -- |
324 -- Variable
324 -- Variable
325 --
325 --
@@ -327,7 +327,7 @@ data Value
327 -- |
327 -- |
328 -- Conditional (if-then-else expression)
328 -- Conditional (if-then-else expression)
329 --
329 --
330− | IfThenElse Value Value Value
330+ | IfThenElse Expr Expr Expr
331 -- |
331 -- |
332 -- A data constructor
332 -- A data constructor
333 --
333 --
@@ -336,15 +336,15 @@ data Value
336 -- A case expression. During the case expansion phase of desugaring, top-level binders will get
336 -- A case expression. During the case expansion phase of desugaring, top-level binders will get
337 -- desugared into case expressions, hence the need for guards and multiple binders per branch here.
337 -- desugared into case expressions, hence the need for guards and multiple binders per branch here.
338 --
338 --
339− | Case [Value] [CaseAlternative]
339+ | Case [Expr] [CaseAlternative]
340 -- |
340 -- |
341 -- A value with a type annotation
341 -- A value with a type annotation
342 --
342 --
343− | TypedValue Bool Value Type
343+ | TypedValue Bool Expr Type
344 -- |
344 -- |
345 -- A let binding
345 -- A let binding
346 --
346 --
347− | Let [Declaration] Value
347+ | Let [Declaration] Expr
348 -- |
348 -- |
349 -- A do-notation block
349 -- A do-notation block
350 --
350 --
@@ -353,7 +353,7 @@ data Value
353 -- An application of a typeclass dictionary constructor. The value should be
353 -- An application of a typeclass dictionary constructor. The value should be
354 -- an ObjectLiteral.
354 -- an ObjectLiteral.
355 --
355 --
356− | TypeClassDictionaryConstructorApp (Qualified ProperName) Value
356+ | TypeClassDictionaryConstructorApp (Qualified ProperName) Expr
357 -- |
357 -- |
358 -- A placeholder for a type class dictionary to be inserted later. At the end of type checking, these
358 -- A placeholder for a type class dictionary to be inserted later. At the end of type checking, these
359 -- placeholders will be replaced with actual expressions representing type classes dictionaries which
359 -- placeholders will be replaced with actual expressions representing type classes dictionaries which
@@ -369,7 +369,7 @@ data Value
369 -- |
369 -- |
370 -- A value with source position information
370 -- A value with source position information
371 --
371 --
372− | PositionedValue SourcePos Value deriving (Show, D.Data, D.Typeable)
372+ | PositionedValue SourcePos Expr deriving (Show, D.Data, D.Typeable)
373
373
374-- |
374-- |
375-- An alternative in a case statement
375-- An alternative in a case statement
@@ -386,7 +386,7 @@ data CaseAlternative = CaseAlternative
386 -- |
386 -- |
387 -- The result expression
387 -- The result expression
388 --
388 --
389− , caseAlternativeResult :: Value
389+ , caseAlternativeResult :: Expr
390 } deriving (Show, D.Data, D.Typeable)
390 } deriving (Show, D.Data, D.Typeable)
391
391
392-- |
392-- |
@@ -403,11 +403,11 @@ data DoNotationElement
403 -- |
403 -- |
404 -- A monadic value without a binder
404 -- A monadic value without a binder
405 --
405 --
406− = DoNotationValue Value
406+ = DoNotationValue Expr
407 -- |
407 -- |
408 -- A monadic value with a binder
408 -- A monadic value with a binder
409 --
409 --
410− | DoNotationBind Binder Value
410+ | DoNotationBind Binder Expr
411 -- |
411 -- |
412 -- A let statement, i.e. a pure value with a binder
412 -- A let statement, i.e. a pure value with a binder
413 --
413 --
@@ -486,9 +486,9 @@ binderNames = go []
486--
486--
487
487
488everywhereOnValues :: (Declaration -> Declaration) ->
488everywhereOnValues :: (Declaration -> Declaration) ->
489− (Value -> Value) ->
489+ (Expr -> Expr) ->
490 (Binder -> Binder) ->
490 (Binder -> Binder) ->
491− (Declaration -> Declaration, Value -> Value, Binder -> Binder)
491+ (Declaration -> Declaration, Expr -> Expr, Binder -> Binder)
492everywhereOnValues f g h = (f', g', h')
492everywhereOnValues f g h = (f', g', h')
493 where
493 where
494 f' :: Declaration -> Declaration
494 f' :: Declaration -> Declaration
@@ -500,7 +500,7 @@ everywhereOnValues f g h = (f', g', h')
500 f' (PositionedDeclaration pos d) = f (PositionedDeclaration pos (f' d))
500 f' (PositionedDeclaration pos d) = f (PositionedDeclaration pos (f' d))
501 f' other = f other
501 f' other = f other
502
502
503− g' :: Value -> Value
503+ g' :: Expr -> Expr
504 g' (UnaryMinus v) = g (UnaryMinus (g' v))
504 g' (UnaryMinus v) = g (UnaryMinus (g' v))
505 g' (BinaryNoParens op v1 v2) = g (BinaryNoParens op (g' v1) (g' v2))
505 g' (BinaryNoParens op v1 v2) = g (BinaryNoParens op (g' v1) (g' v2))
506 g' (Parens v) = g (Parens (g' v))
506 g' (Parens v) = g (Parens (g' v))
@@ -544,9 +544,9 @@ everywhereOnValues f g h = (f', g', h')
544
544
545everywhereOnValuesTopDownM :: (Functor m, Applicative m, Monad m) =>
545everywhereOnValuesTopDownM :: (Functor m, Applicative m, Monad m) =>
546 (Declaration -> m Declaration) ->
546 (Declaration -> m Declaration) ->
547− (Value -> m Value) ->
547+ (Expr -> m Expr) ->
548 (Binder -> m Binder) ->
548 (Binder -> m Binder) ->
549− (Declaration -> m Declaration, Value -> m Value, Binder -> m Binder)
549+ (Declaration -> m Declaration, Expr -> m Expr, Binder -> m Binder)
550everywhereOnValuesTopDownM f g h = (f' <=< f, g' <=< g, h' <=< h)
550everywhereOnValuesTopDownM f g h = (f' <=< f, g' <=< g, h' <=< h)
551 where
551 where
552 f' (DataBindingGroupDeclaration ds) = DataBindingGroupDeclaration <$> mapM (f' <=< f) ds
552 f' (DataBindingGroupDeclaration ds) = DataBindingGroupDeclaration <$> mapM (f' <=< f) ds
@@ -594,9 +594,9 @@ everywhereOnValuesTopDownM f g h = (f' <=< f, g' <=< g, h' <=< h)
594
594
595everywhereOnValuesM :: (Functor m, Applicative m, Monad m) =>
595everywhereOnValuesM :: (Functor m, Applicative m, Monad m) =>
596 (Declaration -> m Declaration) ->
596 (Declaration -> m Declaration) ->
597− (Value -> m Value) ->
597+ (Expr -> m Expr) ->
598 (Binder -> m Binder) ->
598 (Binder -> m Binder) ->
599− (Declaration -> m Declaration, Value -> m Value, Binder -> m Binder)
599+ (Declaration -> m Declaration, Expr -> m Expr, Binder -> m Binder)
600everywhereOnValuesM f g h = (f' <=< f, g' <=< g, h' <=< h)
600everywhereOnValuesM f g h = (f' <=< f, g' <=< g, h' <=< h)
601 where
601 where
602 f' (DataBindingGroupDeclaration ds) = (DataBindingGroupDeclaration <$> mapM f' ds) >>= f
602 f' (DataBindingGroupDeclaration ds) = (DataBindingGroupDeclaration <$> mapM f' ds) >>= f
@@ -644,11 +644,11 @@ everywhereOnValuesM f g h = (f' <=< f, g' <=< g, h' <=< h)
644
644
645everythingOnValues :: (r -> r -> r) ->
645everythingOnValues :: (r -> r -> r) ->
646 (Declaration -> r) ->
646 (Declaration -> r) ->
647− (Value -> r) ->
647+ (Expr -> r) ->
648 (Binder -> r) ->
648 (Binder -> r) ->
649 (CaseAlternative -> r) ->
649 (CaseAlternative -> r) ->
650 (DoNotationElement -> r) ->
650 (DoNotationElement -> r) ->
651− (Declaration -> r, Value -> r, Binder -> r, CaseAlternative -> r, DoNotationElement -> r)
651+ (Declaration -> r, Expr -> r, Binder -> r, CaseAlternative -> r, DoNotationElement -> r)
652everythingOnValues (<>) f g h i j = (f', g', h', i', j')
652everythingOnValues (<>) f g h i j = (f', g', h', i', j')
653 where
653 where
654 f' d@(DataBindingGroupDeclaration ds) = foldl (<>) (f d) (map f' ds)
654 f' d@(DataBindingGroupDeclaration ds) = foldl (<>) (f d) (map f' ds)
@@ -700,12 +700,12 @@ everythingWithContextOnValues ::
700 r ->
700 r ->
701 (r -> r -> r) ->
701 (r -> r -> r) ->
702 (s -> Declaration -> (s, r)) ->
702 (s -> Declaration -> (s, r)) ->
703− (s -> Value -> (s, r)) ->
703+ (s -> Expr -> (s, r)) ->
704 (s -> Binder -> (s, r)) ->
704 (s -> Binder -> (s, r)) ->
705 (s -> CaseAlternative -> (s, r)) ->
705 (s -> CaseAlternative -> (s, r)) ->
706 (s -> DoNotationElement -> (s, r)) ->
706 (s -> DoNotationElement -> (s, r)) ->
707 ( Declaration -> r
707 ( Declaration -> r
708− , Value -> r
708+ , Expr -> r
709 , Binder -> r
709 , Binder -> r
710 , CaseAlternative -> r
710 , CaseAlternative -> r
711 , DoNotationElement -> r)
711 , DoNotationElement -> r)
@@ -767,12 +767,12 @@ everythingWithContextOnValues s0 r0 (<>) f g h i j = (f'' s0, g'' s0, h'' s0, i'
767everywhereWithContextOnValuesM :: (Functor m, Applicative m, Monad m) =>
767everywhereWithContextOnValuesM :: (Functor m, Applicative m, Monad m) =>
768 s ->
768 s ->
769 (s -> Declaration -> m (s, Declaration)) ->
769 (s -> Declaration -> m (s, Declaration)) ->
770− (s -> Value -> m (s, Value)) ->
770+ (s -> Expr -> m (s, Expr)) ->
771 (s -> Binder -> m (s, Binder)) ->
771 (s -> Binder -> m (s, Binder)) ->
772 (s -> CaseAlternative -> m (s, CaseAlternative)) ->
772 (s -> CaseAlternative -> m (s, CaseAlternative)) ->
773 (s -> DoNotationElement -> m (s, DoNotationElement)) ->
773 (s -> DoNotationElement -> m (s, DoNotationElement)) ->
774 ( Declaration -> m Declaration
774 ( Declaration -> m Declaration
775− , Value -> m Value
775+ , Expr -> m Expr
776 , Binder -> m Binder
776 , Binder -> m Binder
777 , CaseAlternative -> m CaseAlternative
777 , CaseAlternative -> m CaseAlternative
778 , DoNotationElement -> m DoNotationElement)
778 , DoNotationElement -> m DoNotationElement)
@@ -829,7 +829,7 @@ everywhereWithContextOnValuesM s0 f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j
829 j' s (DoNotationLet ds) = DoNotationLet <$> mapM (f'' s) ds
829 j' s (DoNotationLet ds) = DoNotationLet <$> mapM (f'' s) ds
830 j' s (PositionedDoNotationElement pos e1) = PositionedDoNotationElement pos <$> j'' s e1
830 j' s (PositionedDoNotationElement pos e1) = PositionedDoNotationElement pos <$> j'' s e1
831
831
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)
833accumTypes f = everythingOnValues mappend forDecls forValues (const mempty) (const mempty) (const mempty)
833accumTypes f = everythingOnValues mappend forDecls forValues (const mempty) (const mempty) (const mempty)
834 where
834 where
835 forDecls (DataDeclaration _ _ _ dctors) = mconcat (concatMap (map f . snd) dctors)
835 forDecls (DataDeclaration _ _ _ dctors) = mconcat (concatMap (map f . snd) dctors)
src/Language/PureScript/Errors.hs+3−3
@@ -30,9 +30,9 @@ import Language.PureScript.Types
30--
30--
31data ErrorSource
31data ErrorSource
32 -- |
32 -- |
33− -- An error which originated at a Value
33+ -- An error which originated at a Expr
34 --
34 --
35− = ValueError Value
35+ = ExprError Expr
36 -- |
36 -- |
37 -- An error which originated at a Type
37 -- An error which originated at a Type
38 --
38 --
@@ -89,7 +89,7 @@ isErrorNonEmpty = not . null . compileErrorMessage
89
89
90showError :: CompileError -> String
90showError :: CompileError -> String
91showError (CompileError msg Nothing _) = msg
91showError (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
93showError (CompileError msg (Just (TypeError ty)) _) = "Error in type " ++ prettyPrintType ty ++ ":\n" ++ msg
93showError (CompileError msg (Just (TypeError ty)) _) = "Error in type " ++ prettyPrintType ty ++ ":\n" ++ msg
94
94
95mkErrorStack :: String -> Maybe ErrorSource -> ErrorStack
95mkErrorStack :: String -> Maybe ErrorSource -> ErrorStack
src/Language/PureScript/ModuleDependencies.hs+1−1
@@ -52,7 +52,7 @@ usedModules = let (f, _, _, _, _) = everythingOnValues (++) forDecls forValues (
52 forDecls (ImportDeclaration mn _ _) = [mn]
52 forDecls (ImportDeclaration mn _ _) = [mn]
53 forDecls _ = []
53 forDecls _ = []
54
54
55− forValues :: Value -> [ModuleName]
55+ forValues :: Expr -> [ModuleName]
56 forValues (Var (Qualified (Just mn) _)) = [mn]
56 forValues (Var (Qualified (Just mn) _)) = [mn]
57 forValues (BinaryNoParens (Qualified (Just mn) _) _ _) = [mn]
57 forValues (BinaryNoParens (Qualified (Just mn) _) _ _) = [mn]
58 forValues (Constructor (Qualified (Just mn) _)) = [mn]
58 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
230booleanLiteral :: P.Parsec String ParseState Bool
230booleanLiteral :: P.Parsec String ParseState Bool
231booleanLiteral = (C.reserved "true" >> return True) P.<|> (C.reserved "false" >> return False)
231booleanLiteral = (C.reserved "true" >> return True) P.<|> (C.reserved "false" >> return False)
232
232
233−parseNumericLiteral :: P.Parsec String ParseState Value
233+parseNumericLiteral :: P.Parsec String ParseState Expr
234parseNumericLiteral = NumericLiteral <$> C.integerOrFloat
234parseNumericLiteral = NumericLiteral <$> C.integerOrFloat
235
235
236−parseStringLiteral :: P.Parsec String ParseState Value
236+parseStringLiteral :: P.Parsec String ParseState Expr
237parseStringLiteral = StringLiteral <$> C.stringLiteral
237parseStringLiteral = StringLiteral <$> C.stringLiteral
238
238
239−parseBooleanLiteral :: P.Parsec String ParseState Value
239+parseBooleanLiteral :: P.Parsec String ParseState Expr
240parseBooleanLiteral = BooleanLiteral <$> booleanLiteral
240parseBooleanLiteral = BooleanLiteral <$> booleanLiteral
241
241
242−parseArrayLiteral :: P.Parsec String ParseState Value
242+parseArrayLiteral :: P.Parsec String ParseState Expr
243parseArrayLiteral = ArrayLiteral <$> C.squares (C.commaSep parseValue)
243parseArrayLiteral = ArrayLiteral <$> C.squares (C.commaSep parseValue)
244
244
245−parseObjectLiteral :: P.Parsec String ParseState Value
245+parseObjectLiteral :: P.Parsec String ParseState Expr
246parseObjectLiteral = ObjectLiteral <$> C.braces (C.commaSep parseIdentifierAndValue)
246parseObjectLiteral = ObjectLiteral <$> C.braces (C.commaSep parseIdentifierAndValue)
247
247
248−parseIdentifierAndValue :: P.Parsec String ParseState (String, Value)
248+parseIdentifierAndValue :: P.Parsec String ParseState (String, Expr)
249parseIdentifierAndValue = (,) <$> (C.indented *> (C.identifier <|> C.stringLiteral) <* C.indented <* C.colon)
249parseIdentifierAndValue = (,) <$> (C.indented *> (C.identifier <|> C.stringLiteral) <* C.indented <* C.colon)
250 <*> (C.indented *> parseValue)
250 <*> (C.indented *> parseValue)
251
251
252−parseAbs :: P.Parsec String ParseState Value
252+parseAbs :: P.Parsec String ParseState Expr
253parseAbs = do
253parseAbs = do
254 C.reservedOp "\\"
254 C.reservedOp "\\"
255 args <- P.many1 (C.indented *> (Abs <$> (Left <$> P.try C.parseIdent <|> Right <$> parseBinderNoParens)))
255 args <- P.many1 (C.indented *> (Abs <$> (Left <$> P.try C.parseIdent <|> Right <$> parseBinderNoParens)))
@@ -257,16 +257,16 @@ parseAbs = do
257 value <- parseValue
257 value <- parseValue
258 return $ toFunction args value
258 return $ toFunction args value
259 where
259 where
260− toFunction :: [Value -> Value] -> Value -> Value
260+ toFunction :: [Expr -> Expr] -> Expr -> Expr
261 toFunction args value = foldr ($) value args
261 toFunction args value = foldr ($) value args
262
262
263−parseVar :: P.Parsec String ParseState Value
263+parseVar :: P.Parsec String ParseState Expr
264parseVar = Var <$> C.parseQualified C.parseIdent
264parseVar = Var <$> C.parseQualified C.parseIdent
265
265
266−parseConstructor :: P.Parsec String ParseState Value
266+parseConstructor :: P.Parsec String ParseState Expr
267parseConstructor = Constructor <$> C.parseQualified C.properName
267parseConstructor = Constructor <$> C.parseQualified C.properName
268
268
269−parseCase :: P.Parsec String ParseState Value
269+parseCase :: P.Parsec String ParseState Expr
270parseCase = Case <$> P.between (P.try (C.reserved "case")) (C.indented *> C.reserved "of") (return <$> parseValue)
270parseCase = Case <$> P.between (P.try (C.reserved "case")) (C.indented *> C.reserved "of") (return <$> parseValue)
271 <*> (C.indented *> C.mark (P.many (C.same *> C.mark parseCaseAlternative)))
271 <*> (C.indented *> C.mark (P.many (C.same *> C.mark parseCaseAlternative)))
272
272
@@ -276,12 +276,12 @@ parseCaseAlternative = CaseAlternative <$> (return <$> parseBinder)
276 <*> (C.indented *> C.reservedOp "->" *> parseValue)
276 <*> (C.indented *> C.reservedOp "->" *> parseValue)
277 P.<?> "case alternative"
277 P.<?> "case alternative"
278
278
279−parseIfThenElse :: P.Parsec String ParseState Value
279+parseIfThenElse :: P.Parsec String ParseState Expr
280parseIfThenElse = IfThenElse <$> (P.try (C.reserved "if") *> C.indented *> parseValue)
280parseIfThenElse = IfThenElse <$> (P.try (C.reserved "if") *> C.indented *> parseValue)
281 <*> (C.indented *> C.reserved "then" *> C.indented *> parseValue)
281 <*> (C.indented *> C.reserved "then" *> C.indented *> parseValue)
282 <*> (C.indented *> C.reserved "else" *> C.indented *> parseValue)
282 <*> (C.indented *> C.reserved "else" *> C.indented *> parseValue)
283
283
284−parseLet :: P.Parsec String ParseState Value
284+parseLet :: P.Parsec String ParseState Expr
285parseLet = do
285parseLet = do
286 C.reserved "let"
286 C.reserved "let"
287 C.indented
287 C.indented
@@ -291,7 +291,7 @@ parseLet = do
291 result <- parseValue
291 result <- parseValue
292 return $ Let ds result
292 return $ Let ds result
293
293
294−parseValueAtom :: P.Parsec String ParseState Value
294+parseValueAtom :: P.Parsec String ParseState Expr
295parseValueAtom = P.choice
295parseValueAtom = P.choice
296 [ P.try parseNumericLiteral
296 [ P.try parseNumericLiteral
297 , P.try parseStringLiteral
297 , P.try parseStringLiteral
@@ -307,18 +307,18 @@ parseValueAtom = P.choice
307 , parseLet
307 , parseLet
308 , Parens <$> C.parens parseValue ]
308 , Parens <$> C.parens parseValue ]
309
309
310−parsePropertyUpdate :: P.Parsec String ParseState (String, Value)
310+parsePropertyUpdate :: P.Parsec String ParseState (String, Expr)
311parsePropertyUpdate = do
311parsePropertyUpdate = do
312 name <- C.lexeme (C.identifier <|> C.stringLiteral)
312 name <- C.lexeme (C.identifier <|> C.stringLiteral)
313 _ <- C.lexeme $ C.indented *> P.char '='
313 _ <- C.lexeme $ C.indented *> P.char '='
314 value <- C.indented *> parseValue
314 value <- C.indented *> parseValue
315 return (name, value)
315 return (name, value)
316
316
317−parseAccessor :: Value -> P.Parsec String ParseState Value
317+parseAccessor :: Expr -> P.Parsec String ParseState Expr
318parseAccessor (Constructor _) = P.unexpected "constructor"
318parseAccessor (Constructor _) = P.unexpected "constructor"
319parseAccessor obj = P.try $ Accessor <$> (C.indented *> C.dot *> P.notFollowedBy C.opLetter *> C.indented *> (C.identifier <|> C.stringLiteral)) <*> pure obj
319parseAccessor obj = P.try $ Accessor <$> (C.indented *> C.dot *> P.notFollowedBy C.opLetter *> C.indented *> (C.identifier <|> C.stringLiteral)) <*> pure obj
320
320
321−parseDo :: P.Parsec String ParseState Value
321+parseDo :: P.Parsec String ParseState Expr
322parseDo = do
322parseDo = do
323 C.reserved "do"
323 C.reserved "do"
324 C.indented
324 C.indented
@@ -339,7 +339,7 @@ parseDoNotationElement = P.choice
339-- |
339-- |
340-- Parse a value
340-- Parse a value
341--
341--
342−parseValue :: P.Parsec String ParseState Value
342+parseValue :: P.Parsec String ParseState Expr
343parseValue = PositionedValue <$> sourcePos <*>
343parseValue = PositionedValue <$> sourcePos <*>
344 (P.buildExpressionParser operators
344 (P.buildExpressionParser operators
345 . C.buildPostfixParser postfixTable2
345 . C.buildPostfixParser postfixTable2
src/Language/PureScript/Pretty/Values.hs+12−12
@@ -30,10 +30,10 @@ import Language.PureScript.Declarations
30import Language.PureScript.Pretty.Common
30import Language.PureScript.Pretty.Common
31import Language.PureScript.Pretty.Types (prettyPrintType)
31import Language.PureScript.Pretty.Types (prettyPrintType)
32
32
33−literals :: Pattern PrinterState Value String
33+literals :: Pattern PrinterState Expr String
34literals = mkPattern' match
34literals = mkPattern' match
35 where
35 where
36− match :: Value -> StateT PrinterState Maybe String
36+ match :: Expr -> StateT PrinterState Maybe String
37 match (NumericLiteral n) = return $ either show show n
37 match (NumericLiteral n) = return $ either show show n
38 match (StringLiteral s) = return $ show s
38 match (StringLiteral s) = return $ show s
39 match (BooleanLiteral True) = return "true"
39 match (BooleanLiteral True) = return "true"
@@ -118,31 +118,31 @@ prettyPrintDoNotationElement (DoNotationLet ds) =
118 ]
118 ]
119prettyPrintDoNotationElement (PositionedDoNotationElement _ el) = prettyPrintDoNotationElement el
119prettyPrintDoNotationElement (PositionedDoNotationElement _ el) = prettyPrintDoNotationElement el
120
120
121−ifThenElse :: Pattern PrinterState Value ((Value, Value), Value)
121+ifThenElse :: Pattern PrinterState Expr ((Expr, Expr), Expr)
122ifThenElse = mkPattern match
122ifThenElse = mkPattern match
123 where
123 where
124 match (IfThenElse cond th el) = Just ((th, el), cond)
124 match (IfThenElse cond th el) = Just ((th, el), cond)
125 match _ = Nothing
125 match _ = Nothing
126
126
127−accessor :: Pattern PrinterState Value (String, Value)
127+accessor :: Pattern PrinterState Expr (String, Expr)
128accessor = mkPattern match
128accessor = mkPattern match
129 where
129 where
130 match (Accessor prop val) = Just (prop, val)
130 match (Accessor prop val) = Just (prop, val)
131 match _ = Nothing
131 match _ = Nothing
132
132
133−objectUpdate :: Pattern PrinterState Value ([String], Value)
133+objectUpdate :: Pattern PrinterState Expr ([String], Expr)
134objectUpdate = mkPattern match
134objectUpdate = mkPattern match
135 where
135 where
136 match (ObjectUpdate o ps) = Just (flip map ps $ \(key, val) -> key ++ " = " ++ prettyPrintValue val, o)
136 match (ObjectUpdate o ps) = Just (flip map ps $ \(key, val) -> key ++ " = " ++ prettyPrintValue val, o)
137 match _ = Nothing
137 match _ = Nothing
138
138
139−app :: Pattern PrinterState Value (String, Value)
139+app :: Pattern PrinterState Expr (String, Expr)
140app = mkPattern match
140app = mkPattern match
141 where
141 where
142 match (App val arg) = Just (prettyPrintValue arg, val)
142 match (App val arg) = Just (prettyPrintValue arg, val)
143 match _ = Nothing
143 match _ = Nothing
144
144
145−lam :: Pattern PrinterState Value (String, Value)
145+lam :: Pattern PrinterState Expr (String, Expr)
146lam = mkPattern match
146lam = mkPattern match
147 where
147 where
148 match (Abs (Left arg) val) = Just (show arg, val)
148 match (Abs (Left arg) val) = Just (show arg, val)
@@ -151,15 +151,15 @@ lam = mkPattern match
151-- |
151-- |
152-- Generate a pretty-printed string representing an expression
152-- Generate a pretty-printed string representing an expression
153--
153--
154−prettyPrintValue :: Value -> String
154+prettyPrintValue :: Expr -> String
155prettyPrintValue = fromMaybe (error "Incomplete pattern") . flip evalStateT (PrinterState 0) . prettyPrintValue'
155prettyPrintValue = fromMaybe (error "Incomplete pattern") . flip evalStateT (PrinterState 0) . prettyPrintValue'
156
156
157−prettyPrintValue' :: Value -> StateT PrinterState Maybe String
157+prettyPrintValue' :: Expr -> StateT PrinterState Maybe String
158prettyPrintValue' = runKleisli $ runPattern matchValue
158prettyPrintValue' = runKleisli $ runPattern matchValue
159 where
159 where
160− matchValue :: Pattern PrinterState Value String
160+ matchValue :: Pattern PrinterState Expr String
161 matchValue = buildPrettyPrinter operators (literals <+> fmap parens matchValue)
161 matchValue = buildPrettyPrinter operators (literals <+> fmap parens matchValue)
162− operators :: OperatorTable PrinterState Value String
162+ operators :: OperatorTable PrinterState Expr String
163 operators =
163 operators =
164 OperatorTable [ [ Wrap accessor $ \prop val -> val ++ "." ++ prop ]
164 OperatorTable [ [ Wrap accessor $ \prop val -> val ++ "." ++ prop ]
165 , [ Wrap objectUpdate $ \ps val -> val ++ "{ " ++ intercalate ", " ps ++ " }" ]
165 , [ Wrap objectUpdate $ \ps val -> val ++ "{ " ++ intercalate ", " ps ++ " }" ]
@@ -224,7 +224,7 @@ prettyPrintObjectPropertyBinder (key, binder) = fmap concat $ sequence
224 , prettyPrintBinder' binder
224 , prettyPrintBinder' binder
225 ]
225 ]
226
226
227−prettyPrintObjectProperty :: (String, Value) -> StateT PrinterState Maybe String
227+prettyPrintObjectProperty :: (String, Expr) -> StateT PrinterState Maybe String
228prettyPrintObjectProperty (key, value) = fmap concat $ sequence
228prettyPrintObjectProperty (key, value) = fmap concat $ sequence
229 [ return $ prettyPrintObjectKey key ++ ": "
229 [ return $ prettyPrintObjectKey key ++ ": "
230 , prettyPrintValue' value
230 , prettyPrintValue' value
src/Language/PureScript/Renamer.hs+3−3
@@ -132,11 +132,11 @@ renameInDecl isTopLevel (BindingGroupDeclaration ds) = do
132 ds' <- mapM updateNames ds
132 ds' <- mapM updateNames ds
133 BindingGroupDeclaration <$> mapM updateValues ds'
133 BindingGroupDeclaration <$> mapM updateValues ds'
134 where
134 where
135− updateNames :: (Ident, NameKind, Value) -> Rename (Ident, NameKind, Value)
135+ updateNames :: (Ident, NameKind, Expr) -> Rename (Ident, NameKind, Expr)
136 updateNames (name, nameKind, val) = do
136 updateNames (name, nameKind, val) = do
137 name' <- if isTopLevel then return name else updateScope name
137 name' <- if isTopLevel then return name else updateScope name
138 return (name', nameKind, val)
138 return (name', nameKind, val)
139− updateValues :: (Ident, NameKind, Value) -> Rename (Ident, NameKind, Value)
139+ updateValues :: (Ident, NameKind, Expr) -> Rename (Ident, NameKind, Expr)
140 updateValues (name, nameKind, val) =
140 updateValues (name, nameKind, val) =
141 (,,) name nameKind <$> renameInValue val
141 (,,) name nameKind <$> renameInValue val
142renameInDecl _ (TypeInstanceDeclaration name cs className args ds) =
142renameInDecl _ (TypeInstanceDeclaration name cs className args ds) =
@@ -148,7 +148,7 @@ renameInDecl _ other = return other
148-- |
148-- |
149-- Renames within a value.
149-- Renames within a value.
150--
150--
151−renameInValue :: Value -> Rename Value
151+renameInValue :: Expr -> Rename Expr
152renameInValue (UnaryMinus v) =
152renameInValue (UnaryMinus v) =
153 UnaryMinus <$> renameInValue v
153 UnaryMinus <$> renameInValue v
154renameInValue (ArrayLiteral vs) =
154renameInValue (ArrayLiteral vs) =
src/Language/PureScript/Sugar/BindingGroups.hs+3−3
@@ -85,7 +85,7 @@ collapseBindingGroups = let (f, _, _) = everywhereOnValues id collapseBindingGro
85 go (PositionedDeclaration pos d) = map (PositionedDeclaration pos) $ go d
85 go (PositionedDeclaration pos d) = map (PositionedDeclaration pos) $ go d
86 go other = [other]
86 go other = [other]
87
87
88−collapseBindingGroupsForValue :: Value -> Value
88+collapseBindingGroupsForValue :: Expr -> Expr
89collapseBindingGroupsForValue (Let ds val) = Let (collapseBindingGroups ds) val
89collapseBindingGroupsForValue (Let ds val) = Let (collapseBindingGroups ds) val
90collapseBindingGroupsForValue other = other
90collapseBindingGroupsForValue other = other
91
91
@@ -94,7 +94,7 @@ usedIdents moduleName =
94 let (f, _, _, _, _) = everythingOnValues (++) (const []) usedNames (const []) (const []) (const [])
94 let (f, _, _, _, _) = everythingOnValues (++) (const []) usedNames (const []) (const []) (const [])
95 in nub . f
95 in nub . f
96 where
96 where
97− usedNames :: Value -> [Ident]
97+ usedNames :: Expr -> [Ident]
98 usedNames (Var (Qualified Nothing name)) = [name]
98 usedNames (Var (Qualified Nothing name)) = [name]
99 usedNames (Var (Qualified (Just moduleName') name)) | moduleName == moduleName' = [name]
99 usedNames (Var (Qualified (Just moduleName') name)) | moduleName == moduleName' = [name]
100 usedNames _ = []
100 usedNames _ = []
@@ -142,7 +142,7 @@ isTypeSynonym (TypeSynonymDeclaration pn _ _) = Just pn
142isTypeSynonym (PositionedDeclaration _ d) = isTypeSynonym d
142isTypeSynonym (PositionedDeclaration _ d) = isTypeSynonym d
143isTypeSynonym _ = Nothing
143isTypeSynonym _ = Nothing
144
144
145−fromValueDecl :: Declaration -> (Ident, NameKind, Value)
145+fromValueDecl :: Declaration -> (Ident, NameKind, Expr)
146fromValueDecl (ValueDeclaration ident nameKind [] Nothing val) = (ident, nameKind, val)
146fromValueDecl (ValueDeclaration ident nameKind [] Nothing val) = (ident, nameKind, val)
147fromValueDecl ValueDeclaration{} = error "Binders should have been desugared"
147fromValueDecl ValueDeclaration{} = error "Binders should have been desugared"
148fromValueDecl (PositionedDeclaration _ d) = fromValueDecl d
148fromValueDecl (PositionedDeclaration _ d) = fromValueDecl d
src/Language/PureScript/Sugar/CaseDeclarations.hs+3−3
@@ -45,7 +45,7 @@ desugarAbs = mapM f
45 where
45 where
46 (f, _, _) = everywhereOnValuesM return replace return
46 (f, _, _) = everywhereOnValuesM return replace return
47
47
48− replace :: Value -> SupplyT (Either ErrorStack) Value
48+ replace :: Expr -> SupplyT (Either ErrorStack) Expr
49 replace (Abs (Right binder) val) = do
49 replace (Abs (Right binder) val) = do
50 ident <- Ident <$> freshName
50 ident <- Ident <$> freshName
51 return $ Abs (Left ident) $ Case [Var (Qualified Nothing ident)] [CaseAlternative [binder] Nothing val]
51 return $ Abs (Left ident) $ Case [Var (Qualified Nothing ident)] [CaseAlternative [binder] Nothing val]
@@ -98,12 +98,12 @@ isVarBinder :: Binder -> Bool
98isVarBinder (VarBinder _) = True
98isVarBinder (VarBinder _) = True
99isVarBinder _ = False
99isVarBinder _ = False
100
100
101−toTuple :: Declaration -> ([Binder], (Maybe Guard, Value))
101+toTuple :: Declaration -> ([Binder], (Maybe Guard, Expr))
102toTuple (ValueDeclaration _ _ bs g val) = (bs, (g, val))
102toTuple (ValueDeclaration _ _ bs g val) = (bs, (g, val))
103toTuple (PositionedDeclaration _ d) = toTuple d
103toTuple (PositionedDeclaration _ d) = toTuple d
104toTuple _ = error "Not a value declaration"
104toTuple _ = error "Not a value declaration"
105
105
106−makeCaseDeclaration :: Ident -> [([Binder], (Maybe Guard, Value))] -> SupplyT (Either ErrorStack) Declaration
106+makeCaseDeclaration :: Ident -> [([Binder], (Maybe Guard, Expr))] -> SupplyT (Either ErrorStack) Declaration
107makeCaseDeclaration ident alternatives = do
107makeCaseDeclaration ident alternatives = do
108 let argPattern = length . fst . head $ alternatives
108 let argPattern = length . fst . head $ alternatives
109 args <- map Ident <$> replicateM argPattern freshName
109 args <- map Ident <$> replicateM argPattern freshName
src/Language/PureScript/Sugar/DoNotation.hs+3−3
@@ -44,15 +44,15 @@ desugarDo d =
44 prelude :: ModuleName
44 prelude :: ModuleName
45 prelude = ModuleName [ProperName C.prelude]
45 prelude = ModuleName [ProperName C.prelude]
46
46
47− bind :: Value
47+ bind :: Expr
48 bind = Var (Qualified (Just prelude) (Op (C.>>=)))
48 bind = Var (Qualified (Just prelude) (Op (C.>>=)))
49
49
50− replace :: Value -> SupplyT (Either ErrorStack) Value
50+ replace :: Expr -> SupplyT (Either ErrorStack) Expr
51 replace (Do els) = go els
51 replace (Do els) = go els
52 replace (PositionedValue pos v) = PositionedValue pos <$> rethrowWithPosition pos (replace v)
52 replace (PositionedValue pos v) = PositionedValue pos <$> rethrowWithPosition pos (replace v)
53 replace other = return other
53 replace other = return other
54
54
55− go :: [DoNotationElement] -> SupplyT (Either ErrorStack) Value
55+ go :: [DoNotationElement] -> SupplyT (Either ErrorStack) Expr
56 go [] = error "The impossible happened in desugarDo"
56 go [] = error "The impossible happened in desugarDo"
57 go [DoNotationValue val] = return val
57 go [DoNotationValue val] = return val
58 go (DoNotationValue val : rest) = do
58 go (DoNotationValue val : rest) = do
src/Language/PureScript/Sugar/Names.hs+1−1
@@ -198,7 +198,7 @@ renameInModule imports exports (Module mn decls exps) =
198 (,) (pos, name : bound) <$> (ExternDeclaration fit name js <$> updateTypesEverywhere pos ty)
198 (,) (pos, name : bound) <$> (ExternDeclaration fit name js <$> updateTypesEverywhere pos ty)
199 updateDecl s d = return (s, d)
199 updateDecl s d = return (s, d)
200
200
201− updateValue :: (Maybe SourcePos, [Ident]) -> Value -> Either ErrorStack ((Maybe SourcePos, [Ident]), Value)
201+ updateValue :: (Maybe SourcePos, [Ident]) -> Expr -> Either ErrorStack ((Maybe SourcePos, [Ident]), Expr)
202 updateValue (_, bound) v@(PositionedValue pos' _) = return ((Just pos', bound), v)
202 updateValue (_, bound) v@(PositionedValue pos' _) = return ((Just pos', bound), v)
203 updateValue (pos, bound) (Abs (Left arg) val') = return ((pos, arg : bound), Abs (Left arg) val')
203 updateValue (pos, bound) (Abs (Left arg) val') = return ((pos, arg : bound), Abs (Left arg) val')
204 updateValue (pos, bound) (Let ds val') =
204 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
63 go (UnaryMinus val) = App (Var (Qualified (Just (ModuleName [ProperName C.prelude])) (Ident C.negate))) val
63 go (UnaryMinus val) = App (Var (Qualified (Just (ModuleName [ProperName C.prelude])) (Ident C.negate))) val
64 go other = other
64 go other = other
65
65
66−rebracketModule :: [[(Qualified Ident, Value -> Value -> Value, Associativity)]] -> Module -> Either ErrorStack Module
66+rebracketModule :: [[(Qualified Ident, Expr -> Expr -> Expr, Associativity)]] -> Module -> Either ErrorStack Module
67rebracketModule opTable (Module mn ds exts) =
67rebracketModule opTable (Module mn ds exts) =
68 let (f, _, _) = everywhereOnValuesTopDownM return (matchOperators opTable) return
68 let (f, _, _) = everywhereOnValuesTopDownM return (matchOperators opTable) return
69 in Module mn <$> (map removeParens <$> mapM f ds) <*> pure exts
69 in Module mn <$> (map removeParens <$> mapM f ds) <*> pure exts
@@ -95,7 +95,7 @@ ensureNoDuplicates m = go $ sortBy (compare `on` fst) m
95 throwError $ mkErrorStack ("Redefined fixity for " ++ show name) Nothing
95 throwError $ mkErrorStack ("Redefined fixity for " ++ show name) Nothing
96 go (_ : rest) = go rest
96 go (_ : rest) = go rest
97
97
98−customOperatorTable :: [(Qualified Ident, Fixity)] -> [[(Qualified Ident, Value -> Value -> Value, Associativity)]]
98+customOperatorTable :: [(Qualified Ident, Fixity)] -> [[(Qualified Ident, Expr -> Expr -> Expr, Associativity)]]
99customOperatorTable fixities =
99customOperatorTable fixities =
100 let
100 let
101 applyUserOp ident t1 = App (App (Var ident) t1)
101 applyUserOp ident t1 = App (App (Var ident) t1)
@@ -105,18 +105,18 @@ customOperatorTable fixities =
105 in
105 in
106 map (map (\(name, f, _, a) -> (name, f, a))) groups
106 map (map (\(name, f, _, a) -> (name, f, a))) groups
107
107
108−type Chain = [Either Value (Qualified Ident)]
108+type Chain = [Either Expr (Qualified Ident)]
109
109
110−matchOperators :: [[(Qualified Ident, Value -> Value -> Value, Associativity)]] -> Value -> Either ErrorStack Value
110+matchOperators :: [[(Qualified Ident, Expr -> Expr -> Expr, Associativity)]] -> Expr -> Either ErrorStack Expr
111matchOperators ops = parseChains
111matchOperators ops = parseChains
112 where
112 where
113− parseChains :: Value -> Either ErrorStack Value
113+ parseChains :: Expr -> Either ErrorStack Expr
114 parseChains b@BinaryNoParens{} = bracketChain (extendChain b)
114 parseChains b@BinaryNoParens{} = bracketChain (extendChain b)
115 parseChains other = return other
115 parseChains other = return other
116− extendChain :: Value -> Chain
116+ extendChain :: Expr -> Chain
117 extendChain (BinaryNoParens name l r) = Left l : Right name : extendChain r
117 extendChain (BinaryNoParens name l r) = Left l : Right name : extendChain r
118 extendChain other = [Left other]
118 extendChain other = [Left other]
119− bracketChain :: Chain -> Either ErrorStack Value
119+ bracketChain :: Chain -> Either ErrorStack Expr
120 bracketChain = either (Left . (`mkErrorStack` Nothing) . show) Right . P.parse (P.buildExpressionParser opTable parseValue <* P.eof) "operator expression"
120 bracketChain = either (Left . (`mkErrorStack` Nothing) . show) Right . P.parse (P.buildExpressionParser opTable parseValue <* P.eof) "operator expression"
121 opTable = [P.Infix (P.try (parseTicks >>= \ident -> return (\t1 t2 -> App (App (Var ident) t1) t2))) P.AssocLeft]
121 opTable = [P.Infix (P.try (parseTicks >>= \ident -> return (\t1 t2 -> App (App (Var ident) t1) t2))) P.AssocLeft]
122 : map (map (\(name, f, a) -> P.Infix (P.try (matchOp name) >> return f) (toAssoc a))) ops
122 : map (map (\(name, f, a) -> P.Infix (P.try (matchOp name) >> return f) (toAssoc a))) ops
@@ -130,7 +130,7 @@ toAssoc Infix = P.AssocNone
130token :: (P.Stream s Identity t, Show t) => (t -> Maybe a) -> P.Parsec s u a
130token :: (P.Stream s Identity t, Show t) => (t -> Maybe a) -> P.Parsec s u a
131token = P.token show (const (P.initialPos ""))
131token = P.token show (const (P.initialPos ""))
132
132
133−parseValue :: P.Parsec Chain () Value
133+parseValue :: P.Parsec Chain () Expr
134parseValue = token (either Just (const Nothing)) P.<?> "expression"
134parseValue = token (either Just (const Nothing)) P.<?> "expression"
135
135
136parseOp :: P.Parsec Chain () (Qualified Ident)
136parseOp :: P.Parsec Chain () (Qualified Ident)
src/Language/PureScript/Sugar/TypeClasses.hs+2−2
@@ -261,7 +261,7 @@ typeInstanceDictionaryDeclaration name mn deps className tys decls =
261 declName (TypeDeclaration ident _) = Just ident
261 declName (TypeDeclaration ident _) = Just ident
262 declName _ = Nothing
262 declName _ = Nothing
263
263
264− memberToNameAndValue :: [(Ident, Type)] -> Declaration -> Desugar (Ident, Value)
264+ memberToNameAndValue :: [(Ident, Type)] -> Declaration -> Desugar (Ident, Expr)
265 memberToNameAndValue tys' d@(ValueDeclaration ident _ _ _ _) = do
265 memberToNameAndValue tys' d@(ValueDeclaration ident _ _ _ _) = do
266 _ <- lift . lift . maybe (Left $ mkErrorStack ("Type class does not define member '" ++ show ident ++ "'") Nothing) Right $ lookup ident tys'
266 _ <- lift . lift . maybe (Left $ mkErrorStack ("Type class does not define member '" ++ show ident ++ "'") Nothing) Right $ lookup ident tys'
267 let memberValue = typeInstanceDictionaryEntryValue d
267 let memberValue = typeInstanceDictionaryEntryValue d
@@ -271,7 +271,7 @@ typeInstanceDictionaryDeclaration name mn deps className tys decls =
271 return (ident, PositionedValue pos val)
271 return (ident, PositionedValue pos val)
272 memberToNameAndValue _ _ = error "Invalid declaration in type instance definition"
272 memberToNameAndValue _ _ = error "Invalid declaration in type instance definition"
273
273
274− typeInstanceDictionaryEntryValue :: Declaration -> Value
274+ typeInstanceDictionaryEntryValue :: Declaration -> Expr
275 typeInstanceDictionaryEntryValue (ValueDeclaration _ _ [] _ val) = val
275 typeInstanceDictionaryEntryValue (ValueDeclaration _ _ [] _ val) = val
276 typeInstanceDictionaryEntryValue (PositionedDeclaration pos d) = PositionedValue pos (typeInstanceDictionaryEntryValue d)
276 typeInstanceDictionaryEntryValue (PositionedDeclaration pos d) = PositionedValue pos (typeInstanceDictionaryEntryValue d)
277 typeInstanceDictionaryEntryValue _ = error "Invalid declaration in type instance definition"
277 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
49 (_, nameKind, val) <- fromValueDeclaration d
49 (_, nameKind, val) <- fromValueDeclaration d
50 desugarTypeDeclarations (ValueDeclaration name nameKind [] Nothing (TypedValue True val ty) : rest)
50 desugarTypeDeclarations (ValueDeclaration name nameKind [] Nothing (TypedValue True val ty) : rest)
51 where
51 where
52− fromValueDeclaration :: Declaration -> Either ErrorStack (Ident, NameKind, Value)
52+ fromValueDeclaration :: Declaration -> Either ErrorStack (Ident, NameKind, Expr)
53 fromValueDeclaration (ValueDeclaration name' nameKind [] Nothing val) | name == name' = return (name', nameKind, val)
53 fromValueDeclaration (ValueDeclaration name' nameKind [] Nothing val) | name == name' = return (name', nameKind, val)
54 fromValueDeclaration (PositionedDeclaration pos d') = do
54 fromValueDeclaration (PositionedDeclaration pos d') = do
55 (ident, nameKind, val) <- rethrowWithPosition pos $ fromValueDeclaration d'
55 (ident, nameKind, val) <- rethrowWithPosition pos $ fromValueDeclaration d'
src/Language/PureScript/TypeChecker/Types.hs+36−36
@@ -168,7 +168,7 @@ unifyRows r1 r2 =
168-- Infer the types of multiple mutually-recursive values, and return elaborated values including
168-- Infer the types of multiple mutually-recursive values, and return elaborated values including
169-- type class dictionaries and type annotations.
169-- type class dictionaries and type annotations.
170--
170--
171−typesOf :: Maybe ModuleName -> ModuleName -> [(Ident, Value)] -> Check [(Ident, (Value, Type))]
171+typesOf :: Maybe ModuleName -> ModuleName -> [(Ident, Expr)] -> Check [(Ident, (Expr, Type))]
172typesOf mainModuleName moduleName vals = do
172typesOf mainModuleName moduleName vals = do
173 tys <- fmap tidyUp . liftUnify $ do
173 tys <- fmap tidyUp . liftUnify $ do
174 (es, dict, untypedDict) <- typeDictionaryForBindingGroup moduleName vals
174 (es, dict, untypedDict) <- typeDictionaryForBindingGroup moduleName vals
@@ -194,7 +194,7 @@ typesOf mainModuleName moduleName vals = do
194 -- Apply the substitution that was returned from runUnify to both types and (type-annotated) values
194 -- Apply the substitution that was returned from runUnify to both types and (type-annotated) values
195 tidyUp (ts, sub) = map (\(i, (val, ty)) -> (i, (overTypes (sub $?) val, sub $? ty))) ts
195 tidyUp (ts, sub) = map (\(i, (val, ty)) -> (i, (overTypes (sub $?) val, sub $? ty))) ts
196
196
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)])
198typeDictionaryForBindingGroup moduleName vals = do
198typeDictionaryForBindingGroup moduleName vals = do
199 let
199 let
200 -- Map each declaration to a name/value pair, with an optional type, if the declaration is typed
200 -- 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
215 dict = M.fromList (map (\(ident, ty) -> ((moduleName, ident), (ty, LocalVariable, Undefined))) $ typedDict ++ untypedDict)
215 dict = M.fromList (map (\(ident, ty) -> ((moduleName, ident), (ty, LocalVariable, Undefined))) $ typedDict ++ untypedDict)
216 return (es, dict, untypedDict)
216 return (es, dict, untypedDict)
217
217
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))
219typeForBindingGroupElement moduleName el dict untypedDict =
219typeForBindingGroupElement moduleName el dict untypedDict =
220 -- If the declaration is a function, it has access to other values in the binding group.
220 -- If the declaration is a function, it has access to other values in the binding group.
221 -- If not, the generated code might fail at runtime since those values might be undefined.
221 -- If not, the generated code might fail at runtime since those values might be undefined.
@@ -241,17 +241,17 @@ typeForBindingGroupElement moduleName el dict untypedDict =
241-- |
241-- |
242-- Check if a value contains a type annotation
242-- Check if a value contains a type annotation
243--
243--
244−isTyped :: (Ident, Value) -> (Ident, (Value, Maybe (Type, Bool)))
244+isTyped :: (Ident, Expr) -> (Ident, (Expr, Maybe (Type, Bool)))
245isTyped (name, TypedValue checkType value ty) = (name, (value, Just (ty, checkType)))
245isTyped (name, TypedValue checkType value ty) = (name, (value, Just (ty, checkType)))
246isTyped (name, value) = (name, (value, Nothing))
246isTyped (name, value) = (name, (value, Nothing))
247
247
248-- |
248-- |
249-- Map a function over type annotations appearing inside a value
249-- Map a function over type annotations appearing inside a value
250--
250--
251−overTypes :: (Type -> Type) -> Value -> Value
251+overTypes :: (Type -> Type) -> Expr -> Expr
252overTypes f = let (_, f', _) = everywhereOnValues id g id in f'
252overTypes f = let (_, f', _) = everywhereOnValues id g id in f'
253 where
253 where
254− g :: Value -> Value
254+ g :: Expr -> Expr
255 g (TypedValue checkTy val t) = TypedValue checkTy val (f t)
255 g (TypedValue checkTy val t) = TypedValue checkTy val (f t)
256 g (TypeClassDictionary b (nm, tys) sco) = TypeClassDictionary b (nm, map f tys) sco
256 g (TypeClassDictionary b (nm, tys) sco) = TypeClassDictionary b (nm, map f tys) sco
257 g other = other
257 g other = other
@@ -259,7 +259,7 @@ overTypes f = let (_, f', _) = everywhereOnValues id g id in f'
259-- |
259-- |
260-- Replace type class dictionary placeholders with inferred type class dictionaries
260-- Replace type class dictionary placeholders with inferred type class dictionaries
261--
261--
262−replaceTypeClassDictionaries :: ModuleName -> Value -> Check Value
262+replaceTypeClassDictionaries :: ModuleName -> Expr -> Check Expr
263replaceTypeClassDictionaries mn =
263replaceTypeClassDictionaries mn =
264 let (_, f, _) = everywhereOnValuesTopDownM return go return
264 let (_, f, _) = everywhereOnValuesTopDownM return go return
265 in f
265 in f
@@ -296,7 +296,7 @@ data DictionaryValue
296-- Check that the current set of type class dictionaries entail the specified type class goal, and, if so,
296-- Check that the current set of type class dictionaries entail the specified type class goal, and, if so,
297-- return a type class dictionary reference.
297-- return a type class dictionary reference.
298--
298--
299−entails :: Environment -> ModuleName -> [TypeClassDictionaryInScope] -> (Qualified ProperName, [Type]) -> Bool -> Check Value
299+entails :: Environment -> ModuleName -> [TypeClassDictionaryInScope] -> (Qualified ProperName, [Type]) -> Bool -> Check Expr
300entails env moduleName context = solve (sortedNubBy canonicalizeDictionary (filter filterModule context))
300entails env moduleName context = solve (sortedNubBy canonicalizeDictionary (filter filterModule context))
301 where
301 where
302 sortedNubBy :: (Ord k) => (v -> k) -> [v] -> [v]
302 sortedNubBy :: (Ord k) => (v -> k) -> [v] -> [v]
@@ -354,8 +354,8 @@ entails env moduleName context = solve (sortedNubBy canonicalizeDictionary (filt
354 mkDictionary fnName Nothing = LocalDictionaryValue fnName
354 mkDictionary fnName Nothing = LocalDictionaryValue fnName
355 mkDictionary fnName (Just []) = GlobalDictionaryValue fnName
355 mkDictionary fnName (Just []) = GlobalDictionaryValue fnName
356 mkDictionary fnName (Just dicts) = DependentDictionaryValue fnName dicts
356 mkDictionary fnName (Just dicts) = DependentDictionaryValue fnName dicts
357− -- Turn a DictionaryValue into a Value
357+ -- Turn a DictionaryValue into a Expr
358− dictionaryValueToValue :: DictionaryValue -> Value
358+ dictionaryValueToValue :: DictionaryValue -> Expr
359 dictionaryValueToValue (LocalDictionaryValue fnName) = Var fnName
359 dictionaryValueToValue (LocalDictionaryValue fnName) = Var fnName
360 dictionaryValueToValue (GlobalDictionaryValue fnName) = App (Var fnName) (ObjectLiteral [])
360 dictionaryValueToValue (GlobalDictionaryValue fnName) = App (Var fnName) (ObjectLiteral [])
361 dictionaryValueToValue (DependentDictionaryValue fnName dicts) = foldl App (Var fnName) (map dictionaryValueToValue dicts)
361 dictionaryValueToValue (DependentDictionaryValue fnName dicts) = foldl App (Var fnName) (map dictionaryValueToValue dicts)
@@ -434,7 +434,7 @@ typeHeadsAreEqual _ _ _ _ = Nothing
434-- |
434-- |
435-- Ensure skolem variables do not escape their scope
435-- Ensure skolem variables do not escape their scope
436--
436--
437−skolemEscapeCheck :: Value -> Check ()
437+skolemEscapeCheck :: Expr -> Check ()
438skolemEscapeCheck (TypedValue False _ _) = return ()
438skolemEscapeCheck (TypedValue False _ _) = return ()
439skolemEscapeCheck root@TypedValue{} =
439skolemEscapeCheck root@TypedValue{} =
440 -- Every skolem variable is created when a ForAll type is skolemized.
440 -- Every skolem variable is created when a ForAll type is skolemized.
@@ -446,11 +446,11 @@ skolemEscapeCheck root@TypedValue{} =
446 let (_, f, _, _, _) = everythingWithContextOnValues [] [] (++) def go def def def
446 let (_, f, _, _, _) = everythingWithContextOnValues [] [] (++) def go def def def
447 in case f root of
447 in case f root of
448 [] -> return ()
448 [] -> 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))
450 where
450 where
451 def s _ = (s, [])
451 def s _ = (s, [])
452
452
453− go :: [(SkolemScope, Value)] -> Value -> ([(SkolemScope, Value)], [(Maybe Value, Value)])
453+ go :: [(SkolemScope, Expr)] -> Expr -> ([(SkolemScope, Expr)], [(Maybe Expr, Expr)])
454 go scos val@(TypedValue _ _ (ForAll _ _ (Just sco))) = ((sco, val) : scos, [])
454 go scos val@(TypedValue _ _ (ForAll _ _ (Just sco))) = ((sco, val) : scos, [])
455 go scos val@(TypedValue _ _ ty) = case collectSkolems ty \\ map fst scos of
455 go scos val@(TypedValue _ _ ty) = case collectSkolems ty \\ map fst scos of
456 (sco : _) -> (scos, [(findBindingScope sco, val)])
456 (sco : _) -> (scos, [(findBindingScope sco, val)])
@@ -462,14 +462,14 @@ skolemEscapeCheck root@TypedValue{} =
462 collect (Skolem _ _ scope) = [scope]
462 collect (Skolem _ _ scope) = [scope]
463 collect _ = []
463 collect _ = []
464 go scos _ = (scos, [])
464 go scos _ = (scos, [])
465− findBindingScope :: SkolemScope -> Maybe Value
465+ findBindingScope :: SkolemScope -> Maybe Expr
466 findBindingScope sco =
466 findBindingScope sco =
467 let (_, f, _, _, _) = everythingOnValues mappend (const mempty) go' (const mempty) (const mempty) (const mempty)
467 let (_, f, _, _, _) = everythingOnValues mappend (const mempty) go' (const mempty) (const mempty) (const mempty)
468 in getFirst $ f root
468 in getFirst $ f root
469 where
469 where
470 go' val@(TypedValue _ _ (ForAll _ _ (Just sco'))) | sco == sco' = First (Just val)
470 go' val@(TypedValue _ _ (ForAll _ _ (Just sco'))) | sco == sco' = First (Just val)
471 go' _ = mempty
471 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))
473
473
474-- |
474-- |
475-- Ensure a row contains no duplicate labels
475-- Ensure a row contains no duplicate labels
@@ -503,7 +503,7 @@ varIfUnknown ty =
503-- This is necessary during type checking to avoid unifying a polymorphic type with a
503-- This is necessary during type checking to avoid unifying a polymorphic type with a
504-- unification variable.
504-- unification variable.
505--
505--
506−instantiatePolyTypeWithUnknowns :: Value -> Type -> UnifyT Type Check (Value, Type)
506+instantiatePolyTypeWithUnknowns :: Expr -> Type -> UnifyT Type Check (Expr, Type)
507instantiatePolyTypeWithUnknowns val (ForAll ident ty _) = do
507instantiatePolyTypeWithUnknowns val (ForAll ident ty _) = do
508 ty' <- replaceVarWithUnknown ident ty
508 ty' <- replaceVarWithUnknown ident ty
509 instantiatePolyTypeWithUnknowns val ty'
509 instantiatePolyTypeWithUnknowns val ty'
@@ -571,19 +571,19 @@ expandAllTypeSynonyms = everywhereOnTypesTopDownM go
571-- |
571-- |
572-- Ensure a set of property names and value does not contain duplicate labels
572-- Ensure a set of property names and value does not contain duplicate labels
573--
573--
574−ensureNoDuplicateProperties :: (Error e, MonadError e m) => [(String, Value)] -> m ()
574+ensureNoDuplicateProperties :: (Error e, MonadError e m) => [(String, Expr)] -> m ()
575ensureNoDuplicateProperties ps = guardWith (strMsg "Duplicate property names") $ length (nub . map fst $ ps) == length ps
575ensureNoDuplicateProperties ps = guardWith (strMsg "Duplicate property names") $ length (nub . map fst $ ps) == length ps
576
576
577-- |
577-- |
578-- Infer a type for a value, rethrowing any error to provide a more useful error message
578-- Infer a type for a value, rethrowing any error to provide a more useful error message
579--
579--
580−infer :: Value -> UnifyT Type Check Value
580+infer :: Expr -> UnifyT Type Check Expr
581−infer val = rethrow (mkErrorStack "Error inferring type of value" (Just (ValueError val)) <>) $ infer' val
581+infer val = rethrow (mkErrorStack "Error inferring type of value" (Just (ExprError val)) <>) $ infer' val
582
582
583-- |
583-- |
584-- Infer a type for a value
584-- Infer a type for a value
585--
585--
586−infer' :: Value -> UnifyT Type Check Value
586+infer' :: Expr -> UnifyT Type Check Expr
587infer' v@(NumericLiteral _) = return $ TypedValue True v tyNumber
587infer' v@(NumericLiteral _) = return $ TypedValue True v tyNumber
588infer' v@(StringLiteral _) = return $ TypedValue True v tyString
588infer' v@(StringLiteral _) = return $ TypedValue True v tyString
589infer' v@(BooleanLiteral _) = return $ TypedValue True v tyBoolean
589infer' v@(BooleanLiteral _) = return $ TypedValue True v tyBoolean
@@ -670,7 +670,7 @@ infer' (TypedValue checkType val ty) = do
670infer' (PositionedValue pos val) = rethrowWithPosition pos $ infer' val
670infer' (PositionedValue pos val) = rethrowWithPosition pos $ infer' val
671infer' _ = error "Invalid argument to infer"
671infer' _ = error "Invalid argument to infer"
672
672
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)
674inferLetBinding seen [] ret j = (,) seen <$> makeBindingGroupVisible (j ret)
674inferLetBinding seen [] ret j = (,) seen <$> makeBindingGroupVisible (j ret)
675inferLetBinding seen (ValueDeclaration ident nameKind [] Nothing tv@(TypedValue checkType val ty) : rest) ret j = do
675inferLetBinding seen (ValueDeclaration ident nameKind [] Nothing tv@(TypedValue checkType val ty) : rest) ret j = do
676 Just moduleName <- checkCurrentModule <$> get
676 Just moduleName <- checkCurrentModule <$> get
@@ -810,7 +810,7 @@ skolemize ident sko scope = replaceTypeVars ident (Skolem ident sko scope)
810-- SuperClassDictionary placeholder. These type variables are somewhat unique since they are the
810-- SuperClassDictionary placeholder. These type variables are somewhat unique since they are the
811-- only example of scoped type variables.
811-- only example of scoped type variables.
812--
812--
813−skolemizeTypesInValue :: String -> Int -> SkolemScope -> Value -> Value
813+skolemizeTypesInValue :: String -> Int -> SkolemScope -> Expr -> Expr
814skolemizeTypesInValue ident sko scope = let (_, f, _) = everywhereOnValues id go id in f
814skolemizeTypesInValue ident sko scope = let (_, f, _) = everywhereOnValues id go id in f
815 where
815 where
816 go (SuperClassDictionary c ts) = SuperClassDictionary c (map (skolemize ident sko scope) ts)
816 go (SuperClassDictionary c ts) = SuperClassDictionary c (map (skolemize ident sko scope) ts)
@@ -828,8 +828,8 @@ introduceSkolemScope = everywhereOnTypesM go
828-- |
828-- |
829-- Check the type of a value, rethrowing errors to provide a better error message
829-- Check the type of a value, rethrowing errors to provide a better error message
830--
830--
831−check :: Value -> Type -> UnifyT Type Check Value
831+check :: Expr -> Type -> UnifyT Type Check Expr
832−check val ty = rethrow (mkErrorStack errorMessage (Just (ValueError val)) <>) $ check' val ty
832+check val ty = rethrow (mkErrorStack errorMessage (Just (ExprError val)) <>) $ check' val ty
833 where
833 where
834 errorMessage =
834 errorMessage =
835 "Error checking type of term " ++
835 "Error checking type of term " ++
@@ -840,7 +840,7 @@ check val ty = rethrow (mkErrorStack errorMessage (Just (ValueError val)) <>) $
840-- |
840-- |
841-- Check the type of a value
841-- Check the type of a value
842--
842--
843−check' :: Value -> Type -> UnifyT Type Check Value
843+check' :: Expr -> Type -> UnifyT Type Check Expr
844check' val (ForAll ident ty _) = do
844check' val (ForAll ident ty _) = do
845 scope <- newSkolemScope
845 scope <- newSkolemScope
846 sko <- newSkolemConstant
846 sko <- newSkolemConstant
@@ -963,7 +963,7 @@ check' val ty | containsTypeSynonyms ty = do
963 check val ty'
963 check val ty'
964check' (PositionedValue pos val) ty =
964check' (PositionedValue pos val) ty =
965 rethrowWithPosition pos $ check val ty
965 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))
967
967
968containsTypeSynonyms :: Type -> Bool
968containsTypeSynonyms :: Type -> Bool
969containsTypeSynonyms = everythingOnTypes (||) go where
969containsTypeSynonyms = everythingOnTypes (||) go where
@@ -975,15 +975,15 @@ containsTypeSynonyms = everythingOnTypes (||) go where
975--
975--
976-- The @lax@ parameter controls whether or not every record member has to be provided. For object updates, this is not the case.
976-- The @lax@ parameter controls whether or not every record member has to be provided. For object updates, this is not the case.
977--
977--
978−checkProperties :: [(String, Value)] -> Type -> Bool -> UnifyT Type Check [(String, Value)]
978+checkProperties :: [(String, Expr)] -> Type -> Bool -> UnifyT Type Check [(String, Expr)]
979checkProperties ps row lax = let (ts, r') = rowToList row in go ps ts r' where
979checkProperties ps row lax = let (ts, r') = rowToList row in go ps ts r' where
980 go [] [] REmpty = return []
980 go [] [] REmpty = return []
981 go [] [] u@(TUnknown _) = do u =?= REmpty
981 go [] [] u@(TUnknown _) = do u =?= REmpty
982 return []
982 return []
983 go [] [] (Skolem _ _ _) | lax = return []
983 go [] [] (Skolem _ _ _) | lax = return []
984 go [] ((p, _): _) _ | lax = return []
984 go [] ((p, _): _) _ | lax = return []
985− | otherwise = throwError $ mkErrorStack ("Object does not have property " ++ p) (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 (ValueError (ObjectLiteral ps)))
986+ go ((p,_):_) [] REmpty = throwError $ mkErrorStack ("Property " ++ p ++ " is not present in closed object type " ++ prettyPrintRow row) (Just (ExprError (ObjectLiteral ps)))
987 go ((p,v):ps') [] u@(TUnknown _) = do
987 go ((p,v):ps') [] u@(TUnknown _) = do
988 v'@(TypedValue _ _ ty) <- infer v
988 v'@(TypedValue _ _ ty) <- infer v
989 rest <- fresh
989 rest <- fresh
@@ -1002,13 +1002,13 @@ checkProperties ps row lax = let (ts, r') = rowToList row in go ps ts r' where
1002 v' <- check v ty
1002 v' <- check v ty
1003 ps'' <- go ps' (delete (p, ty) ts) r
1003 ps'' <- go ps' (delete (p, ty) ts) r
1004 return $ (p, v') : ps''
1004 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)))
1006
1006
1007-- |
1007-- |
1008-- Check the type of a function application, rethrowing errors to provide a better error message
1008-- Check the type of a function application, rethrowing errors to provide a better error message
1009--
1009--
1010−checkFunctionApplication :: Value -> Type -> Value -> Maybe Type -> UnifyT Type Check (Type, Value)
1010+checkFunctionApplication :: Expr -> Type -> Expr -> Maybe Type -> UnifyT Type Check (Type, Expr)
1011−checkFunctionApplication fn fnTy arg ret = rethrow (mkErrorStack errorMessage (Just (ValueError fn)) <>) $ do
1011+checkFunctionApplication fn fnTy arg ret = rethrow (mkErrorStack errorMessage (Just (ExprError fn)) <>) $ do
1012 subst <- unifyCurrentSubstitution <$> UnifyT get
1012 subst <- unifyCurrentSubstitution <$> UnifyT get
1013 checkFunctionApplication' fn (subst $? fnTy) arg (($?) subst <$> ret)
1013 checkFunctionApplication' fn (subst $? fnTy) arg (($?) subst <$> ret)
1014 where
1014 where
@@ -1019,7 +1019,7 @@ checkFunctionApplication fn fnTy arg ret = rethrow (mkErrorStack errorMessage (J
1019-- |
1019-- |
1020-- Check the type of a function application
1020-- Check the type of a function application
1021--
1021--
1022−checkFunctionApplication' :: Value -> Type -> Value -> Maybe Type -> UnifyT Type Check (Type, Value)
1022+checkFunctionApplication' :: Expr -> Type -> Expr -> Maybe Type -> UnifyT Type Check (Type, Expr)
1023checkFunctionApplication' fn (TypeApp (TypeApp tyFunction' argTy) retTy) arg ret = do
1023checkFunctionApplication' fn (TypeApp (TypeApp tyFunction' argTy) retTy) arg ret = do
1024 tyFunction' =?= tyFunction
1024 tyFunction' =?= tyFunction
1025 arg' <- check arg argTy
1025 arg' <- check arg argTy
@@ -1053,8 +1053,8 @@ checkFunctionApplication' _ fnTy arg _ = throwError . strMsg $ "Cannot apply a f
1053-- |
1053-- |
1054-- Check whether one type subsumes another, rethrowing errors to provide a better error message
1054-- Check whether one type subsumes another, rethrowing errors to provide a better error message
1055--
1055--
1056−subsumes :: Maybe Value -> Type -> Type -> UnifyT Type Check (Maybe Value)
1056+subsumes :: Maybe Expr -> Type -> Type -> UnifyT Type Check (Maybe Expr)
1057−subsumes val ty1 ty2 = rethrow (mkErrorStack errorMessage (ValueError <$> val) <>) $ subsumes' val ty1 ty2
1057+subsumes val ty1 ty2 = rethrow (mkErrorStack errorMessage (ExprError <$> val) <>) $ subsumes' val ty1 ty2
1058 where
1058 where
1059 errorMessage = "Error checking that type "
1059 errorMessage = "Error checking that type "
1060 ++ prettyPrintType ty1
1060 ++ prettyPrintType ty1
@@ -1064,7 +1064,7 @@ subsumes val ty1 ty2 = rethrow (mkErrorStack errorMessage (ValueError <$> val) <
1064-- |
1064-- |
1065-- Check whether one type subsumes another
1065-- Check whether one type subsumes another
1066--
1066--
1067−subsumes' :: Maybe Value -> Type -> Type -> UnifyT Type Check (Maybe Value)
1067+subsumes' :: Maybe Expr -> Type -> Type -> UnifyT Type Check (Maybe Expr)
1068subsumes' val (ForAll ident ty1 _) ty2 = do
1068subsumes' val (ForAll ident ty1 _) ty2 = do
1069 replaced <- replaceVarWithUnknown ident ty1
1069 replaced <- replaceVarWithUnknown ident ty1
1070 subsumes val replaced ty2
1070 subsumes val replaced ty2