From 01fef5109c2920d13004ae5b94d192fa5fba205f Mon Sep 17 00:00:00 2001 From: krasimir Date: Mon, 23 Feb 2009 12:42:44 +0000 Subject: Perhaps -> Maybe refactoring and better error message for conflicts during module update --- src/GF/Source/CF.hs | 10 +++--- src/GF/Source/GrammarToSource.hs | 45 ++++++++++----------------- src/GF/Source/SourceToGrammar.hs | 66 ++++++++++++++++++++-------------------- 3 files changed, 54 insertions(+), 67 deletions(-) (limited to 'src/GF/Source') diff --git a/src/GF/Source/CF.hs b/src/GF/Source/CF.hs index ae42958b6..b142fd670 100644 --- a/src/GF/Source/CF.hs +++ b/src/GF/Source/CF.hs @@ -94,9 +94,9 @@ cf2grammar :: CF -> (BinTree Ident Info, BinTree Ident Info) cf2grammar rules = (buildTree abs, buildTree conc) where abs = cats ++ funs conc = lincats ++ lins - cats = [(cat, AbsCat (yes []) (yes [])) | + cats = [(cat, AbsCat (Just []) (Just [])) | cat <- nub (concat (map cf2cat rules))] ----notPredef cat - lincats = [(cat, CncCat (yes defLinType) nope nope) | (cat,AbsCat _ _) <- cats] + lincats = [(cat, CncCat (Just defLinType) Nothing Nothing) | (cat,AbsCat _ _) <- cats] (funs,lins) = unzip (map cf2rule rules) cf2cat :: CFRule -> [Ident] @@ -105,15 +105,15 @@ cf2cat (_,(cat, items)) = map identS $ cat : [c | Left c <- items] cf2rule :: CFRule -> ((Ident,Info),(Ident,Info)) cf2rule (fun, (cat, items)) = (def,ldef) where f = identS fun - def = (f, AbsFun (yes (mkProd (args', Cn (identS cat), []))) nope) + def = (f, AbsFun (Just (mkProd (args', Cn (identS cat), []))) Nothing) args0 = zip (map (identS . ("x" ++) . show) [0..]) items args = [(v, Cn (identS c)) | (v, Left c) <- args0] args' = [(identS "_", Cn (identS c)) | (_, Left c) <- args0] ldef = (f, CncFun Nothing - (yes (mkAbs (map fst args) + (Just (mkAbs (map fst args) (mkRecord (const theLinLabel) [foldconcat (map mkIt args0)]))) - nope) + Nothing) mkIt (v, Left _) = P (Vr v) theLinLabel mkIt (_, Right a) = K a foldconcat [] = K "" diff --git a/src/GF/Source/GrammarToSource.hs b/src/GF/Source/GrammarToSource.hs index d16d75971..19035dca2 100644 --- a/src/GF/Source/GrammarToSource.hs +++ b/src/GF/Source/GrammarToSource.hs @@ -74,18 +74,16 @@ mkTopDefs ds = ds trAnyDef :: (Ident,Info) -> [P.TopDef] trAnyDef (i,info) = let i' = tri i in case info of - AbsCat (Yes co) pd -> [P.DefCat [P.SimpleCatDef i' (map trDecl co)]] - AbsFun (Yes ty) (Yes EData) -> [P.DefFunData [P.FunDef [i'] (trt ty)]] - AbsFun (Yes ty) pt -> [P.DefFun [P.FunDef [i'] (trt ty)]] ++ case pt of - Yes t -> [P.DefDef [P.DDef [mkName i'] (trt t)]] - _ -> [] - AbsFun (May b) _ -> [P.DefFun [P.FunDef [i'] (P.EIndir (tri b))]] + AbsCat (Just co) pd -> [P.DefCat [P.SimpleCatDef i' (map trDecl co)]] + AbsFun (Just ty) (Just EData) -> [P.DefFunData [P.FunDef [i'] (trt ty)]] + AbsFun (Just ty) pt -> [P.DefFun [P.FunDef [i'] (trt ty)]] ++ case pt of + Just t -> [P.DefDef [P.DDef [mkName i'] (trt t)]] + Nothing -> [] ResOper pty ptr -> [P.DefOper [trDef i' pty ptr]] ResParam pp -> [P.DefPar [case pp of - Yes (ps,_) -> P.ParDefDir i' [P.ParConstr (tri c) (map trDecl co) | (c,co) <- ps] - May b -> P.ParDefIndir i' $ tri b - _ -> P.ParDefAbs i']] + Just (ps,_) -> P.ParDefDir i' [P.ParConstr (tri c) (map trDecl co) | (c,co) <- ps] + Nothing -> P.ParDefAbs i']] ResOverload os tysts -> [P.DefOper [P.DDef [mkName i'] ( @@ -94,34 +92,23 @@ trAnyDef (i,info) = let i' = tri i in case info of (map (P.EIdent . tri) os ++ [P.ERecord [P.LDFull [i'] (trt ty) (trt fu) | (ty,fu) <- tysts]]))]] - CncCat (Yes ty) Nope _ -> + CncCat (Just ty) Nothing _ -> [P.DefLincat [P.PrintDef [mkName i'] (trt ty)]] CncCat pty ptr ppr -> [P.DefLindef [trDef i' pty ptr]] ++ - [P.DefPrintCat [P.PrintDef [mkName i'] (trt pr)] | Yes pr <- [ppr]] + [P.DefPrintCat [P.PrintDef [mkName i'] (trt pr)] | Just pr <- [ppr]] CncFun _ ptr ppr -> - [P.DefLin [trDef i' nope ptr]] ++ - [P.DefPrintFun [P.PrintDef [mkName i'] (trt pr)] | Yes pr <- [ppr]] -{- - ---- encoding of AnyInd without changing syntax. AR 20/9/2007 - AnyInd s b -> - [P.DefOper [P.DDef [mkName i] - (P.EApp (P.EInt (if s then 1 else 0)) (P.EIdent (tri b)))]] --} + [P.DefLin [trDef i' Nothing ptr]] ++ + [P.DefPrintFun [P.PrintDef [mkName i'] (trt pr)] | Just pr <- [ppr]] _ -> [] -trDef :: P.PIdent -> Perh Type -> Perh Term -> P.Def +trDef :: P.PIdent -> Maybe Type -> Maybe Term -> P.Def trDef i pty ptr = case (pty,ptr) of - (Nope, Nope) -> P.DDef [mkName i] (P.EMeta) --- - (_, Nope) -> P.DDecl [mkName i] (trPerh pty) - (Nope, _ ) -> P.DDef [mkName i] (trPerh ptr) - (_, _ ) -> P.DFull [mkName i] (trPerh pty) (trPerh ptr) - -trPerh p = case p of - Yes t -> trt t - May b -> P.EIndir $ tri b - _ -> P.EMeta --- + (Nothing, Nothing) -> P.DDef [mkName i] (P.EMeta) --- + (_, Nothing) -> P.DDecl [mkName i] (maybe P.EMeta trt pty) + (Nothing, _ ) -> P.DDef [mkName i] (maybe P.EMeta trt ptr) + (_, _ ) -> P.DFull [mkName i] (maybe P.EMeta trt pty) (maybe P.EMeta trt ptr) trFlags :: Options -> [P.TopDef] trFlags = map trFlag . optionsGFO diff --git a/src/GF/Source/SourceToGrammar.hs b/src/GF/Source/SourceToGrammar.hs index a52c6c2be..67de8fd46 100644 --- a/src/GF/Source/SourceToGrammar.hs +++ b/src/GF/Source/SourceToGrammar.hs @@ -107,7 +107,7 @@ transModDef x = case x of opens' <- transOpens opens defs0 <- mapM trDef $ getTopDefs defs poss0 <- return [(i,p) | Left ds <- defs0, (i,p,_) <- ds] - defs' <- U.buildAnyTree [(i,d) | Left ds <- defs0, (i,_,d) <- ds] + defs' <- U.buildAnyTree id' [(i,d) | Left ds <- defs0, (i,_,d) <- ds] flags' <- return $ concatOptions [o | Right o <- defs0] let poss1 = buildPosTree id' poss0 return (id', GM.ModInfo mtyp' mstat' flags' extends' Nothing opens' [] defs' poss1) @@ -122,7 +122,7 @@ transModDef x = case x of opens' <- transOpens opens defs0 <- mapM trDef $ getTopDefs defs poss0 <- return [(i,p) | Left ds <- defs0, (i,p,_) <- ds] - defs' <- U.buildAnyTree [(i,d) | Left ds <- defs0, (i,_,d) <- ds] + defs' <- U.buildAnyTree id' [(i,d) | Left ds <- defs0, (i,_,d) <- ds] flags' <- return $ concatOptions [o | Right o <- defs0] let poss1 = buildPosTree id' poss0 return (id', GM.ModInfo mtyp' mstat' flags' extends' (Just (fst m',snd m',insts')) opens' [] defs' poss1) @@ -212,23 +212,23 @@ transAbsDef x = case x of DefCat catdefs -> liftM (Left . concat) $ mapM transCatDef catdefs DefFun fundefs -> do fundefs' <- mapM transFunDef fundefs - returnl [(fun, nopos, G.AbsFun (yes typ) nope) | (funs,typ) <- fundefs', fun <- funs] + returnl [(fun, nopos, G.AbsFun (Just typ) Nothing) | (funs,typ) <- fundefs', fun <- funs] DefFunData fundefs -> do fundefs' <- mapM transFunDef fundefs returnl $ - [(cat, nopos, G.AbsCat nope (yes [G.Cn fun])) | (funs,typ) <- fundefs', + [(cat, nopos, G.AbsCat Nothing (Just [G.Cn fun])) | (funs,typ) <- fundefs', fun <- funs, Ok (_,cat) <- [M.valCat typ] ] ++ - [(fun, nopos, G.AbsFun (yes typ) (yes G.EData)) | (funs,typ) <- fundefs', fun <- funs] + [(fun, nopos, G.AbsFun (Just typ) (Just G.EData)) | (funs,typ) <- fundefs', fun <- funs] DefDef defs -> do defs' <- liftM concat $ mapM getDefsGen defs - returnl [(c, nopos, G.AbsFun nope pe) | ((c,p),(_,pe)) <- defs'] + returnl [(c, nopos, G.AbsFun Nothing pe) | ((c,p),(_,pe)) <- defs'] DefData ds -> do ds' <- mapM transDataDef ds returnl $ - [(c, nopos, G.AbsCat nope (yes ps)) | (c,ps) <- ds'] ++ - [(f, nopos, G.AbsFun nope (yes G.EData)) | (_,fs) <- ds', tf <- fs, f <- funs tf] + [(c, nopos, G.AbsCat Nothing (Just ps)) | (c,ps) <- ds'] ++ + [(f, nopos, G.AbsFun Nothing (Just G.EData)) | (_,fs) <- ds', tf <- fs, f <- funs tf] DefFlag defs -> liftM (Right . concatOptions) $ mapM transFlagDef defs _ -> Bad $ "illegal definition in abstract module:" ++++ printTree x where @@ -262,24 +262,24 @@ transCatDef x = case x of cat i pos ddecls = do -- i <- transIdent id cont <- liftM concat $ mapM transDDecl ddecls - return (i, pos, G.AbsCat (yes cont) nope) + return (i, pos, G.AbsCat (Just cont) Nothing) listCat id ddecls size = do (id',pos) <- getIdentPos id let li = mkListId id' baseId = mkBaseId id' consId = mkConsId id' - catd0@(c,p,G.AbsCat (Yes cont0) _) <- cat li pos ddecls + catd0@(c,p,G.AbsCat (Just cont0) _) <- cat li pos ddecls let - catd = (c,pos,G.AbsCat (Yes cont0) (Yes [G.Cn baseId,G.Cn consId])) + catd = (c,pos,G.AbsCat (Just cont0) (Just [G.Cn baseId,G.Cn consId])) cont = [(mkId x i,ty) | (i,(x,ty)) <- zip [0..] cont0] xs = map (G.Vr . fst) cont cd = M.mkDecl (M.mkApp (G.Vr id') xs) lc = M.mkApp (G.Vr li) xs niltyp = M.mkProdSimple (cont ++ genericReplicate size cd) lc - nilfund = (baseId, nopos, G.AbsFun (yes niltyp) (yes G.EData)) + nilfund = (baseId, nopos, G.AbsFun (Just niltyp) (Just G.EData)) constyp = M.mkProdSimple (cont ++ [cd, M.mkDecl lc]) lc - consfund = (consId, nopos, G.AbsFun (yes constyp) (yes G.EData)) + consfund = (consId, nopos, G.AbsFun (Just constyp) (Just G.EData)) return [catd,nilfund,consfund] mkId x i = if isWildIdent x then (varX i) else x @@ -300,10 +300,10 @@ transResDef x = case x of DefPar pardefs -> do pardefs' <- mapM transParDef pardefs returnl $ [(p, nopos, G.ResParam (if null pars - then nope -- abstract param type - else (yes (pars,Nothing)))) + then Nothing -- abstract param type + else (Just (pars,Nothing)))) | (p,pars) <- pardefs'] - ++ [(f, nopos, G.ResValue (yes (M.mkProdSimple co (G.Cn p),Nothing))) | + ++ [(f, nopos, G.ResValue (Just (M.mkProdSimple co (G.Cn p),Nothing))) | (p,pars) <- pardefs', (f,co) <- pars] DefOper defs -> do @@ -319,7 +319,7 @@ transResDef x = case x of _ -> Bad $ "illegal definition form in resource" +++ printTree x where mkOverload op@(c,p,j) = case j of - G.ResOper _ (Yes df) -> case M.appForm df of + G.ResOper _ (Just df) -> case M.appForm df of (keyw, ts@(_:_)) | isOverloading keyw -> case last ts of G.R fs -> [(c,p,G.ResOverload [m | G.Vr m <- ts] [(ty,fu) | (_,(Just ty,fu)) <- fs])] @@ -327,7 +327,7 @@ transResDef x = case x of _ -> [op] -- to enable separare type signature --- not type-checked - G.ResOper (Yes df) _ -> case M.appForm df of + G.ResOper (Just df) _ -> case M.appForm df of (keyw, ts@(_:_)) | isOverloading keyw -> case last ts of G.RecType _ -> [] _ -> [op] @@ -349,27 +349,27 @@ transCncDef :: TopDef -> Err (Either [(Ident, Int, G.Info)] GO.Options) transCncDef x = case x of DefLincat defs -> do defs' <- liftM concat $ mapM transPrintDef defs - returnl [(f, nopos, G.CncCat (yes t) nope nope) | (f,t) <- defs'] + returnl [(f, nopos, G.CncCat (Just t) Nothing Nothing) | (f,t) <- defs'] DefLindef defs -> do defs' <- liftM concat $ mapM getDefs defs - returnl [(f, p, G.CncCat pt pe nope) | ((f,p),(pt,pe)) <- defs'] + returnl [(f, p, G.CncCat pt pe Nothing) | ((f,p),(pt,pe)) <- defs'] DefLin defs -> do defs' <- liftM concat $ mapM getDefs defs - returnl [(f, p, G.CncFun Nothing pe nope) | ((f,p),(_,pe)) <- defs'] + returnl [(f, p, G.CncFun Nothing pe Nothing) | ((f,p),(_,pe)) <- defs'] DefPrintCat defs -> do defs' <- liftM concat $ mapM transPrintDef defs - returnl [(f, nopos, G.CncCat nope nope (yes e)) | (f,e) <- defs'] + returnl [(f, nopos, G.CncCat Nothing Nothing (Just e)) | (f,e) <- defs'] DefPrintFun defs -> do defs' <- liftM concat $ mapM transPrintDef defs - returnl [(f, nopos, G.CncFun Nothing nope (yes e)) | (f,e) <- defs'] + returnl [(f, nopos, G.CncFun Nothing Nothing (Just e)) | (f,e) <- defs'] DefPrintOld defs -> do --- a guess, for backward compatibility defs' <- liftM concat $ mapM transPrintDef defs - returnl [(f, nopos, G.CncFun Nothing nope (yes e)) | (f,e) <- defs'] + returnl [(f, nopos, G.CncFun Nothing Nothing (Just e)) | (f,e) <- defs'] DefFlag defs -> liftM (Right . concatOptions) $ mapM transFlagDef defs DefPattern defs -> do defs' <- liftM concat $ mapM getDefs defs - let defs2 = [(f, termInPattern t) | (f,(_,Yes t)) <- defs'] - returnl [(f, p, G.CncFun Nothing (yes t) nope) | ((f,p),t) <- defs2] + let defs2 = [(f, termInPattern t) | (f,(_,Just t)) <- defs'] + returnl [(f, p, G.CncFun Nothing (Just t) Nothing) | ((f,p),t) <- defs2] _ -> errIn ("illegal definition in concrete syntax:") $ transResDef x @@ -379,35 +379,35 @@ transPrintDef x = case x of (ids,e) <- liftM2 (,) (mapM transName ids) (transExp exp) return $ [(i,e) | i <- ids] -getDefsGen :: Def -> Err [((Ident, Int),(G.Perh G.Type, G.Perh G.Term))] +getDefsGen :: Def -> Err [((Ident, Int),(Maybe G.Type, Maybe G.Term))] getDefsGen d = case d of DDecl ids t -> do ids' <- mapM transNamePos ids t' <- transExp t - return [(i,(yes t', nope)) | i <- ids'] + return [(i,(Just t', Nothing)) | i <- ids'] DDef ids e -> do ids' <- mapM transNamePos ids e' <- transExp e - return [(i,(nope, yes e')) | i <- ids'] + return [(i,(Nothing, Just e')) | i <- ids'] DFull ids t e -> do ids' <- mapM transNamePos ids t' <- transExp t e' <- transExp e - return [(i,(yes t', yes e')) | i <- ids'] + return [(i,(Just t', Just e')) | i <- ids'] DPatt id patts e -> do id' <- transNamePos id ps' <- mapM transPatt patts e' <- transExp e - return [(id',(nope, yes (G.Eqs [(ps',e')])))] + return [(id',(Nothing, Just (G.Eqs [(ps',e')])))] -- | sometimes you need this special case, e.g. in linearization rules -getDefs :: Def -> Err [((Ident,Int), (G.Perh G.Type, G.Perh G.Term))] +getDefs :: Def -> Err [((Ident,Int), (Maybe G.Type, Maybe G.Term))] getDefs d = case d of DPatt id patts e -> do id' <- transNamePos id xs <- mapM tryMakeVar patts e' <- transExp e - return [(id',(nope, yes (M.mkAbs xs e')))] + return [(id',(Nothing, Just (M.mkAbs xs e')))] _ -> getDefsGen d -- | accepts a pattern that is either a variable or a wild card -- cgit v1.2.3