experiment with gfc input

src/GF/Canon/AbsGFC.hs

@@ -1,4 +1,3 @@
-
 module GF.Canon.AbsGFC where
 
 import GF.Infra.Ident --H
@@ -6,12 +5,19 @@ import GF.Infra.Ident --H
 -- Haskell module generated by the BNF converter, except --H
 
 -- newtype Ident = Ident String deriving (Eq,Ord,Show) --H
-
 data Canon =
    MGr [Ident] Ident [Module]
  | Gr [Module]
   deriving (Eq,Ord,Show)
 
+data Line =
+   LMulti [Ident] Ident
+ | LHeader ModType Extend Open
+ | LFlag Flag
+ | LDef Def
+ | LEnd
+  deriving (Eq,Ord,Show)
+
 data Module =
    Mod ModType Extend Open [Flag] [Def]
   deriving (Eq,Ord,Show)
@@ -131,8 +137,8 @@ data Term =
 
 data Tokn =
    KS String
- | KM String
  | KP [String] [Variant]
+ | KM String
   deriving (Eq,Ord,Show)
 
 data Assign =

src/GF/Canon/GFC.cf

@@ -2,11 +2,21 @@
 
 -- Canonical GF. AR 27/4/2003
 
-entrypoints Canon ;
+entrypoints Canon, Line ;
+
+-- old approach: read in a whole grammar
 
 MGr. Canon ::= "grammar" [Ident] "of" Ident ";" [Module] ;
 Gr.  Canon ::= [Module] ;
 
+-- new approach: read line by line
+
+LMulti.  Line ::= "grammar" [Ident] "of" Ident ";" ;
+LHeader. Line ::= ModType "=" Extend Open "{" ;
+LFlag.   Line ::= Flag ";" ;
+LDef.    Line ::= Def ";" ;
+LEnd.    Line ::= "}" ;    
+
 Mod. Module ::= ModType "=" Extend Open "{" [Flag] [Def] "}" ;
 
 MTAbs.   ModType ::= "abstract" Ident ; 

src/GF/Canon/GetGFC.hs

@@ -5,9 +5,9 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/04/21 16:21:23 $ 
--- > CVS $Author: bringert $
--- > CVS $Revision: 1.7 $
+-- > CVS $Date: 2005/05/27 21:05:17 $ 
+-- > CVS $Author: aarne $
+-- > CVS $Revision: 1.8 $
 --
 -- (Description of the module)
 -----------------------------------------------------------------------------
@@ -22,6 +22,10 @@ import GF.Infra.Modules
 import GF.Compile.GetGrammar (err2err) ---
 import GF.Infra.UseIO
 
+import System.IO
+import System.Directory
+import Control.Monad
+
 getCanonModule :: FilePath -> IOE CanonModule
 getCanonModule file = do
   gr <- getCanonGrammar file
@@ -32,6 +36,41 @@ getCanonModule file = do
 getCanonGrammar :: FilePath -> IOE CanonGrammar
 getCanonGrammar file = do
   s <- ioeIO $ readFileIf file
-  -- c <- ioeErr $ err2err $ pCanon $ myLexer s
   c <- ioeErr $ pCanon $ myLexer s
   return $ canon2grammar c
+
+-- the following surprisingly does not save memory so it is
+-- not in use
+
+getCanonGrammarByLine :: FilePath -> IOE CanonGrammar
+getCanonGrammarByLine file = do
+  b <- ioeIO $ doesFileExist file
+  if not b 
+    then ioeErr $ Bad $ "file" +++ file +++ "does not exist"
+    else do
+   ioeIO $ putStrLn ""
+   hand <- ioeIO $ openFile file ReadMode ---- err
+   size <- ioeIO $ hFileSize hand
+   gr <- addNextLine (size,0) 1 hand emptyMGrammar
+   ioeIO $ hClose hand
+   return $ MGrammar $ reverse $ modules gr
+
+ where
+   addNextLine (size,act) d hand gr = do
+     eof <- ioeIO $ hIsEOF hand 
+     if eof 
+       then return gr 
+       else do
+         s <- ioeIO  $ hGetLine hand
+         let act' = act + toInteger (length s)
+--         if isHash act act' then (ioeIO $ putChar '#') else return () 
+         updGrammar act' d gr $ pLine $ myLexer s
+    where     
+      updGrammar a d gr (Ok t) = case buildCanonGrammar d gr t of 
+        (gr',d') -> addNextLine (size,a) d' hand gr'
+      updGrammar _ _ gr (Bad s) = do
+        ioeIO $ putStrLn s
+        return emptyMGrammar
+
+      isHash a b = a `div` step < b `div` step
+      step = size `div` 50

src/GF/Canon/MkGFC.hs

@@ -5,15 +5,15 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/04/21 16:21:26 $ 
--- > CVS $Author: bringert $
--- > CVS $Revision: 1.12 $
+-- > CVS $Date: 2005/05/27 21:05:17 $ 
+-- > CVS $Author: aarne $
+-- > CVS $Revision: 1.13 $
 --
 -- (Description of the module)
 -----------------------------------------------------------------------------
 
 module GF.Canon.MkGFC (prCanonModInfo, prCanon, prCanonMGr,
-	      canon2grammar, grammar2canon, 
+	      canon2grammar, grammar2canon, buildCanonGrammar,
 	      info2mod,
 	      trExp, rtExp, rtQIdent) where
 
@@ -40,8 +40,9 @@ prCanonMGr g = header ++++ prCanon g where
 
 canon2grammar :: Canon -> CanonGrammar
 canon2grammar (MGr _ _ modules) = canon2grammar (Gr modules) ---- ignoring the header
-canon2grammar (Gr modules) = M.MGrammar $ map mod2info modules where
-  mod2info m = case m of
+canon2grammar (Gr modules) = M.MGrammar $ map mod2info modules
+
+mod2info m = case m of
     Mod mt e os flags defs -> 
       let defs' = buildTree $ map def2info defs
           (a,mt') = case mt of
@@ -50,6 +51,7 @@ canon2grammar (Gr modules) = M.MGrammar $ map mod2info modules where
             MTCnc a x -> (a,M.MTConcrete x)
             MTTrans a x y -> (a,M.MTTransfer (M.oSimple x) (M.oSimple y))
       in (a,M.ModMod (M.Module mt' M.MSComplete flags (ee e) (oo os) defs'))
+ where
   ee (Ext m) = m
   ee _ = []
   oo (Opens ms) = map M.oSimple ms
@@ -170,3 +172,58 @@ rtQIdent (m,c) = CIQ (rtIdent m) (rtIdent c)
 rtIdent x 
   | isWildIdent x = identC "h_" --- needed in declarations
   | otherwise = identC $ prt x ---
+
+-- the following is called in GetGFC to read gfc files line
+-- by line. It does not save memory, though, and is therefore
+-- not used.
+
+buildCanonGrammar :: Int -> CanonGrammar -> Line -> (CanonGrammar,Int)
+buildCanonGrammar n gr0 line = mgr $ case line of
+-- LMulti ids id
+  LHeader mt ext op -> newModule mt ext op
+  LFlag f@(Flg (IC "modulesize") (IC n)) -> initModule f $ read $ tail n
+  LFlag flag        -> newFlag flag
+  LDef def          -> newDef $ def2info def
+  LEnd              -> cleanNames
+  _                 -> M.modules gr0
+ where
+   newModule mt ext op = mod2info (Mod mt ext op [] []) : mods
+   initModule f i = case actm of
+     (name, M.ModMod (M.Module mt com flags ee oo defs)) ->
+       (name, M.ModMod (M.Module mt com (f:flags) ee oo (newtree i))) : tmods
+   newFlag f = case actm of
+     (name, M.ModMod (M.Module mt com flags ee oo defs)) ->
+       (name, M.ModMod (M.Module mt com (f:flags) ee oo defs)) : tmods
+   newDef d = case actm of
+     (name, M.ModMod (M.Module mt com flags ee oo defs)) ->
+       (name, M.ModMod (M.Module mt com flags ee oo 
+          (upd (padd 8 n) d defs))) : tmods
+   cleanNames = case actm of
+     (name, M.ModMod (M.Module mt com flags ee oo defs)) ->
+       (name, M.ModMod (M.Module mt com (reverse flags) ee oo 
+          (mapTree (\ (IC f,t) -> (IC (drop 8 f),t)) defs))) : tmods
+
+   actm = head mods -- only used when a new mod has been created
+   mods = M.modules gr0
+   tmods = tail mods
+
+   mgr ms = (M.MGrammar ms, case line of
+     LDef _ -> n+1
+     LEnd   -> 1
+     _ -> n
+     )
+
+   -- create an initial tree with who-cares value
+   newtree (i :: Int) = sorted2tree [
+     (padd 8 k, ResPar []) | 
+     k <- [1..i]] --- padd (length (show i))
+
+   padd l k = let sk = show k in identC (replicate (l - length sk) '0' ++ sk)
+
+   upd n d@(f,t) defs = case defs of
+     NT -> BT (merg n f,t) NT NT --- should not happen
+     BT c@(a,_) left right 
+       | n < a  -> let left'  = upd n d left  in BT c left' right 
+       | n > a  -> let right' = upd n d right in BT c left right' 
+       | otherwise -> BT (merg n f,t) left right
+   merg (IC n) (IC f) = IC (n ++ f)

src/GF/Canon/PrintGFC.hs

@@ -19,7 +19,7 @@ doc = (:)
 render :: Doc -> String
 render d = rend 0 (map ($ "") $ d []) "" where
   rend i ss = case ss of
-    "NEW"    :ts -> realnew . rend i ts --H
+    "*NEW"   :ts -> realnew . rend i ts --H
     "<"      :ts -> showString "<" . rend i ts --H
     "$"      :ts -> showString "$" . rend i ts --H
     "?"      :ts -> showString "?" . rend i ts --H
@@ -99,10 +99,17 @@ instance Print Canon where
    MGr ids id modules -> prPrec i 0 (concatD [doc (showString "grammar") , prt 0 ids , doc (showString "of") , prt 0 id , doc (showString ";") , prt 0 modules])
    Gr modules -> prPrec i 0 (concatD [prt 0 modules])
 
+instance Print Line where
+  prt i e = case e of
+   LMulti ids id -> prPrec i 0 (concatD [doc (showString "grammar") , prt 0 ids , doc (showString "of") , prt 0 id , doc (showString ";") , doc (showString "*NEW")])
+   LHeader modtype extend open -> prPrec i 0 (concatD [prt 0 modtype , doc (showString "=") , prt 0 extend , prt 0 open , doc (showString "{"), doc (showString "*NEW")])
+   LFlag flag -> prPrec i 0 (concatD [prt 0 flag , doc (showString ";") , doc (showString "*NEW")])
+   LDef def -> prPrec i 0 (concatD [prt 0 def , doc (showString ";") , doc (showString "*NEW")])
+   LEnd  -> prPrec i 0 (concatD [doc (showString "}")])
 
 instance Print Module where
   prt i e = case e of
-   Mod modtype extend open flags defs -> prPrec i 0 (concatD [prt 0 modtype , doc (showString "=") , prt 0 extend , prt 0 open , doc (showString "{") , prt 0 flags , prt 0 defs , doc (showString "}")])
+   Mod modtype extend open flags defs -> prPrec i 0 (concatD [prt 0  modtype , doc (showString "=") , prt 0 extend , prt 0 open , doc (showString "{") , doc (showString "*NEW") , prt 0 flags , prt 0 defs , doc (showString "}")])
 
   prtList es = case es of
    [] -> (concatD [])
@@ -134,7 +141,7 @@ instance Print Flag where
 
   prtList es = case es of
    [] -> (concatD [])
-   x:xs -> (concatD [prt 0 x , doc (showString ";") , prt 0 xs])
+   x:xs -> (concatD [prt 0 x , doc (showString ";") , doc (showString "*NEW") , prt 0 xs])
 
 instance Print Def where
   prt i e = case e of
@@ -149,7 +156,7 @@ instance Print Def where
 
   prtList es = case es of
    [] -> (concatD [])
-   x:xs -> (concatD [prt 0 x , doc (showString ";"), doc (showString "NEW") , prt 0 xs]) -- H
+   x:xs -> (concatD [prt 0 x , doc (showString ";"), doc (showString "*NEW") , prt 0 xs]) -- H
 
 instance Print ParDef where
   prt i e = case e of

src/GF/Compile/GrammarToCanon.hs

@@ -5,9 +5,9 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/04/21 16:21:38 $ 
--- > CVS $Author: bringert $
--- > CVS $Revision: 1.17 $
+-- > CVS $Date: 2005/05/27 21:05:17 $ 
+-- > CVS $Author: aarne $
+-- > CVS $Revision: 1.18 $
 --
 -- Code generator from optimized GF source code to GFC.
 -----------------------------------------------------------------------------
@@ -69,8 +69,11 @@ redModInfo (c,info) = do
           mt = mt0 ---- if isIncompl then MTResource else mt0
 
       defss <- mapM (redInfo a) $ tree2list $ js
-      defs  <- return $ sorted2tree $ concat defss  -- sorted, but reduced
-      return $ ModMod $ Module mt MSComplete flags e os defs
+      let defs0 = concat defss
+      let lgh = length defs0
+      defs  <- return $ sorted2tree $ defs0  -- sorted, but reduced
+      let flags' = G.Flg (identC "modulesize") (identC ("n"++show lgh)) : flags
+      return $ ModMod $ Module mt MSComplete flags' e os defs
   return (c',info')
  where
    redExtOpen m = do