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

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

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

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

@@ -1087,8 +1087,6 @@ abstract IrregCatAbs = Cat ** {
-- fun zaherir_V : V ;
-- fun zambullir_V : V ;
-- fun zurcir_V : V ;
fun haver_V : V ;
fun estar_V : V ;
fun callar_V : V ;
fun caure_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
oper
Prec : PType ;
TermPrec : Type = {s : Str ; p : Prec} ;
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
let minfo1 = subexpModule minfo
minfo2 = case minfo1 of
(m,mi) -> (m,mi{jments=Map.filter (\x -> case x of {AnyInd _ _ -> False; _ -> True}) (jments mi)
, positions=Map.empty})
(m,mi) -> (m,mi{jments=Map.filter (\x -> case x of {AnyInd _ _ -> False; _ -> True}) (jments mi)})
putPointE Normal opts (" wrote file" +++ file) $ ioeIO $ encodeFile file minfo2
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 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
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
(constrs,_) <- unifyVal (concat css)
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
checkAbs js i@(c,info) =
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
info <- lookupIdent i js
info <- case info of
@@ -102,8 +103,8 @@ checkCompleteGrammar gr (am,abs) (cm,cnc) = do
return info
_ -> return info
case info of
CncCat (Just (RecType [])) _ _ -> return (foldr (\_ -> Abs Explicit identW) (R []) cxt)
_ -> Bad "no def lin"
CncCat (Just (L loc (RecType []))) _ _ -> return (foldr (\_ -> Abs Explicit identW) (R []) cxt)
_ -> Bad "no def lin"
case lookupIdent c js of
Ok (AnyInd _ _) -> return js
@@ -111,14 +112,14 @@ checkCompleteGrammar gr (am,abs) (cm,cnc) = do
return $ updateTree (c,CncFun ty (Just def) pn) js
Ok (CncFun ty Nothing pn) ->
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
return js
_ -> do
case mb_def of
Ok def -> do (cont,val) <- linTypeOfType gr cm ty
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
return js
AbsCat (Just _) -> case lookupIdent c js of
@@ -127,17 +128,17 @@ checkCompleteGrammar gr (am,abs) (cm,cnc) = do
Ok (CncCat _ mt mp) -> do
checkWarn $
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
checkWarn $
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
checkCnc js i@(c,info) =
case info 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
let linty = (snd (valCat ty),cont,val)
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
checkReservedId c
case info of
AbsCat (Just cont) -> mkCheck "category" $
checkContext gr cont
AbsCat (Just (L loc 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
mkCheck "type of function" $
mkCheck loc "type of function" $
checkTyp gr typ
case md of
Just eqs -> mkCheck "definition of function" $
Just eqs -> mkCheck loc "definition of function" $
checkDef gr (m,c) typ eqs
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
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 <- computeLType gr [] typ
mdef <- case mdef of
Just def -> do
Just (L loc def) -> do
(def,_) <- checkLType gr [] def (mkFunType [typeStr] typ)
return $ Just def
return $ Just (L loc def)
_ -> return mdef
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
(Just ty, Just de) -> do
(Just (L loc1 ty), Just (L loc2 de)) -> do
ty' <- checkLType gr [] ty typeType >>= computeLType gr [] . fst
(de',_) <- checkLType gr [] de ty'
return (Just ty', Just de')
(_ , Just de) -> do
return (Just (L loc1 ty'), Just (L loc2 de'))
(_ , Just (L loc de)) -> do
(de',ty') <- inferLType gr [] de
return (Just ty', Just de')
return (Just (L loc ty'), Just (L loc de'))
(_ , Nothing) -> do
checkError (text "No definition given to the operation")
return (ResOper pty' pde')
ResOverload os tysts -> chIn "overloading" $ do
tysts' <- mapM (uncurry $ flip (checkLType gr [])) tysts -- return explicit ones
ResOverload os tysts -> chIn (0,0) "overloading" $ do
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
tysts1 <- mapM (uncurry $ flip (checkLType gr []))
[(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]
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
return (ResParam (Just pcs) (Just ts))
_ -> return info
where
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
return $ map (mkApp (QC m f)) vs
@@ -229,9 +231,9 @@ checkInfo ms (m,mo) c info = do
| otherwise -> checkUniq $ y:xs
_ -> return ()
mkCheck cat ss = case ss of
mkCheck loc cat ss = case ss of
[] -> 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
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
checkPrintname :: SourceGrammar -> Maybe Term -> Check (Maybe Term)
checkPrintname gr (Just t) = do (t,_) <- checkLType gr [] t typeStr
return (Just t)
checkPrintname gr Nothing = return Nothing
checkPrintname :: SourceGrammar -> Maybe (L Term) -> Check (Maybe (L Term))
checkPrintname gr (Just (L loc t)) = do (t,_) <- checkLType gr [] t typeStr
return (Just (L loc t))
checkPrintname gr Nothing = return Nothing
-- | for grammars obtained otherwise than by parsing ---- update!!
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)
_ -> info
codeTerm :: (String -> String) -> Term -> Term
codeTerm co t = case t of
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
codeTerm :: (String -> String) -> L Term -> L Term
codeTerm co (L loc t) = L loc (codt t)
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
PR rs -> PR [(l,codp p) | (l,p) <- rs]
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
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
mkArrity (Just a) = a
@@ -68,10 +68,10 @@ canon2pgf opts pars cgr@(M.MGrammar ((a,abm):cms)) = do
-- concretes
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
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
catfuns = Map.fromList
[(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
umkTerm = utf . mkTerm
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
-- needed even here because of restricted inheritance
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
[(i2i c, umkTerm tr) | (c,CncCat _ (Just tr) _) <- js]
[(i2i c, umkTerm tr) | (c,CncCat _ (Just (L _ tr)) _) <- js]
printnames = Map.union
(Map.fromAscList [(i2i f, realize (umkTerm tr)) | (f,CncFun _ _ (Just tr)) <- js])
(Map.fromAscList [(i2i f, realize (umkTerm tr)) | (f,CncCat _ _ (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 (L _ tr))) <- js])
params = Map.fromAscList
[(i2i c, pars lang0 c) | (c,CncCat (Just ty) _ _) <- js]
fcfg = Nothing
@@ -236,16 +236,15 @@ mkParamLincat sgr lang cat = errVal (C.R [C.S []]) $ do
reorder :: Ident -> SourceGrammar -> SourceGrammar
reorder abs cg = M.MGrammar $
(abs, M.ModInfo M.MTAbstract M.MSComplete aflags [] Nothing [] [] adefs poss):
[(c, M.ModInfo (M.MTConcrete abs) M.MSComplete fs [] Nothing [] [] (sorted2tree js) poss)
(abs, M.ModInfo M.MTAbstract M.MSComplete aflags [] Nothing [] [] adefs):
[(c, M.ModInfo (M.MTConcrete abs) M.MSComplete fs [] Nothing [] [] (sorted2tree js))
| (c,(fs,js)) <- cncs]
where
poss = emptyBinTree -- positions no longer needed
mos = M.modules cg
adefs = sorted2tree $ sortIds $
predefADefs ++ Look.allOrigInfos cg abs
predefADefs =
[(c, AbsCat (Just [])) | c <- [cFloat,cInt,cString]]
[(c, AbsCat (Just (L (0,0) []))) | c <- [cFloat,cInt,cString]]
aflags =
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)]]
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)
@@ -292,8 +291,8 @@ canon2canon opts abs cg0 =
j2j cg (f,j) =
let debug = if verbAtLeast opts Verbose then trace ("+ " ++ showIdent f) else id in
case j of
CncFun x (Just tr) z -> CncFun x (Just (debug (t2t (unfactor cg0 tr)))) z
CncCat (Just ty) (Just x) y -> CncCat (Just (ty2ty ty)) (Just (t2t (unfactor cg0 x))) y
CncFun x (Just (L loc tr)) z -> CncFun x (Just (L loc (debug (t2t (unfactor cg0 tr))))) z
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
where
cg1 = cg
@@ -315,7 +314,7 @@ canon2canon opts abs cg0 =
-- flatten record arguments of param constructors
p2p (f,j) = case j of
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
unRec (bt,x,ty) = case ty of
RecType fs -> [ity | (_,typ) <- fs, ity <- unRec (Explicit,identW,typ)]
@@ -359,13 +358,13 @@ paramValues cgr = (labels,untyps,typs) where
partyps = nub $
--- [App (Q (IC "Predef") (IC "Ints")) (EInt i) | i <- [1,9]] ---linTypeInt
[ty |
(_,(_,CncCat (Just ty0) _ _)) <- jments,
(_,(_,CncCat (Just (L _ ty0)) _ _)) <- jments,
ty <- typsFrom ty0
] ++ [
Q m ty |
(m,(ty,ResParam _ _)) <- jments
] ++ [ty |
(_,(_,CncFun _ (Just tr) _)) <- jments,
(_,(_,CncFun _ (Just (L _ tr)) _)) <- jments,
ty <- err (const []) snd $ appSTM (typsFromTrm tr) []
]
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]] ++
reverse ---- TODO: really those lincats that are reached
---- 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]]
labels = Map.fromList $ concat
[((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
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
return (Just (factor param c 0 de))
(Just typ, Nothing) -> do
return (Just (L loc (factor param c 0 de)))
(Just (L loc typ), Nothing) -> do
de <- mkLinDefault gr typ
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
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')
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
pde' <- case pde of
Just de -> do de <- partEval opts gr (cont,val) de
return (Just (factor param c 0 de))
Just (L loc de) -> do de <- partEval opts gr (cont,val) de
return (Just (L loc (factor param c 0 de)))
Nothing -> return pde
ppr' <- liftM Just $ evalPrintname gr c ppr pde'
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
| OptExpand `Set.member` optim -> do
pde' <- case pde of
Just de -> do de <- computeConcrete gr de
return (Just (factor param c 0 de))
Just (L loc de) -> do de <- computeConcrete gr de
return (Just (L loc (factor param c 0 de)))
Nothing -> return Nothing
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).
--- 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.
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 =
case ppr of
Just pr -> comp pr
Just (L loc pr) -> do pr <- comp pr
return (L loc pr)
Nothing -> case lin of
Just t -> return $ K $ clean $ render (ppTerm Unqualified 0 (oneBranch t))
Nothing -> return $ K $ showIdent c ----
Just (L loc t) -> return $ L loc (K $ clean $ render (ppTerm Unqualified 0 (oneBranch t)))
Nothing -> return $ L (0,0) (K $ showIdent c) ----
where
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)
where
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
return $ (k', (c, ResOper ptyp (Just trm')):cs)
return $ (k', (c, ResOper ptyp (Just (L loc trm'))):cs)
ResOverload os tyts -> do
(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)
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
return $ (k', (c, CncCat mt (Just trm') pn):cs)
CncFun mt (Just trm) pn -> do ---- refresh pn
return $ (k', (c, CncCat mt (Just (L loc trm')) pn):cs)
CncFun mt (Just (L loc trm)) pn -> do ---- refresh pn
(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)

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
let js1 = jments 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})
type Status = (StatusTree, [(OpenSpec, StatusTree)])
@@ -137,31 +137,49 @@ forceQualif o = case o of
OSimple i -> OQualif i i
OQualif _ i -> OQualif i i
renameInfo :: SourceModInfo -> Status -> Ident -> Info -> Check Info
renameInfo mo status i info = checkIn
(text "renaming definition of" <+> ppIdent i <+> ppPosition mo i) $
case info of
AbsCat pco -> liftM AbsCat (renPerh (renameContext status) pco)
AbsFun pty pa ptr -> liftM3 AbsFun (ren pty) (return pa) (renPerh (mapM (renameEquation status [])) ptr)
ResOper pty ptr -> liftM2 ResOper (ren pty) (ren ptr)
ResOverload os tysts ->
liftM (ResOverload os) (mapM (pairM rent) tysts)
renameInfo :: Status -> Ident -> Ident -> Info -> Check Info
renameInfo status m i info =
case info of
AbsCat pco -> liftM AbsCat (renPerh (renameContext status) pco)
AbsFun pty pa ptr -> liftM3 AbsFun (renTerm pty) (return pa) (renMaybe (mapM (renLoc (renEquation status))) ptr)
ResOper pty ptr -> liftM2 ResOper (renTerm pty) (renTerm ptr)
ResOverload os tysts -> liftM (ResOverload os) (mapM (renPair (renameTerm status [])) tysts)
ResParam (Just pp) m -> do
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
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 = renMaybe (renLoc ren)
renPerh ren (Just t) = liftM Just $ ren t
renPerh ren Nothing = return Nothing
renMaybe ren (Just x) = ren x >>= return . Just
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 env vars = ren vars where
@@ -283,11 +301,6 @@ renamePattern env patt = case patt of
renp = renamePattern 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 b = renc [] where
renc vs cont = case cont of
@@ -303,10 +316,3 @@ renameContext b = renc [] where
return $ (bt,x,t') : xts'
_ -> return cont
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
hasSub ljs = not $ null [c | (c,ResOper _ _) <- ljs]
unparInfo (c,info) = case info of
CncFun xs (Just t) m -> [(c, CncFun xs (Just (unparTerm t)) m)]
ResOper (Just (EInt 8)) _ -> [] -- subexp-generated opers
ResOper pty (Just t) -> [(c, ResOper pty (Just (unparTerm t)))]
CncFun xs (Just (L loc t)) m -> [(c, CncFun xs (Just (L loc (unparTerm t))) m)]
ResOper (Just (L loc (EInt 8))) _ -> [] -- subexp-generated opers
ResOper pty (Just (L loc t)) -> [(c, ResOper pty (Just (L loc (unparTerm t))))]
_ -> [(c,info)]
unparTerm t = case t of
Q m c | isOperIdent c -> --- name convention of subexp opers
@@ -76,12 +76,12 @@ addSubexpConsts mo tree lins = do
mapM mkOne $ opers ++ lins
where
mkOne (f,def) = case def of
CncFun xs (Just trm) pn -> do
CncFun xs (Just (L loc trm)) pn -> do
trm' <- recomp f trm
return (f,CncFun xs (Just trm') pn)
ResOper ty (Just trm) -> do
return (f,CncFun xs (Just (L loc trm')) pn)
ResOper ty (Just (L loc trm)) -> do
trm' <- recomp f trm
return (f,ResOper ty (Just trm'))
return (f,ResOper ty (Just (L loc trm')))
_ -> return (f,def)
recomp f t = case Map.lookup t tree of
Just (_,id) | operIdent id /= f -> return $ Q mo (operIdent id)
@@ -89,7 +89,7 @@ addSubexpConsts mo tree lins = do
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
getSubtermsMod :: Ident -> [(Ident,Info)] -> TermM (Map Term (Int,Int))
@@ -99,10 +99,10 @@ getSubtermsMod mo js = do
return $ Map.filter (\ (nu,_) -> nu > 1) tree0
where
getInfo get fi@(f,i) = case i of
CncFun xs (Just trm) pn -> do
CncFun xs (Just (L _ trm)) pn -> do
get trm
return $ fi
ResOper ty (Just trm) -> do
ResOper ty (Just (L _ trm)) -> do
get trm
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.
-- AR 24/10/2003
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
---- is <- openInterfaces deps i
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
let notInM0 c _ = all (not . isInBinTree c . jments) m0s
let js2 = filterBinTree notInM0 js'
return $ (replaceJudgements mi js2)
{positions = Map.union (positions m1) (positions mi)}
return $ replaceJudgements mi js2
_ -> return mi
-- 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]
testErr (stat' == MSComplete || stat == MSIncomplete)
("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 $
ops_ ++ -- N.B. js has been name-resolved already
[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 js0 = [ci | ci@(c,_) <- tree2list js, isInherited incl c]
let js1 = buildTree (tree2list js_ ++ js0)
let ps1 = Map.union ps_ ps0
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')
@@ -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 m i j = case (i,j) of
(AbsCat mc1, AbsCat mc2) ->
liftM AbsCat (unifMaybe mc1 mc2)
liftM AbsCat (unifMaybeL mc1 mc2)
(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) ->
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 ->
return $ ResOverload ms t
(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) ->
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) ->
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
testErr (b1 == b2) $ "indirection status"
@@ -205,6 +203,15 @@ unifMaybe (Just p1) (Just p2)
| p1==p2 = return (Just p1)
| 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 Nothing Nothing = return Nothing
unifAbsArrity (Just a ) Nothing = return (Just a )
@@ -213,14 +220,8 @@ unifAbsArrity (Just a1) (Just a2)
| a1==a2 = return (Just a1)
| 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 (Just _ ) Nothing = fail ""
unifAbsDefs Nothing (Just _ ) = fail ""
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
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)))

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

@@ -32,7 +32,6 @@ module GF.Infra.Modules (
emptyMGrammar, emptyModInfo,
abstractOfConcrete, abstractModOfConcrete,
lookupModule, lookupModuleType, lookupInfo,
lookupPosition, ppPosition,
isModAbs, isModRes, isModCnc,
sameMType, isCompilableModule, isCompleteModule,
allAbstracts, greatestAbstract, allResources,
@@ -64,8 +63,7 @@ data ModInfo a = ModInfo {
mwith :: Maybe (Ident,MInclude,[(Ident,Ident)]),
opens :: [OpenSpec],
mexdeps :: [Ident],
jments :: Map.Map Ident a,
positions :: Map.Map Ident (String,(Int,Int)) -- file, first line, last line
jments :: Map.Map Ident a
}
deriving Show
@@ -105,13 +103,13 @@ updateMGrammar old new = MGrammar $
ns = modules new
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 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 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 f mo = mo {flags = flags mo `addOptions` f}
@@ -216,7 +214,7 @@ emptyMGrammar :: MGrammar a
emptyMGrammar = MGrammar []
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
@@ -250,15 +248,6 @@ lookupModuleType gr m = do
lookupInfo :: ModInfo a -> Ident -> Err a
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 m =
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))
checkComputeTerm gr t = do
checkComputeTerm gr (L _ t) = do
mo <- maybe (Bad "no source grammar in scope") return $ greatestResource gr
((t,_),_) <- runCheck $ do t <- renameSourceTerm gr mo t
inferLType gr [] t
@@ -128,7 +128,7 @@ loop opts gfenv0 = do
case runP pExp (BS.pack s) of
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)
Bad s -> putStrLn $ enc s
loopNewCPU gfenv