diff --git a/src/GF/Canon/Look.hs b/src/GF/Canon/Look.hs index a71d024c2..ec76008f9 100644 --- a/src/GF/Canon/Look.hs +++ b/src/GF/Canon/Look.hs @@ -33,6 +33,21 @@ lookupLin gr f = do CncCat _ t _ -> return t AnyInd _ n -> lookupLin gr $ redirectIdent n f +lookupLincat :: CanonGrammar -> CIdent -> Err CType +lookupLincat gr f = do + info <- lookupCncInfo gr f + case info of + CncCat t _ _ -> return t + AnyInd _ n -> lookupLincat gr $ redirectIdent n f + +lookupPrintname :: CanonGrammar -> CIdent -> Err Term +lookupPrintname gr f = do + info <- lookupCncInfo gr f + case info of + CncFun _ _ _ t -> return t + CncCat _ _ t -> return t + AnyInd _ n -> lookupPrintname gr $ redirectIdent n f + lookupResInfo :: CanonGrammar -> CIdent -> Err Info lookupResInfo gr f@(CIQ m c) = do mt <- M.lookupModule gr m diff --git a/src/GF/Compile/ShellState.hs b/src/GF/Compile/ShellState.hs index 3c1dffb07..51e05abd0 100644 --- a/src/GF/Compile/ShellState.hs +++ b/src/GF/Compile/ShellState.hs @@ -101,13 +101,14 @@ updateShellState :: Options -> ShellState -> (CanonGrammar,(G.SourceGrammar,[(FilePath,ModTime)])) -> Err ShellState updateShellState opts sh (gr,(sgr,rts)) = do - let cgr = M.updateMGrammar (canModules sh) gr - a' = ifNull Nothing (return . last) $ allAbstracts cgr + let cgr0 = M.updateMGrammar (canModules sh) gr + a' = ifNull Nothing (return . last) $ allAbstracts cgr0 abstr0 <- case abstract sh of Just a -> do --- test that abstract is compatible return $ Just a _ -> return a' + let cgr = filterAbstracts abstr0 cgr0 let concrs = maybe [] (allConcretes cgr) abstr0 concr0 = ifNull Nothing (return . last) concrs notInrts f = notElem f $ map fst rts @@ -146,6 +147,21 @@ prShellStateInfo sh = unlines [ "global options : " +++ prOpts (gloptions sh) ] +-- throw away those abstracts that are not needed --- could be more aggressive + +filterAbstracts :: Maybe Ident -> CanonGrammar -> CanonGrammar +filterAbstracts abstr cgr = M.MGrammar [m | m <- ms, needed m] where + ms = M.modules cgr + needed (i,_) = case abstr of + Just a -> elem i $ needs a + _ -> True + needs a = [i | (i,M.ModMod m) <- ms, not (M.isModAbs m) || dep i a] + dep i a = elem i (ext a mse) + mse = [(i,me) | (i,M.ModMod m) <- ms, M.isModAbs m, me <- [M.extends m]] + ext a es = case lookup a es of + Just (Just e) -> a : ext e es + Just _ -> a : [] + _ -> [] -- form just one state grammar, if unique, from a canonical grammar diff --git a/src/GF/Shell/Commands.hs b/src/GF/Shell/Commands.hs index 128029668..3ba783c3b 100644 --- a/src/GF/Shell/Commands.hs +++ b/src/GF/Shell/Commands.hs @@ -3,7 +3,6 @@ module Commands where import Operations import Zipper -----import AccessGrammar (Term (Vr)) ---- import qualified Grammar as G ---- Cat import GFC import qualified AbsGFC ---- Atom @@ -235,21 +234,20 @@ execECommand env c = case c of else id) (refineByTrees der cgr ts) s - CRefineRandom -> \s -> action2commandNext (refineRandom (stdGenCEnv env s) 41 cgr) s CSelectCand i -> selectCand cgr i CTermCommand c -> case c of - "paraphrase" -> \s -> - replaceByTermCommand der gr c (actTree (stateSState s)) s + "paraphrase" -> \s -> + replaceByTermCommand der gr c (actTree (stateSState s)) s ---- "transfer" -> action2commandNext $ ---- transferSubTree (stateTransferFun sgr) gr - _ -> replaceByEditCommand gr c + _ -> replaceByEditCommand gr c ----- CAddOption o -> changeStOptions (addOption o) ----- CRemoveOption o -> changeStOptions (removeOption o) + CAddOption o -> changeStOptions (addOption o) + CRemoveOption o -> changeStOptions (removeOption o) CDelete -> action2commandNext $ deleteSubTree cgr CUndo -> undoCommand CMenu -> \s -> changeMsg (menuState env s) s @@ -342,28 +340,26 @@ allTermCommands = snd $ customInfo customEditCommand stringCommandMenu = [] displayCommandMenu :: CEnv -> [(Command,String)] -displayCommandMenu env = [] -{- ---- - -termCommandMenu = - -stringCommandMenu = - (CAddOption showStruct, "structured") : - (CRemoveOption showStruct, "unstructured") : - [(CAddOption (filterString s), s) | s <- allStringCommands] - -displayCommandMenu env = +displayCommandMenu env = [(CAddOption (menuDisplay s), s) | s <- "Abs" : langs] ++ [(CAddOption (sizeDisplay s), s) | s <- ["short", "long"]] ++ [(CAddOption (typeDisplay s), s) | s <- ["typed", "untyped"]] where langs = map prLanguage $ allLanguages env +{- ---- + +stringCommandMenu = + (CAddOption showStruct, "structured") : + (CRemoveOption showStruct, "unstructured") : + [(CAddOption (filterString s), s) | s <- allStringCommands] +-} + changeMenuLanguage, changeMenuSize, changeMenuTyped :: String -> Command changeMenuLanguage s = CAddOption (menuDisplay s) changeMenuSize s = CAddOption (sizeDisplay s) changeMenuTyped s = CAddOption (typeDisplay s) --} + menuState env = map snd . mkRefineMenu env @@ -417,7 +413,7 @@ langXML = language "XML" linearizeState :: (String -> [String]) -> Options -> GFGrammar -> State -> [String] linearizeState wrap opts gr = wrap . strop . unt . optLinearizeTreeVal opts gr . loc2treeFocus - --- markedLinString br g + where unt = id ---- customOrDefault (stateOptions g) useUntokenizer customUntokenizer g strop = id ---- maybe id ($ g) $ customAsOptVal opts filterString customStringCommand @@ -437,13 +433,14 @@ 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 f + Just lang -> printn lang _ -> prQIdent f where opts = addOptions (optsSState state) (globalOptions env) - printn lang = linearize gr ---- printOrLinearize (grammarOfLang env (language lang)) - gr = grammarCEnv env - + printn lang = printOrLinearize gr m f where + sgr = stateGrammarOfLang env (language lang) + gr = grammar sgr + m = cncId sgr --- XML printing; does not belong here! diff --git a/src/GF/UseGrammar/Linear.hs b/src/GF/UseGrammar/Linear.hs index 9cf391393..929273562 100644 --- a/src/GF/UseGrammar/Linear.hs +++ b/src/GF/UseGrammar/Linear.hs @@ -8,6 +8,9 @@ import Ident import PrGrammar import CMacros import Look +import LookAbs +import MMacros +import TypeCheck (annotate) ---- import Str import Unlex ----import TypeCheck -- to annotate @@ -115,7 +118,6 @@ linTree2string mk gr m e = err id id $ do let ss = strs2strings $ sTables2strs $ strTables2sTables ts ifNull (prtBad "empty linearization of" e) (return . head) ss - -- argument is a Tree, value is a list of strs; needed in Parsing allLinsOfTree :: CanonGrammar -> Ident -> A.Tree -> [Str] @@ -165,23 +167,19 @@ allLinsOfFun gr f = do -} - - - -{- ---- -- returns printname if one exists; otherwise linearizes with metas -printOrLinearize :: CanonGrammar -> Fun -> String -printOrLinearize gr f = -{- ---- - errVal (prtt f) $ case lookupPrintname cnc f of - Ok s -> return s - _ -> -} - - unlines $ take 1 $ err singleton id $ - do - t <- lookupFunType gr f - f' <- ref2exp [] t (AC f) --- [] - lin f' - where - lin = linearizeToStrings gr (const id) ---- --} + +printOrLinearize :: CanonGrammar -> Ident -> A.Fun -> String +printOrLinearize gr c f@(m, d) = errVal (prt fq) $ + case lookupPrintname gr (CIQ c d) of + Ok t -> do + ss <- strsFromTerm t + let s = strs2strings [ss] + return $ ifNull (prt fq) head s + _ -> do + ty <- lookupFunType gr m d + f' <- ref2exp [] ty (A.QC m d) + tr <- annotate gr f' + return $ linTree2string noMark gr c tr + where + fq = CIQ m d diff --git a/src/Today.hs b/src/Today.hs index e8522e2be..3e8e4ecae 100644 --- a/src/Today.hs +++ b/src/Today.hs @@ -1 +1 @@ -module Today where today = "Thu Oct 2 18:51:58 CEST 2003" +module Today where today = "Fri Oct 3 14:06:22 CEST 2003"