GitHub/gf-core
1
0
Fork 1
mirror of https://github.com/GrammaticalFramework/gf-core.git synced 2026-04-23 03:32:51 -06:00
Code Issues Packages Projects Releases Wiki 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 d1615144b6
commit d3a84f994b
23 changed files with 322 additions and 323 deletions
Download Patch File Download Diff File Expand all files Collapse all files

4
lib/src/abstract/Lexicon.gf
View File

@@ -79,7 +79,6 @@ fun
door_N : N ; door_N : N ;
do_V2 : V2 ; do_V2 : V2 ;
drink_V2 : V2 ; drink_V2 : V2 ;
drink_V2 : V2 ;
dry_A : A ; dry_A : A ;
dull_A : A ; dull_A : A ;
dust_N : N ; dust_N : N ;
@@ -87,7 +86,6 @@ fun
earth_N : N ; earth_N : N ;
easy_A2V : A2 ; easy_A2V : A2 ;
eat_V2 : V2 ; eat_V2 : V2 ;
eat_V2 : V2 ;
egg_N : N ; egg_N : N ;
empty_A : A ; empty_A : A ;
enemy_N : N ; enemy_N : N ;
@@ -140,7 +138,6 @@ fun
head_N : N ; head_N : N ;
heart_N : N ; heart_N : N ;
hear_V2 : V2 ; hear_V2 : V2 ;
hear_V2 : V2 ;
heavy_A : A ; heavy_A : A ;
hill_N : N ; hill_N : N ;
hit_V2 : V2 ; hit_V2 : V2 ;
@@ -255,7 +252,6 @@ fun
seed_N : N ; seed_N : N ;
seek_V2 : V2 ; seek_V2 : V2 ;
see_V2 : V2 ; see_V2 : V2 ;
see_V2 : V2 ;
sell_V3 : V3 ; sell_V3 : V3 ;
send_V3 : V3 ; send_V3 : V3 ;
sew_V : V ; sew_V : V ;

7
lib/src/bulgarian/MorphoFunsBul.gf
View File

@@ -125,16 +125,9 @@ oper
mkVA : V -> VA ; mkVA : V -> VA ;
mkVA v = v ** {lock_VA = <>} ; mkVA v = v ** {lock_VA = <>} ;
mkV2A : V -> Prep -> V2A ;
mkV2A v p = prepV2 v p ** {lock_V2A = <>} ;
mkVQ : V -> VQ ; mkVQ : V -> VQ ;
mkVQ v = v ** {lock_VQ = <>} ; mkVQ v = v ** {lock_VQ = <>} ;
mkV2Q : V -> Prep -> V2Q ;
mkV2Q v p = prepV2 v p ** {lock_V2Q = <>} ;
--2 Nouns --2 Nouns

2
lib/src/catalan/IrregCatAbs.gf
View File

@@ -1087,8 +1087,6 @@ abstract IrregCatAbs = Cat ** {
-- fun zaherir_V : V ; -- fun zaherir_V : V ;
-- fun zambullir_V : V ; -- fun zambullir_V : V ;
-- fun zurcir_V : V ; -- fun zurcir_V : V ;
fun haver_V : V ;
fun estar_V : V ;
fun callar_V : V ; fun callar_V : V ;
fun caure_V : V ; fun caure_V : V ;
fun cloure_V : V ; fun cloure_V : V ;

1
lib/src/prelude/Formal.gf
View File

@@ -3,7 +3,6 @@ resource Formal = open Prelude in {
-- to replace the old library Precedence -- to replace the old library Precedence
oper oper
Prec : PType ;
TermPrec : Type = {s : Str ; p : Prec} ; TermPrec : Type = {s : Str ; p : Prec} ;
mkPrec : Prec -> Str -> TermPrec = \p,s -> mkPrec : Prec -> Str -> TermPrec = \p,s ->

3
src/compiler/GF/Compile.hs
View File

@@ -210,8 +210,7 @@ generateModuleCode :: Options -> FilePath -> SourceModule -> IOE SourceModule
generateModuleCode opts file minfo = do generateModuleCode opts file minfo = do
let minfo1 = subexpModule minfo let minfo1 = subexpModule minfo
minfo2 = case minfo1 of minfo2 = case minfo1 of
(m,mi) -> (m,mi{jments=Map.filter (\x -> case x of {AnyInd _ _ -> False; _ -> True}) (jments mi) (m,mi) -> (m,mi{jments=Map.filter (\x -> case x of {AnyInd _ _ -> False; _ -> True}) (jments mi)})
, positions=Map.empty})
putPointE Normal opts (" wrote file" +++ file) $ ioeIO $ encodeFile file minfo2 putPointE Normal opts (" wrote file" +++ file) $ ioeIO $ encodeFile file minfo2
return minfo1 return minfo1

4
src/compiler/GF/Compile/Abstract/TypeCheck.hs
View File

@@ -72,9 +72,9 @@ checkContext st = checkTyp st . cont2exp
checkTyp :: SourceGrammar -> Type -> [Message] checkTyp :: SourceGrammar -> Type -> [Message]
checkTyp gr typ = err (\x -> [text x]) ppConstrs $ justTypeCheck gr typ vType checkTyp gr typ = err (\x -> [text x]) ppConstrs $ justTypeCheck gr typ vType
checkDef :: SourceGrammar -> Fun -> Type -> [Equation] -> [Message] checkDef :: SourceGrammar -> Fun -> Type -> [L Equation] -> [Message]
checkDef gr (m,fun) typ eqs = err (\x -> [text x]) ppConstrs $ do checkDef gr (m,fun) typ eqs = err (\x -> [text x]) ppConstrs $ do
bcs <- mapM (\b -> checkBranch (grammar2theory gr) (initTCEnv []) b (type2val typ)) eqs bcs <- mapM (\(L _ b) -> checkBranch (grammar2theory gr) (initTCEnv []) b (type2val typ)) eqs
let (bs,css) = unzip bcs let (bs,css) = unzip bcs
(constrs,_) <- unifyVal (concat css) (constrs,_) <- unifyVal (concat css)
return $ filter notJustMeta constrs return $ filter notJustMeta constrs

74
src/compiler/GF/Compile/CheckGrammar.hs
View File

@@ -94,7 +94,8 @@ checkCompleteGrammar gr (am,abs) (cm,cnc) = do
where where
checkAbs js i@(c,info) = checkAbs js i@(c,info) =
case info of case info of
AbsFun (Just ty) _ _ -> do let mb_def = do AbsFun (Just (L loc ty)) _ _
-> do let mb_def = do
let (cxt,(_,i),_) = typeForm ty let (cxt,(_,i),_) = typeForm ty
info <- lookupIdent i js info <- lookupIdent i js
info <- case info of info <- case info of
@@ -102,8 +103,8 @@ checkCompleteGrammar gr (am,abs) (cm,cnc) = do
return info return info
_ -> return info _ -> return info
case info of case info of
CncCat (Just (RecType [])) _ _ -> return (foldr (\_ -> Abs Explicit identW) (R []) cxt) CncCat (Just (L loc (RecType []))) _ _ -> return (foldr (\_ -> Abs Explicit identW) (R []) cxt)
_ -> Bad "no def lin" _ -> Bad "no def lin"
case lookupIdent c js of case lookupIdent c js of
Ok (AnyInd _ _) -> return js Ok (AnyInd _ _) -> return js
@@ -111,14 +112,14 @@ checkCompleteGrammar gr (am,abs) (cm,cnc) = do
return $ updateTree (c,CncFun ty (Just def) pn) js return $ updateTree (c,CncFun ty (Just def) pn) js
Ok (CncFun ty Nothing pn) -> Ok (CncFun ty Nothing pn) ->
case mb_def of case mb_def of
Ok def -> return $ updateTree (c,CncFun ty (Just def) pn) js Ok def -> return $ updateTree (c,CncFun ty (Just (L (0,0) def)) pn) js
Bad _ -> do checkWarn $ text "no linearization of" <+> ppIdent c Bad _ -> do checkWarn $ text "no linearization of" <+> ppIdent c
return js return js
_ -> do _ -> do
case mb_def of case mb_def of
Ok def -> do (cont,val) <- linTypeOfType gr cm ty Ok def -> do (cont,val) <- linTypeOfType gr cm ty
let linty = (snd (valCat ty),cont,val) let linty = (snd (valCat ty),cont,val)
return $ updateTree (c,CncFun (Just linty) (Just def) Nothing) js return $ updateTree (c,CncFun (Just linty) (Just (L (0,0) def)) Nothing) js
Bad _ -> do checkWarn $ text "no linearization of" <+> ppIdent c Bad _ -> do checkWarn $ text "no linearization of" <+> ppIdent c
return js return js
AbsCat (Just _) -> case lookupIdent c js of AbsCat (Just _) -> case lookupIdent c js of
@@ -127,17 +128,17 @@ checkCompleteGrammar gr (am,abs) (cm,cnc) = do
Ok (CncCat _ mt mp) -> do Ok (CncCat _ mt mp) -> do
checkWarn $ checkWarn $
text "no linearization type for" <+> ppIdent c <> text ", inserting default {s : Str}" text "no linearization type for" <+> ppIdent c <> text ", inserting default {s : Str}"
return $ updateTree (c,CncCat (Just defLinType) mt mp) js return $ updateTree (c,CncCat (Just (L (0,0) defLinType)) mt mp) js
_ -> do _ -> do
checkWarn $ checkWarn $
text "no linearization type for" <+> ppIdent c <> text ", inserting default {s : Str}" text "no linearization type for" <+> ppIdent c <> text ", inserting default {s : Str}"
return $ updateTree (c,CncCat (Just defLinType) Nothing Nothing) js return $ updateTree (c,CncCat (Just (L (0,0) defLinType)) Nothing Nothing) js
_ -> return js _ -> return js
checkCnc js i@(c,info) = checkCnc js i@(c,info) =
case info of case info of
CncFun _ d pn -> case lookupOrigInfo gr am c of CncFun _ d pn -> case lookupOrigInfo gr am c of
Ok (_,AbsFun (Just ty) _ _) -> Ok (_,AbsFun (Just (L _ ty)) _ _) ->
do (cont,val) <- linTypeOfType gr cm ty do (cont,val) <- linTypeOfType gr cm ty
let linty = (snd (valCat ty),cont,val) let linty = (snd (valCat ty),cont,val)
return $ updateTree (c,CncFun (Just linty) d pn) js return $ updateTree (c,CncFun (Just linty) d pn) js
@@ -156,50 +157,51 @@ checkInfo :: [SourceModule] -> SourceModule -> Ident -> Info -> Check Info
checkInfo ms (m,mo) c info = do checkInfo ms (m,mo) c info = do
checkReservedId c checkReservedId c
case info of case info of
AbsCat (Just cont) -> mkCheck "category" $ AbsCat (Just (L loc cont)) ->
checkContext gr cont mkCheck loc "category" $
checkContext gr cont
AbsFun (Just typ0) ma md -> do AbsFun (Just (L loc typ0)) ma md -> do
typ <- compAbsTyp [] typ0 -- to calculate let definitions typ <- compAbsTyp [] typ0 -- to calculate let definitions
mkCheck "type of function" $ mkCheck loc "type of function" $
checkTyp gr typ checkTyp gr typ
case md of case md of
Just eqs -> mkCheck "definition of function" $ Just eqs -> mkCheck loc "definition of function" $
checkDef gr (m,c) typ eqs checkDef gr (m,c) typ eqs
Nothing -> return info Nothing -> return info
return (AbsFun (Just typ) ma md) return (AbsFun (Just (L loc typ)) ma md)
CncFun linty@(Just (cat,cont,val)) (Just trm) mpr -> chIn "linearization of" $ do CncFun linty@(Just (cat,cont,val)) (Just (L loc trm)) mpr -> chIn loc "linearization of" $ do
(trm',_) <- checkLType gr [] trm (mkFunType (map (\(_,_,ty) -> ty) cont) val) -- erases arg vars (trm',_) <- checkLType gr [] trm (mkFunType (map (\(_,_,ty) -> ty) cont) val) -- erases arg vars
mpr <- checkPrintname gr mpr mpr <- checkPrintname gr mpr
return (CncFun linty (Just trm') mpr) return (CncFun linty (Just (L loc trm')) mpr)
CncCat (Just typ) mdef mpr -> chIn "linearization type of" $ do CncCat (Just (L loc typ)) mdef mpr -> chIn loc "linearization type of" $ do
(typ,_) <- checkLType gr [] typ typeType (typ,_) <- checkLType gr [] typ typeType
typ <- computeLType gr [] typ typ <- computeLType gr [] typ
mdef <- case mdef of mdef <- case mdef of
Just def -> do Just (L loc def) -> do
(def,_) <- checkLType gr [] def (mkFunType [typeStr] typ) (def,_) <- checkLType gr [] def (mkFunType [typeStr] typ)
return $ Just def return $ Just (L loc def)
_ -> return mdef _ -> return mdef
mpr <- checkPrintname gr mpr mpr <- checkPrintname gr mpr
return (CncCat (Just typ) mdef mpr) return (CncCat (Just (L loc typ)) mdef mpr)
ResOper pty pde -> chIn "operation" $ do ResOper pty pde -> chIn (0,0) "operation" $ do
(pty', pde') <- case (pty,pde) of (pty', pde') <- case (pty,pde) of
(Just ty, Just de) -> do (Just (L loc1 ty), Just (L loc2 de)) -> do
ty' <- checkLType gr [] ty typeType >>= computeLType gr [] . fst ty' <- checkLType gr [] ty typeType >>= computeLType gr [] . fst
(de',_) <- checkLType gr [] de ty' (de',_) <- checkLType gr [] de ty'
return (Just ty', Just de') return (Just (L loc1 ty'), Just (L loc2 de'))
(_ , Just de) -> do (_ , Just (L loc de)) -> do
(de',ty') <- inferLType gr [] de (de',ty') <- inferLType gr [] de
return (Just ty', Just de') return (Just (L loc ty'), Just (L loc de'))
(_ , Nothing) -> do (_ , Nothing) -> do
checkError (text "No definition given to the operation") checkError (text "No definition given to the operation")
return (ResOper pty' pde') return (ResOper pty' pde')
ResOverload os tysts -> chIn "overloading" $ do ResOverload os tysts -> chIn (0,0) "overloading" $ do
tysts' <- mapM (uncurry $ flip (checkLType gr [])) tysts -- return explicit ones tysts' <- mapM (uncurry $ flip (\(L loc1 t) (L loc2 ty) -> checkLType gr [] t ty >>= \(t,ty) -> return (L loc1 t, L loc2 ty))) tysts -- return explicit ones
tysts0 <- checkErr $ lookupOverload gr m c -- check against inherited ones too tysts0 <- checkErr $ lookupOverload gr m c -- check against inherited ones too
tysts1 <- mapM (uncurry $ flip (checkLType gr [])) tysts1 <- mapM (uncurry $ flip (checkLType gr []))
[(mkFunType args val,tr) | (args,(val,tr)) <- tysts0] [(mkFunType args val,tr) | (args,(val,tr)) <- tysts0]
@@ -209,16 +211,16 @@ checkInfo ms (m,mo) c info = do
sort [let (xs,t) = typeFormCnc x in t : map (\(b,x,t) -> t) xs | (_,x) <- tysts1] sort [let (xs,t) = typeFormCnc x in t : map (\(b,x,t) -> t) xs | (_,x) <- tysts1]
return (ResOverload os [(y,x) | (x,y) <- tysts']) return (ResOverload os [(y,x) | (x,y) <- tysts'])
ResParam (Just pcs) _ -> chIn "parameter type" $ do ResParam (Just pcs) _ -> chIn (0,0) "parameter type" $ do
ts <- checkErr $ liftM concat $ mapM mkPar pcs ts <- checkErr $ liftM concat $ mapM mkPar pcs
return (ResParam (Just pcs) (Just ts)) return (ResParam (Just pcs) (Just ts))
_ -> return info _ -> return info
where where
gr = MGrammar ((m,mo) : ms) gr = MGrammar ((m,mo) : ms)
chIn cat = checkIn (text "Happened in" <+> text cat <+> ppIdent c <+> ppPosition mo c <> colon) chIn loc cat = checkIn (text "Happened in" <+> text cat <+> ppIdent c <+> ppPosition m loc <> colon)
mkPar (f,co) = do mkPar (L _ (f,co)) = do
vs <- liftM combinations $ mapM (\(_,_,ty) -> allParamValues gr ty) co vs <- liftM combinations $ mapM (\(_,_,ty) -> allParamValues gr ty) co
return $ map (mkApp (QC m f)) vs return $ map (mkApp (QC m f)) vs
@@ -229,9 +231,9 @@ checkInfo ms (m,mo) c info = do
| otherwise -> checkUniq $ y:xs | otherwise -> checkUniq $ y:xs
_ -> return () _ -> return ()
mkCheck cat ss = case ss of mkCheck loc cat ss = case ss of
[] -> return info [] -> return info
_ -> checkError (vcat ss $$ text "in" <+> text cat <+> ppIdent c <+> ppPosition mo c) _ -> checkError (vcat ss $$ text "in" <+> text cat <+> ppIdent c <+> ppPosition m loc)
compAbsTyp g t = case t of compAbsTyp g t = case t of
Vr x -> maybe (checkError (text "no value given to variable" <+> ppIdent x)) return $ lookup x g Vr x -> maybe (checkError (text "no value given to variable" <+> ppIdent x)) return $ lookup x g
@@ -246,10 +248,10 @@ checkInfo ms (m,mo) c info = do
_ -> composOp (compAbsTyp g) t _ -> composOp (compAbsTyp g) t
checkPrintname :: SourceGrammar -> Maybe Term -> Check (Maybe Term) checkPrintname :: SourceGrammar -> Maybe (L Term) -> Check (Maybe (L Term))
checkPrintname gr (Just t) = do (t,_) <- checkLType gr [] t typeStr checkPrintname gr (Just (L loc t)) = do (t,_) <- checkLType gr [] t typeStr
return (Just t) return (Just (L loc t))
checkPrintname gr Nothing = return Nothing checkPrintname gr Nothing = return Nothing
-- | for grammars obtained otherwise than by parsing ---- update!! -- | for grammars obtained otherwise than by parsing ---- update!!
checkReservedId :: Ident -> Check () checkReservedId :: Ident -> Check ()

14
src/compiler/GF/Compile/Coding.hs
View File

@@ -25,13 +25,15 @@ codeSourceModule co (id,mo) = (id,replaceJudgements mo (mapTree codj (jments mo)
CncFun mty pt mpr -> CncFun mty (fmap (codeTerm co) pt) (fmap (codeTerm co) mpr) CncFun mty pt mpr -> CncFun mty (fmap (codeTerm co) pt) (fmap (codeTerm co) mpr)
_ -> info _ -> info
codeTerm :: (String -> String) -> Term -> Term codeTerm :: (String -> String) -> L Term -> L Term
codeTerm co t = case t of codeTerm co (L loc t) = L loc (codt t)
K s -> K (co s)
T ty cs -> T ty [(codp p,codeTerm co v) | (p,v) <- cs]
EPatt p -> EPatt (codp p)
_ -> composSafeOp (codeTerm co) t
where where
codt t = case t of
K s -> K (co s)
T ty cs -> T ty [(codp p,codt v) | (p,v) <- cs]
EPatt p -> EPatt (codp p)
_ -> composSafeOp codt t
codp p = case p of --- really: composOpPatt codp p = case p of --- really: composOpPatt
PR rs -> PR [(l,codp p) | (l,p) <- rs] PR rs -> PR [(l,codp p) | (l,p) <- rs]
PString s -> PString (co s) PString s -> PString (co s)

37
src/compiler/GF/Compile/GrammarToPGF.hs
View File

@@ -60,7 +60,7 @@ canon2pgf opts pars cgr@(M.MGrammar ((a,abm):cms)) = do
gflags = Map.empty gflags = Map.empty
aflags = Map.fromList [(mkCId f,C.LStr x) | (f,x) <- optionsPGF (M.flags abm)] aflags = Map.fromList [(mkCId f,C.LStr x) | (f,x) <- optionsPGF (M.flags abm)]
mkDef (Just eqs) = Just [C.Equ ps' (mkExp scope' e) | (ps,e) <- eqs, let (scope',ps') = mapAccumL mkPatt [] ps] mkDef (Just eqs) = Just [C.Equ ps' (mkExp scope' e) | L _ (ps,e) <- eqs, let (scope',ps') = mapAccumL mkPatt [] ps]
mkDef Nothing = Nothing mkDef Nothing = Nothing
mkArrity (Just a) = a mkArrity (Just a) = a
@@ -68,10 +68,10 @@ canon2pgf opts pars cgr@(M.MGrammar ((a,abm):cms)) = do
-- concretes -- concretes
lfuns = [(f', (mkType [] ty, mkArrity ma, mkDef pty)) | lfuns = [(f', (mkType [] ty, mkArrity ma, mkDef pty)) |
(f,AbsFun (Just ty) ma pty) <- tree2list (M.jments abm), let f' = i2i f] (f,AbsFun (Just (L _ ty)) ma pty) <- tree2list (M.jments abm), let f' = i2i f]
funs = Map.fromAscList lfuns funs = Map.fromAscList lfuns
lcats = [(i2i c, snd (mkContext [] cont)) | lcats = [(i2i c, snd (mkContext [] cont)) |
(c,AbsCat (Just cont)) <- tree2list (M.jments abm)] (c,AbsCat (Just (L _ cont))) <- tree2list (M.jments abm)]
cats = Map.fromAscList lcats cats = Map.fromAscList lcats
catfuns = Map.fromList catfuns = Map.fromList
[(cat,[f | (f, (C.DTyp _ c _,_,_)) <- lfuns, c==cat]) | (cat,_) <- lcats] [(cat,[f | (f, (C.DTyp _ c _,_,_)) <- lfuns, c==cat]) | (cat,_) <- lcats]
@@ -91,16 +91,16 @@ canon2pgf opts pars cgr@(M.MGrammar ((a,abm):cms)) = do
---- then (trace "decode" D.convertStringsInTerm decodeUTF8) else id ---- then (trace "decode" D.convertStringsInTerm decodeUTF8) else id
umkTerm = utf . mkTerm umkTerm = utf . mkTerm
lins = Map.fromAscList lins = Map.fromAscList
[(f', umkTerm tr) | (f,CncFun _ (Just tr) _) <- js, [(f', umkTerm tr) | (f,CncFun _ (Just (L _ tr)) _) <- js,
let f' = i2i f, exists f'] -- eliminating lins without fun let f' = i2i f, exists f'] -- eliminating lins without fun
-- needed even here because of restricted inheritance -- needed even here because of restricted inheritance
lincats = Map.fromAscList lincats = Map.fromAscList
[(i2i c, mkCType ty) | (c,CncCat (Just ty) _ _) <- js] [(i2i c, mkCType ty) | (c,CncCat (Just (L _ ty)) _ _) <- js]
lindefs = Map.fromAscList lindefs = Map.fromAscList
[(i2i c, umkTerm tr) | (c,CncCat _ (Just tr) _) <- js] [(i2i c, umkTerm tr) | (c,CncCat _ (Just (L _ tr)) _) <- js]
printnames = Map.union printnames = Map.union
(Map.fromAscList [(i2i f, realize (umkTerm tr)) | (f,CncFun _ _ (Just tr)) <- js]) (Map.fromAscList [(i2i f, realize (umkTerm tr)) | (f,CncFun _ _ (Just (L _ tr))) <- js])
(Map.fromAscList [(i2i f, realize (umkTerm tr)) | (f,CncCat _ _ (Just tr)) <- js]) (Map.fromAscList [(i2i f, realize (umkTerm tr)) | (f,CncCat _ _ (Just (L _ tr))) <- js])
params = Map.fromAscList params = Map.fromAscList
[(i2i c, pars lang0 c) | (c,CncCat (Just ty) _ _) <- js] [(i2i c, pars lang0 c) | (c,CncCat (Just ty) _ _) <- js]
fcfg = Nothing fcfg = Nothing
@@ -236,16 +236,15 @@ mkParamLincat sgr lang cat = errVal (C.R [C.S []]) $ do
reorder :: Ident -> SourceGrammar -> SourceGrammar reorder :: Ident -> SourceGrammar -> SourceGrammar
reorder abs cg = M.MGrammar $ reorder abs cg = M.MGrammar $
(abs, M.ModInfo M.MTAbstract M.MSComplete aflags [] Nothing [] [] adefs poss): (abs, M.ModInfo M.MTAbstract M.MSComplete aflags [] Nothing [] [] adefs):
[(c, M.ModInfo (M.MTConcrete abs) M.MSComplete fs [] Nothing [] [] (sorted2tree js) poss) [(c, M.ModInfo (M.MTConcrete abs) M.MSComplete fs [] Nothing [] [] (sorted2tree js))
| (c,(fs,js)) <- cncs] | (c,(fs,js)) <- cncs]
where where
poss = emptyBinTree -- positions no longer needed
mos = M.modules cg mos = M.modules cg
adefs = sorted2tree $ sortIds $ adefs = sorted2tree $ sortIds $
predefADefs ++ Look.allOrigInfos cg abs predefADefs ++ Look.allOrigInfos cg abs
predefADefs = predefADefs =
[(c, AbsCat (Just [])) | c <- [cFloat,cInt,cString]] [(c, AbsCat (Just (L (0,0) []))) | c <- [cFloat,cInt,cString]]
aflags = aflags =
concatOptions [M.flags mo | (_,mo) <- M.modules cg, M.isModAbs mo] concatOptions [M.flags mo | (_,mo) <- M.modules cg, M.isModAbs mo]
@@ -259,7 +258,7 @@ reorder abs cg = M.MGrammar $
Just r <- [lookup i (M.allExtendSpecs cg la)]] Just r <- [lookup i (M.allExtendSpecs cg la)]]
predefCDefs = predefCDefs =
[(c, CncCat (Just GM.defLinType) Nothing Nothing) | c <- [cInt,cFloat,cString]] [(c, CncCat (Just (L (0,0) GM.defLinType)) Nothing Nothing) | c <- [cInt,cFloat,cString]]
sortIds = sortBy (\ (f,_) (g,_) -> compare f g) sortIds = sortBy (\ (f,_) (g,_) -> compare f g)
@@ -292,8 +291,8 @@ canon2canon opts abs cg0 =
j2j cg (f,j) = j2j cg (f,j) =
let debug = if verbAtLeast opts Verbose then trace ("+ " ++ showIdent f) else id in let debug = if verbAtLeast opts Verbose then trace ("+ " ++ showIdent f) else id in
case j of case j of
CncFun x (Just tr) z -> CncFun x (Just (debug (t2t (unfactor cg0 tr)))) z CncFun x (Just (L loc tr)) z -> CncFun x (Just (L loc (debug (t2t (unfactor cg0 tr))))) z
CncCat (Just ty) (Just x) y -> CncCat (Just (ty2ty ty)) (Just (t2t (unfactor cg0 x))) y CncCat (Just (L locty ty)) (Just (L locx x)) y -> CncCat (Just (L locty (ty2ty ty))) (Just (L locx (t2t (unfactor cg0 x)))) y
_ -> j _ -> j
where where
cg1 = cg cg1 = cg
@@ -315,7 +314,7 @@ canon2canon opts abs cg0 =
-- flatten record arguments of param constructors -- flatten record arguments of param constructors
p2p (f,j) = case j of p2p (f,j) = case j of
ResParam (Just ps) (Just vs) -> ResParam (Just ps) (Just vs) ->
ResParam (Just [(c,concatMap unRec cont) | (c,cont) <- ps]) (Just (map unrec vs)) ResParam (Just [L loc (c,concatMap unRec cont) | L loc (c,cont) <- ps]) (Just (map unrec vs))
_ -> j _ -> j
unRec (bt,x,ty) = case ty of unRec (bt,x,ty) = case ty of
RecType fs -> [ity | (_,typ) <- fs, ity <- unRec (Explicit,identW,typ)] RecType fs -> [ity | (_,typ) <- fs, ity <- unRec (Explicit,identW,typ)]
@@ -359,13 +358,13 @@ paramValues cgr = (labels,untyps,typs) where
partyps = nub $ partyps = nub $
--- [App (Q (IC "Predef") (IC "Ints")) (EInt i) | i <- [1,9]] ---linTypeInt --- [App (Q (IC "Predef") (IC "Ints")) (EInt i) | i <- [1,9]] ---linTypeInt
[ty | [ty |
(_,(_,CncCat (Just ty0) _ _)) <- jments, (_,(_,CncCat (Just (L _ ty0)) _ _)) <- jments,
ty <- typsFrom ty0 ty <- typsFrom ty0
] ++ [ ] ++ [
Q m ty | Q m ty |
(m,(ty,ResParam _ _)) <- jments (m,(ty,ResParam _ _)) <- jments
] ++ [ty | ] ++ [ty |
(_,(_,CncFun _ (Just tr) _)) <- jments, (_,(_,CncFun _ (Just (L _ tr)) _)) <- jments,
ty <- err (const []) snd $ appSTM (typsFromTrm tr) [] ty <- err (const []) snd $ appSTM (typsFromTrm tr) []
] ]
params = [(ty, errVal (traceD ("UNKNOWN PARAM TYPE" +++ show ty) []) $ params = [(ty, errVal (traceD ("UNKNOWN PARAM TYPE" +++ show ty) []) $
@@ -407,7 +406,7 @@ paramValues cgr = (labels,untyps,typs) where
[(cat,[f | let RecType fs = GM.defLinType, f <- fs]) | cat <- [cInt,cFloat, cString]] ++ [(cat,[f | let RecType fs = GM.defLinType, f <- fs]) | cat <- [cInt,cFloat, cString]] ++
reverse ---- TODO: really those lincats that are reached reverse ---- TODO: really those lincats that are reached
---- reverse is enough to expel overshadowed ones... ---- reverse is enough to expel overshadowed ones...
[(cat,ls) | (_,(cat,CncCat (Just ty) _ _)) <- jments, [(cat,ls) | (_,(cat,CncCat (Just (L _ ty)) _ _)) <- jments,
RecType ls <- [unlockTy ty]] RecType ls <- [unlockTy ty]]
labels = Map.fromList $ concat labels = Map.fromList $ concat
[((cat,[lab]),(typ,i)): [((cat,[lab]),(typ,i)):

27
src/compiler/GF/Compile/Optimize.hs
View File

@@ -64,24 +64,24 @@ evalInfo opts ms m c info = do
CncCat ptyp pde ppr -> do CncCat ptyp pde ppr -> do
pde' <- case (ptyp,pde) of pde' <- case (ptyp,pde) of
(Just typ, Just de) -> do (Just (L _ typ), Just (L loc de)) -> do
de <- partEval opts gr ([(Explicit, varStr, typeStr)], typ) de de <- partEval opts gr ([(Explicit, varStr, typeStr)], typ) de
return (Just (factor param c 0 de)) return (Just (L loc (factor param c 0 de)))
(Just typ, Nothing) -> do (Just (L loc typ), Nothing) -> do
de <- mkLinDefault gr typ de <- mkLinDefault gr typ
de <- partEval opts gr ([(Explicit, varStr, typeStr)], typ) de de <- partEval opts gr ([(Explicit, varStr, typeStr)], typ) de
return (Just (factor param c 0 de)) return (Just (L loc (factor param c 0 de)))
_ -> return pde -- indirection _ -> return pde -- indirection
ppr' <- liftM Just $ evalPrintname gr c ppr (Just $ K $ showIdent c) ppr' <- liftM Just $ evalPrintname gr c ppr (Just (L (0,0) (K $ showIdent c)))
return (CncCat ptyp pde' ppr') return (CncCat ptyp pde' ppr')
CncFun (mt@(Just (_,cont,val))) pde ppr -> --trace (prt c) $ CncFun (mt@(Just (_,cont,val))) pde ppr -> --trace (prt c) $
eIn (text "linearization in type" <+> ppTerm Unqualified 0 (mkProd cont val []) $$ text "of function") $ do eIn (text "linearization in type" <+> ppTerm Unqualified 0 (mkProd cont val []) $$ text "of function") $ do
pde' <- case pde of pde' <- case pde of
Just de -> do de <- partEval opts gr (cont,val) de Just (L loc de) -> do de <- partEval opts gr (cont,val) de
return (Just (factor param c 0 de)) return (Just (L loc (factor param c 0 de)))
Nothing -> return pde Nothing -> return pde
ppr' <- liftM Just $ evalPrintname gr c ppr pde' ppr' <- liftM Just $ evalPrintname gr c ppr pde'
return $ CncFun mt pde' ppr' -- only cat in type actually needed return $ CncFun mt pde' ppr' -- only cat in type actually needed
@@ -89,8 +89,8 @@ evalInfo opts ms m c info = do
ResOper pty pde ResOper pty pde
| OptExpand `Set.member` optim -> do | OptExpand `Set.member` optim -> do
pde' <- case pde of pde' <- case pde of
Just de -> do de <- computeConcrete gr de Just (L loc de) -> do de <- computeConcrete gr de
return (Just (factor param c 0 de)) return (Just (L loc (factor param c 0 de)))
Nothing -> return Nothing Nothing -> return Nothing
return $ ResOper pty pde' return $ ResOper pty pde'
@@ -161,13 +161,14 @@ mkLinDefault gr typ = liftM (Abs Explicit varStr) $ mkDefField typ
-- lin for functions, cat name for cats (dispatch made in evalCncDef above). -- lin for functions, cat name for cats (dispatch made in evalCncDef above).
--- We cannot use linearization at this stage, since we do not know the --- We cannot use linearization at this stage, since we do not know the
--- defaults we would need for question marks - and we're not yet in canon. --- defaults we would need for question marks - and we're not yet in canon.
evalPrintname :: SourceGrammar -> Ident -> Maybe Term -> Maybe Term -> Err Term evalPrintname :: SourceGrammar -> Ident -> Maybe (L Term) -> Maybe (L Term) -> Err (L Term)
evalPrintname gr c ppr lin = evalPrintname gr c ppr lin =
case ppr of case ppr of
Just pr -> comp pr Just (L loc pr) -> do pr <- comp pr
return (L loc pr)
Nothing -> case lin of Nothing -> case lin of
Just t -> return $ K $ clean $ render (ppTerm Unqualified 0 (oneBranch t)) Just (L loc t) -> return $ L loc (K $ clean $ render (ppTerm Unqualified 0 (oneBranch t)))
Nothing -> return $ K $ showIdent c ---- Nothing -> return $ L (0,0) (K $ showIdent c) ----
where where
comp = computeConcrete gr comp = computeConcrete gr

14
src/compiler/GF/Compile/Refresh.hs
View File

@@ -116,18 +116,18 @@ refreshModule (k,ms) mi@(i,mo)
| otherwise = return (k, mi:ms) | otherwise = return (k, mi:ms)
where where
refreshRes (k,cs) ci@(c,info) = case info of refreshRes (k,cs) ci@(c,info) = case info of
ResOper ptyp (Just trm) -> do ---- refresh ptyp ResOper ptyp (Just (L loc trm)) -> do ---- refresh ptyp
(k',trm') <- refreshTermKN k trm (k',trm') <- refreshTermKN k trm
return $ (k', (c, ResOper ptyp (Just trm')):cs) return $ (k', (c, ResOper ptyp (Just (L loc trm'))):cs)
ResOverload os tyts -> do ResOverload os tyts -> do
(k',tyts') <- liftM (\ (t,(_,i)) -> (i,t)) $ (k',tyts') <- liftM (\ (t,(_,i)) -> (i,t)) $
appSTM (mapPairsM refresh tyts) (initIdStateN k) appSTM (mapPairsM (\(L loc t) -> liftM (L loc) (refresh t)) tyts) (initIdStateN k)
return $ (k', (c, ResOverload os tyts'):cs) return $ (k', (c, ResOverload os tyts'):cs)
CncCat mt (Just trm) pn -> do ---- refresh mt, pn CncCat mt (Just (L loc trm)) pn -> do ---- refresh mt, pn
(k',trm') <- refreshTermKN k trm (k',trm') <- refreshTermKN k trm
return $ (k', (c, CncCat mt (Just trm') pn):cs) return $ (k', (c, CncCat mt (Just (L loc trm')) pn):cs)
CncFun mt (Just trm) pn -> do ---- refresh pn CncFun mt (Just (L loc trm)) pn -> do ---- refresh pn
(k',trm') <- refreshTermKN k trm (k',trm') <- refreshTermKN k trm
return $ (k', (c, CncFun mt (Just trm') pn):cs) return $ (k', (c, CncFun mt (Just (L loc trm')) pn):cs)
_ -> return (k, ci:cs) _ -> return (k, ci:cs)

78
src/compiler/GF/Compile/Rename.hs
View File

@@ -54,7 +54,7 @@ renameModule :: [SourceModule] -> SourceModule -> Check SourceModule
renameModule ms (name,mo) = checkIn (text "renaming module" <+> ppIdent name) $ do renameModule ms (name,mo) = checkIn (text "renaming module" <+> ppIdent name) $ do
let js1 = jments mo let js1 = jments mo
status <- buildStatus (MGrammar ms) name mo status <- buildStatus (MGrammar ms) name mo
js2 <- checkMap (renameInfo mo status) js1 js2 <- checkMap (renameInfo status name) js1
return (name, mo {opens = map forceQualif (opens mo), jments = js2}) return (name, mo {opens = map forceQualif (opens mo), jments = js2})
type Status = (StatusTree, [(OpenSpec, StatusTree)]) type Status = (StatusTree, [(OpenSpec, StatusTree)])
@@ -137,31 +137,49 @@ forceQualif o = case o of
OSimple i -> OQualif i i OSimple i -> OQualif i i
OQualif _ i -> OQualif i i OQualif _ i -> OQualif i i
renameInfo :: SourceModInfo -> Status -> Ident -> Info -> Check Info renameInfo :: Status -> Ident -> Ident -> Info -> Check Info
renameInfo mo status i info = checkIn renameInfo status m i info =
(text "renaming definition of" <+> ppIdent i <+> ppPosition mo i) $ case info of
case info of AbsCat pco -> liftM AbsCat (renPerh (renameContext status) pco)
AbsCat pco -> liftM AbsCat (renPerh (renameContext status) pco) AbsFun pty pa ptr -> liftM3 AbsFun (renTerm pty) (return pa) (renMaybe (mapM (renLoc (renEquation status))) ptr)
AbsFun pty pa ptr -> liftM3 AbsFun (ren pty) (return pa) (renPerh (mapM (renameEquation status [])) ptr) ResOper pty ptr -> liftM2 ResOper (renTerm pty) (renTerm ptr)
ResOper pty ptr -> liftM2 ResOper (ren pty) (ren ptr) ResOverload os tysts -> liftM (ResOverload os) (mapM (renPair (renameTerm status [])) tysts)
ResOverload os tysts -> ResParam (Just pp) m -> do
liftM (ResOverload os) (mapM (pairM rent) tysts) pp' <- mapM (renLoc (renParam status)) pp
return (ResParam (Just pp') m)
ResValue t -> do
t <- renLoc (renameTerm status []) t
return (ResValue t)
CncCat pty ptr ppr -> liftM3 CncCat (renTerm pty) (renTerm ptr) (renTerm ppr)
CncFun mt ptr ppr -> liftM2 (CncFun mt) (renTerm ptr) (renTerm ppr)
_ -> return info
where
renTerm = renPerh (renameTerm status [])
ResParam (Just pp) m -> do renPerh ren = renMaybe (renLoc ren)
pp' <- mapM (renameParam status) pp
return (ResParam (Just pp') m)
ResValue t -> do
t <- rent t
return (ResValue t)
CncCat pty ptr ppr -> liftM3 CncCat (ren pty) (ren ptr) (ren ppr)
CncFun mt ptr ppr -> liftM2 (CncFun mt) (ren ptr) (ren ppr)
_ -> return info
where
ren = renPerh rent
rent = renameTerm status []
renPerh ren (Just t) = liftM Just $ ren t renMaybe ren (Just x) = ren x >>= return . Just
renPerh ren Nothing = return Nothing renMaybe ren Nothing = return Nothing
renLoc ren (L loc x) =
checkIn (text "renaming of" <+> ppIdent i <+> ppPosition m loc) $ do
x <- ren x
return (L loc x)
renPair ren (L locx x, L locy y) = do x <- ren x
y <- ren y
return (L locx x, L locy y)
renEquation :: Status -> Equation -> Check Equation
renEquation b (ps,t) = do
(ps',vs) <- liftM unzip $ mapM (renamePattern b) ps
t' <- renameTerm b (concat vs) t
return (ps',t')
renParam :: Status -> Param -> Check Param
renParam env (c,co) = do
co' <- renameContext env co
return (c,co')
renameTerm :: Status -> [Ident] -> Term -> Check Term renameTerm :: Status -> [Ident] -> Term -> Check Term
renameTerm env vars = ren vars where renameTerm env vars = ren vars where
@@ -283,11 +301,6 @@ renamePattern env patt = case patt of
renp = renamePattern env renp = renamePattern env
renid = renameIdentTerm env renid = renameIdentTerm env
renameParam :: Status -> (Ident, Context) -> Check (Ident, Context)
renameParam env (c,co) = do
co' <- renameContext env co
return (c,co')
renameContext :: Status -> Context -> Check Context renameContext :: Status -> Context -> Check Context
renameContext b = renc [] where renameContext b = renc [] where
renc vs cont = case cont of renc vs cont = case cont of
@@ -303,10 +316,3 @@ renameContext b = renc [] where
return $ (bt,x,t') : xts' return $ (bt,x,t') : xts'
_ -> return cont _ -> return cont
ren = renameTerm b ren = renameTerm b
-- | vars not needed in env, since patterns always overshadow old vars
renameEquation :: Status -> [Ident] -> Equation -> Check Equation
renameEquation b vs (ps,t) = do
(ps',vs') <- liftM unzip $ mapM (renamePattern b) ps
t' <- renameTerm b (concat vs' ++ vs) t
return (ps',t')

20
src/compiler/GF/Compile/SubExOpt.hs
View File

@@ -53,9 +53,9 @@ unsubexpModule sm@(i,mo)
-- perform this iff the module has opers -- perform this iff the module has opers
hasSub ljs = not $ null [c | (c,ResOper _ _) <- ljs] hasSub ljs = not $ null [c | (c,ResOper _ _) <- ljs]
unparInfo (c,info) = case info of unparInfo (c,info) = case info of
CncFun xs (Just t) m -> [(c, CncFun xs (Just (unparTerm t)) m)] CncFun xs (Just (L loc t)) m -> [(c, CncFun xs (Just (L loc (unparTerm t))) m)]
ResOper (Just (EInt 8)) _ -> [] -- subexp-generated opers ResOper (Just (L loc (EInt 8))) _ -> [] -- subexp-generated opers
ResOper pty (Just t) -> [(c, ResOper pty (Just (unparTerm t)))] ResOper pty (Just (L loc t)) -> [(c, ResOper pty (Just (L loc (unparTerm t))))]
_ -> [(c,info)] _ -> [(c,info)]
unparTerm t = case t of unparTerm t = case t of
Q m c | isOperIdent c -> --- name convention of subexp opers Q m c | isOperIdent c -> --- name convention of subexp opers
@@ -76,12 +76,12 @@ addSubexpConsts mo tree lins = do
mapM mkOne $ opers ++ lins mapM mkOne $ opers ++ lins
where where
mkOne (f,def) = case def of mkOne (f,def) = case def of
CncFun xs (Just trm) pn -> do CncFun xs (Just (L loc trm)) pn -> do
trm' <- recomp f trm trm' <- recomp f trm
return (f,CncFun xs (Just trm') pn) return (f,CncFun xs (Just (L loc trm')) pn)
ResOper ty (Just trm) -> do ResOper ty (Just (L loc trm)) -> do
trm' <- recomp f trm trm' <- recomp f trm
return (f,ResOper ty (Just trm')) return (f,ResOper ty (Just (L loc trm')))
_ -> return (f,def) _ -> return (f,def)
recomp f t = case Map.lookup t tree of recomp f t = case Map.lookup t tree of
Just (_,id) | operIdent id /= f -> return $ Q mo (operIdent id) Just (_,id) | operIdent id /= f -> return $ Q mo (operIdent id)
@@ -89,7 +89,7 @@ addSubexpConsts mo tree lins = do
list = Map.toList tree list = Map.toList tree
oper id trm = (operIdent id, ResOper (Just (EInt 8)) (Just trm)) oper id trm = (operIdent id, ResOper (Just (L (0,0) (EInt 8))) (Just (L (0,0) trm)))
--- impossible type encoding generated opers --- impossible type encoding generated opers
getSubtermsMod :: Ident -> [(Ident,Info)] -> TermM (Map Term (Int,Int)) getSubtermsMod :: Ident -> [(Ident,Info)] -> TermM (Map Term (Int,Int))
@@ -99,10 +99,10 @@ getSubtermsMod mo js = do
return $ Map.filter (\ (nu,_) -> nu > 1) tree0 return $ Map.filter (\ (nu,_) -> nu > 1) tree0
where where
getInfo get fi@(f,i) = case i of getInfo get fi@(f,i) = case i of
CncFun xs (Just trm) pn -> do CncFun xs (Just (L _ trm)) pn -> do
get trm get trm
return $ fi return $ fi
ResOper ty (Just trm) -> do ResOper ty (Just (L _ trm)) -> do
get trm get trm
return $ fi return $ fi
_ -> return fi _ -> return fi

37
src/compiler/GF/Compile/Update.hs
View File

@@ -77,7 +77,7 @@ extendModule gr (name,m)
-- | rebuilding instance + interface, and "with" modules, prior to renaming. -- | rebuilding instance + interface, and "with" modules, prior to renaming.
-- AR 24/10/2003 -- AR 24/10/2003
rebuildModule :: SourceGrammar -> SourceModule -> Err SourceModule rebuildModule :: SourceGrammar -> SourceModule -> Err SourceModule
rebuildModule gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ js_ ps_)) = do rebuildModule gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ js_)) = do
---- deps <- moduleDeps ms ---- deps <- moduleDeps ms
---- is <- openInterfaces deps i ---- is <- openInterfaces deps i
let is = [] ---- the method above is buggy: try "i -src" for two grs. AR 8/3/2005 let is = [] ---- the method above is buggy: try "i -src" for two grs. AR 8/3/2005
@@ -100,8 +100,7 @@ rebuildModule gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ js_ ps_)) = do
m0s <- mapM (lookupModule gr) j0s m0s <- mapM (lookupModule 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 mi js2) return $ replaceJudgements mi js2
{positions = Map.union (positions m1) (positions mi)}
_ -> return mi _ -> return mi
-- add the instance opens to an incomplete module "with" instances -- add the instance opens to an incomplete module "with" instances
@@ -111,7 +110,7 @@ rebuildModule gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ js_ ps_)) = do
[i | i <- is, notElem i infs] [i | i <- is, notElem i infs]
testErr (stat' == MSComplete || stat == MSIncomplete) testErr (stat' == MSComplete || stat == MSIncomplete)
("module" +++ showIdent i +++ "remains incomplete") ("module" +++ showIdent i +++ "remains incomplete")
ModInfo mt0 _ fs me' _ ops0 _ js ps0 <- lookupModule gr ext ModInfo mt0 _ fs me' _ ops0 _ js <- lookupModule gr ext
let ops1 = nub $ let ops1 = nub $
ops_ ++ -- N.B. js has been name-resolved already ops_ ++ -- N.B. js has been name-resolved already
[OQualif i j | (i,j) <- ops] ++ [OQualif i j | (i,j) <- ops] ++
@@ -123,9 +122,8 @@ rebuildModule gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ js_ ps_)) = do
let fs1 = fs `addOptions` fs_ -- new flags have priority let fs1 = fs `addOptions` fs_ -- new flags have priority
let js0 = [ci | ci@(c,_) <- tree2list js, isInherited incl c] let js0 = [ci | ci@(c,_) <- tree2list js, isInherited incl c]
let js1 = buildTree (tree2list js_ ++ js0) let js1 = buildTree (tree2list js_ ++ js0)
let ps1 = Map.union ps_ ps0
let med1= nub (ext : infs ++ insts ++ med_) let med1= nub (ext : infs ++ insts ++ med_)
return $ ModInfo mt0 stat' fs1 me Nothing ops1 med1 js1 ps1 return $ ModInfo mt0 stat' fs1 me Nothing ops1 med1 js1
return (i,mi') return (i,mi')
@@ -170,9 +168,9 @@ extendMod gr isCompl (name,cond) base old new = foldM try new $ Map.toList old
unifyAnyInfo :: Ident -> Info -> Info -> Err Info unifyAnyInfo :: Ident -> Info -> Info -> Err Info
unifyAnyInfo m i j = case (i,j) of unifyAnyInfo m i j = case (i,j) of
(AbsCat mc1, AbsCat mc2) -> (AbsCat mc1, AbsCat mc2) ->
liftM AbsCat (unifMaybe mc1 mc2) liftM AbsCat (unifMaybeL mc1 mc2)
(AbsFun mt1 ma1 md1, AbsFun mt2 ma2 md2) -> (AbsFun mt1 ma1 md1, AbsFun mt2 ma2 md2) ->
liftM3 AbsFun (unifMaybe mt1 mt2) (unifAbsArrity ma1 ma2) (unifAbsDefs md1 md2) -- adding defs liftM3 AbsFun (unifMaybeL mt1 mt2) (unifAbsArrity ma1 ma2) (unifAbsDefs md1 md2) -- adding defs
(ResParam mt1 mv1, ResParam mt2 mv2) -> (ResParam mt1 mv1, ResParam mt2 mv2) ->
liftM2 ResParam (unifMaybe mt1 mt2) (unifMaybe mv1 mv2) liftM2 ResParam (unifMaybe mt1 mt2) (unifMaybe mv1 mv2)
@@ -182,12 +180,12 @@ unifyAnyInfo m i j = case (i,j) of
(_, ResOverload ms t) | elem m ms -> (_, ResOverload ms t) | elem m ms ->
return $ ResOverload ms t return $ ResOverload ms t
(ResOper mt1 m1, ResOper mt2 m2) -> (ResOper mt1 m1, ResOper mt2 m2) ->
liftM2 ResOper (unifMaybe mt1 mt2) (unifMaybe m1 m2) liftM2 ResOper (unifMaybeL mt1 mt2) (unifMaybeL m1 m2)
(CncCat mc1 mf1 mp1, CncCat mc2 mf2 mp2) -> (CncCat mc1 mf1 mp1, CncCat mc2 mf2 mp2) ->
liftM3 CncCat (unifMaybe mc1 mc2) (unifMaybe mf1 mf2) (unifMaybe mp1 mp2) liftM3 CncCat (unifMaybeL mc1 mc2) (unifMaybeL mf1 mf2) (unifMaybeL mp1 mp2)
(CncFun m mt1 md1, CncFun _ mt2 md2) -> (CncFun m mt1 md1, CncFun _ mt2 md2) ->
liftM2 (CncFun m) (unifMaybe mt1 mt2) (unifMaybe md1 md2) ---- adding defs liftM2 (CncFun m) (unifMaybeL mt1 mt2) (unifMaybeL md1 md2) ---- adding defs
(AnyInd b1 m1, AnyInd b2 m2) -> do (AnyInd b1 m1, AnyInd b2 m2) -> do
testErr (b1 == b2) $ "indirection status" testErr (b1 == b2) $ "indirection status"
@@ -205,6 +203,15 @@ unifMaybe (Just p1) (Just p2)
| p1==p2 = return (Just p1) | p1==p2 = return (Just p1)
| otherwise = fail "" | otherwise = fail ""
-- | this is what happens when matching two values in the same module
unifMaybeL :: Eq a => Maybe (L a) -> Maybe (L a) -> Err (Maybe (L a))
unifMaybeL Nothing Nothing = return Nothing
unifMaybeL (Just p1) Nothing = return (Just p1)
unifMaybeL Nothing (Just p2) = return (Just p2)
unifMaybeL (Just (L l1 p1)) (Just (L l2 p2))
| p1==p2 = return (Just (L l1 p1))
| otherwise = fail ""
unifAbsArrity :: Maybe Int -> Maybe Int -> Err (Maybe Int) unifAbsArrity :: Maybe Int -> Maybe Int -> Err (Maybe Int)
unifAbsArrity Nothing Nothing = return Nothing unifAbsArrity Nothing Nothing = return Nothing
unifAbsArrity (Just a ) Nothing = return (Just a ) unifAbsArrity (Just a ) Nothing = return (Just a )
@@ -213,14 +220,8 @@ unifAbsArrity (Just a1) (Just a2)
| a1==a2 = return (Just a1) | a1==a2 = return (Just a1)
| otherwise = fail "" | otherwise = fail ""
unifAbsDefs :: Maybe [Equation] -> Maybe [Equation] -> Err (Maybe [Equation]) unifAbsDefs :: Maybe [L Equation] -> Maybe [L Equation] -> Err (Maybe [L Equation])
unifAbsDefs Nothing Nothing = return Nothing unifAbsDefs Nothing Nothing = return Nothing
unifAbsDefs (Just _ ) Nothing = fail "" unifAbsDefs (Just _ ) Nothing = fail ""
unifAbsDefs Nothing (Just _ ) = fail "" unifAbsDefs Nothing (Just _ ) = fail ""
unifAbsDefs (Just xs) (Just ys) = return (Just (xs ++ ys)) unifAbsDefs (Just xs) (Just ys) = return (Just (xs ++ ys))
unifConstrs :: Maybe [Term] -> Maybe [Term] -> Err (Maybe [Term])
unifConstrs p1 p2 = case (p1,p2) of
(Nothing, _) -> return p2
(_, Nothing) -> return p1
(Just bs, Just ds) -> return $ Just $ bs ++ ds

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

@@ -31,9 +31,9 @@ instance Binary a => Binary (MGrammar a) where
get = fmap MGrammar get get = fmap MGrammar get
instance Binary a => Binary (ModInfo a) where 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) 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,positions) <- get get = do (mtype,mstatus,flags,extend,mwith,opens,med,jments) <- get
return (ModInfo mtype mstatus flags extend mwith opens med jments positions) return (ModInfo mtype mstatus flags extend mwith opens med jments)
instance Binary ModuleType where instance Binary ModuleType where
put MTAbstract = putWord8 0 put MTAbstract = putWord8 0
@@ -109,6 +109,10 @@ instance Binary Info where
8 -> get >>= \(x,y) -> return (AnyInd x y) 8 -> get >>= \(x,y) -> return (AnyInd x y)
_ -> decodingError _ -> 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 instance Binary BindType where
put Explicit = putWord8 0 put Explicit = putWord8 0
put Implicit = putWord8 1 put Implicit = putWord8 1
@@ -258,6 +262,6 @@ instance Binary Label where
decodeModHeader :: FilePath -> IO SourceModule decodeModHeader :: FilePath -> IO SourceModule
decodeModHeader fpath = do decodeModHeader fpath = do
(m,mtype,mstatus,flags,extend,mwith,opens,med) <- decodeFile fpath (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" 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 getCFRule s = getcf (wrds s) where
getcf ws = case ws of getcf ws = case ws of
fun : cat : a : its | isArrow a -> 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 -> 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) _ -> Bad (" invalid rule:" +++ s)
isArrow a = elem a ["->", "::="] isArrow a = elem a ["->", "::="]
mkIt w = case w of mkIt w = case w of
@@ -69,7 +69,7 @@ getCFRule s = getcf (wrds s) where
type CF = [CFRule] type CF = [CFRule]
type CFRule = (CFFun, (CFCat, [CFItem])) type CFRule = L (CFFun, (CFCat, [CFItem]))
type CFItem = Either CFCat String type CFItem = Either CFCat String
@@ -97,27 +97,27 @@ cf2grammar rules = (buildTree abs, buildTree conc, cat) where
abs = cats ++ funs abs = cats ++ funs
conc = lincats ++ lins conc = lincats ++ lins
cat = case rules of 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" _ -> error "empty CF"
cats = [(cat, AbsCat (Just [])) | cats = [(cat, AbsCat (Just (L (0,0) []))) |
cat <- nub (concat (map cf2cat rules))] ----notPredef cat 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) (funs,lins) = unzip (map cf2rule rules)
cf2cat :: CFRule -> [Ident] 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 :: CFRule -> ((Ident,Info),(Ident,Info))
cf2rule (fun, (cat, items)) = (def,ldef) where cf2rule (L loc (fun, (cat, items))) = (def,ldef) where
f = identS fun 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 args0 = zip (map (identS . ("x" ++) . show) [0..]) items
args = [((Explicit,v), Cn (identS c)) | (v, Left c) <- args0] args = [((Explicit,v), Cn (identS c)) | (v, Left c) <- args0]
args' = [(Explicit,identS "_", Cn (identS c)) | (_, Left c) <- args0] args' = [(Explicit,identS "_", Cn (identS c)) | (_, Left c) <- args0]
ldef = (f, CncFun ldef = (f, CncFun
Nothing Nothing
(Just (mkAbs (map fst args) (Just (L loc (mkAbs (map fst args)
(mkRecord (const theLinLabel) [foldconcat (map mkIt args0)]))) (mkRecord (const theLinLabel) [foldconcat (map mkIt args0)]))))
Nothing) Nothing)
mkIt (v, Left _) = P (Vr v) theLinLabel mkIt (v, Left _) = P (Vr v) theLinLabel
mkIt (_, Right a) = K a mkIt (_, Right a) = K a

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

@@ -20,6 +20,7 @@ module GF.Grammar.Grammar (SourceGrammar,
SourceModule, SourceModule,
mapSourceModule, mapSourceModule,
Info(..), Info(..),
L(..), unLoc,
Type, Type,
Cat, Cat,
Fun, Fun,
@@ -75,24 +76,33 @@ mapSourceModule f (i,mi) = (i, f mi)
-- and indirection to module (/INDIR/) -- and indirection to module (/INDIR/)
data Info = data Info =
-- judgements in abstract syntax -- judgements in abstract syntax
AbsCat (Maybe Context) AbsCat (Maybe (L Context)) -- ^ (/ABS/) context of a category
| AbsFun (Maybe Type) (Maybe Int) (Maybe [Equation]) -- ^ (/ABS/) type, arrity and definition of function | AbsFun (Maybe (L Type)) (Maybe Int) (Maybe [L Equation]) -- ^ (/ABS/) type, arrity and definition of a function
-- judgements in resource -- judgements in resource
| ResParam (Maybe [Param]) (Maybe [Term]) -- ^ (/RES/) the second parameter is list of all possible values | ResParam (Maybe [L Param]) (Maybe [Term]) -- ^ (/RES/) the second parameter is list of all possible values
| ResValue Type -- ^ (/RES/) to mark parameter constructors for lookup | ResValue (L Type) -- ^ (/RES/) to mark parameter constructors for lookup
| ResOper (Maybe Type) (Maybe Term) -- ^ (/RES/) | 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 -- judgements in concrete syntax
| CncCat (Maybe Type) (Maybe Term) (Maybe Term) -- ^ (/CNC/) lindef ini'zed, | CncCat (Maybe (L Type)) (Maybe (L Term)) (Maybe (L Term)) -- ^ (/CNC/) lindef ini'zed,
| CncFun (Maybe (Ident,Context,Type)) (Maybe Term) (Maybe Term) -- ^ (/CNC/) type info added at 'TC' | CncFun (Maybe (Ident,Context,Type)) (Maybe (L Term)) (Maybe (L Term)) -- ^ (/CNC/) type info added at 'TC'
-- indirection to module Ident -- indirection to module Ident
| AnyInd Bool Ident -- ^ (/INDIR/) the 'Bool' says if canonical | AnyInd Bool Ident -- ^ (/INDIR/) the 'Bool' says if canonical
deriving Show 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 Type = Term
type Cat = QIdent type Cat = QIdent
type Fun = 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 mo <- lookupModule gr m
info <- lookupIdentInfo mo c info <- lookupIdentInfo mo c
case info of case info of
ResOper _ (Just t) -> return t ResOper _ (Just (L _ t)) -> return t
ResOper _ Nothing -> return (Q m c) ResOper _ Nothing -> return (Q m c)
CncCat (Just ty) _ _ -> lock c ty CncCat (Just (L _ ty)) _ _ -> lock c ty
CncCat _ _ _ -> lock c defLinType CncCat _ _ _ -> lock c defLinType
CncFun (Just (cat,_,_)) (Just tr) _ -> unlock cat tr CncFun (Just (cat,_,_)) (Just (L _ tr)) _ -> unlock cat tr
CncFun _ (Just tr) _ -> return tr CncFun _ (Just (L _ tr)) _ -> return tr
AnyInd _ n -> look n c AnyInd _ n -> look n c
ResParam _ _ -> return (QC m c) ResParam _ _ -> return (QC m c)
@@ -85,7 +85,7 @@ lookupResType gr m c = do
mo <- lookupModule gr m mo <- lookupModule gr m
info <- lookupIdentInfo mo c info <- lookupIdentInfo mo c
case info of case info of
ResOper (Just t) _ -> return t ResOper (Just (L _ t)) _ -> return t
-- used in reused concrete -- used in reused concrete
CncCat _ _ _ -> return typeType CncCat _ _ _ -> return typeType
@@ -94,7 +94,7 @@ lookupResType gr m c = do
return $ mkProd cont val' [] return $ mkProd cont val' []
AnyInd _ n -> lookupResType gr n c AnyInd _ n -> lookupResType gr n c
ResParam _ _ -> return typePType 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) _ -> Bad $ render (ppIdent c <+> text "has no type defined in resource" <+> ppIdent m)
lookupOverload :: SourceGrammar -> Ident -> Ident -> Err [([Type],(Type,Term))] lookupOverload :: SourceGrammar -> Ident -> Ident -> Err [([Type],(Type,Term))]
@@ -105,7 +105,7 @@ lookupOverload gr m c = do
ResOverload os tysts -> do ResOverload os tysts -> do
tss <- mapM (\x -> lookupOverload gr x c) os tss <- mapM (\x -> lookupOverload gr x c) os
return $ [let (args,val) = typeFormCnc ty in (map (\(b,x,t) -> t) args,(val,tr)) | 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 concat tss
AnyInd _ n -> lookupOverload gr n c 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 mo <- lookupModule gr m
info <- lookupIdentInfo mo c info <- lookupIdentInfo mo c
case info of case info of
AbsFun _ a d -> return (a,d) AbsFun _ a d -> return (a,fmap (map unLoc) d)
AnyInd _ n -> lookupAbsDef gr n c AnyInd _ n -> lookupAbsDef gr n c
_ -> return (Nothing,Nothing) _ -> return (Nothing,Nothing)
@@ -163,9 +163,9 @@ lookupLincat gr m c = do
mo <- lookupModule gr m mo <- lookupModule gr m
info <- lookupIdentInfo mo c info <- lookupIdentInfo mo c
case info of case info of
CncCat (Just t) _ _ -> return t CncCat (Just (L _ t)) _ _ -> return t
AnyInd _ n -> lookupLincat gr n c AnyInd _ n -> lookupLincat gr n c
_ -> Bad (render (ppIdent c <+> text "has no linearization type in" <+> ppIdent m)) _ -> Bad (render (ppIdent c <+> text "has no linearization type in" <+> ppIdent m))
-- | this is needed at compile time -- | this is needed at compile time
lookupFunType :: SourceGrammar -> Ident -> Ident -> Err Type lookupFunType :: SourceGrammar -> Ident -> Ident -> Err Type
@@ -173,9 +173,9 @@ lookupFunType gr m c = do
mo <- lookupModule gr m mo <- lookupModule gr m
info <- lookupIdentInfo mo c info <- lookupIdentInfo mo c
case info of case info of
AbsFun (Just t) _ _ -> return t AbsFun (Just (L _ t)) _ _ -> return t
AnyInd _ n -> lookupFunType gr n c AnyInd _ n -> lookupFunType gr n c
_ -> Bad (render (text "cannot find type of" <+> ppIdent c)) _ -> Bad (render (text "cannot find type of" <+> ppIdent c))
-- | this is needed at compile time -- | this is needed at compile time
lookupCatContext :: SourceGrammar -> Ident -> Ident -> Err Context lookupCatContext :: SourceGrammar -> Ident -> Ident -> Err Context
@@ -183,6 +183,6 @@ lookupCatContext gr m c = do
mo <- lookupModule gr m mo <- lookupModule gr m
info <- lookupIdentInfo mo c info <- lookupIdentInfo mo c
case info of case info of
AbsCat (Just co) -> return co AbsCat (Just (L _ co)) -> return co
AnyInd _ n -> lookupCatContext gr n c AnyInd _ n -> lookupCatContext gr n c
_ -> Bad (render (text "unknown category" <+> ppIdent 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] Q n c | ism n -> [c]
QC n c | ism n -> [c] QC n c | ism n -> [c]
_ -> collectOp opersIn t _ -> collectOp opersIn t
opty (Just ty) = opersIn ty opty (Just (L _ ty)) = opersIn ty
opty _ = [] opty _ = []
pts i = case i of pts i = case i of
ResOper pty pt -> [pty,pt] 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] CncCat pty _ _ -> [pty]
CncFun _ pt _ -> [pt] ---- (Maybe (Ident,(Context,Type)) CncFun _ pt _ -> [pt] ---- (Maybe (Ident,(Context,Type))
AbsFun pty _ ptr -> [pty] --- ptr is def, which can be mutual 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)] topoSortJments :: SourceModule -> Err [(Ident,Info)]

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

@@ -113,23 +113,17 @@ ModDef
(extends,with,content) = $4 (extends,with,content) = $4
(opens,jments,opts) = case content of { Just c -> c; Nothing -> ([],[],noOptions) } (opens,jments,opts) = case content of { Just c -> c; Nothing -> ([],[],noOptions) }
mapM_ (checkInfoType mtype) jments mapM_ (checkInfoType mtype) jments
defs <- case buildAnyTree id [(i,d) | (i,_,d) <- jments] of defs <- case buildAnyTree id jments of
Ok x -> return x Ok x -> return x
Bad msg -> fail msg Bad msg -> fail msg
let poss = buildTree [(i,(fname,mkSrcSpan p)) | (i,p,_) <- jments] return (id, ModInfo mtype mstat opts extends with opens [] defs) }
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) }
ModHeader :: { SourceModule } ModHeader :: { SourceModule }
ModHeader ModHeader
: ComplMod ModType '=' ModHeaderBody { let { mstat = $1 ; : ComplMod ModType '=' ModHeaderBody { let { mstat = $1 ;
(mtype,id) = $2 ; (mtype,id) = $2 ;
(extends,with,opens) = $4 } (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 :: { ModuleStatus }
ComplMod ComplMod
@@ -164,7 +158,7 @@ ModOpen
ModBody :: { ( [(Ident,MInclude)] ModBody :: { ( [(Ident,MInclude)]
, Maybe (Ident,MInclude,[(Ident,Ident)]) , Maybe (Ident,MInclude,[(Ident,Ident)])
, Maybe ([OpenSpec],[(Ident,SrcSpan,Info)],Options) , Maybe ([OpenSpec],[(Ident,Info)],Options)
) } ) }
ModBody ModBody
: ListIncluded '**' Included 'with' ListInst '**' ModContent { ($1, Just (fst $3,snd $3,$5), Just $7) } : ListIncluded '**' Included 'with' ListInst '**' ModContent { ($1, Just (fst $3,snd $3,$5), Just $7) }
@@ -176,12 +170,12 @@ ModBody
| ModContent { ([], Nothing, Just $1) } | ModContent { ([], Nothing, Just $1) }
| ModBody ';' { $1 } | ModBody ';' { $1 }
ModContent :: { ([OpenSpec],[(Ident,SrcSpan,Info)],Options) } ModContent :: { ([OpenSpec],[(Ident,Info)],Options) }
ModContent ModContent
: '{' ListTopDef '}' { ([],[d | Left ds <- $2, d <- ds],concatOptions [o | Right o <- $2]) } : '{' 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]) } | '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 ListTopDef
: {- empty -} { [] } : {- empty -} { [] }
| TopDef ListTopDef { $1 : $2 } | TopDef ListTopDef { $1 : $2 }
@@ -216,7 +210,7 @@ Included
| Ident '[' ListIdent ']' { ($1,MIOnly $3) } | Ident '[' ListIdent ']' { ($1,MIOnly $3) }
| Ident '-' '[' ListIdent ']' { ($1,MIExcept $4) } | Ident '-' '[' ListIdent ']' { ($1,MIExcept $4) }
TopDef :: { Either [(Ident,SrcSpan,Info)] Options } TopDef :: { Either [(Ident,Info)] Options }
TopDef TopDef
: 'cat' ListCatDef { Left $2 } : 'cat' ListCatDef { Left $2 }
| 'fun' ListFunDef { Left $2 } | 'fun' ListFunDef { Left $2 }
@@ -224,56 +218,56 @@ TopDef
| 'data' ListDataDef { Left $2 } | 'data' ListDataDef { Left $2 }
| 'param' ListParamDef { Left $2 } | 'param' ListParamDef { Left $2 }
| 'oper' ListOperDef { Left $2 } | 'oper' ListOperDef { Left $2 }
| 'lincat' ListTermDef { Left [(f, pos, CncCat (Just e) Nothing Nothing ) | (f,pos,e) <- $2] } | 'lincat' ListTermDef { Left [(f, CncCat (Just e) Nothing Nothing ) | (f,e) <- $2] }
| 'lindef' ListTermDef { Left [(f, pos, CncCat Nothing (Just e) Nothing ) | (f,pos,e) <- $2] } | 'lindef' ListTermDef { Left [(f, CncCat Nothing (Just e) Nothing ) | (f,e) <- $2] }
| 'lin' ListLinDef { Left $2 } | 'lin' ListLinDef { Left $2 }
| 'printname' 'cat' ListTermDef { Left [(f, pos, CncCat 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, pos, CncFun Nothing Nothing (Just e)) | (f,pos,e) <- $3] } | 'printname' 'fun' ListTermDef { Left [(f, CncFun Nothing Nothing (Just e)) | (f,e) <- $3] }
| 'flags' ListFlagDef { Right $2 } | 'flags' ListFlagDef { Right $2 }
CatDef :: { [(Ident,SrcSpan,Info)] } CatDef :: { [(Ident,Info)] }
CatDef CatDef
: Posn Ident ListDDecl Posn { [($2, ($1,$4), AbsCat (Just $3))] } : Posn Ident ListDDecl Posn { [($2, AbsCat (Just (mkL $1 $4 $3)))] }
| Posn '[' Ident ListDDecl ']' Posn { listCatDef $3 ($1,$6) $4 0 } | Posn '[' Ident ListDDecl ']' Posn { listCatDef (mkL $1 $6 ($3,$4,0)) }
| Posn '[' Ident ListDDecl ']' '{' Integer '}' Posn { listCatDef $3 ($1,$9) $4 (fromIntegral $7) } | Posn '[' Ident ListDDecl ']' '{' Integer '}' Posn { listCatDef (mkL $1 $9 ($3,$4,fromIntegral $7)) }
FunDef :: { [(Ident,SrcSpan,Info)] } FunDef :: { [(Ident,Info)] }
FunDef 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 DefDef
: Posn ListName '=' Exp Posn { [(f, ($1,$5),AbsFun Nothing (Just 0) (Just [([],$4)])) | f <- $2] } : Posn ListName '=' Exp Posn { [(f, AbsFun Nothing (Just 0) (Just [mkL $1 $5 ([],$4)])) | f <- $2] }
| Posn Name ListPatt '=' Exp Posn { [($2,($1,$6),AbsFun Nothing (Just (length $3)) (Just [($3,$5)]))] } | 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 DataDef
: Posn Ident '=' ListDataConstr Posn { ($2, ($1,$5), AbsCat Nothing) : : Posn Ident '=' ListDataConstr Posn { ($2, AbsCat Nothing) :
[(fun, ($1,$5), AbsFun Nothing Nothing Nothing) | fun <- $4] } [(fun, AbsFun Nothing Nothing Nothing) | fun <- $4] }
| Posn ListIdent ':' Exp Posn { -- (snd (valCat $4), ($1,$5), AbsCat Nothing) : | Posn ListIdent ':' Exp Posn { -- (snd (valCat $4), AbsCat Nothing) :
[(fun, ($1,$5), AbsFun (Just $4) Nothing Nothing) | fun <- $2] } [(fun, AbsFun (Just (mkL $1 $5 $4)) Nothing Nothing) | fun <- $2] }
ParamDef :: { [(Ident,SrcSpan,Info)] } ParamDef :: { [(Ident,Info)] }
ParamDef ParamDef
: Posn Ident '=' ListParConstr Posn { ($2, ($1,$5), ResParam (Just $4) Nothing) : : Ident '=' ListParConstr { ($1, ResParam (Just $3) Nothing) :
[(f, ($1,$5), ResValue (mkProdSimple co (Cn $2))) | (f,co) <- $4] } [(f, ResValue (L loc (mkProdSimple co (Cn $1)))) | L loc (f,co) <- $3] }
| Posn Ident Posn { [($2, ($1,$3), ResParam Nothing Nothing)] } | Ident { [($1, ResParam Nothing Nothing)] }
OperDef :: { [(Ident,SrcSpan,Info)] } OperDef :: { [(Ident,Info)] }
OperDef OperDef
: Posn ListName ':' Exp Posn { [(i, ($1,$5), info) | i <- $2, info <- mkOverload (Just $4) Nothing ] } : Posn ListName ':' Exp Posn { [(i, info) | i <- $2, info <- mkOverload (Just (mkL $1 $5 $4)) Nothing ] }
| Posn ListName '=' Exp Posn { [(i, ($1,$5), info) | i <- $2, info <- mkOverload Nothing (Just $4)] } | Posn ListName '=' Exp Posn { [(i, info) | i <- $2, info <- mkOverload Nothing (Just (mkL $1 $5 $4))] }
| Posn Name ListArg '=' Exp Posn { [(i, ($1,$6), info) | i <- [$2], info <- mkOverload Nothing (Just (mkAbs $3 $5))] } | 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, ($1,$7), info) | i <- $2, info <- mkOverload (Just $4) (Just $6)] } | 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 LinDef
: Posn ListName '=' Exp Posn { [(f, ($1,$5), CncFun Nothing (Just $4) Nothing) | f <- $2] } : Posn ListName '=' Exp Posn { [(f, CncFun Nothing (Just (mkL $1 $5 $4)) Nothing) | f <- $2] }
| Posn Name ListArg '=' Exp Posn { [($2, ($1,$6), CncFun Nothing (Just (mkAbs $3 $5)) Nothing)] } | 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 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 :: { Options }
FlagDef FlagDef
@@ -286,46 +280,46 @@ ListDataConstr
: Ident { [$1] } : Ident { [$1] }
| Ident '|' ListDataConstr { $1 : $3 } | Ident '|' ListDataConstr { $1 : $3 }
ParConstr :: { Param } ParConstr :: { L Param }
ParConstr ParConstr
: Ident ListDDecl { ($1,$2) } : Posn Ident ListDDecl Posn { mkL $1 $4 ($2,$3) }
ListLinDef :: { [(Ident,SrcSpan,Info)] } ListLinDef :: { [(Ident,Info)] }
ListLinDef ListLinDef
: LinDef ';' { $1 } : LinDef ';' { $1 }
| LinDef ';' ListLinDef { $1 ++ $3 } | LinDef ';' ListLinDef { $1 ++ $3 }
ListDefDef :: { [(Ident,SrcSpan,Info)] } ListDefDef :: { [(Ident,Info)] }
ListDefDef ListDefDef
: DefDef ';' { $1 } : DefDef ';' { $1 }
| DefDef ';' ListDefDef { $1 ++ $3 } | DefDef ';' ListDefDef { $1 ++ $3 }
ListOperDef :: { [(Ident,SrcSpan,Info)] } ListOperDef :: { [(Ident,Info)] }
ListOperDef ListOperDef
: OperDef ';' { $1 } : OperDef ';' { $1 }
| OperDef ';' ListOperDef { $1 ++ $3 } | OperDef ';' ListOperDef { $1 ++ $3 }
ListCatDef :: { [(Ident,SrcSpan,Info)] } ListCatDef :: { [(Ident,Info)] }
ListCatDef ListCatDef
: CatDef ';' { $1 } : CatDef ';' { $1 }
| CatDef ';' ListCatDef { $1 ++ $3 } | CatDef ';' ListCatDef { $1 ++ $3 }
ListFunDef :: { [(Ident,SrcSpan,Info)] } ListFunDef :: { [(Ident,Info)] }
ListFunDef ListFunDef
: FunDef ';' { $1 } : FunDef ';' { $1 }
| FunDef ';' ListFunDef { $1 ++ $3 } | FunDef ';' ListFunDef { $1 ++ $3 }
ListDataDef :: { [(Ident,SrcSpan,Info)] } ListDataDef :: { [(Ident,Info)] }
ListDataDef ListDataDef
: DataDef ';' { $1 } : DataDef ';' { $1 }
| DataDef ';' ListDataDef { $1 ++ $3 } | DataDef ';' ListDataDef { $1 ++ $3 }
ListParamDef :: { [(Ident,SrcSpan,Info)] } ListParamDef :: { [(Ident,Info)] }
ListParamDef ListParamDef
: ParamDef ';' { $1 } : ParamDef ';' { $1 }
| ParamDef ';' ListParamDef { $1 ++ $3 } | ParamDef ';' ListParamDef { $1 ++ $3 }
ListTermDef :: { [(Ident,SrcSpan,Term)] } ListTermDef :: { [(Ident,L Term)] }
ListTermDef ListTermDef
: TermDef ';' { $1 } : TermDef ';' { $1 }
| TermDef ';' ListTermDef { $1 ++ $3 } | TermDef ';' ListTermDef { $1 ++ $3 }
@@ -335,7 +329,7 @@ ListFlagDef
: FlagDef ';' { $1 } : FlagDef ';' { $1 }
| FlagDef ';' ListFlagDef { addOptions $1 $3 } | FlagDef ';' ListFlagDef { addOptions $1 $3 }
ListParConstr :: { [Param] } ListParConstr :: { [L Param] }
ListParConstr ListParConstr
: ParConstr { [$1] } : ParConstr { [$1] }
| ParConstr '|' ListParConstr { $1 : $3 } | ParConstr '|' ListParConstr { $1 : $3 }
@@ -620,16 +614,16 @@ mkBaseId = prefixId (BS.pack "Base")
prefixId :: BS.ByteString -> Ident -> Ident prefixId :: BS.ByteString -> Ident -> Ident
prefixId pref id = identC (BS.append pref (ident2bs id)) prefixId pref id = identC (BS.append pref (ident2bs id))
listCatDef :: Ident -> SrcSpan -> Context -> Int -> [(Ident,SrcSpan,Info)] listCatDef :: L (Ident, Context, Int) -> [(Ident,Info)]
listCatDef id pos cont size = [catd,nilfund,consfund] listCatDef (L loc (id,cont,size)) = [catd,nilfund,consfund]
where where
listId = mkListId id listId = mkListId id
baseId = mkBaseId id baseId = mkBaseId id
consId = mkConsId id consId = mkConsId id
catd = (listId, pos, AbsCat (Just cont')) catd = (listId, AbsCat (Just (L loc cont')))
nilfund = (baseId, pos, AbsFun (Just niltyp) Nothing Nothing) nilfund = (baseId, AbsFun (Just (L loc niltyp)) Nothing Nothing)
consfund = (consId, pos, AbsFun (Just constyp) Nothing Nothing) consfund = (consId, AbsFun (Just (L loc constyp)) Nothing Nothing)
cont' = [(b,mkId x i,ty) | (i,(b,x,ty)) <- zip [0..] cont] cont' = [(b,mkId x i,ty) | (i,(b,x,ty)) <- zip [0..] cont]
xs = map (\(b,x,t) -> Vr x) 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,mty,Just t) = return (ident2label lab,(mty,t))
tryR (lab,_ ,_ ) = fail $ "illegal record field" +++ showIdent lab tryR (lab,_ ,_ ) = fail $ "illegal record field" +++ showIdent lab
mkOverload pdt pdf@(Just df) = mkOverload pdt pdf@(Just (L loc df)) =
case appForm df of case appForm df of
(keyw, ts@(_:_)) | isOverloading keyw -> (keyw, ts@(_:_)) | isOverloading keyw ->
case last ts of 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]
_ -> [ResOper pdt pdf] _ -> [ResOper pdt pdf]
-- to enable separare type signature --- not type-checked -- to enable separare type signature --- not type-checked
mkOverload pdt@(Just df) pdf = mkOverload pdt@(Just (L _ df)) pdf =
case appForm df of case appForm df of
(keyw, ts@(_:_)) | isOverloading keyw -> (keyw, ts@(_:_)) | isOverloading keyw ->
case last ts of case last ts of
@@ -680,29 +674,26 @@ isOverloading t =
_ -> False _ -> False
type SrcSpan = (Posn,Posn) checkInfoType MTAbstract (id,info) =
checkInfoType MTAbstract (id,pos,info) =
case info of case info of
AbsCat _ -> return () AbsCat _ -> return ()
AbsFun _ _ _ -> return () AbsFun _ _ _ -> return ()
_ -> failLoc (fst pos) "illegal definition in abstract module" _ -> failLoc (getInfoPos info) "illegal definition in abstract module"
checkInfoType MTResource (id,pos,info) = checkInfoType MTResource (id,info) =
case info of case info of
ResParam _ _ -> return () ResParam _ _ -> return ()
ResValue _ -> return () ResValue _ -> return ()
ResOper _ _ -> return () ResOper _ _ -> return ()
ResOverload _ _ -> return () ResOverload _ _ -> return ()
_ -> failLoc (fst pos) "illegal definition in resource module" _ -> failLoc (getInfoPos info) "illegal definition in resource module"
checkInfoType MTInterface (id,pos,info) = checkInfoType MTInterface (id,info) =
case info of case info of
ResParam _ _ -> return () ResParam _ _ -> return ()
ResValue _ -> return () ResValue _ -> return ()
ResOper _ _ -> return () ResOper _ _ -> return ()
ResOverload _ _ -> return () ResOverload _ _ -> return ()
_ -> failLoc (fst pos) "illegal definition in interface module" _ -> failLoc (getInfoPos info) "illegal definition in interface module"
checkInfoType (MTConcrete _) (id,pos,info) = checkInfoType (MTConcrete _) (id,info) =
case info of case info of
CncCat _ _ _ -> return () CncCat _ _ _ -> return ()
CncFun _ _ _ -> return () CncFun _ _ _ -> return ()
@@ -710,14 +701,15 @@ checkInfoType (MTConcrete _) (id,pos,info) =
ResValue _ -> return () ResValue _ -> return ()
ResOper _ _ -> return () ResOper _ _ -> return ()
ResOverload _ _ -> return () ResOverload _ _ -> return ()
_ -> failLoc (fst pos) "illegal definition in concrete module" _ -> failLoc (getInfoPos info) "illegal definition in concrete module"
checkInfoType (MTInstance _) (id,pos,info) = checkInfoType (MTInstance _) (id,info) =
case info of case info of
ResParam _ _ -> return () ResParam _ _ -> return ()
ResValue _ -> return () ResValue _ -> return ()
ResOper _ _ -> 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 mkAlts cs = case cs of
_:_ -> do _:_ -> do
@@ -741,5 +733,7 @@ mkAlts cs = case cs of
PM m c -> return (Q m c) --- for macros; not yet complete PM m c -> return (Q m c) --- for macros; not yet complete
_ -> fail "no strs from pattern" _ -> 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 , ppPatt
, ppValue , ppValue
, ppConstrs , ppConstrs
, ppPosition
) where ) where
import GF.Infra.Ident import GF.Infra.Ident
@@ -32,7 +33,7 @@ import qualified Data.Map as Map
data TermPrintQual = Qualified | Unqualified data TermPrintQual = Qualified | Unqualified
ppModule :: TermPrintQual -> SourceModule -> Doc 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 hdr $$ nest 2 (ppOptions opts $$ vcat (map (ppJudgement q) defs)) $$ ftr
where where
defs = Map.toList jments defs = Map.toList jments
@@ -74,15 +75,15 @@ ppOptions opts =
ppJudgement q (id, AbsCat pcont ) = ppJudgement q (id, AbsCat pcont ) =
text "cat" <+> ppIdent id <+> text "cat" <+> ppIdent id <+>
(case pcont of (case pcont of
Just cont -> hsep (map (ppDecl q) cont) Just (L _ cont) -> hsep (map (ppDecl q) cont)
Nothing -> empty) <+> semi Nothing -> empty) <+> semi
ppJudgement q (id, AbsFun ptype _ pexp) = ppJudgement q (id, AbsFun ptype _ pexp) =
(case ptype of (case ptype of
Just typ -> text (if isNothing pexp then "data" else "fun") <+> ppIdent id <+> colon <+> ppTerm q 0 typ <+> semi Just (L _ typ) -> text (if isNothing pexp then "data" else "fun") <+> ppIdent id <+> colon <+> ppTerm q 0 typ <+> semi
Nothing -> empty) $$ Nothing -> empty) $$
(case pexp of (case pexp of
Just [] -> empty 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) Nothing -> empty)
ppJudgement q (id, ResParam pparams _) = ppJudgement q (id, ResParam pparams _) =
text "param" <+> ppIdent id <+> text "param" <+> ppIdent id <+>
@@ -92,31 +93,31 @@ ppJudgement q (id, ResParam pparams _) =
ppJudgement q (id, ResValue pvalue) = empty ppJudgement q (id, ResValue pvalue) = empty
ppJudgement q (id, ResOper ptype pexp) = ppJudgement q (id, ResOper ptype pexp) =
text "oper" <+> ppIdent id <+> text "oper" <+> ppIdent id <+>
(case ptype of {Just t -> colon <+> ppTerm q 0 t; Nothing -> empty} $$ (case ptype of {Just (L _ t) -> colon <+> ppTerm q 0 t; Nothing -> empty} $$
case pexp of {Just e -> equals <+> ppTerm q 0 e; Nothing -> empty}) <+> semi case pexp of {Just (L _ e) -> equals <+> ppTerm q 0 e; Nothing -> empty}) <+> semi
ppJudgement q (id, ResOverload ids defs) = ppJudgement q (id, ResOverload ids defs) =
text "oper" <+> ppIdent id <+> equals <+> text "oper" <+> ppIdent id <+> equals <+>
(text "overload" <+> lbrace $$ (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 rbrace) <+> semi
ppJudgement q (id, CncCat ptype pexp pprn) = ppJudgement q (id, CncCat ptype pexp pprn) =
(case ptype of (case ptype of
Just typ -> text "lincat" <+> ppIdent id <+> equals <+> ppTerm q 0 typ <+> semi Just (L _ typ) -> text "lincat" <+> ppIdent id <+> equals <+> ppTerm q 0 typ <+> semi
Nothing -> empty) $$ Nothing -> empty) $$
(case pexp of (case pexp of
Just exp -> text "lindef" <+> ppIdent id <+> equals <+> ppTerm q 0 exp <+> semi Just (L _ exp) -> text "lindef" <+> ppIdent id <+> equals <+> ppTerm q 0 exp <+> semi
Nothing -> empty) $$ Nothing -> empty) $$
(case pprn of (case pprn of
Just prn -> text "printname" <+> text "cat" <+> ppIdent id <+> equals <+> ppTerm q 0 prn <+> semi Just (L _ prn) -> text "printname" <+> text "cat" <+> ppIdent id <+> equals <+> ppTerm q 0 prn <+> semi
Nothing -> empty) Nothing -> empty)
ppJudgement q (id, CncFun ptype pdef pprn) = ppJudgement q (id, CncFun ptype pdef pprn) =
(case pdef of (case pdef of
Just e -> let (xs,e') = getAbs e Just (L _ e) -> let (xs,e') = getAbs e
in text "lin" <+> ppIdent id <+> hsep (map ppBind xs) <+> equals <+> ppTerm q 0 e' <+> semi in text "lin" <+> ppIdent id <+> hsep (map ppBind xs) <+> equals <+> ppTerm q 0 e' <+> semi
Nothing -> empty) $$ Nothing -> empty) $$
(case pprn of (case pprn of
Just prn -> text "printname" <+> text "fun" <+> ppIdent id <+> equals <+> ppTerm q 0 prn <+> semi Just (L _ prn) -> text "printname" <+> text "fun" <+> ppIdent id <+> equals <+> ppTerm q 0 prn <+> semi
Nothing -> empty) Nothing -> empty)
ppJudgement q (id, AnyInd cann mid) = text "ind" <+> ppIdent id <+> equals <+> (if cann then text "canonical" else empty) <+> ppIdent mid <+> semi 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) 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 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))) commaPunct f ds = (hcat (punctuate comma (map f ds)))

21
src/compiler/GF/Infra/Modules.hs
View File

@@ -32,7 +32,6 @@ module GF.Infra.Modules (
emptyMGrammar, emptyModInfo, emptyMGrammar, emptyModInfo,
abstractOfConcrete, abstractModOfConcrete, abstractOfConcrete, abstractModOfConcrete,
lookupModule, lookupModuleType, lookupInfo, lookupModule, lookupModuleType, lookupInfo,
lookupPosition, ppPosition,
isModAbs, isModRes, isModCnc, isModAbs, isModRes, isModCnc,
sameMType, isCompilableModule, isCompleteModule, sameMType, isCompilableModule, isCompleteModule,
allAbstracts, greatestAbstract, allResources, allAbstracts, greatestAbstract, allResources,
@@ -64,8 +63,7 @@ data ModInfo a = ModInfo {
mwith :: Maybe (Ident,MInclude,[(Ident,Ident)]), mwith :: Maybe (Ident,MInclude,[(Ident,Ident)]),
opens :: [OpenSpec], opens :: [OpenSpec],
mexdeps :: [Ident], mexdeps :: [Ident],
jments :: Map.Map Ident a, jments :: Map.Map Ident a
positions :: Map.Map Ident (String,(Int,Int)) -- file, first line, last line
} }
deriving Show deriving Show
@@ -105,13 +103,13 @@ updateMGrammar old new = MGrammar $
ns = modules new ns = modules new
updateModule :: ModInfo t -> Ident -> t -> ModInfo t updateModule :: ModInfo t -> Ident -> t -> ModInfo t
updateModule (ModInfo mt ms fs me mw ops med js ps) i t = ModInfo mt ms fs me mw ops med (updateTree (i,t) js) ps updateModule (ModInfo mt ms fs me mw ops med js) i t = ModInfo mt ms fs me mw ops med (updateTree (i,t) js)
replaceJudgements :: ModInfo t -> Map.Map Ident t -> ModInfo t replaceJudgements :: ModInfo t -> Map.Map Ident t -> ModInfo t
replaceJudgements (ModInfo mt ms fs me mw ops med _ ps) js = ModInfo mt ms fs me mw ops med js ps replaceJudgements (ModInfo mt ms fs me mw ops med _) js = ModInfo mt ms fs me mw ops med js
addOpenQualif :: Ident -> Ident -> ModInfo t -> ModInfo t addOpenQualif :: Ident -> Ident -> ModInfo t -> ModInfo t
addOpenQualif i j (ModInfo mt ms fs me mw ops med js ps) = ModInfo mt ms fs me mw (OQualif i j : ops) med js ps addOpenQualif i j (ModInfo mt ms fs me mw ops med js) = ModInfo mt ms fs me mw (OQualif i j : ops) med js
addFlag :: Options -> ModInfo t -> ModInfo t addFlag :: Options -> ModInfo t -> ModInfo t
addFlag f mo = mo {flags = flags mo `addOptions` f} addFlag f mo = mo {flags = flags mo `addOptions` f}
@@ -216,7 +214,7 @@ emptyMGrammar :: MGrammar a
emptyMGrammar = MGrammar [] emptyMGrammar = MGrammar []
emptyModInfo :: ModInfo a emptyModInfo :: ModInfo a
emptyModInfo = ModInfo MTResource MSComplete noOptions [] Nothing [] [] emptyBinTree emptyBinTree emptyModInfo = ModInfo MTResource MSComplete noOptions [] Nothing [] [] emptyBinTree
-- | we store the module type with the identifier -- | we store the module type with the identifier
@@ -250,15 +248,6 @@ lookupModuleType gr m = do
lookupInfo :: ModInfo a -> Ident -> Err a lookupInfo :: ModInfo a -> Ident -> Err a
lookupInfo mo i = lookupTree showIdent i (jments mo) lookupInfo mo i = lookupTree showIdent i (jments mo)
lookupPosition :: ModInfo a -> Ident -> Err (String,(Int,Int))
lookupPosition mo i = lookupTree showIdent i (positions mo)
ppPosition :: ModInfo a -> Ident -> Doc
ppPosition mo i = case lookupPosition mo i of
Ok (f,(b,e)) | b == e -> text "in" <+> text f <> text ", line" <+> int b
| otherwise -> text "in" <+> text f <> text ", lines" <+> int b <> text "-" <> int e
_ -> empty
isModAbs :: ModInfo a -> Bool isModAbs :: ModInfo a -> Bool
isModAbs m = isModAbs m =
case mtype m of case mtype m of

4
src/compiler/GFI.hs
View File

@@ -120,7 +120,7 @@ loop opts gfenv0 = do
(style,q,s) = pOpts TermPrintDefault Qualified (tail (words s0)) (style,q,s) = pOpts TermPrintDefault Qualified (tail (words s0))
checkComputeTerm gr t = do checkComputeTerm gr (L _ t) = do
mo <- maybe (Bad "no source grammar in scope") return $ greatestResource gr mo <- maybe (Bad "no source grammar in scope") return $ greatestResource gr
((t,_),_) <- runCheck $ do t <- renameSourceTerm gr mo t ((t,_),_) <- runCheck $ do t <- renameSourceTerm gr mo t
inferLType gr [] t inferLType gr [] t
@@ -128,7 +128,7 @@ loop opts gfenv0 = do
case runP pExp (BS.pack s) of case runP pExp (BS.pack s) of
Left (_,msg) -> putStrLn msg Left (_,msg) -> putStrLn msg
Right t -> case checkComputeTerm sgr (codeTerm (decode gfenv) t) of Right t -> case checkComputeTerm sgr (codeTerm (decode gfenv) (L (0,0) t)) of
Ok x -> putStrLn $ enc (showTerm sgr style q x) Ok x -> putStrLn $ enc (showTerm sgr style q x)
Bad s -> putStrLn $ enc s Bad s -> putStrLn $ enc s
loopNewCPU gfenv loopNewCPU gfenv