diff --git a/src/compiler/GF/Compile/Rename.hs b/src/compiler/GF/Compile/Rename.hs index 9e959c353..6031ab938 100644 --- a/src/compiler/GF/Compile/Rename.hs +++ b/src/compiler/GF/Compile/Rename.hs @@ -39,7 +39,7 @@ import GF.Grammar.Printer import GF.Data.Operations import Control.Monad -import Data.List (nub) +import Data.List (nub,(\\)) import Text.PrettyPrint -- | this gives top-level access to renaming term input in the cc command @@ -235,76 +235,80 @@ renameTerm env vars = ren vars where -- | vars not needed in env, since patterns always overshadow old vars renamePattern :: Status -> Patt -> Check (Patt,[Ident]) -renamePattern env patt = case patt of +renamePattern env patt = + do r@(p',vs) <- renp patt + let dupl = vs \\ nub vs + unless (null dupl) $ checkError (hang (text "[C.4.13] Pattern is not linear:") 4 + (ppPatt Unqualified 0 patt)) + return r + where + renp patt = case patt of + PMacro c -> do + c' <- renid $ Vr c + case c' of + Q d -> renp $ PM d + _ -> checkError (text "unresolved pattern" <+> ppPatt Unqualified 0 patt) - PMacro c -> do - c' <- renid $ Vr c - case c' of - Q d -> renp $ PM d - _ -> checkError (text "unresolved pattern" <+> ppPatt Unqualified 0 patt) + PC c ps -> do + c' <- renid $ Cn c + case c' of + QC c -> do psvss <- mapM renp ps + let (ps,vs) = unzip psvss + return (PP c ps, concat vs) + Q _ -> checkError (text "data constructor expected but" <+> ppTerm Qualified 0 c' <+> text "is found instead") + _ -> checkError (text "unresolved data constructor" <+> ppTerm Qualified 0 c') - PC c ps -> do - c' <- renid $ Cn c - case c' of - QC c -> do psvss <- mapM renp ps - let (ps,vs) = unzip psvss - return (PP c ps, concat vs) - Q _ -> checkError (text "data constructor expected but" <+> ppTerm Qualified 0 c' <+> text "is found instead") - _ -> checkError (text "unresolved data constructor" <+> ppTerm Qualified 0 c') + PP c ps -> do + (QC c') <- renid (QC c) + psvss <- mapM renp ps + let (ps',vs) = unzip psvss + return (PP c' ps', concat vs) - PP c ps -> do - (QC c') <- renid (QC c) - psvss <- mapM renp ps - let (ps',vs) = unzip psvss - return (PP c' ps', concat vs) + PM c -> do + x <- renid (Q c) + c' <- case x of + (Q c') -> return c' + _ -> checkError (text "not a pattern macro" <+> ppPatt Qualified 0 patt) + return (PM c', []) - PM c -> do - x <- renid (Q c) - c' <- case x of - (Q c') -> return c' - _ -> checkError (text "not a pattern macro" <+> ppPatt Qualified 0 patt) - return (PM c', []) + PV x -> checks [ renid' (Vr x) >>= \t' -> case t' of + QC c -> return (PP c [],[]) + _ -> checkError (text "not a constructor") + , return (patt, [x]) + ] - PV x -> checks [ renid' (Vr x) >>= \t' -> case t' of - QC c -> return (PP c [],[]) - _ -> checkError (text "not a constructor") - , return (patt, [x]) - ] + PR r -> do + let (ls,ps) = unzip r + psvss <- mapM renp ps + let (ps',vs') = unzip psvss + return (PR (zip ls ps'), concat vs') - PR r -> do - let (ls,ps) = unzip r - psvss <- mapM renp ps - let (ps',vs') = unzip psvss - return (PR (zip ls ps'), concat vs') + PAlt p q -> do + (p',vs) <- renp p + (q',ws) <- renp q + return (PAlt p' q', vs ++ ws) - PAlt p q -> do - (p',vs) <- renp p - (q',ws) <- renp q - return (PAlt p' q', vs ++ ws) + PSeq p q -> do + (p',vs) <- renp p + (q',ws) <- renp q + return (PSeq p' q', vs ++ ws) - PSeq p q -> do - (p',vs) <- renp p - (q',ws) <- renp q - return (PSeq p' q', vs ++ ws) + PRep p -> do + (p',vs) <- renp p + return (PRep p', vs) - PRep p -> do - (p',vs) <- renp p - return (PRep p', vs) + PNeg p -> do + (p',vs) <- renp p + return (PNeg p', vs) - PNeg p -> do - (p',vs) <- renp p - return (PNeg p', vs) + PAs x p -> do + (p',vs) <- renp p + return (PAs x p', x:vs) - PAs x p -> do - (p',vs) <- renp p - return (PAs x p', x:vs) + _ -> return (patt,[]) - _ -> return (patt,[]) - - where - renp = renamePattern env - renid = renameIdentTerm env - renid' = renameIdentTerm' env + renid = renameIdentTerm env + renid' = renameIdentTerm' env renameContext :: Status -> Context -> Check Context renameContext b = renc [] where