mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-06-07 17:16:32 -06:00
Perhaps -> Maybe refactoring and better error message for conflicts during module update
This commit is contained in:
krasimir
@@ -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 ""
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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
|
||||
|
||||
Reference in New Issue
Block a user