Building interface to PL's parser.

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

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
+  let cgr0 = M.updateMGrammar (canModules sh) gr
-      a' = ifNull Nothing (return . last) $ allAbstracts cgr
+      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
 

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,7 +234,6 @@ execECommand env c = case c of
                            else id) 
                             (refineByTrees der cgr ts) s
 
-  
   CRefineRandom      -> \s -> action2commandNext
                                 (refineRandom (stdGenCEnv env s) 41 cgr) s 
 
@@ -248,8 +246,8 @@ execECommand env c = case c of
 ----                                       transferSubTree (stateTransferFun sgr) gr
                          _ -> replaceByEditCommand gr c
 
-----  CAddOption o       -> changeStOptions (addOption o)
+  CAddOption o       -> changeStOptions (addOption o)
-----  CRemoveOption o    -> changeStOptions (removeOption o)
+  CRemoveOption o    -> changeStOptions (removeOption o)
   CDelete            -> action2commandNext $ deleteSubTree cgr
   CUndo              -> undoCommand
   CMenu              -> \s -> changeMsg (menuState env s) s
@@ -342,16 +340,6 @@ 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 =
   [(CAddOption (menuDisplay s), s) | s <- "Abs" : langs] ++
   [(CAddOption (sizeDisplay s), s) | s <- ["short", "long"]] ++
@@ -359,11 +347,19 @@ displayCommandMenu env =
  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))
+  printn lang = printOrLinearize gr m f where
-  gr = grammarCEnv env
+     sgr = stateGrammarOfLang env (language lang)
-
+     gr  = grammar sgr
+     m   = cncId sgr
 
 --- XML printing; does not belong here!
 

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 $ 
+printOrLinearize :: CanonGrammar -> Ident -> A.Fun -> String
-       do
+printOrLinearize gr c f@(m, d) = errVal (prt fq) $ 
-    t  <- lookupFunType gr f
+  case lookupPrintname gr (CIQ c d) of
-    f' <- ref2exp [] t (AC f) --- []
+    Ok t -> do
-    lin f'
+      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
-   lin = linearizeToStrings gr (const id) ----
+     fq = CIQ m d  
--}

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"