GitHub/gf-core
1
0
Fork 1
mirror of https://github.com/GrammaticalFramework/gf-core.git synced 2026-04-23 03:32:51 -06:00
Code Issues Packages Projects Releases Wiki Activity

remove obsolete code

Browse Source
This commit is contained in:
krangelov
2019-09-20 10:37:50 +02:00
parent 9d3badd8b2
commit 4d79aa8b19
8 changed files with 71 additions and 134 deletions
Download Patch File Download Diff File Expand all files Collapse all files

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

@@ -34,14 +34,13 @@ import qualified GF.Compile.Compute.ConcreteNew as CN
import GF.Grammar import GF.Grammar
import GF.Grammar.Lexer import GF.Grammar.Lexer
import GF.Grammar.Lookup import GF.Grammar.Lookup
--import GF.Grammar.Predef
--import GF.Grammar.PatternMatch
import GF.Data.Operations import GF.Data.Operations
import GF.Infra.CheckM import GF.Infra.CheckM
import Data.List import Data.List
import qualified Data.Set as Set import qualified Data.Set as Set
import qualified Data.Map as Map
import Control.Monad import Control.Monad
import GF.Text.Pretty import GF.Text.Pretty
@@ -59,7 +58,7 @@ checkModule opts cwd sgr mo@(m,mi) = do
where where
updateCheckInfos mo = fmap (foldl update mo) . parallelCheck . map check updateCheckInfos mo = fmap (foldl update mo) . parallelCheck . map check
where check (i,info) = fmap ((,) i) (checkInfo opts cwd sgr mo i info) 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 -- check if restricted inheritance modules are still coherent
-- i.e. that the defs of remaining names don't depend on omitted names -- i.e. that the defs of remaining names don't depend on omitted names
@@ -72,7 +71,7 @@ checkRestrictedInheritance cwd sgr (name,mo) = checkInModule cwd mo NoLoc empty
where where
mos = modules sgr mos = modules sgr
checkRem ((i,m),mi) = do 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 incld c = Set.member c (Set.fromList incl)
let illegal c = Set.member c (Set.fromList excl) let illegal c = Set.member c (Set.fromList excl)
let illegals = [(f,is) | let illegals = [(f,is) |
@@ -89,10 +88,10 @@ checkCompleteGrammar opts cwd gr (am,abs) (cm,cnc) = checkInModule cwd cnc NoLoc
let jsc = jments cnc let jsc = jments cnc
-- check that all concrete constants are in abstract; build types for all lin -- 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 -- 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}) return (cm,cnc{jments=jsc})
where where
@@ -113,17 +112,17 @@ checkCompleteGrammar opts cwd gr (am,abs) (cm,cnc) = checkInModule cwd cnc NoLoc
case lookupIdent c js of case lookupIdent c js of
Ok (AnyInd _ _) -> return js Ok (AnyInd _ _) -> return js
Ok (CncFun ty (Just def) mn mf) -> 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) -> Ok (CncFun ty Nothing mn mf) ->
case mb_def of 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 Bad _ -> do noLinOf c
return js return js
_ -> do _ -> do
case mb_def of case mb_def of
Ok def -> do (cont,val) <- linTypeOfType gr cm ty Ok def -> do (cont,val) <- linTypeOfType gr cm ty
let linty = (snd (valCat ty),cont,val) let linty = (snd (valCat ty),cont,val)
return $ updateTree (c,CncFun (Just linty) (Just (L NoLoc def)) Nothing Nothing) js return $ Map.insert c (CncFun (Just linty) (Just (L NoLoc def)) Nothing Nothing) js
Bad _ -> do noLinOf c Bad _ -> do noLinOf c
return js return js
where noLinOf c = checkWarn ("no linearization of" <+> c) where noLinOf c = checkWarn ("no linearization of" <+> c)
@@ -132,24 +131,24 @@ checkCompleteGrammar opts cwd gr (am,abs) (cm,cnc) = checkInModule cwd cnc NoLoc
Ok (CncCat (Just _) _ _ _ _) -> return js Ok (CncCat (Just _) _ _ _ _) -> return js
Ok (CncCat Nothing md mr mp mpmcfg) -> do Ok (CncCat Nothing md mr mp mpmcfg) -> do
checkWarn ("no linearization type for" <+> c <> ", inserting default {s : Str}") 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 _ -> do
checkWarn ("no linearization type for" <+> c <> ", inserting default {s : Str}") 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 _ -> return js
checkCnc js i@(c,info) = checkCnc js (c,info) =
case info of case info of
CncFun _ d mn mf -> case lookupOrigInfo gr (am,c) of CncFun _ d mn mf -> case lookupOrigInfo gr (am,c) of
Ok (_,AbsFun (Just (L _ ty)) _ _ _) -> Ok (_,AbsFun (Just (L _ ty)) _ _ _) ->
do (cont,val) <- linTypeOfType gr cm ty do (cont,val) <- linTypeOfType gr cm ty
let linty = (snd (valCat ty),cont,val) let linty = (snd (valCat ty),cont,val)
return $ updateTree (c,CncFun (Just linty) d mn mf) js return $ Map.insert c (CncFun (Just linty) d mn mf) js
_ -> do checkWarn ("function" <+> c <+> "is not in abstract") _ -> do checkWarn ("function" <+> c <+> "is not in abstract")
return js return js
CncCat {} -> CncCat {} ->
case lookupOrigInfo gr (am,c) of 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: {- -- This might be too pedantic:
Ok (_,AbsFun {}) -> Ok (_,AbsFun {}) ->
checkError ("lincat:"<+>c<+>"is a fun, not a cat") checkError ("lincat:"<+>c<+>"is a fun, not a cat")
@@ -157,7 +156,7 @@ checkCompleteGrammar opts cwd gr (am,abs) (cm,cnc) = checkInModule cwd cnc NoLoc
_ -> do checkWarn ("category" <+> c <+> "is not in abstract") _ -> do checkWarn ("category" <+> c <+> "is not in abstract")
return js return js
_ -> return $ updateTree i js _ -> return $ Map.insert c info js
-- | General Principle: only Just-values are checked. -- | General Principle: only Just-values are checked.

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

@@ -21,23 +21,16 @@ import GF.Grammar.Printer
import GF.Grammar.Macros import GF.Grammar.Macros
import GF.Grammar.Lookup import GF.Grammar.Lookup
import GF.Grammar.Predef import GF.Grammar.Predef
--import GF.Compile.Refresh
--import GF.Compile.Compute.Concrete
import GF.Compile.Compute.ConcreteNew(GlobalEnv,normalForm,resourceValues) import GF.Compile.Compute.ConcreteNew(GlobalEnv,normalForm,resourceValues)
--import GF.Compile.CheckGrammar
--import GF.Compile.Update
import GF.Data.Operations import GF.Data.Operations
--import GF.Infra.CheckM
import GF.Infra.Option import GF.Infra.Option
import Control.Monad import Control.Monad
--import Data.List
import qualified Data.Set as Set import qualified Data.Set as Set
import qualified Data.Map as Map
import GF.Text.Pretty import GF.Text.Pretty
import Debug.Trace import Debug.Trace
-- | partial evaluation of concrete syntax. AR 6\/2001 -- 16\/5\/2003 -- 5\/2\/2005. -- | partial evaluation of concrete syntax. AR 6\/2001 -- 16\/5\/2003 -- 5\/2\/2005.
optimizeModule :: Options -> SourceGrammar -> SourceModule -> Err SourceModule optimizeModule :: Options -> SourceGrammar -> SourceModule -> Err SourceModule
@@ -54,7 +47,7 @@ optimizeModule opts sgr m@(name,mi)
updateEvalInfo mi (i,info) = do updateEvalInfo mi (i,info) = do
info <- evalInfo oopts resenv sgr (name,mi) i info 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 :: Options -> GlobalEnv -> SourceGrammar -> SourceModule -> Ident -> Info -> Err Info
evalInfo opts resenv sgr m c info = do 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 renameModule
) where ) where
import GF.Infra.Ident
import GF.Infra.CheckM
import GF.Grammar.Grammar import GF.Grammar.Grammar
import GF.Grammar.Values import GF.Grammar.Values
import GF.Grammar.Predef import GF.Grammar.Predef
import GF.Infra.Ident import GF.Grammar.Lookup
import GF.Infra.CheckM
import GF.Grammar.Macros import GF.Grammar.Macros
import GF.Grammar.Printer import GF.Grammar.Printer
--import GF.Grammar.Lookup
--import GF.Grammar.Printer
import GF.Data.Operations import GF.Data.Operations
import Control.Monad import Control.Monad
import Data.List (nub,(\\)) import Data.List (nub,(\\))
import qualified Data.Map as Map
import Data.Maybe(mapMaybe)
import GF.Text.Pretty import GF.Text.Pretty
-- | this gives top-level access to renaming term input in the cc command -- | 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) js <- checkMapRecover (renameInfo cwd status mo) (jments mi)
return (m, mi{jments = js}) 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 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) | m' == cPredef {- && isInPredefined c -} -> return t0
Q (m',c) -> do Q (m',c) -> do
m <- lookupErr m' qualifs m <- lookupErr m' qualifs
f <- lookupTree showIdent c m f <- lookupIdent c m
return $ f c return $ f c
QC (m',c) | m' == cPredef {- && isInPredefined c -} -> return t0 QC (m',c) | m' == cPredef {- && isInPredefined c -} -> return t0
QC (m',c) -> do QC (m',c) -> do
m <- lookupErr m' qualifs m <- lookupErr m' qualifs
f <- lookupTree showIdent c m f <- lookupIdent c m
return $ f c return $ f c
_ -> return t0 _ -> return t0
where where
@@ -93,30 +94,21 @@ renameIdentTerm' env@(act,imps) t0 =
| otherwise = checkError s | otherwise = checkError s
ident alt c = ident alt c =
case lookupTree showIdent c act of case Map.lookup c act of
Ok f -> return (f c) Just f -> return (f c)
_ -> case lookupTreeManyAll showIdent opens c of _ -> case mapMaybe (Map.lookup c) opens of
[f] -> return (f c) [f] -> return (f c)
[] -> alt c ("constant not found:" <+> c $$ [] -> alt c ("constant not found:" <+> c $$
"given" <+> fsep (punctuate ',' (map fst qualifs))) "given" <+> fsep (punctuate ',' (map fst qualifs)))
fs -> case nub [f c | f <- fs] of fs -> case nub [f c | f <- fs] of
[tr] -> return tr [tr] -> return tr
{- ts@(t:_) -> do checkWarn ("atomic term" <+> ppTerm Qualified 0 t0 $$
ts -> return $ AdHocOverload ts "conflict" <+> hsep (punctuate ',' (map (ppTerm Qualified 0) ts)) $$
-- name conflicts resolved as overloading in TypeCheck.RConcrete AR 31/1/2014 "given" <+> fsep (punctuate ',' (map fst qualifs)))
-- the old definition is below and still presupposed in TypeCheck.Concrete return t
-}
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 info2status :: Maybe ModuleName -> Ident -> Info -> StatusInfo
-- in next V: info2status mq c i = case i of
-- Bad $ "conflicting imports:" +++ unwords (map prt ts)
info2status :: Maybe ModuleName -> (Ident,Info) -> StatusInfo
info2status mq (c,i) = case i of
AbsFun _ _ Nothing _ -> maybe Con (curry QC) mq AbsFun _ _ Nothing _ -> maybe Con (curry QC) mq
ResValue _ -> maybe Con (curry QC) mq ResValue _ -> maybe Con (curry QC) mq
ResParam _ _ -> 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 AnyInd False m -> maybe Cn (const (curry Q m)) mq
_ -> maybe Cn (curry Q) 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 tree2status o = case o of
OSimple i -> mapTree (info2status (Just i)) OSimple i -> Map.mapWithKey (info2status (Just i))
OQualif i j -> mapTree (info2status (Just j)) OQualif i j -> Map.mapWithKey (info2status (Just j))
buildStatus :: FilePath -> Grammar -> Module -> Check Status buildStatus :: FilePath -> Grammar -> Module -> Check Status
buildStatus cwd gr mo@(m,mi) = checkInModule cwd mi NoLoc empty $ do 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) ops <- mapM (\o -> lookupModule gr1 (openedModule o) >>= \mi -> return (o,mi)) (mopens mi)
let sts = map modInfo2status (exts++ops) let sts = map modInfo2status (exts++ops)
return (if isModCnc mi 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 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)) modInfo2status (o,mo) = (o,tree2status o (jments mo))
self2status :: ModuleName -> ModuleInfo -> StatusTree self2status :: ModuleName -> ModuleInfo -> StatusMap
self2status c m = mapTree (info2status (Just c)) (jments m) self2status c m = Map.mapWithKey (info2status (Just c)) (jments m)
renameInfo :: FilePath -> Status -> Module -> Ident -> Info -> Check Info 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 import GF.Text.Pretty
-- | combine a list of definitions into a balanced binary search tree -- | 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 buildAnyTree m = go Map.empty
where where
go map [] = return map 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'} [] -> return mi{jments=js'}
j0s -> do j0s -> do
m0s <- mapM (lookupModule gr) j0s m0s <- mapM (lookupModule gr) j0s
let notInM0 c _ = all (not . isInBinTree c . jments) m0s let notInM0 c _ = all (not . Map.member c . jments) m0s
let js2 = filterBinTree notInM0 js' let js2 = Map.filterWithKey notInM0 js'
return mi{jments=js2} return mi{jments=js2}
_ -> return mi _ -> 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 --- check if me is incomplete
let fs1 = fs `addOptions` fs_ -- new flags have priority let fs1 = fs `addOptions` fs_ -- new flags have priority
let js0 = [(c,globalizeLoc fpath j) | (c,j) <- tree2list js, isInherited incl c] let js0 = Map.mapMaybeWithKey (\c j -> if isInherited incl c
let js1 = buildTree (tree2list js_ ++ js0) then Just (globalizeLoc fpath j)
else Nothing)
js
let js1 = Map.union js0 js_
let med1= nub (ext : infs ++ insts ++ med_) let med1= nub (ext : infs ++ insts ++ med_)
return $ ModInfo mt0 stat' fs1 me Nothing ops1 med1 msrc_ env_ js1 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. -- If the extended module is incomplete, its judgements are just copied.
extendMod :: Grammar -> extendMod :: Grammar ->
Bool -> (Module,Ident -> Bool) -> ModuleName -> 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) extendMod gr isCompl ((name,mi),cond) base new = foldM try new $ Map.toList (jments mi)
where where
try new (c,i0) try new (c,i0)
| not (cond c) = return new | not (cond c) = return new
| otherwise = case Map.lookup c new of | otherwise = case Map.lookup c new of
Just j -> case unifyAnyInfo name i j 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 Bad _ -> do (base,j) <- case j of
AnyInd _ m -> lookupOrigInfo gr (m,c) AnyInd _ m -> lookupOrigInfo gr (m,c)
_ -> return (base,j) _ -> 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)) $$ nest 4 (ppJudgement Qualified (c,j)) $$
"in module" <+> base) "in module" <+> base)
Nothing-> if isCompl Nothing-> if isCompl
then return $ updateTree (c,indirInfo name i) new then return $ Map.insert c (indirInfo name i) new
else return $ updateTree (c,i) new else return $ Map.insert c i new
where where
i = globalizeLoc (msrc mi) i0 i = globalizeLoc (msrc mi) i0

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

@@ -28,14 +28,6 @@ module GF.Data.Operations (
-- ** Monadic operations on lists and pairs -- ** Monadic operations on lists and pairs
mapPairListM, mapPairsM, pairM, mapPairListM, mapPairsM, pairM,
-- ** Binary search trees; now with FiniteMap
BinTree, emptyBinTree, isInBinTree, --justLookupTree,
lookupTree, --lookupTreeMany,
lookupTreeManyAll, updateTree,
buildTree, filterBinTree,
mapTree, --mapMTree,
tree2list,
-- ** Printing -- ** Printing
indent, (+++), (++-), (++++), (+++-), (+++++), indent, (+++), (++-), (++++), (+++-), (+++++),
@@ -50,10 +42,6 @@ module GF.Data.Operations (
ifNull, ifNull,
combinations, done, readIntArg, --singleton, combinations, done, readIntArg, --singleton,
iterFix, chunks, iterFix, chunks,
{-
-- ** State monad with error; from Agda 6\/11\/2001
STM(..), appSTM, stm, stmr, readSTM, updateSTM, writeSTM,
-}
) where ) where
@@ -117,44 +105,6 @@ unifyMaybeBy f (Just p1) (Just p2)
unifyMaybeBy _ Nothing mp2 = return mp2 unifyMaybeBy _ Nothing mp2 = return mp2
unifyMaybeBy _ mp1 _ = return mp1 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 -- printing
indent :: Int -> String -> String indent :: Int -> String -> String
@@ -377,4 +327,4 @@ doUntil cond ms = case ms of
v <- a v <- a
if cond v then return v else doUntil cond as if cond v then return v else doUntil cond as
_ -> raise "no result" _ -> raise "no result"
-} -}

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

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

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

@@ -22,14 +22,13 @@ import GF.Data.Operations
import GF.Data.Str import GF.Data.Str
import GF.Infra.Ident import GF.Infra.Ident
import GF.Grammar.Grammar import GF.Grammar.Grammar
--import GF.Grammar.Values
import GF.Grammar.Predef import GF.Grammar.Predef
import GF.Grammar.Printer import GF.Grammar.Printer
import Control.Monad.Identity(Identity(..)) import Control.Monad.Identity(Identity(..))
import qualified Data.Traversable as T(mapM) import qualified Data.Traversable as T(mapM)
import qualified Data.Map as Map
import Control.Monad (liftM, liftM2, liftM3) import Control.Monad (liftM, liftM2, liftM3)
--import Data.Char (isDigit)
import Data.List (sortBy,nub) import Data.List (sortBy,nub)
import Data.Monoid import Data.Monoid
import GF.Text.Pretty(render,(<+>),hsep,fsep) import GF.Text.Pretty(render,(<+>),hsep,fsep)
@@ -608,9 +607,9 @@ sortRec = sortBy ordLabel where
-- | dependency check, detecting circularities and returning topo-sorted list -- | 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 = 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 where
opersIn t = case t of opersIn t = case t of
Q (n,c) | ism n -> [c] Q (n,c) | ism n -> [c]
@@ -634,7 +633,7 @@ topoSortJments (m,mi) = do
return return
(\cyc -> raise (render ("circular definitions:" <+> fsep (head cyc)))) (\cyc -> raise (render ("circular definitions:" <+> fsep (head cyc))))
(topoTest (allDependencies (==m) (jments mi))) (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 :: ErrorMonad m => SourceModule -> m [[(Ident,Info)]]
topoSortJments2 (m,mi) = do topoSortJments2 (m,mi) = do
@@ -644,4 +643,4 @@ topoSortJments2 (m,mi) = do
<+> fsep (head cyc)))) <+> fsep (head cyc))))
(topoTest2 (allDependencies (==m) (jments mi))) (topoTest2 (allDependencies (==m) (jments mi)))
return 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 GF.Compile.Update (buildAnyTree)
import Data.List(intersperse) import Data.List(intersperse)
import Data.Char(isAlphaNum) import Data.Char(isAlphaNum)
import qualified Data.Map as Map
import PGF(mkCId) import PGF(mkCId)
} }
@@ -139,7 +140,7 @@ ModHeader
: ComplMod ModType '=' ModHeaderBody { let { mstat = $1 ; : ComplMod ModType '=' ModHeaderBody { let { mstat = $1 ;
(mtype,id) = $2 ; (mtype,id) = $2 ;
(extends,with,opens) = $4 } (extends,with,opens) = $4 }
in (id, ModInfo mtype mstat noOptions extends with opens [] "" Nothing emptyBinTree) } in (id, ModInfo mtype mstat noOptions extends with opens [] "" Nothing Map.empty) }
ComplMod :: { ModuleStatus } ComplMod :: { ModuleStatus }
ComplMod ComplMod