parsing overloaded constructors as result

3 files changed, 84 insertions, 1 deletions

diff --git a/src/GF/Shell.hs b/src/GF/Shell.hs
index dd8267a91..139a2ab07 100644
--- a/src/GF/Shell.hs
+++ b/src/GF/Shell.hs
@@ -30,6 +30,7 @@ import GF.Grammar.Values
 import GF.UseGrammar.GetTree
 import GF.UseGrammar.Generate (generateAll) ---- should be in API
 import GF.UseGrammar.Treebank
+import GF.UseGrammar.MakeOverload (getOverloadResults)
 
 import GF.Shell.ShellCommands
 
@@ -242,6 +243,9 @@ execC co@(comm, opts0) sa@(sh@(st,(h,_,_,_)),a) = checkOptions st co >> case com
 
   CParse 
 ----    | oElem showMulti opts -> do
+    | oElem (iOpt "overload") opts -> do
+       p <- parse $ prCommandArg a
+       changeArg (opTTs2CommandArg getOverloadResults) p
     | oElem byLines opts -> do
         let ss = (if oElem showAll opts then id else filter (not . null)) $ 
                      lines $ prCommandArg a
@@ -576,3 +580,9 @@ opTT2CommandArg :: (Tree -> Err [Tree]) -> CommandArg -> CommandArg
 opTT2CommandArg f (ATrms ts) = err AError (ATrms . concat) $ mapM f ts
 opTT2CommandArg _ (AError s) = AError ("expected term, but got error:" ++++ s)
 opTT2CommandArg _ a = AError ("expected term, but got:" ++++ prCommandArg a)
+
+opTTs2CommandArg :: ([Tree] -> [Tree]) -> CommandArg -> CommandArg
+opTTs2CommandArg f (ATrms ts) = ATrms $ f ts
+opTTs2CommandArg _ (AError s) = AError ("expected terms, but got error:" ++++ s)
+opTTs2CommandArg _ a = AError ("expected terms, but got:" ++++ prCommandArg a)
+
diff --git a/src/GF/Shell/ShellCommands.hs b/src/GF/Shell/ShellCommands.hs
index fba8a80a7..70238817b 100644
--- a/src/GF/Shell/ShellCommands.hs
+++ b/src/GF/Shell/ShellCommands.hs
@@ -185,7 +185,7 @@ optionsOfCommand co = case co of
   CConvertLatex _ -> none
   CLinearize _ -> both "utf8 table struct record all multi" "lang number unlexer mark"
   CParse -> 
-    both "ambiguous fail cut new newer old cfg mcfg fcfg n ign raw v lines all prob" 
+    both "ambiguous fail cut new newer old overload cfg mcfg fcfg n ign raw v lines all prob" 
          "cat lang lexer parser number rawtrees"
   CTranslate _ _ -> opts "cat lexer parser"
   CGenerateRandom -> both "cf prob" "cat lang number depth atoms noexpand doexpand"
diff --git a/src/GF/UseGrammar/MakeOverload.hs b/src/GF/UseGrammar/MakeOverload.hs
new file mode 100644
index 000000000..1d574d001
--- /dev/null
+++ b/src/GF/UseGrammar/MakeOverload.hs
@@ -0,0 +1,73 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : MakeOverload
+-- Maintainer  : AR
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- choose shallowest trees, and remove an overload resolution prefix
+-----------------------------------------------------------------------------
+
+module GF.UseGrammar.MakeOverload where
+
+import GF.Grammar.Abstract
+import GF.Grammar.Macros
+
+import GF.Data.Operations
+import GF.Data.Zipper
+import Data.List
+
+-- AR 2/7/2007
+-- The top-level function takes a set of trees (typically parses)
+-- and returns the list of those trees that have the minimum size.
+-- In addition, the overload prefix "ovrld123_", is removed
+-- from each constructor in which it appears. This is used for 
+-- showing the library API constructors in a parsable grammar.
+
+getOverloadResults :: [Tree] -> [Tree]
+getOverloadResults = smallestTrs . map mkOverload 
+
+-- NB: this does not always give the desired result, since
+-- some genuine alternatives may be deeper: now we will exclude the 
+-- latter of
+--
+--   mkCl this_NP love_V2 (mkNP that_NP here_Adv)
+--   mkCl this_NP (mkVP (mkVP love_V2 that_NP) here_Adv)
+--
+-- A perfect method would know the definitional equivalences of constructors.
+--
+-- Notice also that size is a better measure than depth, because:
+-- 1. Global depth does not exclude the latter of
+--
+--   mkCl (mkNP he_Pron) love_V2 that_NP
+--   mkCl (mkNP he_Pron) (mkVP love_V2 that_NP)
+--
+-- 2. Length is needed to exclude the latter of
+--
+--   mkS (mkCl (mkNP he_Pron) love_V2 that_NP)
+--   mkS presentTense (mkCl (mkNP he_Pron) love_V2 that_NP)
+--
+
+
+smallestTrs :: [Tr a] -> [Tr a]
+smallestTrs ts = map fst $ filter ((==mx) . snd) tds where
+  tds = [(t, size t) | t <- ts]
+  mx = minimum $ map snd tds
+  size = sizeTr -- depthTr
+
+depthTr :: Tr a -> Int
+depthTr (Tr (_, ts)) = case ts of
+  [] -> 1
+  _ -> 1 + (maximum $ map depthTr ts)
+
+sizeTr :: Tr a -> Int
+sizeTr (Tr (_, ts)) = 1 + sum (map sizeTr ts)
+
+-- format: ovrld123_mkNP
+
+mkOverload :: Tree -> Tree
+mkOverload = mapTr (changeAtom overAtom) where
+  overAtom a = case a of
+    AtC (m, IC f) | take 5 f == "ovrld" -> 
+      AtC (m, IC (tail (dropWhile (/='_') f)))
+    _ -> a