Building interface to PL's parser.

5 files changed, 72 insertions, 46 deletions

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 = []
-{- ----
+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
 
-termCommandMenu = 
+{- ----
 
 stringCommandMenu = 
    (CAddOption showStruct,      "structured") :
    (CRemoveOption showStruct,   "unstructured") :
   [(CAddOption (filterString s), s) | s <- allStringCommands]
-
-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
+-}
 
 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"