From 6db0c74c2f120c829e666879b39f57afe1ed3318 Mon Sep 17 00:00:00 2001
From: aarne <aarne@chalmers.se>
Date: Thu, 22 Sep 2011 12:11:03 +0000
Subject: [PATCH] the sd -size command now shows the size of all code needed
 for defining an oper

---
 src/compiler/GF/Command/Commands.hs |  4 +++-
 src/compiler/GF/Grammar/Analyse.hs  | 28 ++++++++++++++++++----------
 src/compiler/GFI.hs                 | 11 +++++++++--
 3 files changed, 30 insertions(+), 13 deletions(-)

diff --git a/src/compiler/GF/Command/Commands.hs b/src/compiler/GF/Command/Commands.hs
index f3c2790fd..601edca6a 100644
--- a/src/compiler/GF/Command/Commands.hs
+++ b/src/compiler/GF/Command/Commands.hs
@@ -791,9 +791,11 @@ allCommands env@(pgf, mos) = Map.fromList [
        "This command must be a line of its own, and thus cannot be a part of a pipe."
        ],
      options = [
+       ("size","show the size of the source code for each constants (number of constructors)")
        ],
      examples = [
-       "sd ParadigmsEng.mkV    -- show all constants on which this one depends"
+       "sd ParadigmsEng.mkV          -- show all constants on which this one depends",
+       "sd -size ParadigmsEng.mkV    -- show all constants on which this one depends, together with size"
        ],
      needsTypeCheck = False
      }),
diff --git a/src/compiler/GF/Grammar/Analyse.hs b/src/compiler/GF/Grammar/Analyse.hs
index 8d41d1713..c26e68b98 100644
--- a/src/compiler/GF/Grammar/Analyse.hs
+++ b/src/compiler/GF/Grammar/Analyse.hs
@@ -2,6 +2,7 @@ module GF.Grammar.Analyse (
         stripSourceGrammar,
         constantDepsTerm,
         sizeTerm,
+        sizeConstant,
         sizesModule,
         sizesGrammar,
         printSizesGrammar
@@ -45,7 +46,7 @@ constantsInTerm = nub . consts where
 constantDeps :: SourceGrammar -> QIdent -> Err [Term]
 constantDeps sgr f = do
   ts <- deps f
-  let cs = [i | t <- ts, i <- getId t]
+  let cs = [i | t <- ts, Ok i <- [getIdTerm t]]
   ds <- mapM deps cs
   return $ nub $ concat $ ts:ds
  where
@@ -56,18 +57,25 @@ constantDeps sgr f = do
       ty <- lookupResType sgr c
       tr <- lookupResDef sgr c
       return $ constantsInTerm ty ++ constantsInTerm tr
-  getId t = case t of
-    Q i -> [i] 
-    QC i -> [i] 
-    _ -> [] 
 
-constantDepsTerm :: SourceGrammar -> Term -> Err [Term]
-constantDepsTerm sgr t = case t of
-  Q  i -> constantDeps sgr i
-  QC i -> constantDeps sgr i
-  P (Vr r) l -> constantDeps sgr $ (r,label2ident l) ---
+getIdTerm :: Term -> Err QIdent
+getIdTerm t = case t of
+  Q i  -> return i
+  QC i -> return i
+  P (Vr r) l -> return (r,label2ident l) --- needed if term is received from parser
   _ -> Bad ("expected qualified constant, not " ++ show t)
 
+constantDepsTerm :: SourceGrammar -> Term -> Err [Term]
+constantDepsTerm sgr t = do
+  i <- getIdTerm t
+  constantDeps sgr i
+
+sizeConstant :: SourceGrammar -> Term -> Int
+sizeConstant sgr t = err (const 0) id $ do
+  c  <- getIdTerm t
+  ty <- return $ err (const 0) sizeTerm $ lookupResType sgr c  -- if no type sig, return 0
+  tr <- return $ err (const 0) sizeTerm $ lookupResDef sgr c
+  return $ ty + tr
 
 -- the number of constructors in a term, ignoring position information and unnecessary types
 -- ground terms count as 1, i.e. as "one work" each
diff --git a/src/compiler/GFI.hs b/src/compiler/GFI.hs
index 28f7b1dc2..7bb4df878 100644
--- a/src/compiler/GFI.hs
+++ b/src/compiler/GFI.hs
@@ -193,8 +193,15 @@ execute1 opts gfenv0 s0 =
                let Right t = runP pExp (encodeUnicode utf8 (unwords ts))
                err error return $ constantDepsTerm sgr t
              _   -> error "give a term as argument"
-          let printer = showTerm sgr TermPrintDefault Qualified
-          putStrLn $ unwords $ map printer ops
+          let prTerm = showTerm sgr TermPrintDefault Qualified
+          let size = sizeConstant sgr
+          let printed 
+                | elem "-size" os =
+                    let sz = map size ops in 
+                    unlines $ ("total: " ++ show (sum sz)) : 
+                              [prTerm f ++ "\t" ++ show s | (f,s) <- zip ops sz]
+                | otherwise = unwords $ map prTerm ops
+          putStrLn $ printed
           continue gfenv
 
     show_operations ws =