diff --git a/src/compiler/api/GF/Compile/CheckGrammar.hs b/src/compiler/api/GF/Compile/CheckGrammar.hs index c734d8cb7..350e2c81c 100644 --- a/src/compiler/api/GF/Compile/CheckGrammar.hs +++ b/src/compiler/api/GF/Compile/CheckGrammar.hs @@ -33,6 +33,7 @@ import GF.Compile.Compute.Concrete(normalForm,Globals(..),stdPredef) import GF.Grammar import GF.Grammar.Lexer import GF.Grammar.Lookup +import GF.Grammar.Lockfield import GF.Data.Operations import GF.Infra.CheckM @@ -198,9 +199,9 @@ checkInfo opts cwd sgr sm (c,info) = checkInModule cwd (snd sm) NoLoc empty $ do CncFun mty mt mpr mpmcfg -> do mt <- case (mty,mt) of - (Just (_,cat,cont,val),Just (L loc trm)) -> + (Just (args,cat,cont,val),Just (L loc trm)) -> chIn loc "linearization of" $ do - (trm,_) <- checkLType g trm (mkFunType (map (\(_,_,ty) -> ty) cont) val) -- erases arg vars + (trm,_) <- checkLType g trm (mkFunType (zipWith (\cat (_,_,ty) -> lock cat ty) args cont) val) -- erases arg vars return (Just (L loc (etaExpand [] trm cont))) _ -> return mt mpr <- case mpr of diff --git a/src/compiler/api/GF/Grammar/Lockfield.hs b/src/compiler/api/GF/Grammar/Lockfield.hs index 53e58a3ad..9eb487723 100644 --- a/src/compiler/api/GF/Grammar/Lockfield.hs +++ b/src/compiler/api/GF/Grammar/Lockfield.hs @@ -14,29 +14,28 @@ -- AR 8\/2\/2005 detached from 'compile/MkResource' ----------------------------------------------------------------------------- -module GF.Grammar.Lockfield (lockRecType, unlockRecord, lockLabel, isLockLabel) where +module GF.Grammar.Lockfield (lock, lockLabel, isLockLabel) where import GF.Infra.Ident +import GF.Grammar.Predef import GF.Grammar.Grammar -import GF.Grammar.Macros import GF.Data.Operations(ErrorMonad,Err(..)) -lockRecType :: ErrorMonad m => Ident -> Type -> m Type -lockRecType c t@(RecType rs) = - let lab = lockLabel c in - return $ if elem lab (map fst rs) || elem (showIdent c) ["String","Int"] - then t --- don't add an extra copy of lock field, nor predef cats - else RecType (rs ++ [(lockLabel c, RecType [])]) -lockRecType c t = plusRecType t $ RecType [(lockLabel c, RecType [])] - -unlockRecord :: Monad m => Ident -> Term -> m Term -unlockRecord c ft = do - let (xs,t) = termFormCnc ft - let lock = R [(lockLabel c, (Just (RecType []),R []))] - case plusRecord t lock of - Ok t' -> return $ mkAbs xs t' - _ -> return $ mkAbs xs (ExtR t lock) +lock :: Ident -> Term -> Term +lock c t@(RecType rs) = + let lbl = lockLabel c + in if elem lbl (map fst rs) || elem c [cString,cInt] + then t --- don't add an extra copy of lock field, nor predef cats + else RecType (rs ++ [(lbl, RecType [])]) +lock c t@(R rs) = + let lbl = lockLabel c + in if elem lbl (map fst rs) + then t + else R (rs ++ [(lbl, (Just (RecType []),R []))]) +lock c (Abs b x t) = Abs b x (lock c t) +lock c (FV ts) = FV (map (lock c) ts) +lock c t = t lockLabel :: Ident -> Label lockLabel c = LIdent $! prefixRawIdent lockPrefix (ident2raw c) @@ -46,5 +45,4 @@ isLockLabel l = case l of LIdent c -> isPrefixOf lockPrefix c _ -> False - lockPrefix = rawIdentS "lock_" diff --git a/src/compiler/api/GF/Grammar/Lookup.hs b/src/compiler/api/GF/Grammar/Lookup.hs index b756a2abb..6d427fc5d 100644 --- a/src/compiler/api/GF/Grammar/Lookup.hs +++ b/src/compiler/api/GF/Grammar/Lookup.hs @@ -45,10 +45,6 @@ import GF.Text.Pretty import qualified Data.Map as Map import qualified PGF2 --- whether lock fields are added in reuse -lock c = lockRecType c -- return -unlock c = unlockRecord c -- return - -- to look up a constant etc in a search tree --- why here? AR 29/5/2008 lookupIdent :: ErrorMonad m => Ident -> Map.Map Ident b -> m b lookupIdent c t = @@ -101,7 +97,7 @@ lookupQIdentInfo gr (m,c) = do lookupResDef :: ErrorMonad m => Grammar -> QIdent -> m Term lookupResDef gr (m,c) - | isPredefCat c = lock c defLinType + | isPredefCat c = return (lock c defLinType) | otherwise = look m c where look m c = do @@ -109,10 +105,10 @@ lookupResDef gr (m,c) case info of ResOper _ (Just (L _ t)) -> return t ResOper _ Nothing -> return (Q (m,c)) - CncCat (Just (L _ ty)) _ _ _ _ -> lock c ty - CncCat _ _ _ _ _ -> lock c defLinType + CncCat (Just (L _ ty)) _ _ _ _ -> return (lock c ty) + CncCat _ _ _ _ _ -> return (lock c defLinType) - CncFun (Just (_,cat,_,_)) (Just (L _ tr)) _ _ -> unlock cat tr + CncFun (Just (_,cat,_,_)) (Just (L _ tr)) _ _ -> return (lock cat tr) CncFun _ (Just (L _ tr)) _ _ -> return tr AnyInd _ n -> look n c @@ -128,9 +124,8 @@ lookupResType gr (m,c) = do -- used in reused concrete CncCat _ _ _ _ _ -> return typeType - CncFun (Just (_,cat,cont,val)) _ _ _ -> do - val' <- lock cat val - return $ mkProd cont val' [] + CncFun (Just (args,cat,cont,val)) _ _ _ -> + return $ (mkFunType (zipWith (\cat (_,_,ty) -> lock cat ty) args cont) (lock cat val)) AnyInd _ n -> lookupResType gr (n,c) ResParam _ _ -> return typePType ResValue (L _ t) _ -> return t @@ -145,8 +140,7 @@ lookupOverloadTypes gr id@(m,c) = do -- used in reused concrete CncCat _ _ _ _ _ -> ret typeType CncFun (Just (_,cat,cont,val)) _ _ _ -> do - val' <- lock cat val - ret $ mkProd cont val' [] + ret $ mkProd cont (lock cat val) [] ResParam _ _ -> ret typePType ResValue (L _ t) _ -> ret t ResOverload os tysts -> do @@ -265,13 +259,9 @@ allOpers gr = ResValue ltyp _ -> [ltyp] ResOverload _ tytrs -> [ltyp | (ltyp,_) <- tytrs] CncFun (Just (_,i,ctx,typ)) _ _ _ -> - [L NoLoc (mkProdSimple ctx (lock' i typ))] + [L NoLoc (mkProdSimple ctx (lock i typ))] _ -> [] - lock' i typ = case lock i typ of - Ok t -> t - _ -> typ - --- not for dependent types allOpersTo :: Grammar -> Type -> [(QIdent,Type,Location)] allOpersTo gr ty = [op | op@(_,typ,_) <- allOpers gr, isProdTo ty typ] where