From 958e81126d9bee7d190e738102836918f37b756b Mon Sep 17 00:00:00 2001
From: aarne <aarne@chalmers.se>
Date: Wed, 21 Sep 2011 08:12:14 +0000
Subject: commands ss to show source, and sd to show the dependencies of a
 constant

---
 src/compiler/GF/Grammar/Analyse.hs | 41 ++++++++++++++++++++++++++++++++++++--
 1 file changed, 39 insertions(+), 2 deletions(-)

(limited to 'src/compiler/GF/Grammar')

diff --git a/src/compiler/GF/Grammar/Analyse.hs b/src/compiler/GF/Grammar/Analyse.hs
index ad538de87..9946c7812 100644
--- a/src/compiler/GF/Grammar/Analyse.hs
+++ b/src/compiler/GF/Grammar/Analyse.hs
@@ -1,16 +1,20 @@
 module GF.Grammar.Analyse (
-        stripSourceGrammar
+        stripSourceGrammar,
+        constantDepsTerm
         ) where
 
 import GF.Grammar.Grammar
 import GF.Infra.Ident
 import GF.Infra.Option ---
 import GF.Infra.Modules
+import GF.Grammar.Macros
+import GF.Grammar.Lookup
 
 import GF.Data.Operations
 
 import qualified Data.Map as Map
-
+import Data.List (nub)
+import Debug.Trace
 
 stripSourceGrammar :: SourceGrammar -> SourceGrammar
 stripSourceGrammar sgr = mGrammar [(i, m{jments = Map.map stripInfo (jments m)}) | (i,m) <- modules sgr]
@@ -27,3 +31,36 @@ stripInfo i = case i of
   CncFun mict mte mtf -> CncFun mict Nothing Nothing
   AnyInd b f -> i
 
+constantsInTerm :: Term -> [Term]
+constantsInTerm = nub . consts where
+  consts t = case t of
+    Q _  -> [t]
+    QC _ -> [t]
+    _ -> collectOp consts t
+
+constantDeps :: SourceGrammar -> QIdent -> Err [Term]
+constantDeps sgr f = do
+  ts <- deps f
+  let cs = [i | t <- ts, i <- getId t]
+  ds <- mapM deps cs
+  return $ nub $ concat $ ts:ds
+ where
+  deps c = case lookupOverload sgr c of
+    Ok tts -> 
+      return $ concat [constantsInTerm ty ++ constantsInTerm tr | (_,(ty,tr)) <- tts]
+    _ -> 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) ---
+  _ -> Bad ("expected qualified constant, not " ++ show t)
+
-- 
cgit v1.2.3