msyds/gf-core
1
0
Fork 0
forked from GitHub/gf-core
Code Pull Requests Activity

store and propagate the exact source location for all judgements in the grammar. It may not be used accurately in the error messages yet

Browse Source
This commit is contained in:
krasimir
2010-03-22 21:15:29 +00:00
parent 716a209f65
commit bf74f50733
19 changed files with 322 additions and 309 deletions
Download Patch File Download Diff File Expand all files Collapse all files

12
src/compiler/GF/Grammar/Binary.hs
View File

@@ -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"

22
src/compiler/GF/Grammar/CF.hs
View File

@@ -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

26
src/compiler/GF/Grammar/Grammar.hs
View File

@@ -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

34
src/compiler/GF/Grammar/Lookup.hs
View File

@@ -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))

6
src/compiler/GF/Grammar/Macros.hs
View File

@@ -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)]

150
src/compiler/GF/Grammar/Parser.y
View File

@@ -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
}

48
src/compiler/GF/Grammar/Printer.hs
View File

@@ -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)))