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

Restored printnames.

Browse Source
This commit is contained in:
aarne
2003-10-08 10:09:58 +00:00
parent 889e5a92e4
commit a979508aa7
7 changed files with 78 additions and 152 deletions
Download Patch File Download Diff File Expand all files Collapse all files

117
src/GF/Canon/CMacros.hs
View File

@@ -149,120 +149,5 @@ allLinValues trm = do
redirectIdent n f@(CIQ _ c) = CIQ n c
{- ---- to be removed 21/9
-- to analyse types and terms into eta normal form
typeForm :: Exp -> Err (Context, Exp, [Exp])
typeForm e = do
(cont,val) <- getContext e
(cat,args) <- getArgs val
return (cont,cat,args)
getContext :: Exp -> Err (Context, Exp)
getContext e = case e of
EProd x a b -> do
(g,b') <- getContext b
return ((x,a):g,b')
_ -> return ([],e)
valAtom :: Exp -> Err Atom
valAtom e = do
(_,val,_) <- typeForm e
case val of
EAtom a -> return a
_ -> prtBad "atom expected instead of" val
valCat :: Exp -> Err CIdent
valCat e = do
a <- valAtom e
case a of
AC c -> return c
_ -> prtBad "cat expected instead of" a
termForm :: Exp -> Err ([A.Ident], Exp, [Exp])
termForm e = do
(cont,val) <- getBinds e
(cat,args) <- getArgs val
return (cont,cat,args)
getBinds :: Exp -> Err ([A.Ident], Exp)
getBinds e = case e of
EAbs x b -> do
(g,b') <- getBinds b
return (x:g,b')
_ -> return ([],e)
getArgs :: Exp -> Err (Exp,[Exp])
getArgs = get [] where
get xs e = case e of
EApp f a -> get (a:xs) f
_ -> return (e, reverse xs)
-- the inverses of these
mkProd :: Context -> Exp -> Exp
mkProd c e = foldr (uncurry EProd) e c
mkApp :: Exp -> [Exp] -> Exp
mkApp = foldl EApp
mkAppAtom :: Atom -> [Exp] -> Exp
mkAppAtom a = mkApp (EAtom a)
mkAppCons :: CIdent -> [Exp] -> Exp
mkAppCons c = mkAppAtom $ AC c
mkType :: Context -> Exp -> [Exp] -> Exp
mkType c e xs = mkProd c $ mkApp e xs
mkAbs :: Context -> Exp -> Exp
mkAbs c e = foldr EAbs e $ map fst c
mkTerm :: Context -> Exp -> [Exp] -> Exp
mkTerm c e xs = mkAbs c $ mkApp e xs
mkAbsR :: [A.Ident] -> Exp -> Exp
mkAbsR c e = foldr EAbs e c
mkTermR :: [A.Ident] -> Exp -> [Exp] -> Exp
mkTermR c e xs = mkAbsR c $ mkApp e xs
-- this is used to create heuristic menus
eqCatId :: Cat -> Atom -> Bool
eqCatId (CIQ _ c) b = case b of
AC (CIQ _ d) -> c == d
AD (CIQ _ d) -> c == d
_ -> False
-- a very weak notion of "compatible value category"
compatCat :: Cat -> Type -> Bool
compatCat c t = case t of
EAtom b -> eqCatId c b
EApp f _ -> compatCat c f
_ -> False
-- this is the way an atomic category looks as a type
cat2type :: Cat -> Type
cat2type = EAtom . AC
compatType :: Type -> Type -> Bool
compatType t = case t of
EAtom (AC c) -> compatCat c
_ -> (t ==)
type Fun = CIdent
type Cat = CIdent
type Type = Exp
mkFun, mkCat :: String -> String -> Fun
mkFun m f = CIQ (A.identC m) (A.identC f)
mkCat = mkFun
mkFunC, mkCatC :: String -> Fun
mkFunC s = let (m,f) = span (/= '.') s in mkFun m (drop 1 f)
mkCatC = mkFunC
-}
ciq n f = CIQ n f

16
src/GF/Compile/GrammarToCanon.hs
View File

@@ -74,22 +74,22 @@ redInfo am (c,info) = errIn ("translating definition of" +++ prt c) $ do
ps' <- mapM redParam ps
returns c' $ C.ResPar ps'
CncCat pty ptr ppr -> case (pty,ptr) of
(Yes ty, Yes (Abs _ t)) -> do
CncCat pty ptr ppr -> case (pty,ptr,ppr) of
(Yes ty, Yes (Abs _ t), Yes pr) -> do
ty' <- redCType ty
trm' <- redCTerm t
ppr' <- return $ G.FV [] ---- redCTerm
return [(c', C.CncCat ty' trm' ppr')]
pr' <- redCTerm pr
return [(c', C.CncCat ty' trm' pr')]
_ -> prtBad "cannot reduce rule for" c
CncFun mt ptr ppr -> case (mt,ptr) of
(Just (cat,_), Yes trm) -> do
CncFun mt ptr ppr -> case (mt,ptr,ppr) of
(Just (cat,_), Yes trm, Yes pr) -> do
cat' <- redIdent cat
(xx,body,_) <- termForm trm
xx' <- mapM redArgvar xx
body' <- errIn (prt body) $ redCTerm body ---- debug
ppr' <- return $ G.FV [] ---- redCTerm
return [(c',C.CncFun (G.CIQ am cat') xx' body' ppr')]
pr' <- redCTerm pr
return [(c',C.CncFun (G.CIQ am cat') xx' body' pr')]
_ -> prtBad ("cannot reduce rule" +++ show info +++ "for") c ---- debug
AnyInd s b -> do

30
src/GF/Compile/Optimize.hs
View File

@@ -82,7 +82,7 @@ evalCncInfo gr cnc abs (c,info) = case info of
return $ May b
_ -> return pde -- indirection
ppr' <- return ppr ----
ppr' <- liftM yes $ evalPrintname gr c ppr (yes $ K $ prt c)
return (c, CncCat ptyp pde' ppr')
@@ -92,9 +92,7 @@ evalCncInfo gr cnc abs (c,info) = case info of
Yes de -> do
liftM yes $ pEval ty de
_ -> return pde
ppr' <- case ppr of
Yes pr -> liftM yes $ comp pr
_ -> return ppr
ppr' <- liftM yes $ evalPrintname gr c ppr pde'
return $ (c, CncFun mt pde' ppr') -- only cat in type actually needed
_ -> return (c,info)
@@ -169,3 +167,27 @@ mkLinDefault gr typ = do
return $ R $ [assign l t | (l,t) <- zip ls ts']
_ -> prtBad "linearization type field cannot be" typ
-- Form the printname: if given, compute. If not, use the computed
-- lin for functions, cat name for cats (dispatch made in evalCncDef above).
--- We cannot use linearization at this stage, since we do not know the
--- defaults we would need for question marks - and we're not yet in canon.
evalPrintname :: SourceGrammar -> Ident -> MPr -> Perh Term -> Err Term
evalPrintname gr c ppr lin =
case ppr of
Yes pr -> comp pr
_ -> case lin of
Yes t -> return $ K $ prt $ oneBranch t ---- stringFromTerm
_ -> return $ K $ prt c ----
where
comp = computeConcrete gr
oneBranch t = case t of
Abs _ b -> oneBranch b
R (r:_) -> oneBranch $ snd $ snd r
T _ (c:_) -> oneBranch $ snd c
FV (t:_) -> oneBranch t
C x y -> C (oneBranch x) (oneBranch y)
S x _ -> oneBranch x
P x _ -> oneBranch x
_ -> t

49
src/GF/Shell/Commands.hs
View File

@@ -3,10 +3,11 @@ module Commands where
import Operations
import Zipper
import qualified Grammar as G ---- Cat, Fun
import qualified Grammar as G ---- Cat, Fun, Q, QC
import GFC
import CMacros
import LookAbs
import Look
import Values (loc2treeFocus)----
import GetTree
@@ -14,7 +15,6 @@ import API
import ShellState
import qualified Shell
import qualified Ident as I
import qualified PShell
import qualified Macros as M
import PrGrammar
@@ -23,7 +23,6 @@ import IOGrammar
import UseIO
import Unicode
import Option
import CF
import CFIdent (cat2CFCat, cfCat2Cat)
import Linear
@@ -32,10 +31,13 @@ import Editing
import Session
import Custom
import Random (mkStdGen)
import qualified Ident as I
import Option
import Str (sstr) ----
import Random (mkStdGen, newStdGen)
import Monad (liftM2)
import List (intersperse)
import Random (newStdGen)
--- temporary hacks for GF 2.0
@@ -105,10 +107,11 @@ abstractCEnv = absId
stdGenCEnv env s = mkStdGen (length (displayJustStateIn env s) * 31 +11) ---
initSStateEnv env = case getOptVal (stateOptions sgr) gStartCat of
---- Just cat -> action2commandNext (newCat gr (identC cat)) initSState
Just cat -> action2commandNext (newCat gr (abs, I.identC cat)) initSState
_ -> initSState
where
sgr = firstStateGrammar env
abs = absId sgr
gr = stateGrammarST sgr
-- the main function
@@ -274,8 +277,8 @@ string2varPair s = case words s of
cMenuDisplay :: String -> Command
cMenuDisplay s = CAddOption (menuDisplay s)
newCatMenu env = [(CNewCat c, prQIdent c) | ---- printname env initSState c) |
(c,[]) <- allCatsOf (canCEnv env)]
newCatMenu env = [(CNewCat c, printname env initSState c) |
(c,[]) <- allCatsOf (canCEnv env)]
mkRefineMenu :: CEnv -> SState -> [(Command,String)]
mkRefineMenu env sstate = [(c,s) | (c,(s,_)) <- mkRefineMenuAll env sstate]
@@ -293,7 +296,7 @@ mkRefineMenuAll env sstate =
where
prRef (f,t) =
(ifShort "r" "Refine" +++ prOrLinExp f +++ ifTyped (":" +++ prt t),
(ifShort "r" "Refine" +++ prOrLinRef f +++ ifTyped (":" +++ prt t),
"r" +++ prRefinement f)
prChangeHead f =
(ifShort "ch" "ChangeHead" +++ prOrLinFun f,
@@ -314,11 +317,10 @@ mkRefineMenuAll env sstate =
_ -> b
ifShort = ifOpt sizeDisplay "short"
ifTyped t = ifOpt typeDisplay "typed" t ""
prOrLinExp t = prRefinement t --- maybe (prt t) prOrLinFun $ M.justIdentOf t
prOrLinTree t = case getOptVal opts menuDisplay of
Just "Abs" -> prt t
Just lang -> optLinearizeTreeVal (addOption firstLin opts)
(stateGrammarOfLang env (language lang)) t
prOrLinExp t = prt t ----
prOrLinRef t = case t of
G.Q m f -> printname env sstate (m,f)
G.QC m f -> printname env sstate (m,f)
_ -> prt t
prOrLinFun = printname env sstate
@@ -364,9 +366,11 @@ menuState env = map snd . mkRefineMenu env
prState :: State -> [String]
prState s = prMarkedTree (loc2treeMarked s)
displayJustStateIn :: CEnv -> SState -> String
displayJustStateIn env state = case displaySStateIn env state of
(t,msg,_) -> unlines (t ++ ["",""] ++ msg) --- ad hoc for CommandF
displaySStateIn :: CEnv -> SState -> ([String],[String],[(String,String)])
displaySStateIn env state = (tree',msg,menu) where
(tree,msg,menu) = displaySState env state
grs = allStateGrammars env
@@ -380,6 +384,7 @@ displaySStateIn env state = (tree',msg,menu) where
linAll = map lin grs
separ = singleton . map unlines . intersperse [replicate 72 '*']
displaySStateJavaX :: CEnv -> SState -> String
displaySStateJavaX env state = unlines $ tagXML "gfedit" $ concat [
tagXML "linearizations" (concat
[tagAttrXML "lin" ("lang", prLanguage lang) ss | (lang,ss) <- lins]),
@@ -391,7 +396,7 @@ displaySStateJavaX env state = unlines $ tagXML "gfedit" $ concat [
(tree,msg,menu) = displaySState env state
menu' = [tagXML "show" [s] ++ tagXML "send" [c] | (s,c) <- menu]
(ls,grs) = unzip $ lgrs
lgrs = allStateGrammarsWithNames env --- allActiveStateGrammarsWithNames env
lgrs = allStateGrammarsWithNames env ---- allActiveStateGrammarsWithNames env
lins = (langAbstract, exp) : linAll
opts = addOptions (optsSState state) -- state opts override
(addOption (markLin mark) (globalOptions env))
@@ -406,14 +411,13 @@ displaySStateJavaX env state = unlines $ tagXML "gfedit" $ concat [
langAbstract = language "Abstract"
langXML = language "XML"
linearizeState :: (String -> [String]) -> Options -> GFGrammar -> State -> [String]
linearizeState wrap opts gr =
wrap . strop . unt . optLinearizeTreeVal opts gr . loc2treeFocus
where
unt = id ---- customOrDefault (stateOptions g) useUntokenizer customUntokenizer g
strop = id ---- maybe id ($ g) $ customAsOptVal opts filterString customStringCommand
unt = customOrDefault (stateOptions gr) useUntokenizer customUntokenizer gr
strop = maybe id ($ gr) $ customAsOptVal opts filterString customStringCommand
br = oElem showStruct opts
noWrap, fudWrap :: String -> [String]
@@ -430,14 +434,17 @@ menuSState env state = [(s,c) | (_,(s,c)) <- mkRefineMenuAll env state]
printname :: CEnv -> SState -> G.Fun -> String
printname env state f = case getOptVal opts menuDisplay of
Just "Abs" -> prQIdent f
Just lang -> printn lang
Just lang -> printn lang f
_ -> prQIdent f
where
opts = addOptions (optsSState state) (globalOptions env)
printn lang = printOrLinearize gr m f where
printn lang f = err id (ifNull (prQIdent f) (sstr . head)) $ do
t <- lookupPrintname gr mf
strsFromTerm t
where
sgr = stateGrammarOfLang env (language lang)
gr = grammar sgr
m = cncId sgr
mf = ciq (cncId sgr) (snd f)
--- XML printing; does not belong here!

14
src/GF/UseGrammar/Editing.hs
View File

@@ -164,9 +164,21 @@ noMoreMetas = err (const True) (const False) . goNextMeta
replaceSubTree :: Tree -> Action
replaceSubTree tree state = changeLoc state tree
refineOrReplaceWithTree :: Bool -> CGrammar -> Tree -> Action
refineOrReplaceWithTree der gr tree state = case actMeta state of
Ok m -> refineWithTreeReal der gr tree m state
_ -> do
let tree1 = addBinds (actBinds state) $ tree
state' <- replaceSubTree tree1 state
reCheckState gr state'
refineWithTree :: Bool -> CGrammar -> Tree -> Action
refineWithTree der gr tree state = do
m <- errIn "move pointer to meta" $ actMeta state
m <- errIn "move pointer to meta" $ actMeta state
refineWithTreeReal der gr tree m state
refineWithTreeReal :: Bool -> CGrammar -> Tree -> Meta -> Action
refineWithTreeReal der gr tree m state = do
state' <- replaceSubTree tree state
let cs0 = allConstrs state'
(cs,ms) = splitConstraints cs0

2
src/GF/UseGrammar/Session.hs
View File

@@ -96,7 +96,7 @@ refineByExps der gr trees = case trees of
refineByTrees :: Bool -> CGrammar -> [Tree] -> ECommand
refineByTrees der gr trees = case trees of
[t] -> action2commandNext (refineWithTree der gr t)
[t] -> action2commandNext (refineOrReplaceWithTree der gr t)
_ -> changeCands $ map tree2exp trees
replaceByTrees :: CGrammar -> [Exp] -> ECommand

2
src/Today.hs
View File

@@ -1 +1 @@
module Today where today = "Tue Oct 7 17:59:46 CEST 2003"
module Today where today = "Wed Oct 8 11:43:12 CEST 2003"