forked from GitHub/gf-core
Some bug fixes mostly in editor commands.
This commit is contained in:
@@ -53,4 +53,29 @@ i -old -abs=Nums -cnc=Tamil tamil.gf
|
||||
i -old -abs=Nums -cnc=Tibetan tibetan.gf
|
||||
i -old -abs=Nums -cnc=Totonac totonac.gf
|
||||
i -old -abs=Nums -cnc=Turkish turkish.gf
|
||||
i -old -abs=Nums -cnc=AfTunni af_tunni.gf
|
||||
i -old -abs=Nums -cnc=Albanian albanian.gf
|
||||
i -old -abs=Nums -cnc=BearlakeSlave bearlake_slave.gf
|
||||
i -old -abs=Nums -cnc=Dagur dagur.gf
|
||||
i -old -abs=Nums -cnc=Fulfulde fulfulde.gf
|
||||
i -old -abs=Nums -cnc=Guahibo guahibo.gf
|
||||
i -old -abs=Nums -cnc=Guarani guarani.gf
|
||||
i -old -abs=Nums -cnc=Kabardian kabardian.gf
|
||||
i -old -abs=Nums -cnc=Kambera kambera.gf
|
||||
i -old -abs=Nums -cnc=Kawaiisu kawaiisu.gf
|
||||
i -old -abs=Nums -cnc=KolymaYukaghir kolyma_yukaghir.gf
|
||||
i -old -abs=Nums -cnc=Kwaza kwaza.gf
|
||||
i -old -abs=Nums -cnc=Lithuanian lithuanian.gf
|
||||
i -old -abs=Nums -cnc=Lotuxo lotuxo.gf
|
||||
i -old -abs=Nums -cnc=Maale maale.gf
|
||||
i -old -abs=Nums -cnc=Maltese maltese.gf
|
||||
i -old -abs=Nums -cnc=Mapuche mapuche.gf
|
||||
i -old -abs=Nums -cnc=Maybrat maybrat.gf
|
||||
i -old -abs=Nums -cnc=Miya miya.gf
|
||||
i -old -abs=Nums -cnc=Nenets nenets.gf
|
||||
i -old -abs=Nums -cnc=Sango sango.gf
|
||||
i -old -abs=Nums -cnc=TukangBesi tukang_besi.gf
|
||||
i -old -abs=Nums -cnc=Welsh welsh.gf
|
||||
i -old -abs=Nums -cnc=YasinBurushaski yasin_burushaski.gf
|
||||
|
||||
---ts -f
|
||||
|
||||
@@ -264,7 +264,7 @@ optPrintSyntax opts = customOrDefault opts grammarPrinter customSyntaxPrinter
|
||||
prCanonGrammar :: CanonGrammar -> String
|
||||
prCanonGrammar = MC.prCanon
|
||||
|
||||
{- ----
|
||||
|
||||
optPrintTree :: Options -> GFGrammar -> Tree -> String
|
||||
optPrintTree opts = customOrDefault opts grammarPrinter customTermPrinter
|
||||
|
||||
@@ -274,11 +274,11 @@ optStringCommand opts g =
|
||||
optIntOrAll opts flagLength .
|
||||
customOrDefault opts filterString customStringCommand g
|
||||
|
||||
optTreeCommand :: Options -> GFGrammar -> Tree -> [Tree]
|
||||
optTreeCommand opts st =
|
||||
optTermCommand :: Options -> GFGrammar -> Tree -> [Tree]
|
||||
optTermCommand opts st =
|
||||
optIntOrAll opts flagNumber .
|
||||
customOrDefault opts termCommand customTermCommand st
|
||||
-}
|
||||
|
||||
|
||||
{-
|
||||
-- wraps term in a function and optionally computes the result
|
||||
|
||||
@@ -28,7 +28,7 @@ import List (nub,nubBy)
|
||||
data ShellState = ShSt {
|
||||
abstract :: Maybe Ident , -- pointer to actual abstract, if not empty st
|
||||
concrete :: Maybe Ident , -- pointer to primary concrete
|
||||
concretes :: [(Ident,Ident)], -- list of all concretes
|
||||
concretes :: [((Ident,Ident),Bool)], -- list of all concretes, and whether active
|
||||
canModules :: CanonGrammar , -- compiled abstracts and concretes
|
||||
srcModules :: G.SourceGrammar , -- saved resource modules
|
||||
cfs :: [(Ident,CF)] , -- context-free grammars
|
||||
@@ -133,7 +133,7 @@ updateShellState opts sh (gr,(sgr,rts)) = do
|
||||
return $ ShSt {
|
||||
abstract = abstr0,
|
||||
concrete = concr0,
|
||||
concretes = zip concrs concrs,
|
||||
concretes = zip (zip concrs concrs) (repeat True),
|
||||
canModules = cgr,
|
||||
srcModules = src,
|
||||
cfs = zip concrs cfs,
|
||||
@@ -148,7 +148,7 @@ prShellStateInfo :: ShellState -> String
|
||||
prShellStateInfo sh = unlines [
|
||||
"main abstract : " +++ abstractName sh,
|
||||
"main concrete : " +++ maybe "(none)" P.prt (concrete sh),
|
||||
"all concretes : " +++ unwords (map (P.prt . fst) (concretes sh)),
|
||||
"all concretes : " +++ unwords (map (P.prt . fst) (map fst (concretes sh))),
|
||||
"canonical modules :" +++ unwords (map (P.prt .fst) (M.modules (canModules sh))),
|
||||
"source modules : " +++ unwords (map (P.prt .fst) (M.modules (srcModules sh))),
|
||||
"global options : " +++ prOpts (gloptions sh)
|
||||
@@ -177,7 +177,7 @@ purgeShellState :: ShellState -> ShellState
|
||||
purgeShellState sh = ShSt {
|
||||
abstract = abstract sh,
|
||||
concrete = concrete sh,
|
||||
concretes = [(a,i) | (a,i) <- concretes sh, elem i needed],
|
||||
concretes = [((a,i),b) | ((a,i),b) <- concretes sh, elem i needed],
|
||||
canModules = M.MGrammar $ purge $ M.modules $ canModules sh,
|
||||
srcModules = M.emptyMGrammar,
|
||||
cfs = cfs sh,
|
||||
@@ -190,7 +190,7 @@ purgeShellState sh = ShSt {
|
||||
where
|
||||
needed = nub $ concatMap (requiredCanModules (canModules sh)) acncs
|
||||
purge = nubBy (\x y -> fst x == fst y) . filter (flip elem needed . fst)
|
||||
acncs = maybe [] singleton (abstract sh) ++ map snd (concretes sh)
|
||||
acncs = maybe [] singleton (abstract sh) ++ map (snd . fst) (concretes sh)
|
||||
|
||||
-- form just one state grammar, if unique, from a canonical grammar
|
||||
|
||||
@@ -259,22 +259,21 @@ stateAbstractGrammar st = StGr {
|
||||
|
||||
-- analysing shell state into parts
|
||||
globalOptions = gloptions
|
||||
allLanguages = map fst . concretes
|
||||
allLanguages = map (fst . fst) . concretes
|
||||
|
||||
allStateGrammars = map snd . allStateGrammarsWithNames
|
||||
|
||||
allStateGrammarsWithNames st = [(c, mkStateGrammar st c) | (c,_) <- concretes st]
|
||||
|
||||
allGrammarFileNames st = [prLanguage c ++ ".gf" | (c,_) <- concretes st] ---
|
||||
|
||||
{-
|
||||
allActiveStateGrammarsWithNames (ShSt (ma,gs,_)) =
|
||||
[(l, mkStateGrammar a c) | (l,((_,True),c)) <- gs, Just a <- [ma]]
|
||||
allStateGrammarsWithNames st =
|
||||
[(c, mkStateGrammar st c) | ((c,_),_) <- concretes st]
|
||||
|
||||
allGrammarFileNames st = [prLanguage c ++ ".gf" | ((c,_),_) <- concretes st] ---
|
||||
|
||||
allActiveStateGrammarsWithNames st =
|
||||
[(c, mkStateGrammar st c) | ((c,_),True) <- concretes st]
|
||||
|
||||
allActiveGrammars = map snd . allActiveStateGrammarsWithNames
|
||||
|
||||
{-
|
||||
allGrammarSTs = map stateGrammarST . allStateGrammars
|
||||
allCFs = map stateCF . allStateGrammars
|
||||
|
||||
@@ -370,14 +369,15 @@ type ShellStateOper = ShellState -> ShellState
|
||||
reinitShellState :: ShellStateOper
|
||||
reinitShellState = const emptyShellState
|
||||
|
||||
{-
|
||||
languageOn = languageOnOff True
|
||||
languageOff = languageOnOff False
|
||||
|
||||
languageOnOff :: Bool -> Language -> ShellStateOper
|
||||
languageOnOff b lang (ShSt (ab,gs,os)) = ShSt (ab, gs', os) where
|
||||
gs' = [if lang==l then (l,((f,b),g)) else i | i@(l,((f,_),g)) <- gs]
|
||||
languageOnOff b lang (ShSt a c cs cg sg cfs ms os fs cats sts) =
|
||||
ShSt a c cs' cg sg cfs ms os fs cats sts where
|
||||
cs' = [if lang==l then ((l,c),b) else i | i@((l,c),_) <- cs]
|
||||
|
||||
{-
|
||||
updateLanguage :: FilePath -> (Language, StateConcrete) -> ShellStateOper
|
||||
updateLanguage file (lang,gr) (ShSt (ab,gs,os)) =
|
||||
ShSt (ab, updateAssoc (lang,((file,True),gr)) gs, os') where
|
||||
|
||||
@@ -119,6 +119,11 @@ funsOnTypeFs compat fs val = [((fun,i),typ) |
|
||||
(i,arg) <- zip [0..] (map snd args),
|
||||
compat val arg]
|
||||
|
||||
allDefs :: GFCGrammar -> [(Fun,Term)]
|
||||
allDefs gr = [((i,c),d) | (i, ModMod m) <- modules gr,
|
||||
isModAbs m,
|
||||
(c, C.AbsFun _ d) <- tree2list (jments m)]
|
||||
|
||||
-- this is needed at compile time
|
||||
|
||||
lookupFunTypeSrc :: Grammar -> Ident -> Ident -> Err Type
|
||||
|
||||
@@ -29,6 +29,11 @@ class Print a where
|
||||
prt_ = prt
|
||||
prpr = return . prt
|
||||
|
||||
-- 8/1/2004
|
||||
--- Usually followed principle: prt_ for displaying in the editor, prt
|
||||
--- in writing grammars to a file. For some constructs, e.g. prMarkedTree,
|
||||
--- only the former is ever needed.
|
||||
|
||||
-- to show terms etc in error messages
|
||||
prtBad :: Print a => String -> a -> Err b
|
||||
prtBad s a = Bad (s +++ prt a)
|
||||
@@ -92,14 +97,18 @@ instance Print TrNode where
|
||||
prBinds bi ++
|
||||
prt at +++ ":" +++ prt vt
|
||||
+++ prConstraints cs +++ prMetaSubst ms
|
||||
prt_ (N (bi,at,vt,(cs,ms),_)) =
|
||||
prBinds bi ++
|
||||
prt_ at +++ ":" +++ prt_ vt
|
||||
+++ prConstraints cs +++ prMetaSubst ms
|
||||
|
||||
prMarkedTree :: Tr (TrNode,Bool) -> [String]
|
||||
prMarkedTree = prf 1 where
|
||||
prf ind t@(Tr (node, trees)) =
|
||||
prNode ind node : concatMap (prf (ind + 2)) trees
|
||||
prNode ind node = case node of
|
||||
(n, False) -> indent ind (prt n)
|
||||
(n, _) -> '*' : indent (ind - 1) (prt n)
|
||||
(n, False) -> indent ind (prt_ n)
|
||||
(n, _) -> '*' : indent (ind - 1) (prt_ n)
|
||||
|
||||
prTree :: Tree -> [String]
|
||||
prTree = prMarkedTree . mapTr (\n -> (n,False))
|
||||
@@ -111,9 +120,9 @@ prprTree :: Tree -> [String]
|
||||
prprTree = prf False where
|
||||
prf par t@(Tr (node, trees)) =
|
||||
parIf par (prn node : concat [prf (ifPar t) t | t <- trees])
|
||||
prn (N (bi,at,_,_,_)) = prb bi ++ prt at
|
||||
prn (N (bi,at,_,_,_)) = prb bi ++ prt_ at
|
||||
prb [] = ""
|
||||
prb bi = "\\" ++ concat (intersperse "," (map (prt . fst) bi)) ++ " -> "
|
||||
prb bi = "\\" ++ concat (intersperse "," (map (prt_ . fst) bi)) ++ " -> "
|
||||
parIf par (s:ss) = map (indent 2) $
|
||||
if par
|
||||
then ('(':s) : ss ++ [")"]
|
||||
@@ -144,15 +153,15 @@ prBinds bi = if null bi
|
||||
then []
|
||||
else "\\" ++ concat (intersperse "," (map prValDecl bi)) +++ "-> "
|
||||
where
|
||||
prValDecl (x,t) = prParenth (prt x +++ ":" +++ prt t)
|
||||
prValDecl (x,t) = prParenth (prt_ x +++ ":" +++ prt_ t)
|
||||
|
||||
instance Print Val where
|
||||
prt (VGen i x) = prt x ---- ++ "-$" ++ show i ---- latter part for debugging
|
||||
prt (VApp u v) = prt u +++ prv1 v
|
||||
prt (VCn mc) = prQIdent mc
|
||||
prt (VCn mc) = prQIdent_ mc
|
||||
prt (VClos env e) = case e of
|
||||
Meta _ -> prt e ++ prEnv env
|
||||
_ -> prt e ---- ++ prEnv env ---- for debugging
|
||||
Meta _ -> prt_ e ++ prEnv env
|
||||
_ -> prt_ e ---- ++ prEnv env ---- for debugging
|
||||
|
||||
prv1 v = case v of
|
||||
VApp _ _ -> prParenth $ prt v
|
||||
@@ -165,10 +174,15 @@ instance Print Atom where
|
||||
prt (AtV i) = prt i
|
||||
prt (AtL s) = s
|
||||
prt (AtI i) = show i
|
||||
prt_ (AtC f) = prQIdent_ f
|
||||
prt_ a = prt a
|
||||
|
||||
prQIdent :: QIdent -> String
|
||||
prQIdent (m,f) = prt m ++ "." ++ prt f
|
||||
|
||||
prQIdent_ :: QIdent -> String
|
||||
prQIdent_ (_,f) = prt f
|
||||
|
||||
-- print terms without qualifications
|
||||
|
||||
prExp :: Term -> String
|
||||
|
||||
@@ -240,3 +240,6 @@ exp2termCommand gr f t = errIn ("modifying term" +++ prt t) $ do
|
||||
let exp = tree2exp t
|
||||
exp2 <- f exp
|
||||
annotate gr exp2
|
||||
|
||||
exp2termlistCommand :: GFCGrammar -> (Exp -> [Exp]) -> Tree -> [Tree]
|
||||
exp2termlistCommand gr f = err (const []) fst . mapErr (annotate gr) . f . tree2exp
|
||||
|
||||
@@ -171,7 +171,7 @@ execC co@(comm, opts0) sa@((st,(h,_)),a) = case comm of
|
||||
CGenerateRandom n -> do
|
||||
ts <- randomTreesIO opts gro (optIntOrN opts flagNumber n)
|
||||
returnArg (ATrms ts) sa
|
||||
----- CPutTerm -> changeArg (opTT2CommandArg (optTermCommand opts gro) . s2t) sa
|
||||
CPutTerm -> changeArg (opTT2CommandArg (optTermCommand opts gro) . s2t) sa
|
||||
----- CWrapTerm f -> changeArg (opTT2CommandArg (return . wrapByFun opts gro f)) sa
|
||||
CMorphoAnalyse -> changeArg (AString . morphoAnalyse opts gro . prCommandArg) sa
|
||||
CTestTokenizer -> changeArg (AString . optTokenizer opts gro . prCommandArg) sa
|
||||
|
||||
@@ -66,8 +66,8 @@ pCommand = pCommandWords . words where
|
||||
"+" : _ -> CLast
|
||||
"mp" : p -> CMovePosition (readIntList (unwords p))
|
||||
"r" : f : _ -> CRefineWithAtom f
|
||||
"w" : f:i : _ -> CWrapWithFun (strings2Fun f, readIntArg i)
|
||||
"ch": f : _ -> CChangeHead (strings2Fun f)
|
||||
"w" : f:i : _ -> CWrapWithFun (f, readIntArg i)
|
||||
"ch": f : _ -> CChangeHead f
|
||||
"ph": _ -> CPeelHead
|
||||
"x" : ws -> CAlphaConvert $ unwords ws
|
||||
"s" : i : _ -> CSelectCand (readIntArg i)
|
||||
|
||||
@@ -37,7 +37,7 @@ import Option
|
||||
import Str (sstr) ----
|
||||
|
||||
import Random (mkStdGen, newStdGen)
|
||||
import Monad (liftM2)
|
||||
import Monad (liftM2, foldM)
|
||||
import List (intersperse)
|
||||
|
||||
--- temporary hacks for GF 2.0
|
||||
@@ -60,8 +60,8 @@ data Command =
|
||||
| CRefineWithClip Int
|
||||
| CRefineWithAtom String
|
||||
| CRefineParse String
|
||||
| CWrapWithFun (G.Fun,Int)
|
||||
| CChangeHead G.Fun
|
||||
| CWrapWithFun (String,Int)
|
||||
| CChangeHead String
|
||||
| CPeelHead
|
||||
| CAlphaConvert String
|
||||
| CRefineRandom
|
||||
@@ -127,13 +127,9 @@ execCommand env c s = case c of
|
||||
st <- shellStateFromFiles opts env file
|
||||
return (st,s)
|
||||
|
||||
{- ----
|
||||
CCEnvEmptyAndImport file -> do
|
||||
gr <- optFile2grammar noOptions Nothing file
|
||||
let lan = getLangNameOpt noOptions file
|
||||
return (updateLanguage file (lan, getStateConcrete gr)
|
||||
(initWithAbstract (stateAbstract gr) emptyShellState), initSState)
|
||||
-}
|
||||
CCEnvEmptyAndImport file -> useIOE (emptyShellState, initSState) $ do
|
||||
st <- shellStateFromFiles opts emptyShellState file
|
||||
return (st,s)
|
||||
|
||||
CCEnvEmpty -> do
|
||||
return (emptyShellState, initSState)
|
||||
@@ -143,33 +139,20 @@ execCommand env c s = case c of
|
||||
(msg,(env',_)) <- Shell.execLines False cs (Shell.initHState env)
|
||||
return (env', changeMsg msg s) ----
|
||||
|
||||
{- ----
|
||||
CCEnvOpenTerm file -> do
|
||||
c <- readFileIf file
|
||||
let (fs,t) = envAndTerm file c
|
||||
|
||||
env' <- shellStateFromFiles noOptions fs
|
||||
return (env', (action2commandNext $ \x ->
|
||||
(string2treeErr (grammarCEnv env') t x >>=
|
||||
\t -> newTree t x)) s)
|
||||
env' <- useIOE env $ foldM (shellStateFromFiles noOptions) env fs
|
||||
return (env', execECommand env' (CNewTree t) s)
|
||||
|
||||
CCEnvOpenString file -> do
|
||||
c <- readFileIf file
|
||||
let (fs,t) = envAndTerm file c
|
||||
env' <- shellStateFromFiles noOptions fs
|
||||
let gr = grammarCEnv env'
|
||||
sgr = firstStateGrammar env'
|
||||
agrs = allActiveGrammars env'
|
||||
cat = firstCatOpts (stateOptions sgr) sgr
|
||||
state0 <- err (const $ return (stateSState s)) return $
|
||||
newCat gr (cfCat2Cat cat) $ stateSState s
|
||||
state1 <- return $
|
||||
refineByExps True gr (parseAny agrs cat t) $ changeState state0 s
|
||||
return (env', state1)
|
||||
-}
|
||||
env' <- useIOE env $ foldM (shellStateFromFiles noOptions) env fs
|
||||
return (env', execECommand env' (CRefineParse t) s)
|
||||
|
||||
CCEnvOn name -> return (env,s) ---- return (languageOn (language name) env,s)
|
||||
CCEnvOff name -> return (env,s) ---- return (languageOff (language name) env,s)
|
||||
CCEnvOn name -> return (languageOn (language name) env,s)
|
||||
CCEnvOff name -> return (languageOff (language name) env,s)
|
||||
|
||||
-- this command is improved by the use of IO
|
||||
CRefineRandom -> do
|
||||
@@ -220,8 +203,8 @@ execECommand env c = case c of
|
||||
t <- string2ref gr s
|
||||
s' <- refineWithAtom der cgr t x
|
||||
uniqueRefinements cgr s'
|
||||
CWrapWithFun fi -> action2commandNext $ wrapWithFun cgr fi
|
||||
CChangeHead f -> action2commandNext $ changeFunHead cgr f
|
||||
CWrapWithFun (f,i) -> action2commandNext $ wrapWithFun cgr (qualif f, i)
|
||||
CChangeHead f -> action2commandNext $ changeFunHead cgr (qualif f)
|
||||
CPeelHead -> action2commandNext $ peelFunHead cgr
|
||||
|
||||
CAlphaConvert s -> action2commandNext $ \x ->
|
||||
@@ -268,12 +251,13 @@ execECommand env c = case c of
|
||||
_ -> changeMsg ["command not yet implemented"]
|
||||
where
|
||||
sgr = firstStateGrammar env
|
||||
agrs = allStateGrammars env ---- allActiveGrammars env
|
||||
agrs = allActiveGrammars env
|
||||
cgr = canCEnv env
|
||||
gr = grammarCEnv env
|
||||
der = maybe True not $ caseYesNo (globalOptions env) noDepTypes
|
||||
-- if there are dep types, then derived refs; deptypes is the default
|
||||
abs = absId sgr
|
||||
qualif = string2Fun gr
|
||||
|
||||
--
|
||||
|
||||
@@ -298,9 +282,12 @@ mkRefineMenuAll :: CEnv -> SState -> [(Command,(String,String))]
|
||||
mkRefineMenuAll env sstate =
|
||||
case (refinementsState cgr state, candsSState sstate, wrappingsState cgr state) of
|
||||
([],[],wraps) ->
|
||||
[(CWrapWithFun fi, prWrap fit) | fit@(fi,_) <- wraps] ++
|
||||
[(CChangeHead f, prChangeHead f) | f <- headChangesState cgr state] ++
|
||||
[(CPeelHead, (ifShort "ph" "PeelHead", "ph")) | canPeelState cgr state] ++
|
||||
[(CWrapWithFun (prQIdent_ f, i), prWrap fit)
|
||||
| fit@((f,i),_) <- wraps] ++
|
||||
[(CChangeHead (prQIdent_ f), prChangeHead f)
|
||||
| f <- headChangesState cgr state] ++
|
||||
[(CPeelHead, (ifShort "ph" "PeelHead", "ph"))
|
||||
| canPeelState cgr state] ++
|
||||
[(CDelete, (ifShort "d" "Delete", "d"))] ++
|
||||
[(CAddClip, (ifShort "ac" "AddClip", "ac"))]
|
||||
(refs,[],_) ->
|
||||
@@ -311,18 +298,18 @@ mkRefineMenuAll env sstate =
|
||||
|
||||
where
|
||||
prRef (f,t) =
|
||||
(ifShort "r" "Refine" +++ prOrLinRef f +++ ifTyped (":" +++ prt t),
|
||||
(ifShort "r" "Refine" +++ prOrLinRef f +++ ifTyped (":" +++ prt_ t),
|
||||
"r" +++ prRefinement f)
|
||||
prClip i t =
|
||||
(ifShort "rc" "Paste" +++ prOrLinTree t,
|
||||
"rc" +++ show i)
|
||||
prChangeHead f =
|
||||
(ifShort "ch" "ChangeHead" +++ prOrLinFun f,
|
||||
"ch" +++ prQIdent f)
|
||||
"ch" +++ prQIdent_ f)
|
||||
prWrap ((f,i),t) =
|
||||
(ifShort "w" "Wrap" +++ prOrLinFun f +++ ifTyped (":" +++ prt t) +++
|
||||
ifShort (show i) (prBracket (show i)),
|
||||
"w" +++ prQIdent f +++ show i)
|
||||
"w" +++ prQIdent_ f +++ show i)
|
||||
prCand (t,i) =
|
||||
(ifShort ("s" +++ prOrLinExp t) ("Select" +++ prOrLinExp t),"s" +++ show i)
|
||||
|
||||
@@ -335,14 +322,14 @@ mkRefineMenuAll env sstate =
|
||||
_ -> b
|
||||
ifShort = ifOpt sizeDisplay "short"
|
||||
ifTyped t = ifOpt typeDisplay "typed" t ""
|
||||
prOrLinExp t = prt 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
|
||||
_ -> prt_ t
|
||||
prOrLinFun = printname env sstate
|
||||
prOrLinTree t = case getOptVal opts menuDisplay of
|
||||
Just "Abs" -> prTermOpt opts $ tree2exp t
|
||||
Just "Abs" -> prt_ $ tree2exp t ---- prTermOpt opts $ tree2exp t
|
||||
Just lang -> prQuotedString $ lin lang t
|
||||
_ -> prTermOpt opts $ tree2exp t
|
||||
lin lang t = optLinearizeTreeVal opts (stateGrammarOfLang env (language lang)) t
|
||||
@@ -422,7 +409,7 @@ displaySStateJavaX isNew 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 = allActiveStateGrammarsWithNames env
|
||||
lins = (langAbstract, exp) : linAll
|
||||
opts = addOptions (optsSState state) -- state opts override
|
||||
(addOption (markLin mark) (globalOptions env))
|
||||
@@ -459,12 +446,12 @@ 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 "Abs" -> prQIdent_ f
|
||||
Just lang -> printn lang f
|
||||
_ -> prTermOpt opts (qq f)
|
||||
_ -> prQIdent_ f ---- prTermOpt opts (qq f)
|
||||
where
|
||||
opts = addOptions (optsSState state) (globalOptions env)
|
||||
printn lang f = err id (ifNull (prQIdent f) (sstr . head)) $ do
|
||||
printn lang f = err id (ifNull (prQIdent_ f) (sstr . head)) $ do
|
||||
t <- lookupPrintname gr mf
|
||||
strsFromTerm t
|
||||
where
|
||||
|
||||
@@ -184,7 +184,8 @@ customTermCommand =
|
||||
,(strCI "compute", \g t -> let gr = grammar g in
|
||||
err (const [t]) return
|
||||
(exp2termCommand gr (computeAbsTerm gr) t))
|
||||
---- ,(strCI "paraphrase", \g t -> mkParaphrases g t)
|
||||
,(strCI "paraphrase", \g t -> let gr = grammar g in
|
||||
exp2termlistCommand gr (mkParaphrases gr) t)
|
||||
---- ,(strCI "typecheck", \g t -> err (const []) return (checkIfValidExp g t))
|
||||
,(strCI "solve", \g t -> err (const [t]) (return . loc2tree)
|
||||
(uniqueRefinements (grammar g) (tree2loc t)))
|
||||
|
||||
@@ -1,41 +1,40 @@
|
||||
module Paraphrases (mkParaphrases) where
|
||||
|
||||
import Operations
|
||||
import AbsGFC
|
||||
import GFC
|
||||
import Look
|
||||
import CMacros ---- (mkApp, eqStrIdent)
|
||||
import Abstract
|
||||
import PrGrammar
|
||||
import LookAbs
|
||||
import AbsCompute
|
||||
|
||||
import Operations
|
||||
|
||||
import List (nub)
|
||||
|
||||
-- paraphrases of GF terms. AR 6/10/1998 -- 24/9/1999 -- 5/7/2000 -- 5/6/2002
|
||||
-- Copyright (c) Aarne Ranta 1998--99, under GNU General Public License (see GPL)
|
||||
-- thus inherited from the old GF. Incomplete and inefficient...
|
||||
|
||||
mkParaphrases :: CanonGrammar -> Exp -> [Exp]
|
||||
mkParaphrases st t = [t]
|
||||
---- mkParaphrases st = nub . map (beta []) . paraphrases (allDefs st)
|
||||
mkParaphrases :: GFCGrammar -> Term -> [Term]
|
||||
mkParaphrases st = nub . map (beta []) . paraphrases (allDefs st)
|
||||
|
||||
{- ----
|
||||
type Definition = (Fun,Trm)
|
||||
type Definition = (Fun,Term)
|
||||
|
||||
paraphrases :: [Definition] -> Trm -> [Trm]
|
||||
paraphrases :: [Definition] -> Term -> [Term]
|
||||
paraphrases th t =
|
||||
t :
|
||||
paraImmed th t ++
|
||||
--- paraMatch th t ++
|
||||
case t of
|
||||
App c a -> [App d b | d <- paraphrases th c, b <- paraphrases th a]
|
||||
Abs x b -> [Abs x d | d <- paraphrases th b]
|
||||
c -> []
|
||||
++ [t]
|
||||
|
||||
paraImmed :: [Definition] -> Trm -> [Trm]
|
||||
paraImmed :: [Definition] -> Term -> [Term]
|
||||
paraImmed defs t =
|
||||
[Cn f | (f, u) <- defs, t == u] ++ --- eqTerm
|
||||
[Q m f | ((m,f), u) <- defs, t == u] ++ --- eqTerm
|
||||
case t of
|
||||
Cn c -> [u | (f, u) <- defs, eqStrIdent f c]
|
||||
---- Cn c -> [u | (f, u) <- defs, eqStrIdent f c]
|
||||
_ -> []
|
||||
-}
|
||||
|
||||
{- ---
|
||||
paraMatch :: [Definition] -> Trm -> [Trm]
|
||||
paraMatch th@defs t =
|
||||
|
||||
@@ -1 +1 @@
|
||||
module Today where today = "Mon Jan 5 11:31:04 CET 2004"
|
||||
module Today where today = "Thu Jan 8 16:37:47 CET 2004"
|
||||
|
||||
Reference in New Issue
Block a user