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

Merge branch 'c-runtime' into compact-pgf

Browse Source
This commit is contained in:
krangelov
2019-09-20 10:55:23 +02:00
parent e989cc69a2 8a419f66a6
commit 9e3512db81
10 changed files with 70 additions and 232 deletions
Download Patch File Download Diff File Expand all files Collapse all files

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

@@ -57,7 +57,7 @@ checkModule opts cwd sgr mo@(m,mi) = do
where
updateCheckInfos mo = fmap (foldl update mo) . parallelCheck . map check
where check (i,info) = fmap ((,) i) (checkInfo opts cwd sgr mo i info)
update mo@(m,mi) (i,info) = (m,mi{jments=updateTree (i,info) (jments mi)})
update mo@(m,mi) (i,info) = (m,mi{jments=Map.insert i info (jments mi)})
-- check if restricted inheritance modules are still coherent
-- i.e. that the defs of remaining names don't depend on omitted names
@@ -70,7 +70,7 @@ checkRestrictedInheritance cwd sgr (name,mo) = checkInModule cwd mo NoLoc empty
where
mos = modules sgr
checkRem ((i,m),mi) = do
let (incl,excl) = partition (isInherited mi) (map fst (tree2list (jments m)))
let (incl,excl) = partition (isInherited mi) (Map.keys (jments m))
let incld c = Set.member c (Set.fromList incl)
let illegal c = Set.member c (Set.fromList excl)
let illegals = [(f,is) |
@@ -87,10 +87,10 @@ checkCompleteGrammar opts cwd gr (am,abs) (cm,cnc) = checkInModule cwd cnc NoLoc
let jsc = jments cnc
-- check that all concrete constants are in abstract; build types for all lin
jsc <- foldM checkCnc emptyBinTree (tree2list jsc)
jsc <- foldM checkCnc Map.empty (Map.toList jsc)
-- check that all abstract constants are in concrete; build default lin and lincats
jsc <- foldM checkAbs jsc (tree2list jsa)
jsc <- foldM checkAbs jsc (Map.toList jsa)
return (cm,cnc{jments=jsc})
where
@@ -111,17 +111,17 @@ checkCompleteGrammar opts cwd gr (am,abs) (cm,cnc) = checkInModule cwd cnc NoLoc
case lookupIdent c js of
Ok (AnyInd _ _) -> return js
Ok (CncFun ty (Just def) mn mf) ->
return $ updateTree (c,CncFun ty (Just def) mn mf) js
return $ Map.insert c (CncFun ty (Just def) mn mf) js
Ok (CncFun ty Nothing mn mf) ->
case mb_def of
Ok def -> return $ updateTree (c,CncFun ty (Just (L NoLoc def)) mn mf) js
Ok def -> return $ Map.insert c (CncFun ty (Just (L NoLoc def)) mn mf) js
Bad _ -> do noLinOf 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 NoLoc def)) Nothing Nothing) js
return $ Map.insert c (CncFun (Just linty) (Just (L NoLoc def)) Nothing Nothing) js
Bad _ -> do noLinOf c
return js
where noLinOf c = checkWarn ("no linearization of" <+> c)
@@ -130,24 +130,24 @@ checkCompleteGrammar opts cwd gr (am,abs) (cm,cnc) = checkInModule cwd cnc NoLoc
Ok (CncCat (Just _) _ _ _ _) -> return js
Ok (CncCat Nothing md mr mp mpmcfg) -> do
checkWarn ("no linearization type for" <+> c <> ", inserting default {s : Str}")
return $ updateTree (c,CncCat (Just (L NoLoc defLinType)) md mr mp mpmcfg) js
return $ Map.insert c (CncCat (Just (L NoLoc defLinType)) md mr mp mpmcfg) js
_ -> do
checkWarn ("no linearization type for" <+> c <> ", inserting default {s : Str}")
return $ updateTree (c,CncCat (Just (L NoLoc defLinType)) Nothing Nothing Nothing Nothing) js
return $ Map.insert c (CncCat (Just (L NoLoc defLinType)) Nothing Nothing Nothing Nothing) js
_ -> return js
checkCnc js i@(c,info) =
checkCnc js (c,info) =
case info of
CncFun _ d mn mf -> case lookupOrigInfo gr (am,c) of
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 mn mf) js
return $ Map.insert c (CncFun (Just linty) d mn mf) js
_ -> do checkWarn ("function" <+> c <+> "is not in abstract")
return js
CncCat {} ->
case lookupOrigInfo gr (am,c) of
Ok (_,AbsCat _) -> return $ updateTree i js
Ok (_,AbsCat _) -> return $ Map.insert c info js
{- -- This might be too pedantic:
Ok (_,AbsFun {}) ->
checkError ("lincat:"<+>c<+>"is a fun, not a cat")
@@ -155,7 +155,7 @@ checkCompleteGrammar opts cwd gr (am,abs) (cm,cnc) = checkInModule cwd cnc NoLoc
_ -> do checkWarn ("category" <+> c <+> "is not in abstract")
return js
_ -> return $ updateTree i js
_ -> return $ Map.insert c info js
-- | General Principle: only Just-values are checked.

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

@@ -1,64 +0,0 @@
module GF.Compile.Coding where
{-
import GF.Grammar.Grammar
import GF.Grammar.Macros
import GF.Text.Coding
--import GF.Infra.Option
import GF.Data.Operations
--import Data.Char
import System.IO
import qualified Data.ByteString.Char8 as BS
encodeStringsInModule :: TextEncoding -> SourceModule -> SourceModule
encodeStringsInModule enc = codeSourceModule (BS.unpack . encodeUnicode enc)
decodeStringsInModule :: TextEncoding -> SourceModule -> SourceModule
decodeStringsInModule enc mo = codeSourceModule (decodeUnicode enc . BS.pack) mo
codeSourceModule :: (String -> String) -> SourceModule -> SourceModule
codeSourceModule co (id,mo) = (id,mo{jments = mapTree codj (jments mo)})
where
codj (c,info) = case info of
ResOper pty pt -> ResOper (codeLTerms co pty) (codeLTerms co pt)
ResOverload es tyts -> ResOverload es [(codeLTerm co ty,codeLTerm co t) | (ty,t) <- tyts]
CncCat mcat mdef mref mpr mpmcfg -> CncCat mcat (codeLTerms co mdef) (codeLTerms co mref) (codeLTerms co mpr) mpmcfg
CncFun mty mt mpr mpmcfg -> CncFun mty (codeLTerms co mt) (codeLTerms co mpr) mpmcfg
_ -> info
codeLTerms co = fmap (codeLTerm co)
codeLTerm :: (String -> String) -> L Term -> L Term
codeLTerm = fmap . codeTerm
codeTerm :: (String -> String) -> Term -> Term
codeTerm co = codt
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)
PChars s -> PChars (co s)
PT x p -> PT x (codp p)
PAs x p -> PAs x (codp p)
PNeg p -> PNeg (codp p)
PRep p -> PRep (codp p)
PSeq p q -> PSeq (codp p) (codp q)
PAlt p q -> PAlt (codp p) (codp q)
_ -> p
-- | Run an encoding function on all string literals within the given string.
codeStringLiterals :: (String -> String) -> String -> String
codeStringLiterals _ [] = []
codeStringLiterals co ('"':cs) = '"' : inStringLiteral cs
where inStringLiteral [] = error "codeStringLiterals: unterminated string literal"
inStringLiteral ('"':ds) = '"' : codeStringLiterals co ds
inStringLiteral ('\\':d:ds) = '\\' : co [d] ++ inStringLiteral ds
inStringLiteral (d:ds) = co [d] ++ inStringLiteral ds
codeStringLiterals co (c:cs) = c : codeStringLiterals co cs
-}

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

@@ -21,23 +21,16 @@ import GF.Grammar.Printer
import GF.Grammar.Macros
import GF.Grammar.Lookup
import GF.Grammar.Predef
--import GF.Compile.Refresh
--import GF.Compile.Compute.Concrete
import GF.Compile.Compute.ConcreteNew(GlobalEnv,normalForm,resourceValues)
--import GF.Compile.CheckGrammar
--import GF.Compile.Update
import GF.Data.Operations
--import GF.Infra.CheckM
import GF.Infra.Option
import Control.Monad
--import Data.List
import qualified Data.Set as Set
import qualified Data.Map as Map
import GF.Text.Pretty
import Debug.Trace
-- | partial evaluation of concrete syntax. AR 6\/2001 -- 16\/5\/2003 -- 5\/2\/2005.
optimizeModule :: Options -> SourceGrammar -> SourceModule -> Err SourceModule
@@ -54,7 +47,7 @@ optimizeModule opts sgr m@(name,mi)
updateEvalInfo mi (i,info) = do
info <- evalInfo oopts resenv sgr (name,mi) i info
return (mi{jments=updateTree (i,info) (jments mi)})
return (mi{jments=Map.insert i info (jments mi)})
evalInfo :: Options -> GlobalEnv -> SourceGrammar -> SourceModule -> Ident -> Info -> Err Info
evalInfo opts resenv sgr m c info = do

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

@@ -27,19 +27,20 @@ module GF.Compile.Rename (
renameModule
) where
import GF.Infra.Ident
import GF.Infra.CheckM
import GF.Grammar.Grammar
import GF.Grammar.Values
import GF.Grammar.Predef
import GF.Infra.Ident
import GF.Infra.CheckM
import GF.Grammar.Lookup
import GF.Grammar.Macros
import GF.Grammar.Printer
--import GF.Grammar.Lookup
--import GF.Grammar.Printer
import GF.Data.Operations
import Control.Monad
import Data.List (nub,(\\))
import qualified Data.Map as Map
import Data.Maybe(mapMaybe)
import GF.Text.Pretty
-- | this gives top-level access to renaming term input in the cc command
@@ -55,9 +56,9 @@ renameModule cwd gr mo@(m,mi) = do
js <- checkMapRecover (renameInfo cwd status mo) (jments mi)
return (m, mi{jments = js})
type Status = (StatusTree, [(OpenSpec, StatusTree)])
type Status = (StatusMap, [(OpenSpec, StatusMap)])
type StatusTree = BinTree Ident StatusInfo
type StatusMap = Map.Map Ident StatusInfo
type StatusInfo = Ident -> Term
@@ -73,12 +74,12 @@ renameIdentTerm' env@(act,imps) t0 =
Q (m',c) | m' == cPredef {- && isInPredefined c -} -> return t0
Q (m',c) -> do
m <- lookupErr m' qualifs
f <- lookupTree showIdent c m
f <- lookupIdent c m
return $ f c
QC (m',c) | m' == cPredef {- && isInPredefined c -} -> return t0
QC (m',c) -> do
m <- lookupErr m' qualifs
f <- lookupTree showIdent c m
f <- lookupIdent c m
return $ f c
_ -> return t0
where
@@ -93,30 +94,21 @@ renameIdentTerm' env@(act,imps) t0 =
| otherwise = checkError s
ident alt c =
case lookupTree showIdent c act of
Ok f -> return (f c)
_ -> case lookupTreeManyAll showIdent opens c of
[f] -> return (f c)
[] -> alt c ("constant not found:" <+> c $$
"given" <+> fsep (punctuate ',' (map fst qualifs)))
fs -> case nub [f c | f <- fs] of
[tr] -> return tr
{-
ts -> return $ AdHocOverload ts
-- name conflicts resolved as overloading in TypeCheck.RConcrete AR 31/1/2014
-- the old definition is below and still presupposed in TypeCheck.Concrete
-}
ts@(t:_) -> do checkWarn ("atomic term" <+> ppTerm Qualified 0 t0 $$
"conflict" <+> hsep (punctuate ',' (map (ppTerm Qualified 0) ts)) $$
"given" <+> fsep (punctuate ',' (map fst qualifs)))
return t
case Map.lookup c act of
Just f -> return (f c)
_ -> case mapMaybe (Map.lookup c) opens of
[f] -> return (f c)
[] -> alt c ("constant not found:" <+> c $$
"given" <+> fsep (punctuate ',' (map fst qualifs)))
fs -> case nub [f c | f <- fs] of
[tr] -> return tr
ts@(t:_) -> do checkWarn ("atomic term" <+> ppTerm Qualified 0 t0 $$
"conflict" <+> hsep (punctuate ',' (map (ppTerm Qualified 0) ts)) $$
"given" <+> fsep (punctuate ',' (map fst qualifs)))
return t
-- a warning will be generated in CheckGrammar, and the head returned
-- in next V:
-- Bad $ "conflicting imports:" +++ unwords (map prt ts)
info2status :: Maybe ModuleName -> (Ident,Info) -> StatusInfo
info2status mq (c,i) = case i of
info2status :: Maybe ModuleName -> Ident -> Info -> StatusInfo
info2status mq c i = case i of
AbsFun _ _ Nothing _ -> maybe Con (curry QC) mq
ResValue _ _ -> maybe Con (curry QC) mq
ResParam _ _ -> maybe Con (curry QC) mq
@@ -124,10 +116,10 @@ info2status mq (c,i) = case i of
AnyInd False m -> maybe Cn (const (curry Q m)) mq
_ -> maybe Cn (curry Q) mq
tree2status :: OpenSpec -> BinTree Ident Info -> BinTree Ident StatusInfo
tree2status :: OpenSpec -> Map.Map Ident Info -> StatusMap
tree2status o = case o of
OSimple i -> mapTree (info2status (Just i))
OQualif i j -> mapTree (info2status (Just j))
OSimple i -> Map.mapWithKey (info2status (Just i))
OQualif i j -> Map.mapWithKey (info2status (Just j))
buildStatus :: FilePath -> Grammar -> Module -> Check Status
buildStatus cwd gr mo@(m,mi) = checkInModule cwd mi NoLoc empty $ do
@@ -136,14 +128,14 @@ buildStatus cwd gr mo@(m,mi) = checkInModule cwd mi NoLoc empty $ do
ops <- mapM (\o -> lookupModule gr1 (openedModule o) >>= \mi -> return (o,mi)) (mopens mi)
let sts = map modInfo2status (exts++ops)
return (if isModCnc mi
then (emptyBinTree, reverse sts) -- the module itself does not define any names
then (Map.empty, reverse sts) -- the module itself does not define any names
else (self2status m mi,reverse sts)) -- so the empty ident is not needed
modInfo2status :: (OpenSpec,ModuleInfo) -> (OpenSpec, StatusTree)
modInfo2status :: (OpenSpec,ModuleInfo) -> (OpenSpec, StatusMap)
modInfo2status (o,mo) = (o,tree2status o (jments mo))
self2status :: ModuleName -> ModuleInfo -> StatusTree
self2status c m = mapTree (info2status (Just c)) (jments m)
self2status :: ModuleName -> ModuleInfo -> StatusMap
self2status c m = Map.mapWithKey (info2status (Just c)) (jments m)
renameInfo :: FilePath -> Status -> Module -> Ident -> Info -> Check Info

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

@@ -29,7 +29,7 @@ import Control.Monad
import GF.Text.Pretty
-- | combine a list of definitions into a balanced binary search tree
buildAnyTree :: Monad m => ModuleName -> [(Ident,Info)] -> m (BinTree Ident Info)
buildAnyTree :: Monad m => ModuleName -> [(Ident,Info)] -> m (Map.Map Ident Info)
buildAnyTree m = go Map.empty
where
go map [] = return map
@@ -101,8 +101,8 @@ rebuildModule cwd gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ msrc_ env_ js
[] -> return mi{jments=js'}
j0s -> do
m0s <- mapM (lookupModule gr) j0s
let notInM0 c _ = all (not . isInBinTree c . jments) m0s
let js2 = filterBinTree notInM0 js'
let notInM0 c _ = all (not . Map.member c . jments) m0s
let js2 = Map.filterWithKey notInM0 js'
return mi{jments=js2}
_ -> return mi
@@ -123,8 +123,11 @@ rebuildModule cwd gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ msrc_ env_ js
--- check if me is incomplete
let fs1 = fs `addOptions` fs_ -- new flags have priority
let js0 = [(c,globalizeLoc fpath j) | (c,j) <- tree2list js, isInherited incl c]
let js1 = buildTree (tree2list js_ ++ js0)
let js0 = Map.mapMaybeWithKey (\c j -> if isInherited incl c
then Just (globalizeLoc fpath j)
else Nothing)
js
let js1 = Map.union js0 js_
let med1= nub (ext : infs ++ insts ++ med_)
return $ ModInfo mt0 stat' fs1 me Nothing ops1 med1 msrc_ env_ js1
@@ -135,14 +138,14 @@ rebuildModule cwd gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ msrc_ env_ js
-- If the extended module is incomplete, its judgements are just copied.
extendMod :: Grammar ->
Bool -> (Module,Ident -> Bool) -> ModuleName ->
BinTree Ident Info -> Check (BinTree Ident Info)
Map.Map Ident Info -> Check (Map.Map Ident Info)
extendMod gr isCompl ((name,mi),cond) base new = foldM try new $ Map.toList (jments mi)
where
try new (c,i0)
| not (cond c) = return new
| otherwise = case Map.lookup c new of
Just j -> case unifyAnyInfo name i j of
Ok k -> return $ updateTree (c,k) new
Ok k -> return $ Map.insert c k new
Bad _ -> do (base,j) <- case j of
AnyInd _ m -> lookupOrigInfo gr (m,c)
_ -> return (base,j)
@@ -155,8 +158,8 @@ extendMod gr isCompl ((name,mi),cond) base new = foldM try new $ Map.toList (jme
nest 4 (ppJudgement Qualified (c,j)) $$
"in module" <+> base)
Nothing-> if isCompl
then return $ updateTree (c,indirInfo name i) new
else return $ updateTree (c,i) new
then return $ Map.insert c (indirInfo name i) new
else return $ Map.insert c i new
where
i = globalizeLoc (msrc mi) i0

2
src/compiler/GF/CompilerAPI.hs
View File

@@ -16,8 +16,6 @@ import GF.Compile.ReadFiles
import GF.Compile.Update
import GF.Compile.Refresh
import GF.Compile.Coding
import GF.Grammar.Grammar
import GF.Grammar.Lookup
import GF.Grammar.Printer

88
src/compiler/GF/Data/Operations.hs
View File

@@ -28,14 +28,6 @@ module GF.Data.Operations (
-- ** Monadic operations on lists and pairs
mapPairListM, mapPairsM, pairM,
-- ** Binary search trees; now with FiniteMap
BinTree, emptyBinTree, isInBinTree, --justLookupTree,
lookupTree, --lookupTreeMany,
lookupTreeManyAll, updateTree,
buildTree, filterBinTree,
mapTree, --mapMTree,
tree2list,
-- ** Printing
indent, (+++), (++-), (++++), (+++-), (+++++),
@@ -50,10 +42,6 @@ module GF.Data.Operations (
ifNull,
combinations, done, readIntArg, --singleton,
iterFix, chunks,
{-
-- ** State monad with error; from Agda 6\/11\/2001
STM(..), appSTM, stm, stmr, readSTM, updateSTM, writeSTM,
-}
) where
@@ -117,44 +105,6 @@ unifyMaybeBy f (Just p1) (Just p2)
unifyMaybeBy _ Nothing mp2 = return mp2
unifyMaybeBy _ mp1 _ = return mp1
-- binary search trees
type BinTree a b = Map a b
emptyBinTree :: BinTree a b
emptyBinTree = Map.empty
isInBinTree :: (Ord a) => a -> BinTree a b -> Bool
isInBinTree = Map.member
{-
justLookupTree :: (ErrorMonad m,Ord a) => a -> BinTree a b -> m b
justLookupTree = lookupTree (const [])
-}
lookupTree :: (ErrorMonad m,Ord a) => (a -> String) -> a -> BinTree a b -> m b
lookupTree pr x = maybeErr no . Map.lookup x
where no = "no occurrence of element" +++ pr x
lookupTreeManyAll :: Ord a => (a -> String) -> [BinTree a b] -> a -> [b]
lookupTreeManyAll pr (t:ts) x = case lookupTree pr x t of
Ok v -> v : lookupTreeManyAll pr ts x
_ -> lookupTreeManyAll pr ts x
lookupTreeManyAll pr [] x = []
updateTree :: (Ord a) => (a,b) -> BinTree a b -> BinTree a b
updateTree (a,b) = Map.insert a b
buildTree :: (Ord a) => [(a,b)] -> BinTree a b
buildTree = Map.fromList
mapTree :: ((a,b) -> c) -> BinTree a b -> BinTree a c
mapTree f = Map.mapWithKey (\k v -> f (k,v))
filterBinTree :: Ord a => (a -> b -> Bool) -> BinTree a b -> BinTree a b
filterBinTree = Map.filterWithKey
tree2list :: BinTree a b -> [(a,b)] -- inorder
tree2list = Map.toList
-- printing
indent :: Int -> String -> String
@@ -297,42 +247,6 @@ chunks sep ws = case span (/= sep) ws of
readIntArg :: String -> Int
readIntArg n = if (not (null n) && all isDigit n) then read n else 0
{-
-- state monad with error; from Agda 6/11/2001
newtype STM s a = STM (s -> Err (a,s))
appSTM :: STM s a -> s -> Err (a,s)
appSTM (STM f) s = f s
stm :: (s -> Err (a,s)) -> STM s a
stm = STM
stmr :: (s -> (a,s)) -> STM s a
stmr f = stm (\s -> return (f s))
instance Functor (STM s) where fmap = liftM
instance Applicative (STM s) where
pure = return
(<*>) = ap
instance Monad (STM s) where
return a = STM (\s -> return (a,s))
STM c >>= f = STM (\s -> do
(x,s') <- c s
let STM f' = f x
f' s')
readSTM :: STM s s
readSTM = stmr (\s -> (s,s))
updateSTM :: (s -> s) -> STM s ()
updateSTM f = stmr (\s -> ((),f s))
writeSTM :: s -> STM s ()
writeSTM s = stmr (const ((),s))
-}
-- | @return ()@
done :: Monad m => m ()
done = return ()
@@ -377,4 +291,4 @@ doUntil cond ms = case ms of
v <- a
if cond v then return v else doUntil cond as
_ -> raise "no result"
-}
-}

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

@@ -52,11 +52,11 @@ lock c = lockRecType c -- return
unlock c = unlockRecord c -- return
-- to look up a constant etc in a search tree --- why here? AR 29/5/2008
lookupIdent :: ErrorMonad m => Ident -> BinTree Ident b -> m b
lookupIdent :: ErrorMonad m => Ident -> Map.Map Ident b -> m b
lookupIdent c t =
case lookupTree showIdent c t of
Ok v -> return v
Bad _ -> raise ("unknown identifier" +++ showIdent c)
case Map.lookup c t of
Just v -> return v
Nothing -> raise ("unknown identifier" +++ showIdent c)
lookupIdentInfo :: ErrorMonad m => SourceModInfo -> Ident -> m Info
lookupIdentInfo mo i = lookupIdent i (jments mo)
@@ -149,7 +149,7 @@ lookupOrigInfo gr (m,c) = do
allOrigInfos :: Grammar -> ModuleName -> [(QIdent,Info)]
allOrigInfos gr m = fromErr [] $ do
mo <- lookupModule gr m
return [((m,c),i) | (c,_) <- tree2list (jments mo), Ok (m,i) <- [lookupOrigInfo gr (m,c)]]
return [((m,c),i) | (c,_) <- Map.toList (jments mo), Ok (m,i) <- [lookupOrigInfo gr (m,c)]]
lookupParamValues :: ErrorMonad m => Grammar -> QIdent -> m [Term]
lookupParamValues gr c = do

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

@@ -27,6 +27,7 @@ import GF.Grammar.Printer
import Control.Monad.Identity(Identity(..))
import qualified Data.Traversable as T(mapM)
import qualified Data.Map as Map
import Control.Monad (liftM, liftM2, liftM3)
import Data.List (sortBy,nub)
import Data.Monoid
@@ -606,9 +607,9 @@ sortRec = sortBy ordLabel where
-- | dependency check, detecting circularities and returning topo-sorted list
allDependencies :: (ModuleName -> Bool) -> BinTree Ident Info -> [(Ident,[Ident])]
allDependencies :: (ModuleName -> Bool) -> Map.Map Ident Info -> [(Ident,[Ident])]
allDependencies ism b =
[(f, nub (concatMap opty (pts i))) | (f,i) <- tree2list b]
[(f, nub (concatMap opty (pts i))) | (f,i) <- Map.toList b]
where
opersIn t = case t of
Q (n,c) | ism n -> [c]
@@ -634,7 +635,7 @@ topoSortJments (m,mi) = do
return
(\cyc -> raise (render ("circular definitions:" <+> fsep (head cyc))))
(topoTest (allDependencies (==m) (jments mi)))
return (reverse [(i,info) | i <- is, Ok info <- [lookupTree showIdent i (jments mi)]])
return (reverse [(i,info) | i <- is, Just info <- [Map.lookup i (jments mi)]])
topoSortJments2 :: ErrorMonad m => SourceModule -> m [[(Ident,Info)]]
topoSortJments2 (m,mi) = do
@@ -644,4 +645,4 @@ topoSortJments2 (m,mi) = do
<+> fsep (head cyc))))
(topoTest2 (allDependencies (==m) (jments mi)))
return
[[(i,info) | i<-is,Ok info<-[lookupTree showIdent i (jments mi)]] | is<-iss]
[[(i,info) | i<-is,Just info<-[Map.lookup i (jments mi)]] | is<-iss]

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

@@ -24,6 +24,7 @@ import GF.Grammar.Lexer
import GF.Compile.Update (buildAnyTree)
import Data.List(intersperse)
import Data.Char(isAlphaNum)
import qualified Data.Map as Map
}
@@ -138,7 +139,7 @@ ModHeader
: ComplMod ModType '=' ModHeaderBody { let { mstat = $1 ;
(mtype,id) = $2 ;
(extends,with,opens) = $4 }
in (id, ModInfo mtype mstat noOptions extends with opens [] "" Nothing emptyBinTree) }
in (id, ModInfo mtype mstat noOptions extends with opens [] "" Nothing Map.empty) }
ComplMod :: { ModuleStatus }
ComplMod