From c7a953bb935f578bcbb389e9d4fbe91822ef3f14 Mon Sep 17 00:00:00 2001 From: aarne Date: Thu, 8 Jan 2004 14:58:46 +0000 Subject: [PATCH] Some bug fixes mostly in editor commands. --- grammars/numerals/old/transNum.gfs | 25 ++++++++++ src/GF/API.hs | 8 ++-- src/GF/Compile/ShellState.hs | 32 ++++++------- src/GF/Grammar/LookAbs.hs | 5 ++ src/GF/Grammar/PrGrammar.hs | 30 ++++++++---- src/GF/Grammar/TypeCheck.hs | 3 ++ src/GF/Shell.hs | 2 +- src/GF/Shell/CommandL.hs | 4 +- src/GF/Shell/Commands.hs | 77 +++++++++++++----------------- src/GF/UseGrammar/Custom.hs | 3 +- src/GF/UseGrammar/Paraphrases.hs | 31 ++++++------ src/Today.hs | 2 +- 12 files changed, 128 insertions(+), 94 deletions(-) diff --git a/grammars/numerals/old/transNum.gfs b/grammars/numerals/old/transNum.gfs index 177f8e130..0b6954305 100644 --- a/grammars/numerals/old/transNum.gfs +++ b/grammars/numerals/old/transNum.gfs @@ -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 diff --git a/src/GF/API.hs b/src/GF/API.hs index ab630d7a6..7053a1b67 100644 --- a/src/GF/API.hs +++ b/src/GF/API.hs @@ -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 diff --git a/src/GF/Compile/ShellState.hs b/src/GF/Compile/ShellState.hs index d0232b97e..7c674a0dc 100644 --- a/src/GF/Compile/ShellState.hs +++ b/src/GF/Compile/ShellState.hs @@ -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 diff --git a/src/GF/Grammar/LookAbs.hs b/src/GF/Grammar/LookAbs.hs index 3cd8999ce..462a77ea8 100644 --- a/src/GF/Grammar/LookAbs.hs +++ b/src/GF/Grammar/LookAbs.hs @@ -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 diff --git a/src/GF/Grammar/PrGrammar.hs b/src/GF/Grammar/PrGrammar.hs index 2b5648d8a..aa155c966 100644 --- a/src/GF/Grammar/PrGrammar.hs +++ b/src/GF/Grammar/PrGrammar.hs @@ -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 diff --git a/src/GF/Grammar/TypeCheck.hs b/src/GF/Grammar/TypeCheck.hs index 53bf426c8..1cc486965 100644 --- a/src/GF/Grammar/TypeCheck.hs +++ b/src/GF/Grammar/TypeCheck.hs @@ -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 diff --git a/src/GF/Shell.hs b/src/GF/Shell.hs index b0647b954..dba4e1823 100644 --- a/src/GF/Shell.hs +++ b/src/GF/Shell.hs @@ -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 diff --git a/src/GF/Shell/CommandL.hs b/src/GF/Shell/CommandL.hs index c3d159574..3fd64dd00 100644 --- a/src/GF/Shell/CommandL.hs +++ b/src/GF/Shell/CommandL.hs @@ -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) diff --git a/src/GF/Shell/Commands.hs b/src/GF/Shell/Commands.hs index c15ad13ed..00d8d176b 100644 --- a/src/GF/Shell/Commands.hs +++ b/src/GF/Shell/Commands.hs @@ -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 diff --git a/src/GF/UseGrammar/Custom.hs b/src/GF/UseGrammar/Custom.hs index c117c0335..bd1ed49e1 100644 --- a/src/GF/UseGrammar/Custom.hs +++ b/src/GF/UseGrammar/Custom.hs @@ -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))) diff --git a/src/GF/UseGrammar/Paraphrases.hs b/src/GF/UseGrammar/Paraphrases.hs index f5dc710f9..41a407d6e 100644 --- a/src/GF/UseGrammar/Paraphrases.hs +++ b/src/GF/UseGrammar/Paraphrases.hs @@ -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 = diff --git a/src/Today.hs b/src/Today.hs index f636f81fc..20d7e02ee 100644 --- a/src/Today.hs +++ b/src/Today.hs @@ -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"