Translating linearization functions to Haskell: move a common record type to PGF.Haskell

Move the Haskell representation of the common linearization type {s:T} to the
shared module PGF.Haskell, so that the same overloaded projection function
proj_s can be used for all concrete syntaxes.

2 files changed, 27 insertions, 4 deletions

diff --git a/src/compiler/GF/Compile/ConcreteToHaskell.hs b/src/compiler/GF/Compile/ConcreteToHaskell.hs
index 93becd16e..daeb4dfb6 100644
--- a/src/compiler/GF/Compile/ConcreteToHaskell.hs
+++ b/src/compiler/GF/Compile/ConcreteToHaskell.hs
@@ -38,11 +38,16 @@ concrete2haskell opts gr cenv absname cnc modinfo =
       "--- Linearization types and linearization functions ---" $$
       vcat (map ppDef defs) $$ "" $$
       "--- Type classes for projection functions ---" $$
-      vcat (map labelClass (S.toList (S.unions (map S.fromList rs)))) $$ "" $$
+      vcat (map labelClass (S.toList labels)) $$ "" $$
       "--- Record types ---" $$
-      vcat (map recordType rs)
+      vcat (map recordType recs)
   where
-    rs = S.toList (S.insert [ident2label (identS "s")] (records rhss))
+    labels = S.difference (S.unions (map S.fromList recs)) common_labels
+    recs = S.toList (S.difference (records rhss) common_records)
+    common_records = S.fromList [[label_s]]
+    common_labels = S.fromList [label_s]
+    label_s = ident2label (identS "s")
+
     rhss = map (snd.snd) defs
     defs = sortBy (compare `on` fst) .
            concatMap (toHaskell gId gr absname cenv) . 
diff --git a/src/runtime/haskell/PGF/Haskell.hs b/src/runtime/haskell/PGF/Haskell.hs
index 8f5021bfe..e09f6635e 100644
--- a/src/runtime/haskell/PGF/Haskell.hs
+++ b/src/runtime/haskell/PGF/Haskell.hs
@@ -1,10 +1,14 @@
 -- | Auxiliary types and functions for use with grammars translated to Haskell
--- with gf -output-format=haskell -haskell=concrete
+-- with @gf -output-format=haskell -haskell=concrete@
+{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances #-}
 module PGF.Haskell where
+import Control.Applicative((<$>))
 import Data.Char(toUpper)
 import Data.List(isPrefixOf)
 import qualified Data.Map as M
 
+-- ** Concrete syntax
+
 -- | For enumerating parameter values used in tables
 class EnumAll a where enumAll :: [a]
 
@@ -42,3 +46,17 @@ fromStr = from False False
     toUpper1 s     = s
 
     pick alts def r = head ([str|(ps,str)<-alts,any (`isPrefixOf` r) ps]++[def])
+
+-- *** Common record types
+
+-- | Overloaded function to project the @s@ field from any record type
+class Has_s r a | r -> a where proj_s :: r -> a
+
+-- | Haskell representation of the GF record type @{s:t}@
+data R_s t = R_s t deriving (Eq,Ord,Show)
+instance (EnumAll t) => EnumAll (R_s t) where
+    enumAll = (R_s <$> enumAll)
+instance Has_s (R_s t) t where proj_s (R_s t) = t
+
+-- | Coerce from any record type @{...,s:t,...}@ field to the supertype @{s:t}@
+to_R_s r = R_s (proj_s r)