summaryrefslogtreecommitdiff
path: root/src/compiler/GF/Grammar
diff options
context:
space:
mode:
Diffstat (limited to 'src/compiler/GF/Grammar')
-rw-r--r--src/compiler/GF/Grammar/Binary.hs12
-rw-r--r--src/compiler/GF/Grammar/CF.hs22
-rw-r--r--src/compiler/GF/Grammar/Grammar.hs26
-rw-r--r--src/compiler/GF/Grammar/Lookup.hs34
-rw-r--r--src/compiler/GF/Grammar/Macros.hs6
-rw-r--r--src/compiler/GF/Grammar/Parser.y150
-rw-r--r--src/compiler/GF/Grammar/Printer.hs48
7 files changed, 156 insertions, 142 deletions
diff --git a/src/compiler/GF/Grammar/Binary.hs b/src/compiler/GF/Grammar/Binary.hs
index 1febdcd46..ff34ae38a 100644
--- a/src/compiler/GF/Grammar/Binary.hs
+++ b/src/compiler/GF/Grammar/Binary.hs
@@ -31,9 +31,9 @@ instance Binary a => Binary (MGrammar a) where
get = fmap MGrammar get
instance Binary a => Binary (ModInfo a) where
- put mi = do put (mtype mi,mstatus mi,flags mi,extend mi,mwith mi,opens mi,mexdeps mi,jments mi,positions mi)
- get = do (mtype,mstatus,flags,extend,mwith,opens,med,jments,positions) <- get
- return (ModInfo mtype mstatus flags extend mwith opens med jments positions)
+ put mi = do put (mtype mi,mstatus mi,flags mi,extend mi,mwith mi,opens mi,mexdeps mi,jments mi)
+ get = do (mtype,mstatus,flags,extend,mwith,opens,med,jments) <- get
+ return (ModInfo mtype mstatus flags extend mwith opens med jments)
instance Binary ModuleType where
put MTAbstract = putWord8 0
@@ -109,6 +109,10 @@ instance Binary Info where
8 -> get >>= \(x,y) -> return (AnyInd x y)
_ -> decodingError
+instance Binary a => Binary (L a) where
+ put (L x y) = put (x,y)
+ get = get >>= \(x,y) -> return (L x y)
+
instance Binary BindType where
put Explicit = putWord8 0
put Implicit = putWord8 1
@@ -258,6 +262,6 @@ instance Binary Label where
decodeModHeader :: FilePath -> IO SourceModule
decodeModHeader fpath = do
(m,mtype,mstatus,flags,extend,mwith,opens,med) <- decodeFile fpath
- return (m,ModInfo mtype mstatus flags extend mwith opens med Map.empty Map.empty)
+ return (m,ModInfo mtype mstatus flags extend mwith opens med Map.empty)
decodingError = fail "This GFO file was compiled with different version of GF"
diff --git a/src/compiler/GF/Grammar/CF.hs b/src/compiler/GF/Grammar/CF.hs
index e883d0552..06f67234b 100644
--- a/src/compiler/GF/Grammar/CF.hs
+++ b/src/compiler/GF/Grammar/CF.hs
@@ -50,9 +50,9 @@ getCFRule :: String -> Err [CFRule]
getCFRule s = getcf (wrds s) where
getcf ws = case ws of
fun : cat : a : its | isArrow a ->
- Ok [(init fun, (cat, map mkIt its))]
+ Ok [L (0,0) (init fun, (cat, map mkIt its))]
cat : a : its | isArrow a ->
- Ok [(mkFun cat it, (cat, map mkIt it)) | it <- chunk its]
+ Ok [L (0,0) (mkFun cat it, (cat, map mkIt it)) | it <- chunk its]
_ -> Bad (" invalid rule:" +++ s)
isArrow a = elem a ["->", "::="]
mkIt w = case w of
@@ -69,7 +69,7 @@ getCFRule s = getcf (wrds s) where
type CF = [CFRule]
-type CFRule = (CFFun, (CFCat, [CFItem]))
+type CFRule = L (CFFun, (CFCat, [CFItem]))
type CFItem = Either CFCat String
@@ -97,27 +97,27 @@ cf2grammar rules = (buildTree abs, buildTree conc, cat) where
abs = cats ++ funs
conc = lincats ++ lins
cat = case rules of
- (_,(c,_)):_ -> c -- the value category of the first rule
+ (L _ (_,(c,_))):_ -> c -- the value category of the first rule
_ -> error "empty CF"
- cats = [(cat, AbsCat (Just [])) |
+ cats = [(cat, AbsCat (Just (L (0,0) []))) |
cat <- nub (concat (map cf2cat rules))] ----notPredef cat
- lincats = [(cat, CncCat (Just defLinType) Nothing Nothing) | (cat,AbsCat _) <- cats]
+ lincats = [(cat, CncCat (Just (L loc defLinType)) Nothing Nothing) | (cat,AbsCat (Just (L loc _))) <- cats]
(funs,lins) = unzip (map cf2rule rules)
cf2cat :: CFRule -> [Ident]
-cf2cat (_,(cat, items)) = map identS $ cat : [c | Left c <- items]
+cf2cat (L loc (_,(cat, items))) = map identS $ cat : [c | Left c <- items]
cf2rule :: CFRule -> ((Ident,Info),(Ident,Info))
-cf2rule (fun, (cat, items)) = (def,ldef) where
+cf2rule (L loc (fun, (cat, items))) = (def,ldef) where
f = identS fun
- def = (f, AbsFun (Just (mkProd args' (Cn (identS cat)) [])) Nothing Nothing)
+ def = (f, AbsFun (Just (L loc (mkProd args' (Cn (identS cat)) []))) Nothing Nothing)
args0 = zip (map (identS . ("x" ++) . show) [0..]) items
args = [((Explicit,v), Cn (identS c)) | (v, Left c) <- args0]
args' = [(Explicit,identS "_", Cn (identS c)) | (_, Left c) <- args0]
ldef = (f, CncFun
Nothing
- (Just (mkAbs (map fst args)
- (mkRecord (const theLinLabel) [foldconcat (map mkIt args0)])))
+ (Just (L loc (mkAbs (map fst args)
+ (mkRecord (const theLinLabel) [foldconcat (map mkIt args0)]))))
Nothing)
mkIt (v, Left _) = P (Vr v) theLinLabel
mkIt (_, Right a) = K a
diff --git a/src/compiler/GF/Grammar/Grammar.hs b/src/compiler/GF/Grammar/Grammar.hs
index 371e0ac08..4aa2ace51 100644
--- a/src/compiler/GF/Grammar/Grammar.hs
+++ b/src/compiler/GF/Grammar/Grammar.hs
@@ -20,6 +20,7 @@ module GF.Grammar.Grammar (SourceGrammar,
SourceModule,
mapSourceModule,
Info(..),
+ L(..), unLoc,
Type,
Cat,
Fun,
@@ -75,24 +76,33 @@ mapSourceModule f (i,mi) = (i, f mi)
-- and indirection to module (/INDIR/)
data Info =
-- judgements in abstract syntax
- AbsCat (Maybe Context)
- | AbsFun (Maybe Type) (Maybe Int) (Maybe [Equation]) -- ^ (/ABS/) type, arrity and definition of function
+ AbsCat (Maybe (L Context)) -- ^ (/ABS/) context of a category
+ | AbsFun (Maybe (L Type)) (Maybe Int) (Maybe [L Equation]) -- ^ (/ABS/) type, arrity and definition of a function
-- judgements in resource
- | ResParam (Maybe [Param]) (Maybe [Term]) -- ^ (/RES/) the second parameter is list of all possible values
- | ResValue Type -- ^ (/RES/) to mark parameter constructors for lookup
- | ResOper (Maybe Type) (Maybe Term) -- ^ (/RES/)
+ | ResParam (Maybe [L Param]) (Maybe [Term]) -- ^ (/RES/) the second parameter is list of all possible values
+ | ResValue (L Type) -- ^ (/RES/) to mark parameter constructors for lookup
+ | ResOper (Maybe (L Type)) (Maybe (L Term)) -- ^ (/RES/)
- | ResOverload [Ident] [(Type,Term)] -- ^ (/RES/) idents: modules inherited
+ | ResOverload [Ident] [(L Type,L Term)] -- ^ (/RES/) idents: modules inherited
-- judgements in concrete syntax
- | CncCat (Maybe Type) (Maybe Term) (Maybe Term) -- ^ (/CNC/) lindef ini'zed,
- | CncFun (Maybe (Ident,Context,Type)) (Maybe Term) (Maybe Term) -- ^ (/CNC/) type info added at 'TC'
+ | CncCat (Maybe (L Type)) (Maybe (L Term)) (Maybe (L Term)) -- ^ (/CNC/) lindef ini'zed,
+ | CncFun (Maybe (Ident,Context,Type)) (Maybe (L Term)) (Maybe (L Term)) -- ^ (/CNC/) type info added at 'TC'
-- indirection to module Ident
| AnyInd Bool Ident -- ^ (/INDIR/) the 'Bool' says if canonical
deriving Show
+data L a = L (Int,Int) a -- location information
+ deriving (Eq,Show)
+
+instance Functor L where
+ fmap f (L loc x) = L loc (f x)
+
+unLoc :: L a -> a
+unLoc (L _ x) = x
+
type Type = Term
type Cat = QIdent
type Fun = QIdent
diff --git a/src/compiler/GF/Grammar/Lookup.hs b/src/compiler/GF/Grammar/Lookup.hs
index 14f1ab498..90d8263cd 100644
--- a/src/compiler/GF/Grammar/Lookup.hs
+++ b/src/compiler/GF/Grammar/Lookup.hs
@@ -67,13 +67,13 @@ lookupResDef gr m c
mo <- lookupModule gr m
info <- lookupIdentInfo mo c
case info of
- ResOper _ (Just t) -> return t
+ ResOper _ (Just (L _ t)) -> return t
ResOper _ Nothing -> return (Q m c)
- CncCat (Just ty) _ _ -> lock c ty
+ CncCat (Just (L _ ty)) _ _ -> lock c ty
CncCat _ _ _ -> lock c defLinType
- CncFun (Just (cat,_,_)) (Just tr) _ -> unlock cat tr
- CncFun _ (Just tr) _ -> return tr
+ CncFun (Just (cat,_,_)) (Just (L _ tr)) _ -> unlock cat tr
+ CncFun _ (Just (L _ tr)) _ -> return tr
AnyInd _ n -> look n c
ResParam _ _ -> return (QC m c)
@@ -85,7 +85,7 @@ lookupResType gr m c = do
mo <- lookupModule gr m
info <- lookupIdentInfo mo c
case info of
- ResOper (Just t) _ -> return t
+ ResOper (Just (L _ t)) _ -> return t
-- used in reused concrete
CncCat _ _ _ -> return typeType
@@ -94,7 +94,7 @@ lookupResType gr m c = do
return $ mkProd cont val' []
AnyInd _ n -> lookupResType gr n c
ResParam _ _ -> return typePType
- ResValue t -> return t
+ ResValue (L _ t) -> return t
_ -> Bad $ render (ppIdent c <+> text "has no type defined in resource" <+> ppIdent m)
lookupOverload :: SourceGrammar -> Ident -> Ident -> Err [([Type],(Type,Term))]
@@ -105,7 +105,7 @@ lookupOverload gr m c = do
ResOverload os tysts -> do
tss <- mapM (\x -> lookupOverload gr x c) os
return $ [let (args,val) = typeFormCnc ty in (map (\(b,x,t) -> t) args,(val,tr)) |
- (ty,tr) <- tysts] ++
+ (L _ ty,L _ tr) <- tysts] ++
concat tss
AnyInd _ n -> lookupOverload gr n c
@@ -153,7 +153,7 @@ lookupAbsDef gr m c = errIn (render (text "looking up absdef of" <+> ppIdent c))
mo <- lookupModule gr m
info <- lookupIdentInfo mo c
case info of
- AbsFun _ a d -> return (a,d)
+ AbsFun _ a d -> return (a,fmap (map unLoc) d)
AnyInd _ n -> lookupAbsDef gr n c
_ -> return (Nothing,Nothing)
@@ -163,9 +163,9 @@ lookupLincat gr m c = do
mo <- lookupModule gr m
info <- lookupIdentInfo mo c
case info of
- CncCat (Just t) _ _ -> return t
- AnyInd _ n -> lookupLincat gr n c
- _ -> Bad (render (ppIdent c <+> text "has no linearization type in" <+> ppIdent m))
+ CncCat (Just (L _ t)) _ _ -> return t
+ AnyInd _ n -> lookupLincat gr n c
+ _ -> Bad (render (ppIdent c <+> text "has no linearization type in" <+> ppIdent m))
-- | this is needed at compile time
lookupFunType :: SourceGrammar -> Ident -> Ident -> Err Type
@@ -173,9 +173,9 @@ lookupFunType gr m c = do
mo <- lookupModule gr m
info <- lookupIdentInfo mo c
case info of
- AbsFun (Just t) _ _ -> return t
- AnyInd _ n -> lookupFunType gr n c
- _ -> Bad (render (text "cannot find type of" <+> ppIdent c))
+ AbsFun (Just (L _ t)) _ _ -> return t
+ AnyInd _ n -> lookupFunType gr n c
+ _ -> Bad (render (text "cannot find type of" <+> ppIdent c))
-- | this is needed at compile time
lookupCatContext :: SourceGrammar -> Ident -> Ident -> Err Context
@@ -183,6 +183,6 @@ lookupCatContext gr m c = do
mo <- lookupModule gr m
info <- lookupIdentInfo mo c
case info of
- AbsCat (Just co) -> return co
- AnyInd _ n -> lookupCatContext gr n c
- _ -> Bad (render (text "unknown category" <+> ppIdent c))
+ AbsCat (Just (L _ co)) -> return co
+ AnyInd _ n -> lookupCatContext gr n c
+ _ -> Bad (render (text "unknown category" <+> ppIdent c))
diff --git a/src/compiler/GF/Grammar/Macros.hs b/src/compiler/GF/Grammar/Macros.hs
index ef68b740d..5282b30b1 100644
--- a/src/compiler/GF/Grammar/Macros.hs
+++ b/src/compiler/GF/Grammar/Macros.hs
@@ -607,15 +607,15 @@ allDependencies ism b =
Q n c | ism n -> [c]
QC n c | ism n -> [c]
_ -> collectOp opersIn t
- opty (Just ty) = opersIn ty
+ opty (Just (L _ ty)) = opersIn ty
opty _ = []
pts i = case i of
ResOper pty pt -> [pty,pt]
- ResParam (Just ps) _ -> [Just t | (_,cont) <- ps, (_,_,t) <- cont]
+ ResParam (Just ps) _ -> [Just (L loc t) | L loc (_,cont) <- ps, (_,_,t) <- cont]
CncCat pty _ _ -> [pty]
CncFun _ pt _ -> [pt] ---- (Maybe (Ident,(Context,Type))
AbsFun pty _ ptr -> [pty] --- ptr is def, which can be mutual
- AbsCat (Just co) -> [Just ty | (_,_,ty) <- co]
+ AbsCat (Just (L loc co)) -> [Just (L loc ty) | (_,_,ty) <- co]
_ -> []
topoSortJments :: SourceModule -> Err [(Ident,Info)]
diff --git a/src/compiler/GF/Grammar/Parser.y b/src/compiler/GF/Grammar/Parser.y
index 2346953a9..16cea88b8 100644
--- a/src/compiler/GF/Grammar/Parser.y
+++ b/src/compiler/GF/Grammar/Parser.y
@@ -113,23 +113,17 @@ ModDef
(extends,with,content) = $4
(opens,jments,opts) = case content of { Just c -> c; Nothing -> ([],[],noOptions) }
mapM_ (checkInfoType mtype) jments
- defs <- case buildAnyTree id [(i,d) | (i,_,d) <- jments] of
+ defs <- case buildAnyTree id jments of
Ok x -> return x
Bad msg -> fail msg
- let poss = buildTree [(i,(fname,mkSrcSpan p)) | (i,p,_) <- jments]
- fname = showIdent id ++ ".gf"
-
- mkSrcSpan :: (Posn, Posn) -> (Int,Int)
- mkSrcSpan (Pn l1 _, Pn l2 _) = (l1,l2)
-
- return (id, ModInfo mtype mstat opts extends with opens [] defs poss) }
+ return (id, ModInfo mtype mstat opts extends with opens [] defs) }
ModHeader :: { SourceModule }
ModHeader
: ComplMod ModType '=' ModHeaderBody { let { mstat = $1 ;
(mtype,id) = $2 ;
(extends,with,opens) = $4 }
- in (id, ModInfo mtype mstat noOptions extends with opens [] emptyBinTree emptyBinTree) }
+ in (id, ModInfo mtype mstat noOptions extends with opens [] emptyBinTree) }
ComplMod :: { ModuleStatus }
ComplMod
@@ -164,7 +158,7 @@ ModOpen
ModBody :: { ( [(Ident,MInclude)]
, Maybe (Ident,MInclude,[(Ident,Ident)])
- , Maybe ([OpenSpec],[(Ident,SrcSpan,Info)],Options)
+ , Maybe ([OpenSpec],[(Ident,Info)],Options)
) }
ModBody
: ListIncluded '**' Included 'with' ListInst '**' ModContent { ($1, Just (fst $3,snd $3,$5), Just $7) }
@@ -176,12 +170,12 @@ ModBody
| ModContent { ([], Nothing, Just $1) }
| ModBody ';' { $1 }
-ModContent :: { ([OpenSpec],[(Ident,SrcSpan,Info)],Options) }
+ModContent :: { ([OpenSpec],[(Ident,Info)],Options) }
ModContent
: '{' ListTopDef '}' { ([],[d | Left ds <- $2, d <- ds],concatOptions [o | Right o <- $2]) }
| 'open' ListOpen 'in' '{' ListTopDef '}' { ($2,[d | Left ds <- $5, d <- ds],concatOptions [o | Right o <- $5]) }
-ListTopDef :: { [Either [(Ident,SrcSpan,Info)] Options] }
+ListTopDef :: { [Either [(Ident,Info)] Options] }
ListTopDef
: {- empty -} { [] }
| TopDef ListTopDef { $1 : $2 }
@@ -216,7 +210,7 @@ Included
| Ident '[' ListIdent ']' { ($1,MIOnly $3) }
| Ident '-' '[' ListIdent ']' { ($1,MIExcept $4) }
-TopDef :: { Either [(Ident,SrcSpan,Info)] Options }
+TopDef :: { Either [(Ident,Info)] Options }
TopDef
: 'cat' ListCatDef { Left $2 }
| 'fun' ListFunDef { Left $2 }
@@ -224,56 +218,56 @@ TopDef
| 'data' ListDataDef { Left $2 }
| 'param' ListParamDef { Left $2 }
| 'oper' ListOperDef { Left $2 }
- | 'lincat' ListTermDef { Left [(f, pos, CncCat (Just e) Nothing Nothing ) | (f,pos,e) <- $2] }
- | 'lindef' ListTermDef { Left [(f, pos, CncCat Nothing (Just e) Nothing ) | (f,pos,e) <- $2] }
+ | 'lincat' ListTermDef { Left [(f, CncCat (Just e) Nothing Nothing ) | (f,e) <- $2] }
+ | 'lindef' ListTermDef { Left [(f, CncCat Nothing (Just e) Nothing ) | (f,e) <- $2] }
| 'lin' ListLinDef { Left $2 }
- | 'printname' 'cat' ListTermDef { Left [(f, pos, CncCat Nothing Nothing (Just e)) | (f,pos,e) <- $3] }
- | 'printname' 'fun' ListTermDef { Left [(f, pos, CncFun Nothing Nothing (Just e)) | (f,pos,e) <- $3] }
+ | 'printname' 'cat' ListTermDef { Left [(f, CncCat Nothing Nothing (Just e)) | (f,e) <- $3] }
+ | 'printname' 'fun' ListTermDef { Left [(f, CncFun Nothing Nothing (Just e)) | (f,e) <- $3] }
| 'flags' ListFlagDef { Right $2 }
-CatDef :: { [(Ident,SrcSpan,Info)] }
+CatDef :: { [(Ident,Info)] }
CatDef
- : Posn Ident ListDDecl Posn { [($2, ($1,$4), AbsCat (Just $3))] }
- | Posn '[' Ident ListDDecl ']' Posn { listCatDef $3 ($1,$6) $4 0 }
- | Posn '[' Ident ListDDecl ']' '{' Integer '}' Posn { listCatDef $3 ($1,$9) $4 (fromIntegral $7) }
+ : Posn Ident ListDDecl Posn { [($2, AbsCat (Just (mkL $1 $4 $3)))] }
+ | Posn '[' Ident ListDDecl ']' Posn { listCatDef (mkL $1 $6 ($3,$4,0)) }
+ | Posn '[' Ident ListDDecl ']' '{' Integer '}' Posn { listCatDef (mkL $1 $9 ($3,$4,fromIntegral $7)) }
-FunDef :: { [(Ident,SrcSpan,Info)] }
+FunDef :: { [(Ident,Info)] }
FunDef
- : Posn ListIdent ':' Exp Posn { [(fun, ($1,$5), AbsFun (Just $4) Nothing (Just [])) | fun <- $2] }
+ : Posn ListIdent ':' Exp Posn { [(fun, AbsFun (Just (mkL $1 $5 $4)) Nothing (Just [])) | fun <- $2] }
-DefDef :: { [(Ident,SrcSpan,Info)] }
+DefDef :: { [(Ident,Info)] }
DefDef
- : Posn ListName '=' Exp Posn { [(f, ($1,$5),AbsFun Nothing (Just 0) (Just [([],$4)])) | f <- $2] }
- | Posn Name ListPatt '=' Exp Posn { [($2,($1,$6),AbsFun Nothing (Just (length $3)) (Just [($3,$5)]))] }
+ : Posn ListName '=' Exp Posn { [(f, AbsFun Nothing (Just 0) (Just [mkL $1 $5 ([],$4)])) | f <- $2] }
+ | Posn Name ListPatt '=' Exp Posn { [($2,AbsFun Nothing (Just (length $3)) (Just [mkL $1 $6 ($3,$5)]))] }
-DataDef :: { [(Ident,SrcSpan,Info)] }
+DataDef :: { [(Ident,Info)] }
DataDef
- : Posn Ident '=' ListDataConstr Posn { ($2, ($1,$5), AbsCat Nothing) :
- [(fun, ($1,$5), AbsFun Nothing Nothing Nothing) | fun <- $4] }
- | Posn ListIdent ':' Exp Posn { -- (snd (valCat $4), ($1,$5), AbsCat Nothing) :
- [(fun, ($1,$5), AbsFun (Just $4) Nothing Nothing) | fun <- $2] }
+ : Posn Ident '=' ListDataConstr Posn { ($2, AbsCat Nothing) :
+ [(fun, AbsFun Nothing Nothing Nothing) | fun <- $4] }
+ | Posn ListIdent ':' Exp Posn { -- (snd (valCat $4), AbsCat Nothing) :
+ [(fun, AbsFun (Just (mkL $1 $5 $4)) Nothing Nothing) | fun <- $2] }
-ParamDef :: { [(Ident,SrcSpan,Info)] }
+ParamDef :: { [(Ident,Info)] }
ParamDef
- : Posn Ident '=' ListParConstr Posn { ($2, ($1,$5), ResParam (Just $4) Nothing) :
- [(f, ($1,$5), ResValue (mkProdSimple co (Cn $2))) | (f,co) <- $4] }
- | Posn Ident Posn { [($2, ($1,$3), ResParam Nothing Nothing)] }
+ : Ident '=' ListParConstr { ($1, ResParam (Just $3) Nothing) :
+ [(f, ResValue (L loc (mkProdSimple co (Cn $1)))) | L loc (f,co) <- $3] }
+ | Ident { [($1, ResParam Nothing Nothing)] }
-OperDef :: { [(Ident,SrcSpan,Info)] }
+OperDef :: { [(Ident,Info)] }
OperDef
- : Posn ListName ':' Exp Posn { [(i, ($1,$5), info) | i <- $2, info <- mkOverload (Just $4) Nothing ] }
- | Posn ListName '=' Exp Posn { [(i, ($1,$5), info) | i <- $2, info <- mkOverload Nothing (Just $4)] }
- | Posn Name ListArg '=' Exp Posn { [(i, ($1,$6), info) | i <- [$2], info <- mkOverload Nothing (Just (mkAbs $3 $5))] }
- | Posn ListName ':' Exp '=' Exp Posn { [(i, ($1,$7), info) | i <- $2, info <- mkOverload (Just $4) (Just $6)] }
+ : Posn ListName ':' Exp Posn { [(i, info) | i <- $2, info <- mkOverload (Just (mkL $1 $5 $4)) Nothing ] }
+ | Posn ListName '=' Exp Posn { [(i, info) | i <- $2, info <- mkOverload Nothing (Just (mkL $1 $5 $4))] }
+ | Posn Name ListArg '=' Exp Posn { [(i, info) | i <- [$2], info <- mkOverload Nothing (Just (mkL $1 $6 (mkAbs $3 $5)))] }
+ | Posn ListName ':' Exp '=' Exp Posn { [(i, info) | i <- $2, info <- mkOverload (Just (mkL $1 $7 $4)) (Just (mkL $1 $7 $6))] }
-LinDef :: { [(Ident,SrcSpan,Info)] }
+LinDef :: { [(Ident,Info)] }
LinDef
- : Posn ListName '=' Exp Posn { [(f, ($1,$5), CncFun Nothing (Just $4) Nothing) | f <- $2] }
- | Posn Name ListArg '=' Exp Posn { [($2, ($1,$6), CncFun Nothing (Just (mkAbs $3 $5)) Nothing)] }
+ : Posn ListName '=' Exp Posn { [(f, CncFun Nothing (Just (mkL $1 $5 $4)) Nothing) | f <- $2] }
+ | Posn Name ListArg '=' Exp Posn { [($2, CncFun Nothing (Just (mkL $1 $6 (mkAbs $3 $5))) Nothing)] }
-TermDef :: { [(Ident,SrcSpan,Term)] }
+TermDef :: { [(Ident,L Term)] }
TermDef
- : Posn ListName '=' Exp Posn { [(i,($1,$5),$4) | i <- $2] }
+ : Posn ListName '=' Exp Posn { [(i,mkL $1 $5 $4) | i <- $2] }
FlagDef :: { Options }
FlagDef
@@ -286,46 +280,46 @@ ListDataConstr
: Ident { [$1] }
| Ident '|' ListDataConstr { $1 : $3 }
-ParConstr :: { Param }
+ParConstr :: { L Param }
ParConstr
- : Ident ListDDecl { ($1,$2) }
+ : Posn Ident ListDDecl Posn { mkL $1 $4 ($2,$3) }
-ListLinDef :: { [(Ident,SrcSpan,Info)] }
+ListLinDef :: { [(Ident,Info)] }
ListLinDef
: LinDef ';' { $1 }
| LinDef ';' ListLinDef { $1 ++ $3 }
-ListDefDef :: { [(Ident,SrcSpan,Info)] }
+ListDefDef :: { [(Ident,Info)] }
ListDefDef
: DefDef ';' { $1 }
| DefDef ';' ListDefDef { $1 ++ $3 }
-ListOperDef :: { [(Ident,SrcSpan,Info)] }
+ListOperDef :: { [(Ident,Info)] }
ListOperDef
: OperDef ';' { $1 }
| OperDef ';' ListOperDef { $1 ++ $3 }
-ListCatDef :: { [(Ident,SrcSpan,Info)] }
+ListCatDef :: { [(Ident,Info)] }
ListCatDef
: CatDef ';' { $1 }
| CatDef ';' ListCatDef { $1 ++ $3 }
-ListFunDef :: { [(Ident,SrcSpan,Info)] }
+ListFunDef :: { [(Ident,Info)] }
ListFunDef
: FunDef ';' { $1 }
| FunDef ';' ListFunDef { $1 ++ $3 }
-ListDataDef :: { [(Ident,SrcSpan,Info)] }
+ListDataDef :: { [(Ident,Info)] }
ListDataDef
: DataDef ';' { $1 }
| DataDef ';' ListDataDef { $1 ++ $3 }
-ListParamDef :: { [(Ident,SrcSpan,Info)] }
+ListParamDef :: { [(Ident,Info)] }
ListParamDef
: ParamDef ';' { $1 }
| ParamDef ';' ListParamDef { $1 ++ $3 }
-ListTermDef :: { [(Ident,SrcSpan,Term)] }
+ListTermDef :: { [(Ident,L Term)] }
ListTermDef
: TermDef ';' { $1 }
| TermDef ';' ListTermDef { $1 ++ $3 }
@@ -335,7 +329,7 @@ ListFlagDef
: FlagDef ';' { $1 }
| FlagDef ';' ListFlagDef { addOptions $1 $3 }
-ListParConstr :: { [Param] }
+ListParConstr :: { [L Param] }
ListParConstr
: ParConstr { [$1] }
| ParConstr '|' ListParConstr { $1 : $3 }
@@ -620,16 +614,16 @@ mkBaseId = prefixId (BS.pack "Base")
prefixId :: BS.ByteString -> Ident -> Ident
prefixId pref id = identC (BS.append pref (ident2bs id))
-listCatDef :: Ident -> SrcSpan -> Context -> Int -> [(Ident,SrcSpan,Info)]
-listCatDef id pos cont size = [catd,nilfund,consfund]
+listCatDef :: L (Ident, Context, Int) -> [(Ident,Info)]
+listCatDef (L loc (id,cont,size)) = [catd,nilfund,consfund]
where
listId = mkListId id
baseId = mkBaseId id
consId = mkConsId id
- catd = (listId, pos, AbsCat (Just cont'))
- nilfund = (baseId, pos, AbsFun (Just niltyp) Nothing Nothing)
- consfund = (consId, pos, AbsFun (Just constyp) Nothing Nothing)
+ catd = (listId, AbsCat (Just (L loc cont')))
+ nilfund = (baseId, AbsFun (Just (L loc niltyp)) Nothing Nothing)
+ consfund = (consId, AbsFun (Just (L loc constyp)) Nothing Nothing)
cont' = [(b,mkId x i,ty) | (i,(b,x,ty)) <- zip [0..] cont]
xs = map (\(b,x,t) -> Vr x) cont'
@@ -656,16 +650,16 @@ mkR fs@(f:_) =
tryR (lab,mty,Just t) = return (ident2label lab,(mty,t))
tryR (lab,_ ,_ ) = fail $ "illegal record field" +++ showIdent lab
-mkOverload pdt pdf@(Just df) =
+mkOverload pdt pdf@(Just (L loc df)) =
case appForm df of
(keyw, ts@(_:_)) | isOverloading keyw ->
case last ts of
- R fs -> [ResOverload [m | Vr m <- ts] [(ty,fu) | (_,(Just ty,fu)) <- fs]]
+ R fs -> [ResOverload [m | Vr m <- ts] [(L loc ty,L loc fu) | (_,(Just ty,fu)) <- fs]]
_ -> [ResOper pdt pdf]
_ -> [ResOper pdt pdf]
-- to enable separare type signature --- not type-checked
-mkOverload pdt@(Just df) pdf =
+mkOverload pdt@(Just (L _ df)) pdf =
case appForm df of
(keyw, ts@(_:_)) | isOverloading keyw ->
case last ts of
@@ -680,29 +674,26 @@ isOverloading t =
_ -> False
-type SrcSpan = (Posn,Posn)
-
-
-checkInfoType MTAbstract (id,pos,info) =
+checkInfoType MTAbstract (id,info) =
case info of
AbsCat _ -> return ()
AbsFun _ _ _ -> return ()
- _ -> failLoc (fst pos) "illegal definition in abstract module"
-checkInfoType MTResource (id,pos,info) =
+ _ -> failLoc (getInfoPos info) "illegal definition in abstract module"
+checkInfoType MTResource (id,info) =
case info of
ResParam _ _ -> return ()
ResValue _ -> return ()
ResOper _ _ -> return ()
ResOverload _ _ -> return ()
- _ -> failLoc (fst pos) "illegal definition in resource module"
-checkInfoType MTInterface (id,pos,info) =
+ _ -> failLoc (getInfoPos info) "illegal definition in resource module"
+checkInfoType MTInterface (id,info) =
case info of
ResParam _ _ -> return ()
ResValue _ -> return ()
ResOper _ _ -> return ()
ResOverload _ _ -> return ()
- _ -> failLoc (fst pos) "illegal definition in interface module"
-checkInfoType (MTConcrete _) (id,pos,info) =
+ _ -> failLoc (getInfoPos info) "illegal definition in interface module"
+checkInfoType (MTConcrete _) (id,info) =
case info of
CncCat _ _ _ -> return ()
CncFun _ _ _ -> return ()
@@ -710,14 +701,15 @@ checkInfoType (MTConcrete _) (id,pos,info) =
ResValue _ -> return ()
ResOper _ _ -> return ()
ResOverload _ _ -> return ()
- _ -> failLoc (fst pos) "illegal definition in concrete module"
-checkInfoType (MTInstance _) (id,pos,info) =
+ _ -> failLoc (getInfoPos info) "illegal definition in concrete module"
+checkInfoType (MTInstance _) (id,info) =
case info of
ResParam _ _ -> return ()
ResValue _ -> return ()
ResOper _ _ -> return ()
- _ -> failLoc (fst pos) "illegal definition in instance module"
+ _ -> failLoc (getInfoPos info) "illegal definition in instance module"
+getInfoPos = undefined
mkAlts cs = case cs of
_:_ -> do
@@ -741,5 +733,7 @@ mkAlts cs = case cs of
PM m c -> return (Q m c) --- for macros; not yet complete
_ -> fail "no strs from pattern"
-}
+mkL :: Posn -> Posn -> x -> L x
+mkL (Pn l1 _) (Pn l2 _) x = L (l1,l2) x
+} \ No newline at end of file
diff --git a/src/compiler/GF/Grammar/Printer.hs b/src/compiler/GF/Grammar/Printer.hs
index 15afef865..1db1eb4f3 100644
--- a/src/compiler/GF/Grammar/Printer.hs
+++ b/src/compiler/GF/Grammar/Printer.hs
@@ -16,6 +16,7 @@ module GF.Grammar.Printer
, ppPatt
, ppValue
, ppConstrs
+ , ppPosition
) where
import GF.Infra.Ident
@@ -32,7 +33,7 @@ import qualified Data.Map as Map
data TermPrintQual = Qualified | Unqualified
ppModule :: TermPrintQual -> SourceModule -> Doc
-ppModule q (mn, ModInfo mtype mstat opts exts with opens _ jments _) =
+ppModule q (mn, ModInfo mtype mstat opts exts with opens _ jments) =
hdr $$ nest 2 (ppOptions opts $$ vcat (map (ppJudgement q) defs)) $$ ftr
where
defs = Map.toList jments
@@ -74,15 +75,15 @@ ppOptions opts =
ppJudgement q (id, AbsCat pcont ) =
text "cat" <+> ppIdent id <+>
(case pcont of
- Just cont -> hsep (map (ppDecl q) cont)
- Nothing -> empty) <+> semi
+ Just (L _ cont) -> hsep (map (ppDecl q) cont)
+ Nothing -> empty) <+> semi
ppJudgement q (id, AbsFun ptype _ pexp) =
(case ptype of
- Just typ -> text (if isNothing pexp then "data" else "fun") <+> ppIdent id <+> colon <+> ppTerm q 0 typ <+> semi
- Nothing -> empty) $$
+ Just (L _ typ) -> text (if isNothing pexp then "data" else "fun") <+> ppIdent id <+> colon <+> ppTerm q 0 typ <+> semi
+ Nothing -> empty) $$
(case pexp of
Just [] -> empty
- Just eqs -> text "def" <+> vcat [ppIdent id <+> hsep (map (ppPatt q 2) ps) <+> equals <+> ppTerm q 0 e <+> semi | (ps,e) <- eqs]
+ Just eqs -> text "def" <+> vcat [ppIdent id <+> hsep (map (ppPatt q 2) ps) <+> equals <+> ppTerm q 0 e <+> semi | L _ (ps,e) <- eqs]
Nothing -> empty)
ppJudgement q (id, ResParam pparams _) =
text "param" <+> ppIdent id <+>
@@ -92,31 +93,31 @@ ppJudgement q (id, ResParam pparams _) =
ppJudgement q (id, ResValue pvalue) = empty
ppJudgement q (id, ResOper ptype pexp) =
text "oper" <+> ppIdent id <+>
- (case ptype of {Just t -> colon <+> ppTerm q 0 t; Nothing -> empty} $$
- case pexp of {Just e -> equals <+> ppTerm q 0 e; Nothing -> empty}) <+> semi
+ (case ptype of {Just (L _ t) -> colon <+> ppTerm q 0 t; Nothing -> empty} $$
+ case pexp of {Just (L _ e) -> equals <+> ppTerm q 0 e; Nothing -> empty}) <+> semi
ppJudgement q (id, ResOverload ids defs) =
text "oper" <+> ppIdent id <+> equals <+>
(text "overload" <+> lbrace $$
- nest 2 (vcat [ppIdent id <+> (colon <+> ppTerm q 0 ty $$ equals <+> ppTerm q 0 e) | (ty,e) <- defs]) $$
+ nest 2 (vcat [ppIdent id <+> (colon <+> ppTerm q 0 ty $$ equals <+> ppTerm q 0 e) | (L _ ty,L _ e) <- defs]) $$
rbrace) <+> semi
ppJudgement q (id, CncCat ptype pexp pprn) =
(case ptype of
- Just typ -> text "lincat" <+> ppIdent id <+> equals <+> ppTerm q 0 typ <+> semi
- Nothing -> empty) $$
+ Just (L _ typ) -> text "lincat" <+> ppIdent id <+> equals <+> ppTerm q 0 typ <+> semi
+ Nothing -> empty) $$
(case pexp of
- Just exp -> text "lindef" <+> ppIdent id <+> equals <+> ppTerm q 0 exp <+> semi
- Nothing -> empty) $$
+ Just (L _ exp) -> text "lindef" <+> ppIdent id <+> equals <+> ppTerm q 0 exp <+> semi
+ Nothing -> empty) $$
(case pprn of
- Just prn -> text "printname" <+> text "cat" <+> ppIdent id <+> equals <+> ppTerm q 0 prn <+> semi
- Nothing -> empty)
+ Just (L _ prn) -> text "printname" <+> text "cat" <+> ppIdent id <+> equals <+> ppTerm q 0 prn <+> semi
+ Nothing -> empty)
ppJudgement q (id, CncFun ptype pdef pprn) =
(case pdef of
- Just e -> let (xs,e') = getAbs e
- in text "lin" <+> ppIdent id <+> hsep (map ppBind xs) <+> equals <+> ppTerm q 0 e' <+> semi
- Nothing -> empty) $$
+ Just (L _ e) -> let (xs,e') = getAbs e
+ in text "lin" <+> ppIdent id <+> hsep (map ppBind xs) <+> equals <+> ppTerm q 0 e' <+> semi
+ Nothing -> empty) $$
(case pprn of
- Just prn -> text "printname" <+> text "fun" <+> ppIdent id <+> equals <+> ppTerm q 0 prn <+> semi
- Nothing -> empty)
+ Just (L _ prn) -> text "printname" <+> text "fun" <+> ppIdent id <+> equals <+> ppTerm q 0 prn <+> semi
+ Nothing -> empty)
ppJudgement q (id, AnyInd cann mid) = text "ind" <+> ppIdent id <+> equals <+> (if cann then text "canonical" else empty) <+> ppIdent mid <+> semi
ppTerm q d (Abs b v e) = let (xs,e') = getAbs (Abs b v e)
@@ -257,7 +258,12 @@ ppBind (Implicit,v) = braces (ppIdent v)
ppAltern q (x,y) = ppTerm q 0 x <+> char '/' <+> ppTerm q 0 y
-ppParam q (id,cxt) = ppIdent id <+> hsep (map (ppDDecl q) cxt)
+ppParam q (L _ (id,cxt)) = ppIdent id <+> hsep (map (ppDDecl q) cxt)
+
+ppPosition :: Ident -> (Int,Int) -> Doc
+ppPosition m (b,e)
+ | b == e = text "in" <+> ppIdent m <> text ".gf, line" <+> int b
+ | otherwise = text "in" <+> ppIdent m <> text ".gf, lines" <+> int b <> text "-" <> int e
commaPunct f ds = (hcat (punctuate comma (map f ds)))
generated by cgit v1.2.3 (git 2.39.1) at 2026-06-11 15:36:31 +0000