summaryrefslogtreecommitdiff
path: root/src/compiler/GF/Compile
diff options
context:
space:
mode:
Diffstat (limited to 'src/compiler/GF/Compile')
-rw-r--r--src/compiler/GF/Compile/CheckGrammar.hs30
-rw-r--r--src/compiler/GF/Compile/Compute/AppPredefined.hs6
-rw-r--r--src/compiler/GF/Compile/GetGrammar.hs5
-rw-r--r--src/compiler/GF/Compile/GrammarToPGF.hs8
-rw-r--r--src/compiler/GF/Compile/Rename.hs27
-rw-r--r--src/compiler/GF/Compile/SubExOpt.hs2
-rw-r--r--src/compiler/GF/Compile/Update.hs45
7 files changed, 72 insertions, 51 deletions
diff --git a/src/compiler/GF/Compile/CheckGrammar.hs b/src/compiler/GF/Compile/CheckGrammar.hs
index b3129128b..44e2e552b 100644
--- a/src/compiler/GF/Compile/CheckGrammar.hs
+++ b/src/compiler/GF/Compile/CheckGrammar.hs
@@ -112,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 (L (0,0) def)) pn) js
+ Ok def -> return $ updateTree (c,CncFun ty (Just (L NoLoc 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 (L (0,0) def)) Nothing) js
+ return $ updateTree (c,CncFun (Just linty) (Just (L NoLoc def)) Nothing) js
Bad _ -> do checkWarn $ text "no linearization of" <+> ppIdent c
return js
AbsCat (Just _) -> case lookupIdent c js of
@@ -128,11 +128,11 @@ 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 (L (0,0) defLinType)) mt mp) js
+ return $ updateTree (c,CncCat (Just (L NoLoc defLinType)) mt mp) js
_ -> do
checkWarn $
text "no linearization type for" <+> ppIdent c <> text ", inserting default {s : Str}"
- return $ updateTree (c,CncCat (Just (L (0,0) defLinType)) Nothing Nothing) js
+ return $ updateTree (c,CncCat (Just (L NoLoc defLinType)) Nothing Nothing) js
_ -> return js
checkCnc js i@(c,info) =
@@ -158,15 +158,15 @@ checkInfo ms (m,mo) c info = do
checkReservedId c
case info of
AbsCat (Just (L loc cont)) ->
- mkCheck loc "category" $
+ mkCheck loc "the category" $
checkContext gr cont
AbsFun (Just (L loc typ0)) ma md moper -> do
typ <- compAbsTyp [] typ0 -- to calculate let definitions
- mkCheck loc "type of function" $
+ mkCheck loc "the type of function" $
checkTyp gr typ
case md of
- Just eqs -> mapM_ (\(L loc eq) -> mkCheck loc "definition of function" $
+ Just eqs -> mapM_ (\(L loc eq) -> mkCheck loc "the definition of function" $
checkDef gr (m,c) typ eq) eqs
Nothing -> return ()
return (AbsFun (Just (L loc typ)) ma md moper)
@@ -204,7 +204,7 @@ checkInfo ms (m,mo) c info = do
checkError (text "No definition given to the operation")
return (ResOper pty' pde')
- ResOverload os tysts -> chIn (0,0) "overloading" $ do
+ ResOverload os tysts -> chIn NoLoc "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 []))
@@ -215,17 +215,17 @@ 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) _ -> do
- ts <- liftM concat $ mapM mkPar pcs
- return (ResParam (Just pcs) (Just ts))
+ ResParam (Just (L loc pcs)) _ -> do
+ ts <- chIn loc "parameter type" $
+ liftM concat $ mapM mkPar pcs
+ return (ResParam (Just (L loc pcs)) (Just ts))
_ -> return info
where
gr = mGrammar ((m,mo) : ms)
- chIn loc cat = checkIn (text "Happened in" <+> text cat <+> ppIdent c <+> ppPosition m loc <> colon)
+ chIn loc cat = checkIn (ppLocation (msrc mo) loc <> colon $$ text "Happened in" <+> text cat <+> ppIdent c)
- mkPar (L loc (f,co)) =
- chIn loc "parameter type" $ do
+ mkPar (f,co) = do
vs <- checkErr $ liftM combinations $ mapM (\(_,_,ty) -> allParamValues gr ty) co
return $ map (mkApp (QC (m,f))) vs
@@ -238,7 +238,7 @@ checkInfo ms (m,mo) c info = do
mkCheck loc cat ss = case ss of
[] -> return info
- _ -> checkError (vcat ss $$ text "in" <+> text cat <+> ppIdent c <+> ppPosition m loc)
+ _ -> checkError (ppLocation (msrc mo) loc <> colon $$ text "Happened in" <+> text cat <+> ppIdent c $$ nest 3 (vcat ss))
compAbsTyp g t = case t of
Vr x -> maybe (checkError (text "no value given to variable" <+> ppIdent x)) return $ lookup x g
diff --git a/src/compiler/GF/Compile/Compute/AppPredefined.hs b/src/compiler/GF/Compile/Compute/AppPredefined.hs
index d15d57001..8732a8e06 100644
--- a/src/compiler/GF/Compile/Compute/AppPredefined.hs
+++ b/src/compiler/GF/Compile/Compute/AppPredefined.hs
@@ -46,14 +46,14 @@ arrityPredefined f = do ty <- typPredefined f
return (length ctxt)
predefModInfo :: SourceModInfo
-predefModInfo = ModInfo MTResource MSComplete noOptions [] Nothing [] [] primitives
+predefModInfo = ModInfo MTResource MSComplete noOptions [] Nothing [] [] "Predef.gf" primitives
primitives = Map.fromList
[ (cErrorType, ResOper (Just (noLoc typeType)) Nothing)
, (cInt , ResOper (Just (noLoc typePType)) Nothing)
, (cFloat , ResOper (Just (noLoc typePType)) Nothing)
, (cInts , fun [typeInt] typePType)
- , (cPBool , ResParam (Just [noLoc (cPTrue,[]),noLoc (cPFalse,[])]) (Just [QC (cPredef,cPTrue), QC (cPredef,cPFalse)]))
+ , (cPBool , ResParam (Just (noLoc [(cPTrue,[]),(cPFalse,[])])) (Just [QC (cPredef,cPTrue), QC (cPredef,cPFalse)]))
, (cPTrue , ResValue (noLoc typePBool))
, (cPFalse , ResValue (noLoc typePBool))
, (cError , fun [typeStr] typeError) -- non-can. of empty set
@@ -87,7 +87,7 @@ primitives = Map.fromList
fun from to = oper (mkFunType from to)
oper ty = ResOper (Just (noLoc ty)) Nothing
- noLoc = L (0,0)
+ noLoc = L NoLoc
varL :: Ident
varL = identC (BS.pack "L")
diff --git a/src/compiler/GF/Compile/GetGrammar.hs b/src/compiler/GF/Compile/GetGrammar.hs
index c7fea11b0..339f28578 100644
--- a/src/compiler/GF/Compile/GetGrammar.hs
+++ b/src/compiler/GF/Compile/GetGrammar.hs
@@ -41,9 +41,12 @@ getSourceModule opts file0 = ioe $
let location = file++":"++show l++":"++show c
return (Bad (location++": "++msg))
Right mo -> do removeTemp tmp
- return (Ok (addOptionsToModule opts mo))
+ return (Ok (addOptionsToModule opts (setSrcPath file0 mo)))
`catch` (return . Bad . show)
+setSrcPath :: FilePath -> SourceModule -> SourceModule
+setSrcPath fpath = mapSourceModule (\m -> m{msrc=fpath})
+
addOptionsToModule :: Options -> SourceModule -> SourceModule
addOptionsToModule opts = mapSourceModule (\m -> m { flags = flags m `addOptions` opts })
diff --git a/src/compiler/GF/Compile/GrammarToPGF.hs b/src/compiler/GF/Compile/GrammarToPGF.hs
index ed10697fd..81d2b3632 100644
--- a/src/compiler/GF/Compile/GrammarToPGF.hs
+++ b/src/compiler/GF/Compile/GrammarToPGF.hs
@@ -154,8 +154,8 @@ compilePatt eqs = whilePP eqs Map.empty
reorder :: Ident -> SourceGrammar -> AbsConcsGrammar
reorder abs cg =
-- M.MGrammar $
- ((abs, M.ModInfo M.MTAbstract M.MSComplete aflags [] Nothing [] [] adefs),
- [(cnc, M.ModInfo (M.MTConcrete abs) M.MSComplete cflags [] Nothing [] [] cdefs)
+ ((abs, M.ModInfo M.MTAbstract M.MSComplete aflags [] Nothing [] [] "" adefs),
+ [(cnc, M.ModInfo (M.MTConcrete abs) M.MSComplete cflags [] Nothing [] [] "" cdefs)
| cnc <- M.allConcretes cg abs, let (cflags,cdefs) = concr cnc])
where
aflags =
@@ -165,7 +165,7 @@ reorder abs cg =
Map.fromList (predefADefs ++ Look.allOrigInfos cg abs)
where
predefADefs =
- [(c, AbsCat (Just (L (0,0) []))) | c <- [cFloat,cInt,cString]]
+ [(c, AbsCat (Just (L NoLoc []))) | c <- [cFloat,cInt,cString]]
concr la = (flags, Map.fromList (predefCDefs ++ jments))
where
@@ -173,4 +173,4 @@ reorder abs cg =
Just r <- [lookup i (M.allExtendSpecs cg la)]]
jments = Look.allOrigInfos cg la
predefCDefs =
- [(c, CncCat (Just (L (0,0) GM.defLinType)) Nothing Nothing) | c <- [cInt,cFloat,cString]]
+ [(c, CncCat (Just (L NoLoc GM.defLinType)) Nothing Nothing) | c <- [cInt,cFloat,cString]]
diff --git a/src/compiler/GF/Compile/Rename.hs b/src/compiler/GF/Compile/Rename.hs
index 8cd84a1a0..4c959c194 100644
--- a/src/compiler/GF/Compile/Rename.hs
+++ b/src/compiler/GF/Compile/Rename.hs
@@ -47,24 +47,23 @@ import Text.PrettyPrint
-- | this gives top-level access to renaming term input in the cc command
renameSourceTerm :: SourceGrammar -> Ident -> Term -> Check Term
renameSourceTerm g m t = do
- mo <- checkErr $ lookupModule g m
- status <- buildStatus g m mo
+ mi <- checkErr $ lookupModule g m
+ status <- buildStatus g m mi
renameTerm status [] t
-- | this gives top-level access to renaming term input in the cj command
renameSourceJudgement :: SourceGrammar -> Ident -> (Ident,Info) -> Check (Ident,Info)
renameSourceJudgement g m (i,t) = do
- mo <- checkErr $ lookupModule g m
- status <- buildStatus g m mo
- t2 <- renameInfo status m i t
+ mi <- checkErr $ lookupModule g m
+ status <- buildStatus g m mi
+ t2 <- renameInfo status (m,mi) i t
return (i,t2)
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 status name) js1
- return (name, mo {opens = map forceQualif (opens mo), jments = js2})
+renameModule ms mo@(m,mi) = checkIn (text "renaming module" <+> ppIdent m) $ do
+ status <- buildStatus (mGrammar ms) m mi
+ js <- checkMap (renameInfo status mo) (jments mi)
+ return (m, mi{opens = map forceQualif (opens mi), jments = js})
type Status = (StatusTree, [(OpenSpec, StatusTree)])
@@ -147,15 +146,15 @@ forceQualif o = case o of
OSimple i -> OQualif i i
OQualif _ i -> OQualif i i
-renameInfo :: Status -> Ident -> Ident -> Info -> Check Info
-renameInfo status m i info =
+renameInfo :: Status -> SourceModule -> Ident -> Info -> Check Info
+renameInfo status (m,mi) i info =
case info of
AbsCat pco -> liftM AbsCat (renPerh (renameContext status) pco)
AbsFun pty pa ptr poper -> liftM4 AbsFun (renTerm pty) (return pa) (renMaybe (mapM (renLoc (renEquation status))) ptr) (return poper)
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
+ pp' <- renLoc (mapM (renParam status)) pp
return (ResParam (Just pp') m)
ResValue t -> do
t <- renLoc (renameTerm status []) t
@@ -172,7 +171,7 @@ renameInfo status m i info =
renMaybe ren Nothing = return Nothing
renLoc ren (L loc x) =
- checkIn (text "renaming of" <+> ppIdent i <+> ppPosition m loc) $ do
+ checkIn (ppLocation (msrc mi) loc <> colon $$ text "Happened in the renaming of" <+> ppIdent i) $ do
x <- ren x
return (L loc x)
diff --git a/src/compiler/GF/Compile/SubExOpt.hs b/src/compiler/GF/Compile/SubExOpt.hs
index 49d7efb81..808e4dca8 100644
--- a/src/compiler/GF/Compile/SubExOpt.hs
+++ b/src/compiler/GF/Compile/SubExOpt.hs
@@ -89,7 +89,7 @@ addSubexpConsts mo tree lins = do
list = Map.toList tree
- oper id trm = (operIdent id, ResOper (Just (L (0,0) (EInt 8))) (Just (L (0,0) trm)))
+ oper id trm = (operIdent id, ResOper (Just (L NoLoc (EInt 8))) (Just (L NoLoc trm)))
--- impossible type encoding generated opers
getSubtermsMod :: Ident -> [(Ident,Info)] -> TermM (Map Term (Int,Int))
diff --git a/src/compiler/GF/Compile/Update.hs b/src/compiler/GF/Compile/Update.hs
index 1dcae722c..fe9bd5984 100644
--- a/src/compiler/GF/Compile/Update.hs
+++ b/src/compiler/GF/Compile/Update.hs
@@ -63,7 +63,7 @@ extendModule gr (name,m)
let isCompl = isCompleteModule m0
-- build extension in a way depending on whether the old module is complete
- js1 <- extendMod gr isCompl (n, isInherited cond) name (jments m0) (jments mo)
+ js1 <- extendMod gr isCompl ((n,m0), isInherited cond) name (jments mo)
-- if incomplete, throw away extension information
return $
@@ -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_)) = do
+rebuildModule gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ src_ 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
@@ -92,7 +92,7 @@ rebuildModule gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ js_)) = do
MTInstance (i0,mincl) -> do
m1 <- lookupModule gr i0
testErr (isModRes m1) ("interface expected instead of" +++ showIdent i0)
- js' <- extendMod gr False (i0, isInherited mincl) i (jments m1) (jments mi)
+ js' <- extendMod gr False ((i0,m1), isInherited mincl) i (jments mi)
--- to avoid double inclusions, in instance I of I0 = J0 ** ...
case extends mi of
[] -> return $ replaceJudgements mi js'
@@ -110,7 +110,7 @@ rebuildModule gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ js_)) = do
[i | i <- is, notElem i infs]
testErr (stat' == MSComplete || stat == MSIncomplete)
("module" +++ showIdent i +++ "remains incomplete")
- ModInfo mt0 _ fs me' _ ops0 _ js <- 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,7 +123,7 @@ rebuildModule gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ js_)) = do
let js0 = [ci | ci@(c,_) <- tree2list js, isInherited incl c]
let js1 = buildTree (tree2list js_ ++ js0)
let med1= nub (ext : infs ++ insts ++ med_)
- return $ ModInfo mt0 stat' fs1 me Nothing ops1 med1 js1
+ return $ ModInfo mt0 stat' fs1 me Nothing ops1 med1 src_ js1
return (i,mi')
@@ -131,12 +131,11 @@ rebuildModule gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ js_)) = do
-- and the process is interrupted if unification fails.
-- If the extended module is incomplete, its judgements are just copied.
extendMod :: SourceGrammar ->
- Bool -> (Ident,Ident -> Bool) -> Ident ->
- BinTree Ident Info -> BinTree Ident Info ->
- Err (BinTree Ident Info)
-extendMod gr isCompl (name,cond) base old new = foldM try new $ Map.toList old
+ Bool -> (SourceModule,Ident -> Bool) -> Ident ->
+ BinTree Ident Info -> Err (BinTree Ident Info)
+extendMod gr isCompl ((name,mi),cond) base new = foldM try new $ Map.toList (jments mi)
where
- try new (c,i)
+ try new (c,i0)
| not (cond c) = return new
| otherwise = case Map.lookup c new of
Just j -> case unifyAnyInfo name i j of
@@ -155,6 +154,8 @@ extendMod gr isCompl (name,cond) base old new = foldM try new $ Map.toList old
Nothing-> if isCompl
then return $ updateTree (c,indirInfo name i) new
else return $ updateTree (c,i) new
+ where
+ i = globalizeLoc (msrc mi) i0
indirInfo :: Ident -> Info -> Info
indirInfo n info = AnyInd b n' where
@@ -165,6 +166,24 @@ extendMod gr isCompl (name,cond) base old new = foldM try new $ Map.toList old
AnyInd b k -> (b,k)
_ -> (False,n) ---- canonical in Abs
+globalizeLoc fpath i =
+ case i of
+ AbsCat mc -> AbsCat (fmap gl mc)
+ AbsFun mt ma md moper -> AbsFun (fmap gl mt) ma (fmap (fmap gl) md) moper
+ ResParam mt mv -> ResParam (fmap gl mt) mv
+ ResValue t -> ResValue (gl t)
+ ResOper mt m -> ResOper (fmap gl mt) (fmap gl m)
+ ResOverload ms os -> ResOverload ms (map (\(x,y) -> (gl x,gl y)) os)
+ CncCat mc mf mp -> CncCat (fmap gl mc) (fmap gl mf) (fmap gl mp)
+ CncFun m mt md -> CncFun m (fmap gl mt) (fmap gl md)
+ AnyInd b m -> AnyInd b m
+ where
+ gl (L loc0 x) = loc `seq` L (External fpath loc) x
+ where
+ loc = case loc0 of
+ External _ loc -> loc
+ loc -> loc
+
unifyAnyInfo :: Ident -> Info -> Info -> Err Info
unifyAnyInfo m i j = case (i,j) of
(AbsCat mc1, AbsCat mc2) ->
@@ -173,9 +192,9 @@ unifyAnyInfo m i j = case (i,j) of
liftM4 AbsFun (unifMaybeL mt1 mt2) (unifAbsArrity ma1 ma2) (unifAbsDefs md1 md2) (unifMaybe moper1 moper2) -- adding defs
(ResParam mt1 mv1, ResParam mt2 mv2) ->
- liftM2 ResParam (unifMaybe mt1 mt2) (unifMaybe mv1 mv2)
- (ResValue t1, ResValue t2)
- | t1==t2 -> return (ResValue t1)
+ liftM2 ResParam (unifMaybeL mt1 mt2) (unifMaybe mv1 mv2)
+ (ResValue (L l1 t1), ResValue (L l2 t2))
+ | t1==t2 -> return (ResValue (L l1 t1))
| otherwise -> fail ""
(_, ResOverload ms t) | elem m ms ->
return $ ResOverload ms t
generated by cgit v1.2.3 (git 2.39.1) at 2026-05-20 06:20:05 +0000