Merge branch 'master' of https://github.com/GrammaticalFramework/gf-core

src/compiler/GF/Compile/GrammarToCanonical.hs

@@ -1,6 +1,9 @@
 -- | Translate grammars to Canonical form
 -- (a common intermediate representation to simplify export to other formats)
-module GF.Compile.GrammarToCanonical(grammar2canonical,abstract2canonical,concretes2canonical) where
+module GF.Compile.GrammarToCanonical(
+       grammar2canonical,abstract2canonical,concretes2canonical,
+       projection,selection
+       ) where
 import Data.List(nub,partition)
 import qualified Data.Map as M
 import qualified Data.Set as S
@@ -238,6 +241,7 @@ concatValue v1 v2 =
     (_,LiteralValue (StrConstant "")) -> v1
     _ -> ConcatValue v1 v2
 
+-- | Smart constructor for projections
 projection r l = maybe (Projection r l) id (proj r l)
 
 proj r l =
@@ -247,20 +251,31 @@ proj r l =
                           _ -> Nothing
     _ -> Nothing
 
+-- | Smart constructor for selections
 selection t v =
+  -- Note: impossible cases can become possible after grammar transformation
   case t of
     TableValue tt r ->
         case nub [rv|TableRow _ rv<-keep] of
           [rv] -> rv
           _ -> Selection (TableValue tt r') v
       where
+        -- Don't introduce wildcard patterns, true to the canonical format,
+        -- annotate (or eliminate) rhs in impossible rows
+        r' = map trunc r
+        trunc r@(TableRow p e) = if mightMatchRow v r
+                                 then r
+                                 else TableRow p (impossible e)
+        {-
+        -- Creates smaller tables, but introduces wildcard patterns
         r' = if null discard
              then r
              else keep++[TableRow WildPattern impossible]
+        -}
         (keep,discard) = partition (mightMatchRow v) r
     _ -> Selection t v
 
-impossible = ErrorValue "impossible"
+impossible = CommentedValue "impossible"
 
 mightMatchRow v (TableRow p _) =
   case p of

src/compiler/GF/Grammar/Canonical.hs

@@ -217,6 +217,7 @@ instance Pretty LinValue where
   pp lv = case lv of
             ConcatValue v1 v2 -> sep [v1 <+> "++",pp v2]
             ErrorValue s -> "Predef.error"<+>doubleQuotes s
+            ParamConstant pv -> pp pv
             Projection lv l -> ppA lv<>"."<>l
             Selection tv pv -> ppA tv<>"!"<>ppA pv
             VariantValue vs -> "variants"<+>block vs
@@ -260,6 +261,7 @@ instance Pretty LinPattern where
 instance PPA LinPattern where
   ppA p =
     case p of
+      ParamPattern pv -> ppA pv
       RecordPattern r -> block r
       TuplePattern ps -> "<"<>punctuate "," ps<>">"
       WildPattern     -> pp "_"                

src/runtime/haskell/PGF/VisualizeTree.hs

@@ -564,7 +564,7 @@ dep2latex d =
    Picture defaultUnit (width,height) (
      [Put (wpos rwld i,0) (Text w) | (i,w) <- zip [0..] (map fst (tokens d))]   -- words
   ++ [Put (wpos rwld i,15) (TinyText w) | (i,(w,_)) <- zip [0..] (map snd (tokens d))]   -- pos tags 15u above bottom
-  ++ [Put (wpos rwld i,-15) (TinyText w) | (i,(_,w)) <- zip [0..] (map snd (tokens d))]   -- features 15u below bottom
+---  ++ [Put (wpos rwld i,-15) (TinyText w) | (i,(_,w)) <- zip [0..] (map snd (tokens d))]   -- features 15u below bottom -> DON'T SHOW
   ++ concat [putArc rwld (aheight x y) x y label | ((x,y),label) <- deps d]    -- arcs and labels
   ++ [Put (wpos rwld (root d) + 15,height) (ArrowDown (height-arcbase))]
   ++ [Put (wpos rwld (root d) + 20,height - 10) (TinyText "ROOT")]
@@ -595,7 +595,7 @@ conll2dep' ls = Dep {
   , root = head $ [read x-1 | x:_:_:_:_:_:"0":_ <- ls] ++ [1]
   }
  where
-   wld i = maximum (0:[charWidth * fromIntegral (length w) | w <- let (tok,(pos,feat)) = toks !! i in [tok,pos,feat]])
+   wld i = maximum (0:[charWidth * fromIntegral (length w) | w <- let (tok,(pos,feat)) = toks !! i in [tok,pos {-,feat-}]]) --- feat not shown
    toks = [(w,(c,m)) | _:w:_:c:_:m:_ <- ls]
    dps = [((read y-1, read x-1),lab) | x:_:_:_:_:_:y:lab:_ <- ls, y /="0"]
    --maxdist = maximum [abs (x-y) | ((x,y),_) <- dps]