diff --git a/src/GF/Devel/Compile/CheckGrammar.hs b/src/GF/Devel/Compile/CheckGrammar.hs index 4bf9049f2..40fe6075e 100644 --- a/src/GF/Devel/Compile/CheckGrammar.hs +++ b/src/GF/Devel/Compile/CheckGrammar.hs @@ -73,7 +73,7 @@ checkModule gf0 (name,mo) = checkIn ("checking module" +++ prt name) $ do ---- checkRestrictedInheritance gr (name, mo) mo1 <- case mtype mo of MTAbstract -> judgementOpModule (checkAbsInfo gr name) mo - MTGrammar -> judgementOpModule (checkResInfo gr name) mo + MTGrammar -> entryOpModule (checkResInfo gr name) mo MTConcrete aname -> do checkErr $ topoSortOpers $ allOperDependencies name $ mjments mo @@ -81,12 +81,12 @@ checkModule gf0 (name,mo) = checkIn ("checking module" +++ prt name) $ do mo1 <- checkCompleteGrammar abs mo entryOpModule (checkCncInfo gr name (aname,abs)) mo1 - MTInterface -> judgementOpModule (checkResInfo gr name) mo + MTInterface -> entryOpModule (checkResInfo gr name) mo MTInstance iname -> do intf <- checkErr $ lookupModule gr iname -- checkCompleteInstance abs mo -- this is done in Rebuild - judgementOpModule (checkResInfo gr name) mo + entryOpModule (checkResInfo gr name) mo return $ (name, mo1) @@ -202,8 +202,8 @@ checkCompleteGrammar abs cnc = do return $ Map.insert c (Left (cncCat defLinType)) js _ -> return js -checkResInfo :: GF -> Ident -> Judgement -> Check Judgement -checkResInfo gr mo info = do +checkResInfo :: GF -> Ident -> Ident -> Judgement -> Check Judgement +checkResInfo gr mo c info = do ---- checkReservedId c case jform info of JOper -> chIn "operation" $ case (jtype info, jdef info) of @@ -212,6 +212,7 @@ checkResInfo gr mo info = do return info (Meta _,de) -> do (de',ty') <- infer de + ---- trace ("inferred" +++ prt de' +++ ":" +++ prt ty') $ return (resOper ty' de') (ty, de) -> do ty' <- check ty typeType >>= comp . fst @@ -238,7 +239,7 @@ checkResInfo gr mo info = do where infer = inferLType gr check = checkLType gr - chIn cat = checkIn ("Happened in" +++ cat) ---- +++ prt c +++ ":") + chIn cat = checkIn ("Happened in" +++ cat +++ prt c +++ ":") comp = computeLType gr checkUniq xss = case xss of @@ -279,7 +280,7 @@ checkCncInfo gr cnc (a,abs) c info = do checkPrintname gr (jprintname info) return (info {jtype = typ'}) - _ -> checkResInfo gr cnc info + _ -> checkResInfo gr cnc c info where env = gr @@ -377,8 +378,8 @@ computeLType gr t = do let fs' = sortBy (\x y -> compare (fst x) (fst y)) fs liftM RecType $ mapPairsM comp fs' ----- _ | ty == typeStr -> return typeStr ----- _ | isPredefConstant ty -> return ty + _ | ty == typeTok -> return typeStr ---- deprecated + _ | isPredefConstant ty -> return ty _ -> composOp comp ty @@ -634,7 +635,7 @@ inferLType gr trm = case trm of -- the latter permits matching with value type getOverload :: GF -> Maybe Type -> Term -> Check (Maybe (Term,Type)) getOverload env@gr mt t = case appForm t of - (f@(Q m c), ts) -> case (return []) of ---- lookupOverload gr m c of + (f@(Q m c), ts) -> case lookupOverload gr m c of Ok typs -> do ttys <- mapM infer ts v <- matchOverload f typs ttys @@ -722,6 +723,8 @@ checkLType env trm typ0 = do (trm',ty') <- infer trm termWith trm' $ checkEq typ ty' trm' + EData -> return (trm,typ) + T _ [] -> prtFail "found empty table in type" typ T _ cs -> case typ of @@ -729,11 +732,11 @@ checkLType env trm typ0 = do case allParamValues env arg of Ok vs -> do let ps0 = map fst cs - ps <- checkErr $ testOvershadow ps0 vs + ps <- return [] ---- checkErr $ testOvershadow ps0 vs if null ps then return () - else checkWarn $ "WARNING: patterns never reached:" +++ - concat (intersperse ", " (map prt ps)) + else checkWarn $ "WARNING: patterns never reached:" + ---- +++ concat (intersperse ", " (map prt ps)) _ -> return () -- happens with variable types cs' <- mapM (checkCase arg val) cs @@ -953,6 +956,9 @@ checkIfEqLType env t u trm = do -- error (the empty type!) is subtype of any other type (_,Q (IC "Predef") (IC "Error")) -> True + -- unknown type unifies with any type ---- + (_,Meta _) -> True + -- contravariance (Prod x a b, Prod y c d) -> alpha g c a && alpha ((x,y):g) b d @@ -1010,7 +1016,7 @@ checkIfEqLType env t u trm = do ---- to revise allExtendsPlus _ n = [n] - sTypes = [typeStr, typeString] + sTypes = [typeStr, typeString, typeTok] ---- Tok deprecated comp = computeLType env -- printing a type with a lock field lock_C as C diff --git a/src/GF/Devel/Compile/Compile.hs b/src/GF/Devel/Compile/Compile.hs index 3b8558586..9c4079519 100644 --- a/src/GF/Devel/Compile/Compile.hs +++ b/src/GF/Devel/Compile/Compile.hs @@ -5,7 +5,7 @@ import GF.Devel.Compile.GetGrammar import GF.Devel.Compile.Extend import GF.Devel.Compile.Rename import GF.Devel.Compile.CheckGrammar -----import GF.Grammar.Refresh +import GF.Devel.Compile.Refresh ----import GF.Devel.Optimize ----import GF.Devel.OptimizeGF @@ -156,7 +156,12 @@ compileSourceModule opts env@(k,gr) mo@(i,mi) = do if null warnings then return () else putp warnings $ return () intermOut opts (iOpt "show_typecheck") (prMod moc) - return (k,mor) ---- + (k',mox) <- putpp " refreshing " $ ioeErr $ refreshModule k moc + intermOut opts (iOpt "show_refresh") (prMod mox) + + + + return (k,mox) ---- {- ---- @@ -173,10 +178,6 @@ compileSourceModule opts env@(k,gr) mo@(i,mi) = do if null warnings then return () else putp warnings $ return () intermOut opts (iOpt "show_typecheck") (prMod mo3) - - (k',mo3r:_) <- putpp " refreshing " $ ioeErr $ refreshModule (k,mos) mo3 - intermOut opts (iOpt "show_refresh") (prMod mo3r) - let eenv = () --- emptyEEnv (mo4,eenv') <- ---- if oElem "check_only" opts diff --git a/src/GF/Devel/Compile/Refresh.hs b/src/GF/Devel/Compile/Refresh.hs index c7c11fee4..2a7054851 100644 --- a/src/GF/Devel/Compile/Refresh.hs +++ b/src/GF/Devel/Compile/Refresh.hs @@ -9,20 +9,33 @@ -- > CVS $Author: bringert $ -- > CVS $Revision: 1.6 $ -- --- (Description of the module) +-- make variable names unique by adding an integer index to each ----------------------------------------------------------------------------- -module GF.Devel.Compile.Refresh (refreshTerm, refreshTermN, - refreshModule - ) where +module GF.Devel.Compile.Refresh ( + refreshModule, + refreshTerm, + refreshTermN + ) where + +import GF.Devel.Grammar.Modules +import GF.Devel.Grammar.Terms +import GF.Devel.Grammar.Macros +import GF.Infra.Ident import GF.Data.Operations -import GF.Grammar.Grammar -import GF.Infra.Ident -import GF.Infra.Modules -import GF.Grammar.Macros + import Control.Monad + +-- for concrete and resource in grammar, before optimizing + +refreshModule :: Int -> SourceModule -> Err (Int,SourceModule) +refreshModule k (m,mo) = do + (mo',(_,k')) <- appSTM (termOpModule refresh mo) (initIdStateN k) + return (k',(m,mo')) + + refreshTerm :: Term -> Err Term refreshTerm = refreshTermN 0 @@ -103,31 +116,3 @@ refreshEquation :: Equation -> Err ([Patt],Term) refreshEquation pst = err Bad (return . fst) (appSTM (refr pst) initIdState) where refr (ps,t) = liftM2 (,) (mapM refreshPatt ps) (refresh t) --- for concrete and resource in grammar, before optimizing - -refreshGrammar :: SourceGrammar -> Err SourceGrammar -refreshGrammar = liftM (MGrammar . snd) . foldM refreshModule (0,[]) . modules - -refreshModule :: (Int,[SourceModule]) -> SourceModule -> Err (Int,[SourceModule]) -refreshModule (k,ms) mi@(i,m) = case m of - ModMod mo@(Module mt fs st me ops js) | (isModCnc mo || isModRes mo) -> do - (k',js') <- foldM refreshRes (k,[]) $ tree2list js - return (k', (i, ModMod(Module mt fs st me ops (buildTree js'))) : ms) - _ -> return (k, mi:ms) - where - refreshRes (k,cs) ci@(c,info) = case info of - ResOper ptyp (Yes trm) -> do ---- refresh ptyp - (k',trm') <- refreshTermKN k trm - return $ (k', (c, ResOper ptyp (Yes trm')):cs) - ResOverload tyts -> do - (k',tyts') <- liftM (\ (t,(_,i)) -> (i,t)) $ - appSTM (mapPairsM refresh tyts) (initIdStateN k) - return $ (k', (c, ResOverload tyts'):cs) - CncCat mt (Yes trm) pn -> do ---- refresh mt, pn - (k',trm') <- refreshTermKN k trm - return $ (k', (c, CncCat mt (Yes trm') pn):cs) - CncFun mt (Yes trm) pn -> do ---- refresh pn - (k',trm') <- refreshTermKN k trm - return $ (k', (c, CncFun mt (Yes trm') pn):cs) - _ -> return (k, ci:cs) - diff --git a/src/GF/Devel/Grammar/Lookup.hs b/src/GF/Devel/Grammar/Lookup.hs index 3980577df..756345f2e 100644 --- a/src/GF/Devel/Grammar/Lookup.hs +++ b/src/GF/Devel/Grammar/Lookup.hs @@ -9,6 +9,7 @@ import GF.Infra.Ident import GF.Data.Operations +import Control.Monad (liftM) import Data.Map import Data.List (sortBy) ---- @@ -39,11 +40,26 @@ lookupLincat :: GF -> Ident -> Ident -> Err Term lookupLincat = lookupJField jtype lookupOperType :: GF -> Ident -> Ident -> Err Term -lookupOperType = lookupJField jtype +lookupOperType gr m c = do + ju <- lookupJudgement gr m c + case jform ju of + JParam -> return typePType + _ -> case jtype ju of + Meta _ -> fail "no type given" + ty -> return ty +---- can't be just lookupJField jtype lookupOperDef :: GF -> Ident -> Ident -> Err Term lookupOperDef = lookupJField jdef +lookupOverload :: GF -> Ident -> Ident -> Err [([Type],(Type,Term))] +lookupOverload gr m c = do + tr <- lookupJField jdef gr m c + case tr of + Overload tysts -> return + [(lmap snd args,(val,tr)) | (ty,tr) <- tysts, let (args,val) = prodForm ty] + _ -> Bad $ prt c +++ "is not an overloaded operation" + lookupParams :: GF -> Ident -> Ident -> Err [(Ident,Context)] lookupParams gf m c = do ty <- lookupJField jtype gf m c @@ -56,8 +72,14 @@ lookupParamValues :: GF -> Ident -> Ident -> Err [Term] lookupParamValues gf m c = do d <- lookupJField jdef gf m c case d of - V _ ts -> return ts - _ -> raise "no parameter values" + ---- V _ ts -> return ts + _ -> do + ps <- lookupParams gf m c + liftM concat $ mapM mkPar ps + where + mkPar (f,co) = do + vs <- liftM combinations $ mapM (\ (_,ty) -> allParamValues gf ty) co + return $ lmap (mkApp (QC m f)) vs allParamValues :: GF -> Type -> Err [Term] allParamValues cnc ptyp = case ptyp of @@ -95,4 +117,5 @@ mlookup = Data.Map.lookup raiseIdent msg i = raise (msg +++ prIdent i) +lmap = Prelude.map diff --git a/src/GF/Devel/Grammar/Macros.hs b/src/GF/Devel/Grammar/Macros.hs index 51c1669f4..db84fc7a4 100644 --- a/src/GF/Devel/Grammar/Macros.hs +++ b/src/GF/Devel/Grammar/Macros.hs @@ -163,6 +163,9 @@ typePType = Sort "PType" typeStr :: Type typeStr = Sort "Str" +typeTok :: Type ---- deprecated +typeTok = Sort "Tok" + cPredef :: Ident cPredef = identC "Predef" diff --git a/src/GF/Infra/CompactPrint.hs b/src/GF/Infra/CompactPrint.hs index 5625041cd..7b37679ee 100644 --- a/src/GF/Infra/CompactPrint.hs +++ b/src/GF/Infra/CompactPrint.hs @@ -5,7 +5,9 @@ compactPrint = compactPrintCustom keywordGF (const False) compactPrintGFCC = compactPrintCustom (const False) keywordGFCC -compactPrintCustom pre post = tail . concat . map (spaceIf pre post) . words +compactPrintCustom pre post = dps . concat . map (spaceIf pre post) . words + +dps = dropWhile isSpace spaceIf pre post w = case w of _ | pre w -> "\n" ++ w