From bd22b935de38f7a25169905a787e36b6dbe37792 Mon Sep 17 00:00:00 2001
From: aarne <aarne@chalmers.se>
Date: Wed, 21 Sep 2011 13:24:59 +0000
Subject: [PATCH] statistics on grammar size in terms of constructors

---
 src/compiler/GF/Grammar/Analyse.hs | 84 +++++++++++++++++++++++++++++-
 src/compiler/GFI.hs                | 19 ++++---
 2 files changed, 96 insertions(+), 7 deletions(-)

diff --git a/src/compiler/GF/Grammar/Analyse.hs b/src/compiler/GF/Grammar/Analyse.hs
index 9946c7812..b8c9f5042 100644
--- a/src/compiler/GF/Grammar/Analyse.hs
+++ b/src/compiler/GF/Grammar/Analyse.hs
@@ -1,6 +1,10 @@
 module GF.Grammar.Analyse (
         stripSourceGrammar,
-        constantDepsTerm
+        constantDepsTerm,
+        sizeTerm,
+        sizesModule,
+        sizesGrammar,
+        printSizesGrammar
         ) where
 
 import GF.Grammar.Grammar
@@ -64,3 +68,81 @@ constantDepsTerm sgr t = case t of
   P (Vr r) l -> constantDeps sgr $ (r,label2ident l) ---
   _ -> Bad ("expected qualified constant, not " ++ show t)
 
+
+-- the number of constructors in a term, ignoring position information and unnecessary types
+-- ground terms count as 1, i.e. as "one work" each
+sizeTerm :: Term -> Int
+sizeTerm t = case t of
+  App c a      -> 1 + sizeTerm c + sizeTerm a 
+  Abs _ _ b    -> 2 + sizeTerm b
+  Prod _ _ a b -> 2 + sizeTerm a + sizeTerm b 
+  S c a        -> 1 + sizeTerm c + sizeTerm a
+  Table a c    -> 1 + sizeTerm a + sizeTerm c
+  ExtR a c     -> 1 + sizeTerm a + sizeTerm c
+  R r          -> 1 + sum [1 + sizeTerm a | (_,(_,a)) <- r]  -- label counts as 1, type ignored
+  RecType r    -> 1 + sum [1 + sizeTerm a | (_,a)     <- r]  -- label counts as 1
+  P t i        -> 2 + sizeTerm t
+  T _ cc       -> 1 + sum [1 + sizeTerm (patt2term p) + sizeTerm v | (p,v) <- cc]
+  V ty cc      -> 1 + sizeTerm ty + sum [1 + sizeTerm v | v <- cc]
+  Let (x,(mt,a)) b -> 2 + maybe 0 sizeTerm mt + sizeTerm a + sizeTerm b
+  C s1 s2      -> 1 + sizeTerm s1 + sizeTerm s2 
+  Glue s1 s2   -> 1 + sizeTerm s1 + sizeTerm s2 
+  Alts t aa    -> 1 + sizeTerm t + sum [sizeTerm p + sizeTerm v | (p,v) <- aa]
+  FV ts        -> 1 + sum (map sizeTerm ts)
+  Strs tt      -> 1 + sum (map sizeTerm tt)
+  _            -> 1
+
+
+-- the size of a judgement
+sizeInfo :: Info -> Int
+sizeInfo i = case i of
+  AbsCat (Just (L _ co)) -> 1 + sum [1 + sizeTerm ty | (_,_,ty) <- co]
+  AbsFun mt mi me mb -> 1 + msize mt + 
+    sum [sum (map (sizeTerm . patt2term) ps) + sizeTerm t | Just es <- [me], L _ (ps,t) <- es]
+  ResParam mp mt -> 
+    1 + sum [1 + sum [1 + sizeTerm ty | (_,_,ty) <- co] | Just ps <- [mp], L _ (_,co) <- ps]
+  ResValue lt -> 0
+  ResOper mt md -> 1 + msize mt + msize md
+  ResOverload is fs -> 1 + sum [sizeTerm ty + sizeTerm tr | (L _ ty, L _ tr) <- fs]
+  CncCat mty mte mtf -> 1 + msize mty   -- ignoring lindef and printname
+  CncFun mict mte mtf -> 1 + msize mte  -- ignoring type and printname
+  AnyInd b f -> 0
+  _ -> 0
+ where 
+  msize mt = case mt of
+    Just (L _ t) -> sizeTerm t
+    _ -> 0
+
+-- the size of a module
+sizeModule :: SourceModule -> Int
+sizeModule = fst . sizesModule
+
+sizesModule :: SourceModule -> (Int, [(Ident,Int)])
+sizesModule (_,m) = 
+  let 
+    js = Map.toList (jments m) 
+    tb = [(i,sizeInfo j) | (i,j) <- js]
+  in (length tb + sum (map snd tb),tb)
+
+-- the size of a grammar
+sizeGrammar :: SourceGrammar -> Int
+sizeGrammar = fst . sizesGrammar
+
+sizesGrammar :: SourceGrammar -> (Int,[(Ident,(Int,[(Ident,Int)]))])
+sizesGrammar g = 
+  let 
+    ms = modules g 
+    mz = [(i,sizesModule m) | m@(i,j) <- ms]
+  in (length mz + sum (map (fst . snd) mz), mz)
+
+printSizesGrammar :: SourceGrammar -> String
+printSizesGrammar g = unlines $ 
+  ("total" +++ show s):
+  [showIdent m +++ "total" +++ show i ++++ 
+   unlines [indent 2 (showIdent j +++ show k) | (j,k) <- js]
+     | (m,(i,js)) <- sg
+  ]
+ where
+   (s,sg) = sizesGrammar g
+
+
diff --git a/src/compiler/GFI.hs b/src/compiler/GFI.hs
index b0e36462e..28f7b1dc2 100644
--- a/src/compiler/GFI.hs
+++ b/src/compiler/GFI.hs
@@ -224,13 +224,20 @@ execute1 opts gfenv0 s0 =
       let mygr = strip $ case ts of
             _:_ -> mGrammar [(i,m) | (i,m) <- modules sgr, elem (showIdent i) ts] 
             [] -> sgr
-      if elem "-save" os
-        then mapM_ 
-               (\ m@(i,_) -> let file = (showIdent i ++ ".gfh") in 
-                  writeFile file (render (ppModule Qualified m)) >> putStrLn ("wrote " ++ file))
-               (modules mygr)  
-        else putStrLn $ render $ ppGrammar mygr
+      case 0 of
+        _ | elem "-detailedsize" os -> putStrLn (printSizesGrammar mygr)
+        _ | elem "-size" os -> do
+               let sz = sizesGrammar mygr
+               putStrLn $ unlines $
+                 ("total\t" ++ show (fst sz)): 
+                 [showIdent j ++ "\t" ++ show (fst k) | (j,k) <- snd sz]
+        _ | elem "-save" os -> mapM_ 
+                 (\ m@(i,_) -> let file = (showIdent i ++ ".gfh") in 
+                    writeFile file (render (ppModule Qualified m)) >> putStrLn ("wrote " ++ file))
+                 (modules mygr)  
+        _ -> putStrLn $ render $ ppGrammar mygr
       continue gfenv
+
     dependency_graph ws =
       do let stop = case ws of
                ('-':'o':'n':'l':'y':'=':fs):_ -> Just $ chunks ',' fs