summaryrefslogtreecommitdiff
path: root/src/GF/Source
diff options
context:
space:
mode:
Diffstat (limited to 'src/GF/Source')
-rw-r--r--src/GF/Source/CF.hs10
-rw-r--r--src/GF/Source/GrammarToSource.hs45
-rw-r--r--src/GF/Source/SourceToGrammar.hs66
3 files changed, 54 insertions, 67 deletions
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
generated by cgit v1.2.3 (git 2.39.1) at 2026-05-20 11:31:33 +0000