GitHub/gf-core
1
0
Fork 1
mirror of https://github.com/GrammaticalFramework/gf-core.git synced 2026-04-22 03:09:33 -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.Lexer
import GF.Grammar.Lookup
--import GF.Grammar.Predef
--import GF.Grammar.PatternMatch
import GF.Data.Operations
import GF.Infra.CheckM
import Data.List
import qualified Data.Set as Set
import qualified Data.Map as Map
import Control.Monad
import GF.Text.Pretty
@@ -59,7 +58,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
@@ -72,7 +71,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) |
@@ -89,10 +88,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
@@ -113,17 +112,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)
@@ -132,24 +131,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")
@@ -157,7 +156,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.

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