forked from GitHub/gf-core
printing line numbers in rename and check-grammar error messages
This commit is contained in:
@@ -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)
|
||||||
|
|||||||
@@ -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
|
||||||
|
|
||||||
|
|||||||
@@ -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)
|
||||||
|
|||||||
@@ -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]
|
||||||
|
|
||||||
|
|||||||
@@ -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')))]
|
||||||
|
|||||||
Reference in New Issue
Block a user