diff options
Diffstat (limited to 'src/GF/Compile')
| -rw-r--r-- | src/GF/Compile/CheckGrammar.hs | 53 | ||||
| -rw-r--r-- | src/GF/Compile/Rename.hs | 2 |
2 files changed, 44 insertions, 11 deletions
diff --git a/src/GF/Compile/CheckGrammar.hs b/src/GF/Compile/CheckGrammar.hs index f0da2386a..9542331b4 100644 --- a/src/GF/Compile/CheckGrammar.hs +++ b/src/GF/Compile/CheckGrammar.hs @@ -171,7 +171,6 @@ checkResInfo :: SourceGrammar -> Ident -> (Ident,Info) -> Check (Ident,Info) checkResInfo gr mo (c,info) = do checkReservedId c case info of - ResOper pty pde -> chIn "operation" $ do (pty', pde') <- case (pty,pde) of (Yes ty, Yes de) -> do @@ -187,6 +186,11 @@ checkResInfo gr mo (c,info) = do _ -> return (pty, pde) --- other cases are uninteresting return (c, ResOper pty' pde') + ResOverload tysts -> chIn "overloading" $ do + tysts' <- mapM (uncurry $ flip check) tysts + ---- TODO: check uniqueness of arg type lists + return (c,ResOverload [(y,x) | (x,y) <- tysts']) + ResParam (Yes (pcs,_)) -> chIn "parameter type" $ do ---- mapM ((mapM (computeLType gr . snd)) . snd) pcs mapM_ ((mapM_ (checkIfParType gr . snd)) . snd) pcs @@ -200,6 +204,8 @@ checkResInfo gr mo (c,info) = do chIn cat = checkIn ("Happened in" +++ cat +++ prt c +++ ":") comp = computeLType gr + + checkCncInfo :: SourceGrammar -> Ident -> (Ident,SourceAbs) -> (Ident,Info) -> Check (Ident,Info) checkCncInfo gr m (a,abs) (c,info) = do @@ -378,16 +384,20 @@ inferLType gr trm = case trm of return (e,t') App f a -> do - (f',fty) <- infer f - fty' <- comp fty - case fty' of - Prod z arg val -> do - a' <- justCheck a arg - ty <- if isWildIdent z - then return val - else substituteLType [(z,a')] val - return (App f' a',ty) - _ -> prtFail ("function type expected for"+++ prt f +++"instead of") fty + over <- getOverload trm + case over of + Just trty -> return trty + _ -> do + (f',fty) <- infer f + fty' <- comp fty + case fty' of + Prod z arg val -> do + a' <- justCheck a arg + ty <- if isWildIdent z + then return val + else substituteLType [(z,a')] val + return (App f' a',ty) + _ -> prtFail ("function type expected for"+++ prt f +++"instead of") fty S f x -> do (f', fty) <- infer f @@ -550,6 +560,27 @@ inferLType gr trm = case trm of PRep _ -> return $ typeTok _ -> infer (patt2term p) >>= return . snd + getOverload t = case appForm t of + (f@(Q m c), ts) -> case lookupOverload gr m c of + Ok typs -> do + ttys <- mapM infer ts + v <- matchOverload f typs ttys + return $ Just v + _ -> return Nothing + _ -> return Nothing + + matchOverload f typs ttys = do + let (tts,tys) = unzip ttys + case lookupOverloadInstance tys typs of + Just (val,fun) -> return (mkApp fun tts, val) + _ -> fail $ "no overload instance of" +++ prt f +++ + "for" +++ unwords (map prt_ tys) +++ "among" ++++ + unlines [unwords (map prt_ ty) | (ty,_) <- typs] + ++++ "DEBUG" +++ unwords (map show tys) +++ ";" ++++ + unlines (map (show . fst) typs) ---- + + lookupOverloadInstance tys typs = lookup tys typs ---- use Map + checkLType :: SourceGrammar -> Term -> Type -> Check (Term, Type) checkLType env trm typ0 = do diff --git a/src/GF/Compile/Rename.hs b/src/GF/Compile/Rename.hs index 4276fc6e8..0e408aaee 100644 --- a/src/GF/Compile/Rename.hs +++ b/src/GF/Compile/Rename.hs @@ -159,6 +159,8 @@ renameInfo status (i,info) = errIn ("renaming definition of" +++ prt i) $ AbsTrans f -> liftM AbsTrans (rent f) ResOper pty ptr -> liftM2 ResOper (ren pty) (ren ptr) + ResOverload tysts -> liftM ResOverload $ mapM (pairM rent) tysts + ResParam (Yes (pp,m)) -> do pp' <- mapM (renameParam status) pp return $ ResParam $ Yes (pp',m) |