started IDE support project

src/GF/Compile/ShellState.hs

@@ -5,9 +5,9 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/10/31 19:02:35 $ 
+-- > CVS $Date: 2005/11/09 22:34:01 $ 
 -- > CVS $Author: aarne $
--- > CVS $Revision: 1.50 $
+-- > CVS $Revision: 1.51 $
 --
 -- (Description of the module)
 -----------------------------------------------------------------------------
@@ -52,7 +52,7 @@ data ShellState = ShSt {
   canModules :: CanonGrammar ,       -- ^ compiled abstracts and concretes
   srcModules :: G.SourceGrammar ,    -- ^ saved resource modules
   cfs        :: [(Ident,CF)] ,       -- ^ context-free grammars (small, no parameters, very over-generating)
-  pInfosOld  :: [(Ident,CnvOld.PInfo)], -- ^ parser information, peb 18\/6-04 (OBSOLETE)
+  abstracts  :: [(Ident,[Ident])],   -- ^ abstracts and their associated concretes
   mcfgs      :: [(Ident, Cnv.MGrammar)], -- ^ MCFG, converted according to Ljunglöf (2004, ch 3)
   cfgs       :: [(Ident, Cnv.CGrammar)], -- ^ CFG, converted from mcfg 
                                          -- (large, with parameters, no-so overgenerating)
@@ -69,6 +69,16 @@ data ShellState = ShSt {
   statistics :: [Statistics]         -- ^ statistics on grammars
   }                             
 
+actualConcretes :: ShellState -> [((Ident,Ident),Bool)]
+actualConcretes sh = nub [((c,c),b) | 
+  Just a <- [abstract sh],
+  c <- concretesOfAbstract sh a,
+  let b = True -----
+  ]
+
+concretesOfAbstract :: ShellState -> Ident -> [Ident]
+concretesOfAbstract sh a = [c | (b,cs) <- abstracts sh, b == a, c <- cs]
+
 data Statistics = 
     StDepTypes Bool        -- ^ whether there are dependent types      
   | StBoundVars [G.Cat]    -- ^ which categories have bound variables
@@ -83,7 +93,7 @@ emptyShellState = ShSt {
   canModules = M.emptyMGrammar,
   srcModules = M.emptyMGrammar,
   cfs        = [],
-  pInfosOld  = [], -- peb 18/6 (OBSOLETE)
+  abstracts  = [],
   mcfgs      = [],
   cfgs       = [],
   pInfos     = [],
@@ -112,7 +122,6 @@ data StateGrammar = StGr {
   cncId    :: Ident,
   grammar  :: CanonGrammar,
   cf       :: CF,
-  pInfoOld :: CnvOld.PInfo, -- peb 8/6 (OBSOLETE)
   mcfg     :: Cnv.MGrammar,
   cfg      :: Cnv.CGrammar,
   pInfo    :: Prs.PInfo,
@@ -127,7 +136,6 @@ emptyStateGrammar = StGr {
   cncId    = identC "#EMPTY", ---
   grammar  = M.emptyMGrammar,
   cf       = emptyCF,
-  pInfoOld = CnvOld.emptyPInfo, -- peb 18/6 (OBSOLETE)
   mcfg     = [],
   cfg      = [],
   pInfo    = Prs.buildPInfo [] [],
@@ -140,7 +148,6 @@ emptyStateGrammar = StGr {
 
 stateGrammarST    :: StateGrammar -> CanonGrammar
 stateCF           :: StateGrammar -> CF
-statePInfoOld     :: StateGrammar -> CnvOld.PInfo -- OBSOLETE
 stateMCFG         :: StateGrammar -> Cnv.MGrammar
 stateCFG          :: StateGrammar -> Cnv.CGrammar
 statePInfo        :: StateGrammar -> Prs.PInfo
@@ -152,7 +159,6 @@ stateGrammarLang  :: StateGrammar -> (CanonGrammar, Ident)
 
 stateGrammarST = grammar
 stateCF        = cf
-statePInfoOld  = pInfoOld -- OBSOLETE
 stateMCFG      = mcfg
 stateCFG       = cfg
 statePInfo     = pInfo
@@ -177,20 +183,30 @@ updateShellState :: Options -> Maybe Ident -> ShellState ->
                     Err ShellState 
 updateShellState opts mcnc sh ((_,sgr,gr),rts) = do 
   let cgr0 = M.updateMGrammar (canModules sh) gr
-  a' <- return $ case mcnc of
+
+  -- a0 = abstract of old state
+  -- a1 = abstract of compiled grammar
+
+  let a0 = abstract sh
+  a1 <- return $ case mcnc of
     Just cnc -> err (const Nothing) Just $ M.abstractOfConcrete cgr0 cnc
     _ -> M.greatestAbstract cgr0
-  abstr0 <- case abstract sh of
+
-    Just a -> do
+  -- abstr0 = a1 if it exists
-      -- test that abstract is compatible --- unsafe exception for old? 
+
-      --- if True oElem showOld opts then return () else
+  let (abstr0,isNew) = case (a0,a1) of
-      case a' of
+        (Just a,  Just b) | a /= b -> (a1, True)
-        Nothing -> return ()
+        (Nothing, Just _)          -> (a1, True)
-        Just b -> testErr (a==b) ("expected abstract" +++ P.prt a +++ "but found " +++ P.prt b) 
+        _                          -> (a0, False)
-      return $ Just a
+
-    _ -> return a'
+  let concrs0 = maybe [] (M.allConcretes cgr0) abstr0
-  let cgr = filterAbstracts abstr0 cgr0
+
-  let concrs = maybe [] (M.allConcretes cgr) abstr0
+  let abstrs = nubBy (\ (x,_) (y,_) -> x == y) $ 
+               maybe id (\a -> ((a,concrs0):)) abstr0 $ abstracts sh
+
+  let cgr = filterAbstracts (map fst abstrs) cgr0
+
+  let concrs = nub $ concrs0 ++ map (snd . fst) (concretes sh)
       concr0 = ifNull Nothing (return . head) concrs
       notInrts f = notElem f $ map fst rts
       subcgr = unSubelimCanon cgr
@@ -199,7 +215,6 @@ updateShellState opts mcnc sh ((_,sgr,gr),rts) = do
   let morphos = map (mkMorpho subcgr) concrs
   let probss = [] -----
 
-  let pinfosOld = map (CnvOld.pInfo opts cgr) concrs  -- peb 18/6 (OBSOLETE)
 
   let fromGFC       = snd . snd . Cnv.convertGFC opts
       (mcfgs, cfgs) = unzip $ map (curry fromGFC cgr) concrs 
@@ -222,7 +237,7 @@ updateShellState opts mcnc sh ((_,sgr,gr),rts) = do
     canModules = cgr,
     srcModules = src,
     cfs        = zip concrs cfs,
-    pInfosOld  = zip concrs pinfosOld, -- peb 8/6 (OBSOLETE)
+    abstracts  = abstrs,
     mcfgs      = zip concrs mcfgs,
     cfgs       = zip concrs cfgs,
     pInfos     = zip concrs pInfos,
@@ -238,7 +253,9 @@ 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) (map fst (concretes sh))),
+  "actual concretes : " +++ unwords (map (P.prt . fst . fst) (actualConcretes sh)),
+  "all abstracts :    " +++ unwords (map (P.prt . fst) (abstracts sh)),
+  "all concretes :    " +++ unwords (map (P.prt . fst . 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)
@@ -262,13 +279,11 @@ abstractName :: ShellState -> String
 abstractName sh = maybe "(none)" P.prt (abstract sh)
 
 -- | throw away those abstracts that are not needed --- could be more aggressive
-filterAbstracts :: Maybe Ident -> CanonGrammar -> CanonGrammar
+filterAbstracts :: [Ident] -> CanonGrammar -> CanonGrammar
-filterAbstracts abstr cgr = M.MGrammar (nubBy (\x y -> fst x == fst y) [m | m <- ms, needed m]) where
+filterAbstracts absts cgr = M.MGrammar (nubBy (\x y -> fst x == fst y) [m | m <- ms, needed m]) where
   ms = M.modules cgr
-  needed (i,_) = case abstr of
+  needed (i,_) = elem i needs
-    Just a -> elem i $ needs a
+  needs   = [i | (i,M.ModMod m) <- ms, not (M.isModAbs m) || any (dep i) absts]
-    _ -> True
-  needs a = [i | (i,M.ModMod m) <- ms, not (M.isModAbs m) || dep i a]
   dep i a = elem i (ext mse a)
   mse = [(i,me) | (i,M.ModMod m) <- ms, M.isModAbs m, me <- [M.extends m]]
   ext es a = case lookup a es of
@@ -278,13 +293,13 @@ filterAbstracts abstr cgr = M.MGrammar (nubBy (\x y -> fst x == fst y) [m | m <-
 
 purgeShellState :: ShellState -> ShellState
 purgeShellState sh = ShSt {
-  abstract   = abstract sh,
+  abstract   = abstr,
   concrete   = concrete sh,
-  concretes  = [((a,i),b) | ((a,i),b) <- concretes sh, elem i needed],
+  concretes  = concrs,
   canModules = M.MGrammar $ purge $ M.modules $ canModules sh,
   srcModules = M.emptyMGrammar,
   cfs        = cfs sh,
-  pInfosOld  = pInfosOld sh, -- OBSOLETE
+  abstracts  = maybe [] (\a -> [(a,map (snd . fst) concrs)]) abstr,
   mcfgs      = mcfgs sh,
   cfgs       = cfgs sh,
   pInfos     = pInfos sh,
@@ -296,9 +311,11 @@ purgeShellState sh = ShSt {
   statistics = statistics sh
   }
  where
+   abstr = abstract sh
+   concrs = [((a,i),b) | ((a,i),b) <- concretes sh, elem i needed]
    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 . fst) (concretes sh)
+   acncs = maybe [] singleton (abstract sh) ++ map (snd . fst) (actualConcretes sh)
 
 changeMain :: Maybe Ident -> ShellState -> Err ShellState
 changeMain Nothing (ShSt _ _ cs ms ss cfs old_pis mcfgs cfgs pinfos mos pbs os rs acs s) = 
@@ -333,7 +350,6 @@ stateGrammarOfLang st l = StGr {
   cncId    = l,
   grammar  = can,
   cf       = maybe emptyCF id (lookup l (cfs st)),
-  pInfoOld = maybe CnvOld.emptyPInfo id (lookup l (pInfosOld st)), -- peb 18/6 (OBSOLETE)
   mcfg     = maybe [] id $ lookup l $ mcfgs st,
   cfg      = maybe [] id $ lookup l $ cfgs st,
   pInfo    = maybe (Prs.buildPInfo [] []) id $ lookup l $ pInfos st,
@@ -373,7 +389,6 @@ stateAbstractGrammar st = StGr {
   cncId    = identC "#Cnc", ---
   grammar  = canModules st, ---- only abstarct ones
   cf       = emptyCF,
-  pInfoOld = CnvOld.emptyPInfo, -- peb 18/6 (OBSOLETE)
   mcfg     = [],
   cfg      = [],
   pInfo    = Prs.buildPInfo [] [],
@@ -401,12 +416,12 @@ allCategories = map fst . allCatsOf . canModules
 allStateGrammars = map snd . allStateGrammarsWithNames
 
 allStateGrammarsWithNames st = 
-  [(c, mkStateGrammar st c) | ((c,_),_) <- concretes st]
+  [(c, mkStateGrammar st c) | ((c,_),_) <- actualConcretes st]
 
-allGrammarFileNames st = [prLanguage c ++ ".gf" | ((c,_),_) <- concretes st] ---
+allGrammarFileNames st = [prLanguage c ++ ".gf" | ((c,_),_) <- actualConcretes st]
 
 allActiveStateGrammarsWithNames st =   
-  [(c, mkStateGrammar st c) | ((c,_),True) <- concretes st]
+  [(c, mkStateGrammar st c) | ((c,_),True) <- concretes st] --- actual
 
 allActiveGrammars = map snd . allActiveStateGrammarsWithNames
 

src/GF/IDE/IDECommands.hs

@@ -0,0 +1,91 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : IDECommands
+-- Maintainer  : AR
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/11/09 22:34:01 $ 
+-- > CVS $Author: aarne $
+-- > CVS $Revision: 1.1 $
+--
+-- Commands usable in grammar-writing IDE.
+-----------------------------------------------------------------------------
+
+module GF.IDE.IDECommands where
+
+import GF.Infra.Ident (Ident, identC)
+import GF.Compile.ShellState
+import qualified GF.Shell.ShellCommands as S
+import qualified GF.Shell.Commands as E
+import qualified GF.Shell.CommandL as PE
+import GF.UseGrammar.Session
+import GF.UseGrammar.Custom
+import GF.Grammar.PrGrammar
+
+import GF.Infra.Option
+import GF.Data.Operations
+import GF.Infra.Modules
+import GF.Infra.UseIO
+
+data IDEState = IDE {
+  ideShellState :: ShellState, 
+  ideAbstract   :: Maybe Ident,
+  ideConcretes  :: [Ident],
+  ideCurrentCnc :: Maybe Ident,
+  ideCurrentLin :: Maybe Ident, -- lin or lincat
+  ideSState     :: Maybe SState
+  }
+
+emptyIDEState :: ShellState -> IDEState
+emptyIDEState shst = IDE shst Nothing [] Nothing Nothing Nothing
+
+data IDECommand =
+    IDEInit
+  | IDEAbstract Ident
+  | IDEConcrete Ident
+  | IDELin      Ident
+  | IDEShell    String -- S.Command
+  | IDEEdit     String -- E.Command
+  | IDEQuit
+  | IDEVoid     String -- the given command itself maybe
+
+
+execIDECommand :: IDECommand -> IDEState -> IOE IDEState
+execIDECommand c state = case c of
+  IDEInit -> 
+    return $ emptyIDEState env
+  IDEAbstract a -> 
+    return $ state {ideAbstract = Just a} ---- check a exists or import it
+  IDEEdit s ->
+    execEdit s
+  IDEShell s ->
+    execShell s
+  IDEVoid s  -> ioeErr $ fail s
+  _ -> ioeErr $ fail "command not implemented"
+
+ where
+   env = ideShellState state
+   sstate = maybe initSState id $ ideSState state
+
+   execShell s = execEdit $ "gf" +++ s
+
+   execEdit s = ioeIO $ do
+     (env',sstate') <- E.execCommand env (PE.pCommand s) sstate
+     return $ state {ideShellState = env', ideSState = Just sstate'}
+
+   putMsg = putStrLn ---- XML
+
+pCommands :: String -> [IDECommand]
+pCommands = map pCommand . concatMap (chunks ";;" . words) . lines
+
+pCommand :: [String] -> IDECommand
+pCommand ws = case ws of
+  "gf"       : s     -> IDEShell $ unwords s
+  "edit"     : s     -> IDEEdit  $ unwords s
+  "abstract" : a : _ -> IDEAbstract $ identC a
+  "concrete" : a : _ -> IDEConcrete $ identC a
+  "lin"      : a : _ -> IDELin      $ identC a
+  "empty"    : _     -> IDEInit
+  "quit"     : _     -> IDEQuit
+  _                  -> IDEVoid $ unwords ws