GF.Grammar.Canonical: some Functor/Foldable/Traversable instances

src/compiler/GF/Compile/ConcreteToHaskell.hs

@@ -194,8 +194,8 @@ concrete2haskell opts
             else LambdaCase (map ppCase cs)
           where
             (ds,ts') = dedup ts
-            (ps,ts) = unzip [(p,t)|TableRowValue p t<-cs]
+            (ps,ts) = unzip [(p,t)|TableRow p t<-cs]
-        ppCase (TableRowValue p t) = (ppP p,ppTv (patVars p++vs) t)
+        ppCase (TableRow p t) = (ppP p,ppTv (patVars p++vs) t)
 {-
         ppPredef n =
           case predef n of
@@ -309,8 +309,8 @@ instance Records LinValue where
       Selection v1 v2 -> records (v1,v2)
       _ -> S.empty
 
-instance Records TableRowValue where
+instance Records rhs => Records (TableRow rhs) where
-  records (TableRowValue _ v) = records v
+  records (TableRow _ v) = records v
 
 
 -- | Record subtyping is converted into explicit coercions in Haskell
@@ -318,7 +318,7 @@ coerce env ty t =
   case (ty,t) of 
     (_,VariantValue ts) -> VariantValue (map (coerce env ty) ts)
     (TableType ti tv,TableValue _ cs) ->
-      TableValue ti [TableRowValue p (coerce env tv t)|TableRowValue p t<-cs]
+      TableValue ti [TableRow p (coerce env tv t)|TableRow p t<-cs]
     (RecordType rt,RecordValue r) ->
       RecordValue [RecordRow l (coerce env ft f) |
                      RecordRow l f<-r,ft<-[ft|RecordRow l' ft<-rt,l'==l]]

src/compiler/GF/Compile/GrammarToCanonical.hs

@@ -151,7 +151,7 @@ convert' gr vs = ppT
       case t of
 --      Abs b x t -> ...
 --      V ty ts -> VTableValue (convType ty) (map ppT ts)
-        V ty ts -> TableValue (convType ty) [TableRowValue (ppP p) (ppT t)|(p,t)<-zip ps ts]
+        V ty ts -> TableValue (convType ty) [TableRow (ppP p) (ppT t)|(p,t)<-zip ps ts]
           where
             Ok pts = allParamValues gr ty
             Ok ps = mapM term2patt pts
@@ -174,7 +174,7 @@ convert' gr vs = ppT
         Alts t' vs -> alts vs (ppT t')
         _ -> error $ "convert' "++show t
 
-    ppCase (p,t) = TableRowValue (ppP p) (ppTv (patVars p++vs) t)
+    ppCase (p,t) = TableRow (ppP p) (ppTv (patVars p++vs) t)
 
     ppPredef n =
       case predef n of
@@ -249,19 +249,19 @@ proj r l =
 selection t v =
   case t of
     TableValue tt r ->
-        case nub [rv|TableRowValue _ rv<-keep] of
+        case nub [rv|TableRow _ rv<-keep] of
           [rv] -> rv
           _ -> Selection (TableValue tt r') v
       where
         r' = if null discard
              then r
-             else keep++[TableRowValue WildPattern impossible]
+             else keep++[TableRow WildPattern impossible]
         (keep,discard) = partition (mightMatchRow v) r
     _ -> Selection t v
 
 impossible = ErrorValue "impossible"
 
-mightMatchRow v (TableRowValue p _) =
+mightMatchRow v (TableRow p _) =
   case p of
     WildPattern -> True
     _ -> mightMatch v p

src/compiler/GF/Grammar/Canonical.hs

@@ -7,6 +7,7 @@
 -- by partial evaluation. This is intended as a common intermediate
 -- representation to simplify export to other formats.
 
+{-# LANGUAGE DeriveTraversable #-}
 module GF.Grammar.Canonical where
 import Prelude hiding ((<>))
 import GF.Text.Pretty
@@ -87,13 +88,17 @@ type ParamValue = Param LinValue
 type ParamPattern = Param LinPattern
 type ParamValueDef = Param ParamId
 
-data Param arg = Param ParamId [arg] deriving (Eq,Ord,Show)
+data Param arg = Param ParamId [arg]
+                 deriving (Eq,Ord,Show,Functor,Foldable,Traversable)
 
 type RecordRowType  = RecordRow LinType
 type RecordRowValue = RecordRow LinValue
+type TableRowValue  = TableRow LinValue
 
-data RecordRow rhs  = RecordRow LabelId rhs  deriving (Eq,Ord,Show)
+data RecordRow rhs = RecordRow LabelId    rhs
-data TableRowValue  = TableRowValue LinPattern LinValue  deriving (Eq,Ord,Show)
+                     deriving (Eq,Ord,Show,Functor,Foldable,Traversable)
+data TableRow  rhs = TableRow  LinPattern rhs
+                     deriving (Eq,Ord,Show,Functor,Foldable,Traversable)
 
 -- *** Identifiers in Concrete Syntax
 
@@ -265,8 +270,8 @@ instance RhsSeparator LinPattern where rhsSep _ = pp "="
 instance RhsSeparator rhs => Pretty (RecordRow rhs) where
   pp (RecordRow l v) = hang (l<+>rhsSep v) 2 v
 
-instance Pretty TableRowValue where
+instance Pretty rhs => Pretty (TableRow rhs) where
-  pp (TableRowValue l v) = hang (l<+>"=>") 2 v
+  pp (TableRow l v) = hang (l<+>"=>") 2 v
 
 --------------------------------------------------------------------------------
 instance Pretty ModId where pp (ModId s) = pp s

src/compiler/GF/Grammar/CanonicalJSON.hs

@@ -210,10 +210,10 @@ instance JSON a => JSON (RecordRow a) where
     where fromRow (lbl, jsvalue) = do value <- readJSON jsvalue
                                       return (RecordRow (LabelId lbl) value)
 
-instance JSON TableRowValue where
+instance JSON rhs => JSON (TableRow rhs) where
-  showJSON (TableRowValue l v) = makeObj [(".pattern", showJSON l), (".value", showJSON v)]
+  showJSON (TableRow l v) = makeObj [(".pattern", showJSON l), (".value", showJSON v)]
 
-  readJSON o = TableRowValue <$> o!".pattern" <*> o!".value"
+  readJSON o = TableRow <$> o!".pattern" <*> o!".value"
 
 
 -- *** Identifiers in Concrete Syntax