diff options
author | Péter Diviánszky <divipp@gmail.com> | 2016-05-05 15:28:08 +0200 |
---|---|---|
committer | Péter Diviánszky <divipp@gmail.com> | 2016-05-05 15:28:08 +0200 |
commit | f24ab8bd8d5cb60a7a75e52655b567f916f73a53 (patch) | |
tree | 2ca518cb2aed46d71889f6c3f49c7c1880aa684f /src | |
parent | c5a72c2e9a15525dabab33ed55f6936d60943ddc (diff) |
show error location in recheck
Diffstat (limited to 'src')
-rw-r--r-- | src/LambdaCube/Compiler/Infer.hs | 36 |
1 files changed, 20 insertions, 16 deletions
diff --git a/src/LambdaCube/Compiler/Infer.hs b/src/LambdaCube/Compiler/Infer.hs index 1dea1e3b..b511d9c0 100644 --- a/src/LambdaCube/Compiler/Infer.hs +++ b/src/LambdaCube/Compiler/Infer.hs | |||
@@ -432,13 +432,15 @@ inferN_ tellTrace = infer where | |||
432 | 432 | ||
433 | type Message = String | 433 | type Message = String |
434 | 434 | ||
435 | recheck :: Message -> Env -> ExpType -> ExpType | 435 | recheck :: Monad m => SIName -> Env -> ExpType -> m ExpType |
436 | recheck msg e = recheck' msg e | 436 | recheck sn e = return . recheck' sn e |
437 | 437 | ||
438 | -- todo: check type also | 438 | -- todo: check type also |
439 | recheck' :: Message -> Env -> ExpType -> ExpType | 439 | recheck' :: SIName -> Env -> ExpType -> ExpType |
440 | recheck' msg' e (ET x xt) = ET (recheck_ "main" (checkEnv e) (ET x xt)) xt | 440 | recheck' sn e (ET x xt) = ET (recheck_ "main" (checkEnv e) (ET x xt)) xt |
441 | where | 441 | where |
442 | err s = error $ "At " ++ ppShow sn ++ "\n" ++ s | ||
443 | |||
442 | checkEnv = \case | 444 | checkEnv = \case |
443 | e@EGlobal{} -> e | 445 | e@EGlobal{} -> e |
444 | EBind1 si h e b -> EBind1 si h (checkEnv e) b | 446 | EBind1 si h e b -> EBind1 si h (checkEnv e) b |
@@ -475,10 +477,10 @@ recheck' msg' e (ET x xt) = ET (recheck_ "main" (checkEnv e) (ET x xt)) xt | |||
475 | checkApps s acc zt f _ t [] | 477 | checkApps s acc zt f _ t [] |
476 | | t == zt = f $ reverse acc | 478 | | t == zt = f $ reverse acc |
477 | | otherwise = | 479 | | otherwise = |
478 | error $ "checkApps' " ++ s ++ " " ++ msg ++ "\n" ++ showEnvExp te{-todo-} (ET t TType) ++ "\n\n" ++ showEnvExp te (ET zt TType) | 480 | err $ "checkApps' " ++ s ++ " " ++ msg ++ "\n" ++ showEnvExp te{-todo-} (ET t TType) ++ "\n\n" ++ showEnvExp te (ET zt TType) |
479 | checkApps s acc zt f te t@(hnf -> Pi h x y) (b_: xs) = checkApps (s++"+") (b: acc) zt f te (appTy t b) xs where b = recheck_ "checkApps" te (ET b_ x) | 481 | checkApps s acc zt f te t@(hnf -> Pi h x y) (b_: xs) = checkApps (s++"+") (b: acc) zt f te (appTy t b) xs where b = recheck_ "checkApps" te (ET b_ x) |
480 | checkApps s acc zt f te t _ = | 482 | checkApps s acc zt f te t _ = |
481 | error $ "checkApps " ++ s ++ " " ++ msg ++ "\n" ++ showEnvExp te{-todo-} (ET t TType) ++ "\n\n" ++ showEnvExp e (ET x xt) | 483 | err $ "checkApps " ++ s ++ " " ++ msg ++ "\n" ++ showEnvExp te{-todo-} (ET t TType) ++ "\n\n" ++ showEnvExp e (ET x xt) |
482 | 484 | ||
483 | -------------------------------------------------------------------------------- inference for statements | 485 | -------------------------------------------------------------------------------- inference for statements |
484 | 486 | ||
@@ -491,12 +493,12 @@ inference (x:xs) = do | |||
491 | handleStmt :: MonadFix m => Stmt -> IM m GlobalEnv | 493 | handleStmt :: MonadFix m => Stmt -> IM m GlobalEnv |
492 | handleStmt = \case | 494 | handleStmt = \case |
493 | Primitive n t_ -> do | 495 | Primitive n t_ -> do |
494 | t <- inferType $ trSExp' t_ | 496 | t <- inferType n $ trSExp' t_ |
495 | tellType (sourceInfo n) t | 497 | tellType (sourceInfo n) t |
496 | addToEnv n $ flip ET t $ lamify t $ DFun (mkFName n) t | 498 | addToEnv n $ flip ET t $ lamify t $ DFun (mkFName n) t |
497 | Let n mt t_ -> do | 499 | Let n mt t_ -> do |
498 | let t__ = maybe id (flip SAnn) mt t_ | 500 | let t__ = maybe id (flip SAnn) mt t_ |
499 | ET x t <- inferTerm (sName n) $ trSExp' $ addFix n t__ | 501 | ET x t <- inferTerm n $ trSExp' $ addFix n t__ |
500 | tellType (sourceInfo n) t | 502 | tellType (sourceInfo n) t |
501 | addToEnv n (ET (mkELet n x t EGlobal) t) | 503 | addToEnv n (ET (mkELet n x t EGlobal) t) |
502 | {- -- hack | 504 | {- -- hack |
@@ -511,7 +513,7 @@ handleStmt = \case | |||
511 | -} | 513 | -} |
512 | PrecDef{} -> return mempty | 514 | PrecDef{} -> return mempty |
513 | Data s (map (second trSExp') -> ps) (trSExp' -> t_@(UncurryS tl_ _)) cs -> do | 515 | Data s (map (second trSExp') -> ps) (trSExp' -> t_@(UncurryS tl_ _)) cs -> do |
514 | vty <- inferType $ UncurryS ps t_ | 516 | vty <- inferType s $ UncurryS ps t_ |
515 | tellType (sourceInfo s) vty | 517 | tellType (sourceInfo s) vty |
516 | let | 518 | let |
517 | sint = mkFName s | 519 | sint = mkFName s |
@@ -521,7 +523,7 @@ handleStmt = \case | |||
521 | mkConstr j (cn, trSExp' -> ct@(UncurryS ctl (AppsS c (map snd -> xs)))) | 523 | mkConstr j (cn, trSExp' -> ct@(UncurryS ctl (AppsS c (map snd -> xs)))) |
522 | | c == SGlobal s && take pnum' xs == downToS "a3" (length ctl) pnum' | 524 | | c == SGlobal s && take pnum' xs == downToS "a3" (length ctl) pnum' |
523 | = do | 525 | = do |
524 | cty <- removeHiddenUnit <$> inferType (UncurryS [(Hidden, x) | (Visible, x) <- ps] ct) | 526 | cty <- removeHiddenUnit <$> inferType cn (UncurryS [(Hidden, x) | (Visible, x) <- ps] ct) |
525 | -- tellType (sourceInfo cn) cty | 527 | -- tellType (sourceInfo cn) cty |
526 | let pars = zipWith (\x -> second $ STyped . flip ET TType . rUp (1+j) x) [0..] $ drop (length ps) $ fst $ getParams cty | 528 | let pars = zipWith (\x -> second $ STyped . flip ET TType . rUp (1+j) x) [0..] $ drop (length ps) $ fst $ getParams cty |
527 | act = length . fst . getParams $ cty | 529 | act = length . fst . getParams $ cty |
@@ -542,7 +544,7 @@ handleStmt = \case | |||
542 | let tcn = TyConName sint inum vty (map fst cons') cfn | 544 | let tcn = TyConName sint inum vty (map fst cons') cfn |
543 | e1 <- addToEnv s (ET (TyCon tcn []) vty) | 545 | e1 <- addToEnv s (ET (TyCon tcn []) vty) |
544 | (unzip -> (mconcat -> es, cons)) <- withEnv e1 $ zipWithM mkConstr [0..] cs | 546 | (unzip -> (mconcat -> es, cons)) <- withEnv e1 $ zipWithM mkConstr [0..] cs |
545 | ct <- withEnv (e1 <> es) $ inferType | 547 | ct <- withEnv (e1 <> es) $ inferType s |
546 | ( UncurryS | 548 | ( UncurryS |
547 | ( [(Hidden, x) | (_, x) <- ps] | 549 | ( [(Hidden, x) | (_, x) <- ps] |
548 | ++ (Visible, motive) | 550 | ++ (Visible, motive) |
@@ -566,10 +568,12 @@ handleStmt = \case | |||
566 | 568 | ||
567 | stmt -> error $ "handleStmt: " ++ ppShow stmt | 569 | stmt -> error $ "handleStmt: " ++ ppShow stmt |
568 | 570 | ||
569 | inferTerm :: Monad m => String -> SExp2 -> IM m ExpType | 571 | inferTerm :: Monad m => SIName -> SExp2 -> IM m ExpType |
570 | inferTerm msg t = | 572 | inferTerm sn t = fmap closedExp $ recheck sn EGlobal . replaceMetas (lamPi Hidden) =<< inferN EGlobal t |
571 | fmap (closedExp . recheck msg EGlobal . replaceMetas (lamPi Hidden)) $ inferN EGlobal t | 573 | |
572 | inferType :: Monad m => SExp2 -> IM m Type | 574 | inferType :: Monad m => SIName -> SExp2 -> IM m Type |
573 | inferType t = fmap (closedExp . expr . recheck "inferType" EGlobal . flip ET TType . replaceMetas (Pi Hidden) . fmap expr) $ inferN (CheckType_ (debugSI "inferType CheckType_") TType EGlobal) t | 575 | inferType sn t = fmap (closedExp . expr) |
576 | $ recheck sn EGlobal . flip ET TType . replaceMetas (Pi Hidden) . fmap expr | ||
577 | =<< inferN (CheckType_ (sourceInfo sn) TType EGlobal) t | ||
574 | 578 | ||
575 | 579 | ||