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

Now the compiler maintains more precise information for the source locations of the different definitions. There is a --tags option which generates a list of all identifiers with their source locations.

Browse Source
This commit is contained in:
kr.angelov
2011-11-02 11:44:59 +00:00
parent 5664c0699d
commit bc35626489
22 changed files with 232 additions and 129 deletions
Download Patch File Download Diff File Expand all files Collapse all files

9
src/compiler/GF/Command/Importing.hs
View File

@@ -55,12 +55,11 @@ importSource src0 opts files = do
-- for different cf formats
importCF opts files get = do
s <- fmap unlines $ mapM readFile files
let cnc = justModuleName (last files)
gf <- case get cnc s of
Ok g -> return g
gf <- case get (last files) s of
Ok gf -> return gf
Bad s -> error s ----
Ok gr <- appIOE $ compileSourceGrammar opts gf
epgf <- appIOE $ link opts (identC (BS.pack (cnc ++ "Abs"))) gr
epgf <- appIOE $ link opts (identC (BS.pack (justModuleName (last files) ++ "Abs"))) gr
case epgf of
Ok pgf -> return pgf
Bad s -> error s ----
Bad s -> error s ----

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

@@ -70,12 +70,11 @@ batchCompile opts files = do
-- to compile a set of modules, e.g. an old GF or a .cf file
compileSourceGrammar :: Options -> SourceGrammar -> IOE SourceGrammar
compileSourceGrammar opts gr = do
(_,gr',_) <- foldM compOne (0,emptySourceGrammar,Map.empty) (modules gr)
(_,gr',_) <- foldM (\env -> compileSourceModule opts env Nothing)
(0,emptySourceGrammar,Map.empty)
(modules gr)
return gr'
where
compOne env mo = do
(k,mo') <- compileSourceModule opts env mo
extendCompileEnvInt env k Nothing mo' --- file for the same of modif time...
-- to output an intermediate stage
intermOut :: Options -> Dump -> Doc -> IOE ()
@@ -161,18 +160,16 @@ compileOne opts env@(_,srcgr,_) file = do
sm00 <- putpOpt ("- parsing" +++ file) ("- compiling" +++ file ++ "... ") $
getSourceModule opts file
enc <- ioeIO $ mkTextEncoding (renameEncoding (flag optEncoding (flagsModule sm00)))
let sm0 = decodeStringsInModule enc sm00
let sm = decodeStringsInModule enc sm00
intermOut opts DumpSource (ppModule Qualified sm0)
intermOut opts DumpSource (ppModule Qualified sm)
(k',sm) <- compileSourceModule opts env sm0
putPointE Verbose opts " generating code... " $ generateModuleCode opts gfo sm
extendCompileEnvInt env k' (Just gfo) sm
compileSourceModule opts env (Just gfo) sm
where
isConcr (_,m) = isModCnc m && mstatus m /= MSIncomplete
compileSourceModule :: Options -> CompileEnv -> SourceModule -> IOE (Int,SourceModule)
compileSourceModule opts env@(k,gr,_) mo@(i,mi) = do
compileSourceModule :: Options -> CompileEnv -> Maybe FilePath -> SourceModule -> IOE CompileEnv
compileSourceModule opts env@(k,gr,_) mb_gfo mo@(i,mi) = do
let puts = putPointE Quiet opts
putpp = putPointE Verbose opts
@@ -185,7 +182,13 @@ compileSourceModule opts env@(k,gr,_) mo@(i,mi) = do
case mo1b of
(_,n) | not (isCompleteModule n) -> do
return (k,mo1b) -- refresh would fail, since not renamed
case mb_gfo of
Just gfo -> if flag optMode opts /= ModeTags
then putPointE Verbose opts " generating code... " $ generateModuleCode opts gfo mo1b
else putStrLnE "" >> return mo1b
Nothing -> return mo1b
extendCompileEnvInt env k mb_gfo mo1b
_ -> do
let mos = modules gr
@@ -197,13 +200,21 @@ compileSourceModule opts env@(k,gr,_) mo@(i,mi) = do
if null warnings then return () else puts warnings $ return ()
intermOut opts DumpTypeCheck (ppModule Qualified mo3)
(k',mo3r:_) <- putpp " refreshing " $ ioeErr $ refreshModule (k,mos) mo3
intermOut opts DumpRefresh (ppModule Qualified mo3r)
if flag optMode opts /= ModeTags
then do (k',mo3r:_) <- putpp " refreshing " $ ioeErr $ refreshModule (k,mos) mo3
intermOut opts DumpRefresh (ppModule Qualified mo3r)
mo4 <- putpp " optimizing " $ ioeErr $ optimizeModule opts mos mo3r
intermOut opts DumpOptimize (ppModule Qualified mo4)
mo4 <- putpp " optimizing " $ ioeErr $ optimizeModule opts mos mo3r
intermOut opts DumpOptimize (ppModule Qualified mo4)
case mb_gfo of
Just gfo -> putPointE Verbose opts " generating code... " $ generateModuleCode opts gfo mo4
Nothing -> return mo4
extendCompileEnvInt env k' mb_gfo mo4
else do putStrLnE ""
extendCompileEnvInt env k mb_gfo mo3
return (k',mo4)
generateModuleCode :: Options -> FilePath -> SourceModule -> IOE SourceModule
generateModuleCode opts file minfo = do

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

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

6
src/compiler/GF/Compile/Compute/AppPredefined.hs
View File

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

5
src/compiler/GF/Compile/GetGrammar.hs
View File

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

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

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

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

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

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

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

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

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

2
src/compiler/GF/Grammar/Analyse.hs
View File

@@ -107,7 +107,7 @@ sizeInfo i = case i of
AbsFun mt mi me mb -> 1 + msize mt +
sum [sum (map (sizeTerm . patt2term) ps) + sizeTerm t | Just es <- [me], L _ (ps,t) <- es]
ResParam mp mt ->
1 + sum [1 + sum [1 + sizeTerm ty | (_,_,ty) <- co] | Just ps <- [mp], L _ (_,co) <- ps]
1 + sum [1 + sum [1 + sizeTerm ty | (_,_,ty) <- co] | Just (L _ ps) <- [mp], (_,co) <- ps]
ResValue lt -> 0
ResOper mt md -> 1 + msize mt + msize md
ResOverload is fs -> 1 + sum [sizeTerm ty + sizeTerm tr | (L _ ty, L _ tr) <- fs]

20
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)
get = do (mtype,mstatus,flags,extend,mwith,opens,med,jments) <- get
return (ModInfo mtype mstatus flags extend mwith opens med jments)
put mi = do put (mtype mi,mstatus mi,flags mi,extend mi,mwith mi,opens mi,mexdeps mi,msrc mi,jments mi)
get = do (mtype,mstatus,flags,extend,mwith,opens,med,src,jments) <- get
return (ModInfo mtype mstatus flags extend mwith opens med src jments)
instance Binary ModuleType where
put MTAbstract = putWord8 0
@@ -109,6 +109,16 @@ instance Binary Info where
8 -> get >>= \(x,y) -> return (AnyInd x y)
_ -> decodingError
instance Binary Location where
put NoLoc = putWord8 0
put (Local x y) = putWord8 1 >> put (x,y)
put (External x y) = putWord8 2 >> put (x,y)
get = do tag <- getWord8
case tag of
0 -> return NoLoc
1 -> get >>= \(x,y) -> return (Local x y)
2 -> get >>= \(x,y) -> return (External x y)
instance Binary a => Binary (L a) where
put (L x y) = put (x,y)
get = get >>= \(x,y) -> return (L x y)
@@ -261,7 +271,7 @@ 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)
(m,mtype,mstatus,flags,extend,mwith,opens,med,src) <- decodeFile fpath
return (m,ModInfo mtype mstatus flags extend mwith opens med src Map.empty)
decodingError = fail "This GFO file was compiled with different version of GF"

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

@@ -19,15 +19,17 @@ import GF.Grammar.Macros
import GF.Infra.Ident
import GF.Infra.Modules
import GF.Infra.Option
import GF.Infra.UseIO
import GF.Data.Operations
import Data.Char
import Data.List
import qualified Data.ByteString.Char8 as BS
import System.FilePath
getCF :: String -> String -> Err SourceGrammar
getCF name = fmap (cf2gf name) . pCF
getCF :: FilePath -> String -> Err SourceGrammar
getCF fpath = fmap (cf2gf fpath) . pCF
---------------------
-- the parser -------
@@ -50,9 +52,9 @@ getCFRule :: String -> Err [CFRule]
getCFRule s = getcf (wrds s) where
getcf ws = case ws of
fun : cat : a : its | isArrow a ->
Ok [L (0,0) (init fun, (cat, map mkIt its))]
Ok [L NoLoc (init fun, (cat, map mkIt its))]
cat : a : its | isArrow a ->
Ok [L (0,0) (mkFun cat it, (cat, map mkIt it)) | it <- chunk its]
Ok [L NoLoc (mkFun cat it, (cat, map mkIt it)) | it <- chunk its]
_ -> Bad (" invalid rule:" +++ s)
isArrow a = elem a ["->", "::="]
mkIt w = case w of
@@ -80,13 +82,14 @@ type CFFun = String
-- the compiler ----------
--------------------------
cf2gf :: String -> CF -> SourceGrammar
cf2gf name cf = mGrammar [
cf2gf :: FilePath -> CF -> SourceGrammar
cf2gf fpath cf = mGrammar [
(aname, addFlag (modifyFlags (\fs -> fs{optStartCat = Just cat}))
(emptyModInfo{mtype = MTAbstract, jments = abs})),
(cname, emptyModInfo{mtype = MTConcrete aname, jments = cnc})
(emptyModInfo{mtype = MTAbstract, msrc=fpath, jments = abs})),
(cname, emptyModInfo{mtype = MTConcrete aname, msrc=fpath, jments = cnc})
]
where
name = justModuleName fpath
(abs,cnc,cat) = cf2grammar cf
aname = identS $ name ++ "Abs"
cname = identS name
@@ -99,7 +102,7 @@ cf2grammar rules = (buildTree abs, buildTree conc, cat) where
cat = case rules of
(L _ (_,(c,_))):_ -> c -- the value category of the first rule
_ -> error "empty CF"
cats = [(cat, AbsCat (Just (L (0,0) []))) |
cats = [(cat, AbsCat (Just (L NoLoc []))) |
cat <- nub (concat (map cf2cat rules))] ----notPredef cat
lincats = [(cat, CncCat (Just (L loc defLinType)) Nothing Nothing) | (cat,AbsCat (Just (L loc _))) <- cats]
(funs,lins) = unzip (map cf2rule rules)

7
src/compiler/GF/Grammar/EBNF.hs
View File

@@ -24,13 +24,14 @@ import GF.Grammar.Grammar
import Data.Char
import Data.List
import System.FilePath
-- AR 18/4/2000 - 31/3/2004
getEBNF :: String -> String -> Err SourceGrammar
getEBNF name = fmap (cf2gf name . ebnf2cf) . pEBNF
getEBNF :: FilePath -> String -> Err SourceGrammar
getEBNF fpath = fmap (cf2gf fpath . ebnf2cf) . pEBNF
type EBNF = [ERule]
type ERule = (ECat, ERHS)
@@ -54,7 +55,7 @@ type CFJustRule = (CFCat, CFRHS)
ebnf2cf :: EBNF -> [CFRule]
ebnf2cf ebnf =
[L (0,0) (mkCFF i rule,rule) | (i,rule) <- zip [0..] (normEBNF ebnf)] where
[L NoLoc (mkCFF i rule,rule) | (i,rule) <- zip [0..] (normEBNF ebnf)] where
mkCFF i (c, _) = ("Mk" ++ c ++ "_" ++ show i)
normEBNF :: EBNF -> [CFJustRule]

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

@@ -20,7 +20,7 @@ module GF.Grammar.Grammar (SourceGrammar,
SourceModule,
mapSourceModule,
Info(..),
L(..), unLoc,
Location(..), L(..), unLoc,
Type,
Cat,
Fun,
@@ -80,7 +80,7 @@ data Info =
| AbsFun (Maybe (L Type)) (Maybe Int) (Maybe [L Equation]) (Maybe Bool) -- ^ (/ABS/) type, arrity and definition of a function
-- judgements in resource
| ResParam (Maybe [L 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 (L Type) -- ^ (/RES/) to mark parameter constructors for lookup
| ResOper (Maybe (L Type)) (Maybe (L Term)) -- ^ (/RES/)
@@ -94,8 +94,14 @@ data Info =
| AnyInd Bool Ident -- ^ (/INDIR/) the 'Bool' says if canonical
deriving Show
data L a = L (Int,Int) a -- location information
deriving (Eq,Show)
data Location
= NoLoc
| Local Int Int
| External FilePath Location
deriving (Show,Eq,Ord)
data L a = L Location a -- location information
deriving Show
instance Functor L where
fmap f (L loc x) = L loc (f x)

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

@@ -191,7 +191,7 @@ lookupCatContext gr m c = do
-- this gives all opers and param constructors, also overloaded opers and funs, and the types, and locations
-- notice that it only gives the modules that are reachable and the opers that are included
allOpers :: SourceGrammar -> [((Ident,Ident),Type,(Int,Int))]
allOpers :: SourceGrammar -> [((Ident,Ident),Type,Location)]
allOpers gr =
[((mo,op),typ,loc) |
(mo,minc) <- reachable,
@@ -212,7 +212,7 @@ allOpers gr =
_ -> []
--- not for dependent types
allOpersTo :: SourceGrammar -> Type -> [((Ident,Ident),Type,(Int,Int))]
allOpersTo :: SourceGrammar -> Type -> [((Ident,Ident),Type,Location)]
allOpersTo gr ty = [op | op@(_,typ,_) <- allOpers gr, isProdTo ty typ] where
isProdTo t typ = eqProd typ t || case typ of
Prod _ _ a b -> isProdTo t b

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

@@ -560,7 +560,7 @@ allDependencies ism b =
pts i = case i of
ResOper pty pt -> [pty,pt]
ResOverload _ tyts -> concat [[Just ty, Just tr] | (ty,tr) <- tyts]
ResParam (Just ps) _ -> [Just (L loc t) | L loc (_,cont) <- ps, (_,_,t) <- cont]
ResParam (Just (L loc ps)) _ -> [Just (L loc t) | (_,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

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

@@ -5,7 +5,7 @@ module GF.Grammar.Parser
, pModDef
, pModHeader
, pExp
, pTopDef
, pTopDef
) where
import GF.Infra.Ident
@@ -118,14 +118,14 @@ ModDef
defs <- case buildAnyTree id jments of
Ok x -> return x
Bad msg -> fail msg
return (id, ModInfo mtype mstat opts extends with opens [] defs) }
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) }
in (id, ModInfo mtype mstat noOptions extends with opens [] "" emptyBinTree) }
ComplMod :: { ModuleStatus }
ComplMod
@@ -251,9 +251,9 @@ DataDef
ParamDef :: { [(Ident,Info)] }
ParamDef
: 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)] }
: Posn Ident '=' ListParConstr Posn { ($2, ResParam (Just (mkL $1 $5 [param | L loc param <- $4])) Nothing) :
[(f, ResValue (L loc (mkProdSimple co (Cn $2)))) | L loc (f,co) <- $4] }
| Posn Ident Posn { [($2, ResParam Nothing Nothing)] }
OperDef :: { [(Ident,Info)] }
OperDef
@@ -679,7 +679,7 @@ checkInfoType mt jment@(id,info) =
AbsFun pty _ pde _ -> ifAbstract mt (locPerh pty ++ maybe [] locAll pde)
CncCat pty pd ppn -> ifConcrete mt (locPerh pty ++ locPerh pd ++ locPerh ppn)
CncFun _ pd ppn -> ifConcrete mt (locPerh pd ++ locPerh ppn)
ResParam pparam _ -> ifResource mt (maybe [] locAll pparam)
ResParam pparam _ -> ifResource mt (locPerh pparam)
ResValue ty -> ifResource mt (locL ty)
ResOper pty pt -> ifOper mt pty pt
ResOverload _ xs -> ifResource mt (concat [[loc1,loc2] | (L loc1 _,L loc2 _) <- xs])
@@ -688,8 +688,8 @@ checkInfoType mt jment@(id,info) =
locAll xs = [loc | L loc x <- xs]
locL (L loc x) = [loc]
illegal ((s,e):_) = failLoc (Pn s 0) "illegal definition"
illegal _ = return jment
illegal (Local s e:_) = failLoc (Pn s 0) "illegal definition"
illegal _ = return jment
ifAbstract MTAbstract locs = return jment
ifAbstract _ locs = illegal locs
@@ -729,6 +729,6 @@ mkAlts cs = case cs of
_ -> fail "no strs from pattern"
mkL :: Posn -> Posn -> x -> L x
mkL (Pn l1 _) (Pn l2 _) x = L (l1,l2) x
mkL (Pn l1 _) (Pn l2 _) x = L (Local l1 l2) x
}

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

@@ -17,7 +17,7 @@ module GF.Grammar.Printer
, ppPatt
, ppValue
, ppConstrs
, ppPosition
, ppLocation
, ppQIdent
) where
@@ -38,7 +38,7 @@ ppGrammar :: SourceGrammar -> Doc
ppGrammar sgr = vcat $ map (ppModule Qualified) $ modules sgr
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
@@ -97,8 +97,8 @@ ppJudgement q (id, AbsFun ptype _ pexp poper) =
ppJudgement q (id, ResParam pparams _) =
text "param" <+> ppIdent id <+>
(case pparams of
Just ps -> equals <+> fsep (intersperse (char '|') (map (ppParam q) ps))
_ -> empty) <+> semi
Just (L _ ps) -> equals <+> fsep (intersperse (char '|') (map (ppParam q) ps))
_ -> empty) <+> semi
ppJudgement q (id, ResValue pvalue) = empty
ppJudgement q (id, ResOper ptype pexp) =
text "oper" <+> ppIdent id <+>
@@ -269,12 +269,14 @@ ppBind (Implicit,v) = braces (ppIdent v)
ppAltern q (x,y) = ppTerm q 0 x <+> char '/' <+> ppTerm q 0 y
ppParam q (L _ (id,cxt)) = ppIdent id <+> hsep (map (ppDDecl q) cxt)
ppParam q (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
ppLocation :: FilePath -> Location -> Doc
ppLocation fpath NoLoc = text fpath
ppLocation fpath (External p l) = ppLocation p l
ppLocation fpath (Local b e)
| b == e = text fpath <> colon <> int b
| otherwise = text fpath <> colon <> int b <> text "-" <> int e
commaPunct f ds = (hcat (punctuate comma (map f ds)))

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

@@ -46,16 +46,11 @@ import GF.Data.Operations
import Data.List
import qualified Data.Map as Map
import Text.PrettyPrint
import System.FilePath
-- AR 29/4/2003
-- The same structure will be used in both source code and canonical.
-- The parameters tell what kind of data is involved.
-- Invariant: modules are stored in dependency order
--mGrammar = MGrammar
--newtype MGrammar a = MGrammar {modules :: [(Ident,ModInfo a)]}
data MGrammar a = MGrammar { moduleMap :: Map.Map Ident (ModInfo a),
modules :: [(Ident,ModInfo a)] }
deriving Show
@@ -69,6 +64,7 @@ data ModInfo a = ModInfo {
mwith :: Maybe (Ident,MInclude,[(Ident,Ident)]),
opens :: [OpenSpec],
mexdeps :: [Ident],
msrc :: FilePath,
jments :: Map.Map Ident a
}
deriving Show
@@ -109,13 +105,13 @@ updateMGrammar (MGrammar omap os) (MGrammar nmap ns) =
nis = map fst ns
-}
updateModule :: ModInfo t -> Ident -> t -> ModInfo t
updateModule (ModInfo mt ms fs me mw ops med js) i t = ModInfo mt ms fs me mw ops med (updateTree (i,t) js)
updateModule (ModInfo mt ms fs me mw ops med src js) i t = ModInfo mt ms fs me mw ops med src (updateTree (i,t) js)
replaceJudgements :: ModInfo t -> Map.Map Ident t -> ModInfo t
replaceJudgements (ModInfo mt ms fs me mw ops med _) js = ModInfo mt ms fs me mw ops med js
replaceJudgements (ModInfo mt ms fs me mw ops med src _) js = ModInfo mt ms fs me mw ops med src js
addOpenQualif :: Ident -> Ident -> ModInfo t -> ModInfo t
addOpenQualif i j (ModInfo mt ms fs me mw ops med js) = ModInfo mt ms fs me mw (OQualif i j : ops) med js
addOpenQualif i j (ModInfo mt ms fs me mw ops med src js) = ModInfo mt ms fs me mw (OQualif i j : ops) med src js
addFlag :: Options -> ModInfo t -> ModInfo t
addFlag f mo = mo {flags = flags mo `addOptions` f}
@@ -227,7 +223,7 @@ emptyMGrammar :: MGrammar a
emptyMGrammar = mGrammar []
emptyModInfo :: ModInfo a
emptyModInfo = ModInfo MTResource MSComplete noOptions [] Nothing [] [] emptyBinTree
emptyModInfo = ModInfo MTResource MSComplete noOptions [] Nothing [] [] "" emptyBinTree
-- | we store the module type with the identifier

3
src/compiler/GF/Infra/Option.hs
View File

@@ -74,7 +74,7 @@ errors = fail . unlines
-- Types
data Mode = ModeVersion | ModeHelp | ModeInteractive | ModeRun | ModeCompiler
| ModeServer
| ModeServer | ModeTags
deriving (Show,Eq,Ord)
data Verbosity = Quiet | Normal | Verbose | Debug
@@ -299,6 +299,7 @@ optDescr =
Option [] ["interactive"] (NoArg (mode ModeInteractive)) "Run in interactive mode (default).",
Option [] ["run"] (NoArg (mode ModeRun)) "Run in interactive mode, showing output only (no other messages).",
Option [] ["server"] (NoArg (mode ModeServer)) "Run in HTTP server mode.",
Option [] ["tags"] (NoArg (mode ModeTags)) "Build TAGS file and exit.",
Option ['E'] [] (NoArg (phase Preproc)) "Stop after preprocessing (with --preproc).",
Option ['C'] [] (NoArg (phase Convert)) "Stop after conversion to .gf.",
Option ['c'] [] (NoArg (phase Compile)) "Stop after compiling to .gfo (default) .",