1
0
forked from GitHub/gf-core

printing line numbers in rename and check-grammar error messages

This commit is contained in:
aarne
2008-05-31 16:30:36 +00:00
parent 9229c15764
commit bd7d0c7c5e
5 changed files with 114 additions and 73 deletions

View File

@@ -69,24 +69,24 @@ checkModule ms (name,mod) = checkIn ("checking module" +++ prt name) $ case mod
let js = jments mo let js = jments mo
checkRestrictedInheritance ms (name, mo) checkRestrictedInheritance ms (name, mo)
js' <- case mtype mo of js' <- case mtype mo of
MTAbstract -> mapsCheckTree (checkAbsInfo gr name) js MTAbstract -> mapsCheckTree (checkAbsInfo gr name mo) js
MTTransfer a b -> mapsCheckTree (checkAbsInfo gr name) js MTTransfer a b -> mapsCheckTree (checkAbsInfo gr name mo) js
MTResource -> mapsCheckTree (checkResInfo gr name) js MTResource -> mapsCheckTree (checkResInfo gr name mo) js
MTConcrete a -> do MTConcrete a -> do
checkErr $ topoSortOpers $ allOperDependencies name js checkErr $ topoSortOpers $ allOperDependencies name js
ModMod abs <- checkErr $ lookupModule gr a ModMod abs <- checkErr $ lookupModule gr a
js1 <- checkCompleteGrammar abs mo js1 <- checkCompleteGrammar abs mo
mapsCheckTree (checkCncInfo gr name (a,abs)) js1 mapsCheckTree (checkCncInfo gr name mo (a,abs)) js1
MTInterface -> mapsCheckTree (checkResInfo gr name) js MTInterface -> mapsCheckTree (checkResInfo gr name mo) js
MTInstance a -> do MTInstance a -> do
ModMod abs <- checkErr $ lookupModule gr a ModMod abs <- checkErr $ lookupModule gr a
-- checkCompleteInstance abs mo -- this is done in Rebuild -- checkCompleteInstance abs mo -- this is done in Rebuild
mapsCheckTree (checkResInfo gr name) js mapsCheckTree (checkResInfo gr name mo) js
return $ (name, ModMod (replaceJudgements mo js')) : ms return $ (name, ModMod (replaceJudgements mo js')) : ms
@@ -126,8 +126,9 @@ justCheckLTerm src t = do
((t',_),_) <- checkStart (inferLType src t) ((t',_),_) <- checkStart (inferLType src t)
return t' return t'
checkAbsInfo :: SourceGrammar -> Ident -> (Ident,Info) -> Check (Ident,Info) checkAbsInfo ::
checkAbsInfo st m (c,info) = do SourceGrammar -> Ident -> Module Ident Info -> (Ident,Info) -> Check (Ident,Info)
checkAbsInfo st m mo (c,info) = do
---- checkReservedId c ---- checkReservedId c
case info of case info of
AbsCat (Yes cont) _ -> mkCheck "category" $ AbsCat (Yes cont) _ -> mkCheck "category" $
@@ -147,12 +148,17 @@ checkAbsInfo st m (c,info) = do
mkCheck cat ss = case ss of mkCheck cat ss = case ss of
[] -> return (c,info) [] -> return (c,info)
["[]"] -> return (c,info) ---- ["[]"] -> return (c,info) ----
_ -> checkErr $ prtBad (unlines ss ++++ "in" +++ cat) c _ -> checkErr $ Bad (unlines ss ++++ "in" +++ cat +++ prt c +++ pos c)
---- temporary solution when tc of defs is incomplete ---- temporary solution when tc of defs is incomplete
mkCheckWarn cat ss = case ss of mkCheckWarn cat ss = case ss of
[] -> return (c,info) [] -> return (c,info)
["[]"] -> return (c,info) ---- ["[]"] -> return (c,info) ----
_ -> checkWarn (unlines ss ++++ "in" +++ cat +++ prt c) >> return (c,info) _ -> do
checkWarn (unlines ss ++++ "in" +++ cat +++ prt c +++ pos c)
return (c,info)
pos c = showPosition mo c
compAbsTyp g t = case t of compAbsTyp g t = case t of
Vr x -> maybe (fail ("no value given to variable" +++ prt x)) return $ lookup x g Vr x -> maybe (fail ("no value given to variable" +++ prt x)) return $ lookup x g
Let (x,(_,a)) b -> do Let (x,(_,a)) b -> do
@@ -205,8 +211,9 @@ checkCompleteGrammar abs cnc = do
-- | General Principle: only Yes-values are checked. -- | General Principle: only Yes-values are checked.
-- A May-value has always been checked in its origin module. -- A May-value has always been checked in its origin module.
checkResInfo :: SourceGrammar -> Ident -> (Ident,Info) -> Check (Ident,Info) checkResInfo ::
checkResInfo gr mo (c,info) = do SourceGrammar -> Ident -> Module Ident Info -> (Ident,Info) -> Check (Ident,Info)
checkResInfo gr mo mm (c,info) = do
checkReservedId c checkReservedId c
case info of case info of
ResOper pty pde -> chIn "operation" $ do ResOper pty pde -> chIn "operation" $ do
@@ -243,8 +250,9 @@ checkResInfo gr mo (c,info) = do
where where
infer = inferLType gr infer = inferLType gr
check = checkLType gr check = checkLType gr
chIn cat = checkIn ("Happened in" +++ cat +++ prt c +++ ":") chIn cat = checkIn ("Happened in" +++ cat +++ prt c +++ pos c +++ ":")
comp = computeLType gr comp = computeLType gr
pos c = showPosition mm c
checkUniq xss = case xss of checkUniq xss = case xss of
x:y:xs x:y:xs
@@ -254,9 +262,10 @@ checkResInfo gr mo (c,info) = do
_ -> return () _ -> return ()
checkCncInfo :: SourceGrammar -> Ident -> (Ident,SourceAbs) -> checkCncInfo :: SourceGrammar -> Ident -> Module Ident Info ->
(Ident,SourceAbs) ->
(Ident,Info) -> Check (Ident,Info) (Ident,Info) -> Check (Ident,Info)
checkCncInfo gr m (a,abs) (c,info) = do checkCncInfo gr m mo (a,abs) (c,info) = do
checkReservedId c checkReservedId c
case info of case info of
@@ -281,14 +290,15 @@ checkCncInfo gr m (a,abs) (c,info) = do
checkPrintname gr mpr checkPrintname gr mpr
return (c,CncCat (Yes typ') mdef' mpr) return (c,CncCat (Yes typ') mdef' mpr)
_ -> checkResInfo gr m (c,info) _ -> checkResInfo gr m mo (c,info)
where where
env = gr env = gr
infer = inferLType gr infer = inferLType gr
comp = computeLType gr comp = computeLType gr
check = checkLType gr check = checkLType gr
chIn cat = checkIn ("Happened in" +++ cat +++ prt c +++ ":") chIn cat = checkIn ("Happened in" +++ cat +++ prt c +++ pos c +++ ":")
pos c = showPosition mo c
checkIfParType :: SourceGrammar -> Type -> Check () checkIfParType :: SourceGrammar -> Type -> Check ()
checkIfParType st typ = checkCond ("Not parameter type" +++ prt typ) (isParType typ) checkIfParType st typ = checkCond ("Not parameter type" +++ prt typ) (isParType typ)

View File

@@ -56,7 +56,10 @@ rebuildModule ms mo@(i,mi) = do
m0s <- mapM (lookupModMod gr) j0s m0s <- mapM (lookupModMod gr) j0s
let notInM0 c _ = all (not . isInBinTree c . jments) m0s let notInM0 c _ = all (not . isInBinTree c . jments) m0s
let js2 = filterBinTree notInM0 js' let js2 = filterBinTree notInM0 js'
return $ replaceJudgements m js2 return $ (replaceJudgements m js2)
{positions =
buildTree (tree2list (positions m1) ++
tree2list (positions m))}
return $ ModMod m' return $ ModMod m'
_ -> return mi _ -> return mi

View File

@@ -58,7 +58,7 @@ renameModule ms (name,mod) = errIn ("renaming module" +++ prt name) $ case mod o
ModMod mo -> do ModMod mo -> do
let js1 = jments mo let js1 = jments mo
status <- buildStatus (MGrammar ms) name mod status <- buildStatus (MGrammar ms) name mod
js2 <- mapsErrTree (renameInfo status) js1 js2 <- mapsErrTree (renameInfo mo status) js1
let mod2 = ModMod $ mo {opens = map forceQualif (opens mo), jments = js2} let mod2 = ModMod $ mo {opens = map forceQualif (opens mo), jments = js2}
return $ (name,mod2) : ms return $ (name,mod2) : ms
@@ -160,8 +160,9 @@ forceQualif o = case o of
OSimple q i -> OQualif q i i OSimple q i -> OQualif q i i
OQualif q _ i -> OQualif q i i OQualif q _ i -> OQualif q i i
renameInfo :: Status -> (Ident,Info) -> Err (Ident,Info) renameInfo :: Module Ident Info -> Status -> (Ident,Info) -> Err (Ident,Info)
renameInfo status (i,info) = errIn ("renaming definition of" +++ prt i) $ renameInfo mo status (i,info) = errIn
("renaming definition of" +++ prt i +++ showPosition mo i) $
liftM ((,) i) $ case info of liftM ((,) i) $ case info of
AbsCat pco pfs -> liftM2 AbsCat (renPerh (renameContext status) pco) AbsCat pco pfs -> liftM2 AbsCat (renPerh (renameContext status) pco)
(renPerh (mapM rent) pfs) (renPerh (mapM rent) pfs)

View File

@@ -34,6 +34,7 @@ module GF.Infra.Modules (
IdentM(..), IdentM(..),
typeOfModule, abstractOfConcrete, abstractModOfConcrete, typeOfModule, abstractOfConcrete, abstractModOfConcrete,
lookupModule, lookupModuleType, lookupModMod, lookupInfo, lookupModule, lookupModuleType, lookupModMod, lookupInfo,
lookupPosition, showPosition,
allModMod, isModAbs, isModRes, isModCnc, isModTrans, allModMod, isModAbs, isModRes, isModCnc, isModTrans,
sameMType, isCompilableModule, isCompleteModule, sameMType, isCompilableModule, isCompleteModule,
allAbstracts, greatestAbstract, allResources, allAbstracts, greatestAbstract, allResources,
@@ -326,6 +327,16 @@ lookupModMod gr i = do
lookupInfo :: (Show i, Ord i) => Module i a -> i -> Err a lookupInfo :: (Show i, Ord i) => Module i a -> i -> Err a
lookupInfo mo i = lookupTree show i (jments mo) lookupInfo mo i = lookupTree show i (jments mo)
lookupPosition :: (Show i, Ord i) => Module i a -> i -> Err (String,(Int,Int))
lookupPosition mo i = lookupTree show i (positions mo)
showPosition :: (Show i, Ord i) => Module i a -> i -> String
showPosition mo i = case lookupPosition mo i of
Ok (f,(b,e)) | b == e -> "in" +++ f ++ ", line" +++ show b
Ok (f,(b,e)) -> "in" +++ f ++ ", lines" +++ show b ++ "-" ++ show e
_ -> ""
allModMod :: (Show i,Eq i) => MGrammar i a -> [(i,Module i a)] allModMod :: (Show i,Eq i) => MGrammar i a -> [(i,Module i a)]
allModMod gr = [(i,m) | (i, ModMod m) <- modules gr] allModMod gr = [(i,m) | (i, ModMod m) <- modules gr]

View File

@@ -59,6 +59,11 @@ transName n = case n of
IdentName i -> transIdent i IdentName i -> transIdent i
ListName i -> liftM mkListId (transIdent i) ListName i -> liftM mkListId (transIdent i)
transNamePos :: Name -> Err (Ident,Int)
transNamePos n = case n of
IdentName i -> getIdentPos i
ListName i -> liftM (\ (c,p) -> (mkListId c,p)) (getIdentPos i)
transGrammar :: Grammar -> Err G.SourceGrammar transGrammar :: Grammar -> Err G.SourceGrammar
transGrammar x = case x of transGrammar x = case x of
Gr moddefs -> do Gr moddefs -> do
@@ -108,9 +113,12 @@ transModDef x = case x of
extends' <- transExtend extends extends' <- transExtend extends
opens' <- transOpens opens opens' <- transOpens opens
defs0 <- mapM trDef $ getTopDefs defs defs0 <- mapM trDef $ getTopDefs defs
defs' <- U.buildAnyTree [d | Left ds <- defs0, d <- ds] poss0 <- return [(i,p) | Left ds <- defs0, (i,p,_) <- ds]
defs' <- U.buildAnyTree [(i,d) | Left ds <- defs0, (i,_,d) <- ds]
flags' <- return $ concatModuleOptions [o | Right o <- defs0] flags' <- return $ concatModuleOptions [o | Right o <- defs0]
return (id',GM.ModMod (GM.Module mtyp' mstat' flags' extends' opens' defs' poss)) let poss1 = buildPosTree id' poss0
return (id',
GM.ModMod (GM.Module mtyp' mstat' flags' extends' opens' defs' poss1))
MReuse _ -> do MReuse _ -> do
return (id', GM.ModMod (GM.Module mtyp' mstat' noModuleOptions [] [] emptyBinTree poss)) return (id', GM.ModMod (GM.Module mtyp' mstat' noModuleOptions [] [] emptyBinTree poss))
MUnion imps -> do MUnion imps -> do
@@ -127,10 +135,12 @@ transModDef x = case x of
insts' <- mapM transOpen insts insts' <- mapM transOpen insts
opens' <- transOpens opens opens' <- transOpens opens
defs0 <- mapM trDef $ getTopDefs defs defs0 <- mapM trDef $ getTopDefs defs
defs' <- U.buildAnyTree [d | Left ds <- defs0, d <- ds] poss0 <- return [(i,p) | Left ds <- defs0, (i,p,_) <- ds]
defs' <- U.buildAnyTree [(i,d) | Left ds <- defs0, (i,_,d) <- ds]
flags' <- return $ concatModuleOptions [o | Right o <- defs0] flags' <- return $ concatModuleOptions [o | Right o <- defs0]
let poss1 = buildPosTree id' poss0
return (id', return (id',
GM.ModWith (GM.Module mtyp' mstat' flags' extends' opens' defs' poss) m' insts') GM.ModWith (GM.Module mtyp' mstat' flags' extends' opens' defs' poss1) m' insts')
mkModRes id mtyp body = do mkModRes id mtyp body = do
id' <- transIdent id id' <- transIdent id
@@ -217,31 +227,43 @@ transIncludedExt x = case x of
ISome i ids -> liftM2 (,) (transIdent i) (liftM GM.MIOnly $ mapM transIdent ids) ISome i ids -> liftM2 (,) (transIdent i) (liftM GM.MIOnly $ mapM transIdent ids)
IMinus i ids -> liftM2 (,) (transIdent i) (liftM GM.MIExcept $ mapM transIdent ids) IMinus i ids -> liftM2 (,) (transIdent i) (liftM GM.MIExcept $ mapM transIdent ids)
transAbsDef :: TopDef -> Err (Either [(Ident, G.Info)] GO.ModuleOptions) --- where no position is saved
nopos :: Int
nopos = -1
buildPosTree :: Ident -> [(Ident,Int)] -> BinTree Ident (String,(Int,Int))
buildPosTree m = buildTree . mkPoss . filter ((>0) . snd) where
mkPoss cs = case cs of
(i,p):rest@((_,q):_) -> (i,(name,(p,max p (q-1)))) : mkPoss rest
(i,p):[] -> (i,(name,(p,p+100))) : [] --- don't know last line
_ -> []
name = prIdent m ++ ".gf" ----
transAbsDef :: TopDef -> Err (Either [(Ident, Int, G.Info)] GO.ModuleOptions)
transAbsDef x = case x of transAbsDef x = case x of
DefCat catdefs -> liftM (Left . concat) $ mapM transCatDef catdefs DefCat catdefs -> liftM (Left . concat) $ mapM transCatDef catdefs
DefFun fundefs -> do DefFun fundefs -> do
fundefs' <- mapM transFunDef fundefs fundefs' <- mapM transFunDef fundefs
returnl [(fun, G.AbsFun (yes typ) nope) | (funs,typ) <- fundefs', fun <- funs] returnl [(fun, nopos, G.AbsFun (yes typ) nope) | (funs,typ) <- fundefs', fun <- funs]
DefFunData fundefs -> do DefFunData fundefs -> do
fundefs' <- mapM transFunDef fundefs fundefs' <- mapM transFunDef fundefs
returnl $ returnl $
[(cat, G.AbsCat nope (yes [G.Cn fun])) | (funs,typ) <- fundefs', [(cat, nopos, G.AbsCat nope (yes [G.Cn fun])) | (funs,typ) <- fundefs',
fun <- funs, fun <- funs,
Ok (_,cat) <- [M.valCat typ] Ok (_,cat) <- [M.valCat typ]
] ++ ] ++
[(fun, G.AbsFun (yes typ) (yes G.EData)) | (funs,typ) <- fundefs', fun <- funs] [(fun, nopos, G.AbsFun (yes typ) (yes G.EData)) | (funs,typ) <- fundefs', fun <- funs]
DefDef defs -> do DefDef defs -> do
defs' <- liftM concat $ mapM getDefsGen defs defs' <- liftM concat $ mapM getDefsGen defs
returnl [(c, G.AbsFun nope pe) | (c,(_,pe)) <- defs'] returnl [(c, nopos, G.AbsFun nope pe) | ((c,p),(_,pe)) <- defs']
DefData ds -> do DefData ds -> do
ds' <- mapM transDataDef ds ds' <- mapM transDataDef ds
returnl $ returnl $
[(c, G.AbsCat nope (yes ps)) | (c,ps) <- ds'] ++ [(c, nopos, G.AbsCat nope (yes ps)) | (c,ps) <- ds'] ++
[(f, G.AbsFun nope (yes G.EData)) | (_,fs) <- ds', tf <- fs, f <- funs tf] [(f, nopos, G.AbsFun nope (yes G.EData)) | (_,fs) <- ds', tf <- fs, f <- funs tf]
DefTrans defs -> do DefTrans defs -> do
defs' <- liftM concat $ mapM getDefsGen defs defs' <- liftM concat $ mapM getDefsGen defs
returnl [(c, G.AbsTrans f) | (c,(_,Yes f)) <- defs'] returnl [(c, nopos, G.AbsTrans f) | ((c,p),(_,Yes f)) <- defs']
DefFlag defs -> liftM (Right . concatModuleOptions) $ mapM transFlagDef defs DefFlag defs -> liftM (Right . concatModuleOptions) $ mapM transFlagDef defs
_ -> Bad $ "illegal definition in abstract module:" ++++ printTree x _ -> Bad $ "illegal definition in abstract module:" ++++ printTree x
where where
@@ -264,35 +286,35 @@ transFlagDef x = case x of
-- | Cat definitions can also return some fun defs -- | Cat definitions can also return some fun defs
-- if it is a list category definition -- if it is a list category definition
transCatDef :: CatDef -> Err [(Ident, G.Info)] transCatDef :: CatDef -> Err [(Ident, Int, G.Info)]
transCatDef x = case x of transCatDef x = case x of
SimpleCatDef id ddecls -> do SimpleCatDef id ddecls -> do
id' <- transIdent id (id',pos) <- getIdentPos id
liftM (:[]) $ cat id' ddecls liftM (:[]) $ cat id' pos ddecls
ListCatDef id ddecls -> listCat id ddecls 0 ListCatDef id ddecls -> listCat id ddecls 0
ListSizeCatDef id ddecls size -> listCat id ddecls size ListSizeCatDef id ddecls size -> listCat id ddecls size
where where
cat i ddecls = do cat i pos ddecls = do
-- i <- transIdent id -- i <- transIdent id
cont <- liftM concat $ mapM transDDecl ddecls cont <- liftM concat $ mapM transDDecl ddecls
return (i, G.AbsCat (yes cont) nope) return (i, pos, G.AbsCat (yes cont) nope)
listCat id ddecls size = do listCat id ddecls size = do
id' <- transIdent id (id',pos) <- getIdentPos id
let let
li = mkListId id' li = mkListId id'
baseId = mkBaseId id' baseId = mkBaseId id'
consId = mkConsId id' consId = mkConsId id'
catd0@(c,G.AbsCat (Yes cont0) _) <- cat li ddecls catd0@(c,p,G.AbsCat (Yes cont0) _) <- cat li pos ddecls
let let
catd = (c,G.AbsCat (Yes cont0) (Yes [G.Cn baseId,G.Cn consId])) catd = (c,pos,G.AbsCat (Yes cont0) (Yes [G.Cn baseId,G.Cn consId]))
cont = [(mkId x i,ty) | (i,(x,ty)) <- zip [0..] cont0] cont = [(mkId x i,ty) | (i,(x,ty)) <- zip [0..] cont0]
xs = map (G.Vr . fst) cont xs = map (G.Vr . fst) cont
cd = M.mkDecl (M.mkApp (G.Vr id') xs) cd = M.mkDecl (M.mkApp (G.Vr id') xs)
lc = M.mkApp (G.Vr li) xs lc = M.mkApp (G.Vr li) xs
niltyp = M.mkProdSimple (cont ++ genericReplicate size cd) lc niltyp = M.mkProdSimple (cont ++ genericReplicate size cd) lc
nilfund = (baseId, G.AbsFun (yes niltyp) (yes G.EData)) nilfund = (baseId, nopos, G.AbsFun (yes niltyp) (yes G.EData))
constyp = M.mkProdSimple (cont ++ [cd, M.mkDecl lc]) lc constyp = M.mkProdSimple (cont ++ [cd, M.mkDecl lc]) lc
consfund = (consId, G.AbsFun (yes constyp) (yes G.EData)) consfund = (consId, nopos, G.AbsFun (yes constyp) (yes G.EData))
return [catd,nilfund,consfund] return [catd,nilfund,consfund]
mkId x i = if isWildIdent x then (varX i) else x mkId x i = if isWildIdent x then (varX i) else x
@@ -308,44 +330,38 @@ transDataDef x = case x of
DataId id -> liftM G.Cn $ transIdent id DataId id -> liftM G.Cn $ transIdent id
DataQId id0 id -> liftM2 G.QC (transIdent id0) (transIdent id) DataQId id0 id -> liftM2 G.QC (transIdent id0) (transIdent id)
transResDef :: TopDef -> Err (Either [(Ident, G.Info)] GO.ModuleOptions) transResDef :: TopDef -> Err (Either [(Ident, Int, G.Info)] GO.ModuleOptions)
transResDef x = case x of transResDef x = case x of
DefPar pardefs -> do DefPar pardefs -> do
pardefs' <- mapM transParDef pardefs pardefs' <- mapM transParDef pardefs
returnl $ [(p, G.ResParam (if null pars returnl $ [(p, nopos, G.ResParam (if null pars
then nope -- abstract param type then nope -- abstract param type
else (yes (pars,Nothing)))) else (yes (pars,Nothing))))
| (p,pars) <- pardefs'] | (p,pars) <- pardefs']
++ [(f, G.ResValue (yes (M.mkProdSimple co (G.Cn p),Nothing))) | ++ [(f, nopos, G.ResValue (yes (M.mkProdSimple co (G.Cn p),Nothing))) |
(p,pars) <- pardefs', (f,co) <- pars] (p,pars) <- pardefs', (f,co) <- pars]
{-
---- encoding of AnyInd without changing syntax. AR 20/9/2007
DefOper [DDef [c] (EApp (EInt status) (EIdent mo))] -> do
c' <- transName c
mo' <- transIdent mo
return $ Left [(c',G.AnyInd (status==1) mo')]
-}
DefOper defs -> do DefOper defs -> do
defs' <- liftM concat $ mapM getDefs defs defs' <- liftM concat $ mapM getDefs defs
returnl $ concatMap mkOverload [(f, G.ResOper pt pe) | (f,(pt,pe)) <- defs'] returnl $
concatMap mkOverload [(f, p, G.ResOper pt pe) | ((f,p),(pt,pe)) <- defs']
DefLintype defs -> do DefLintype defs -> do
defs' <- liftM concat $ mapM getDefs defs defs' <- liftM concat $ mapM getDefs defs
returnl [(f, G.ResOper pt pe) | (f,(pt,pe)) <- defs'] returnl [(f, p, G.ResOper pt pe) | ((f,p),(pt,pe)) <- defs']
DefFlag defs -> liftM (Right . concatModuleOptions) $ mapM transFlagDef defs DefFlag defs -> liftM (Right . concatModuleOptions) $ mapM transFlagDef defs
_ -> Bad $ "illegal definition form in resource" +++ printTree x _ -> Bad $ "illegal definition form in resource" +++ printTree x
where where
mkOverload (c,j) = case j of mkOverload (c,p,j) = case j of
G.ResOper _ (Yes (G.App keyw (G.R fs@(_:_:_)))) | G.ResOper _ (Yes (G.App keyw (G.R fs@(_:_:_)))) |
isOverloading keyw c fs -> isOverloading keyw c fs ->
[(c,G.ResOverload [(ty,fu) | (_,(Just ty,fu)) <- fs])] [(c,p,G.ResOverload [(ty,fu) | (_,(Just ty,fu)) <- fs])]
-- to enable separare type signature --- not type-checked -- to enable separare type signature --- not type-checked
G.ResOper (Yes (G.App keyw (G.RecType fs@(_:_:_)))) _ | G.ResOper (Yes (G.App keyw (G.RecType fs@(_:_:_)))) _ |
isOverloading keyw c fs -> [] isOverloading keyw c fs -> []
_ -> [(c,j)] _ -> [(c,p,j)]
isOverloading keyw c fs = isOverloading keyw c fs =
GP.prt keyw == "overload" && -- overload is a "soft keyword" GP.prt keyw == "overload" && -- overload is a "soft keyword"
all (== GP.prt c) (map (GP.prt . fst) fs) all (== GP.prt c) (map (GP.prt . fst) fs)
@@ -356,31 +372,31 @@ transParDef x = case x of
ParDefAbs id -> liftM2 (,) (transIdent id) (return []) ParDefAbs id -> liftM2 (,) (transIdent id) (return [])
_ -> Bad $ "illegal definition in resource:" ++++ printTree x _ -> Bad $ "illegal definition in resource:" ++++ printTree x
transCncDef :: TopDef -> Err (Either [(Ident, G.Info)] GO.ModuleOptions) transCncDef :: TopDef -> Err (Either [(Ident, Int, G.Info)] GO.ModuleOptions)
transCncDef x = case x of transCncDef x = case x of
DefLincat defs -> do DefLincat defs -> do
defs' <- liftM concat $ mapM transPrintDef defs defs' <- liftM concat $ mapM transPrintDef defs
returnl [(f, G.CncCat (yes t) nope nope) | (f,t) <- defs'] returnl [(f, nopos, G.CncCat (yes t) nope nope) | (f,t) <- defs']
DefLindef defs -> do DefLindef defs -> do
defs' <- liftM concat $ mapM getDefs defs defs' <- liftM concat $ mapM getDefs defs
returnl [(f, G.CncCat pt pe nope) | (f,(pt,pe)) <- defs'] returnl [(f, p, G.CncCat pt pe nope) | ((f,p),(pt,pe)) <- defs']
DefLin defs -> do DefLin defs -> do
defs' <- liftM concat $ mapM getDefs defs defs' <- liftM concat $ mapM getDefs defs
returnl [(f, G.CncFun Nothing pe nope) | (f,(_,pe)) <- defs'] returnl [(f, p, G.CncFun Nothing pe nope) | ((f,p),(_,pe)) <- defs']
DefPrintCat defs -> do DefPrintCat defs -> do
defs' <- liftM concat $ mapM transPrintDef defs defs' <- liftM concat $ mapM transPrintDef defs
returnl [(f, G.CncCat nope nope (yes e)) | (f,e) <- defs'] returnl [(f, nopos, G.CncCat nope nope (yes e)) | (f,e) <- defs']
DefPrintFun defs -> do DefPrintFun defs -> do
defs' <- liftM concat $ mapM transPrintDef defs defs' <- liftM concat $ mapM transPrintDef defs
returnl [(f, G.CncFun Nothing nope (yes e)) | (f,e) <- defs'] returnl [(f, nopos, G.CncFun Nothing nope (yes e)) | (f,e) <- defs']
DefPrintOld defs -> do --- a guess, for backward compatibility DefPrintOld defs -> do --- a guess, for backward compatibility
defs' <- liftM concat $ mapM transPrintDef defs defs' <- liftM concat $ mapM transPrintDef defs
returnl [(f, G.CncFun Nothing nope (yes e)) | (f,e) <- defs'] returnl [(f, nopos, G.CncFun Nothing nope (yes e)) | (f,e) <- defs']
DefFlag defs -> liftM (Right . concatModuleOptions) $ mapM transFlagDef defs DefFlag defs -> liftM (Right . concatModuleOptions) $ mapM transFlagDef defs
DefPattern defs -> do DefPattern defs -> do
defs' <- liftM concat $ mapM getDefs defs defs' <- liftM concat $ mapM getDefs defs
let defs2 = [(f, termInPattern t) | (f,(_,Yes t)) <- defs'] let defs2 = [(f, termInPattern t) | (f,(_,Yes t)) <- defs']
returnl [(f, G.CncFun Nothing (yes t) nope) | (f,t) <- defs2] returnl [(f, p, G.CncFun Nothing (yes t) nope) | ((f,p),t) <- defs2]
_ -> errIn ("illegal definition in concrete syntax:") $ transResDef x _ -> errIn ("illegal definition in concrete syntax:") $ transResDef x
@@ -390,32 +406,32 @@ transPrintDef x = case x of
(ids,e) <- liftM2 (,) (mapM transName ids) (transExp exp) (ids,e) <- liftM2 (,) (mapM transName ids) (transExp exp)
return $ [(i,e) | i <- ids] return $ [(i,e) | i <- ids]
getDefsGen :: Def -> Err [(Ident, (G.Perh G.Type, G.Perh G.Term))] getDefsGen :: Def -> Err [((Ident, Int),(G.Perh G.Type, G.Perh G.Term))]
getDefsGen d = case d of getDefsGen d = case d of
DDecl ids t -> do DDecl ids t -> do
ids' <- mapM transName ids ids' <- mapM transNamePos ids
t' <- transExp t t' <- transExp t
return [(i,(yes t', nope)) | i <- ids'] return [(i,(yes t', nope)) | i <- ids']
DDef ids e -> do DDef ids e -> do
ids' <- mapM transName ids ids' <- mapM transNamePos ids
e' <- transExp e e' <- transExp e
return [(i,(nope, yes e')) | i <- ids'] return [(i,(nope, yes e')) | i <- ids']
DFull ids t e -> do DFull ids t e -> do
ids' <- mapM transName ids ids' <- mapM transNamePos ids
t' <- transExp t t' <- transExp t
e' <- transExp e e' <- transExp e
return [(i,(yes t', yes e')) | i <- ids'] return [(i,(yes t', yes e')) | i <- ids']
DPatt id patts e -> do DPatt id patts e -> do
id' <- transName id id' <- transNamePos id
ps' <- mapM transPatt patts ps' <- mapM transPatt patts
e' <- transExp e e' <- transExp e
return [(id',(nope, yes (G.Eqs [(ps',e')])))] return [(id',(nope, yes (G.Eqs [(ps',e')])))]
-- | sometimes you need this special case, e.g. in linearization rules -- | sometimes you need this special case, e.g. in linearization rules
getDefs :: Def -> Err [(Ident, (G.Perh G.Type, G.Perh G.Term))] getDefs :: Def -> Err [((Ident,Int), (G.Perh G.Type, G.Perh G.Term))]
getDefs d = case d of getDefs d = case d of
DPatt id patts e -> do DPatt id patts e -> do
id' <- transName id id' <- transNamePos id
xs <- mapM tryMakeVar patts xs <- mapM tryMakeVar patts
e' <- transExp e e' <- transExp e
return [(id',(nope, yes (M.mkAbs xs e')))] return [(id',(nope, yes (M.mkAbs xs e')))]