diff --git a/src/compiler/GF/Compile/ConcreteToHaskell.hs b/src/compiler/GF/Compile/ConcreteToHaskell.hs
index 9d870e68c..93becd16e 100644
--- a/src/compiler/GF/Compile/ConcreteToHaskell.hs
+++ b/src/compiler/GF/Compile/ConcreteToHaskell.hs
@@ -83,22 +83,14 @@ haskPreamble absname cncname =
   "import Control.Applicative((<$>),(<*>))" $$
   "import qualified Data.Map as M" $$
   "import Data.Map((!))" $$
+  "import PGF.Haskell" $$
   "import qualified" <+> absname <+> "as A" $$
   "" $$
   "--- Standard definitions ---" $$
-  "class EnumAll a where enumAll :: [a]" $$
-  "type Str = [Tok] -- token sequence" $$
-  "type Prefix = String -- to match with prefix of following token" $$
-  "type Simple = [String] -- Simple token sequence" $$
-  hang "data Tok = TK String | TP [([Prefix],Simple)] Simple" 4
-       "deriving (Eq,Ord,Show)" $$
   "linString (A.GString s) = R_s [TK s]" $$
   "linInt (A.GInt i) = R_s [TK (show i)]" $$
   "linFloat (A.GFloat x) = R_s [TK (show x)]" $$
   "" $$
---"table is vs = let m = M.fromList (zip is vs) in (m!)" $$
-  "table vs = let m = M.fromList (zip enumAll vs) in (m!)" $$
-  "" $$
   "----------------------------------------------------" $$
   "-- Automatic translation from GF to Haskell follows" $$
   "----------------------------------------------------"
@@ -237,7 +229,7 @@ convert' atomic gId gr = if atomic then ppA else ppT
         Sort k -> pp k
         EInt n -> pp n
         Q (m,n) -> if m==cPredef
-                   then ppPredef token n
+                   then ppPredef n
                    else pp (qual m n)
         QC (m,n) -> gId (qual m n)
         K s -> token s
@@ -246,11 +238,11 @@ convert' atomic gId gr = if atomic then ppA else ppT
         Alts t' vs -> alts t' vs
         _ -> parens (ppT' True t)
 
-    ppPredef tok n =
+    ppPredef n =
       case predef n of
-        Ok BIND -> tok "&+"
-        Ok SOFT_BIND -> tok "SOFT_BIND" -- hmm
-        Ok CAPIT -> tok "CAPIT" -- hmm
+        Ok BIND      -> brackets "BIND"
+        Ok SOFT_BIND -> brackets "SOFT_BIND"
+        Ok CAPIT     -> brackets "CAPIT"
         _ -> pp n
 
     ppP p =
@@ -273,16 +265,9 @@ convert' atomic gId gr = if atomic then ppA else ppT
         
     token s = brackets ("TK"<+>doubleQuotes s)
 
-    alts t' vs = brackets ("TP" <+> list' (map alt vs) <+> simple t')
+    alts t' vs = brackets ("TP" <+> list' (map alt vs) <+> ppT t')
       where
-        alt (t,p) = parens (show (pre p)<>","<>simple t)
-
-        simple (K s) = brackets (doubleQuotes s)
-        simple (C t1 t2) = parens (simple t1 <+>"++"<+>simple t2)
-        simple (Q (m,n)) = if m==cPredef
-                           then ppPredef simp n
-                           else pp (qual m n) -- hmm !!
-        simp op = brackets (doubleQuotes op)
+        alt (t,p) = parens (show (pre p)<>","<>ppT t)
 
         pre (K s) = [s]
         pre (Strs ts) = concatMap pre ts
diff --git a/src/runtime/haskell/PGF/Haskell.hs b/src/runtime/haskell/PGF/Haskell.hs
new file mode 100644
index 000000000..8f5021bfe
--- /dev/null
+++ b/src/runtime/haskell/PGF/Haskell.hs
@@ -0,0 +1,44 @@
+-- | Auxiliary types and functions for use with grammars translated to Haskell
+-- with gf -output-format=haskell -haskell=concrete
+module PGF.Haskell where
+import Data.Char(toUpper)
+import Data.List(isPrefixOf)
+import qualified Data.Map as M
+
+-- | For enumerating parameter values used in tables
+class EnumAll a where enumAll :: [a]
+
+-- | Tables
+table vs = let m = M.fromList (zip enumAll vs) in (M.!) m
+
+
+-- | Token sequences, output form linearization functions
+type Str = [Tok] -- token sequence
+
+-- | Tokens
+data Tok = TK String | TP [([Prefix],Str)] Str | BIND | SOFT_BIND | CAPIT
+         deriving (Eq,Ord,Show)
+
+type Prefix = String -- ^ To be matched with the prefix of a following token
+
+-- | Render a token sequence as a 'String'
+fromStr :: Str -> String
+fromStr = from False False
+  where
+    from space cap ts =
+      case ts of
+        [] -> []
+        TK s:ts -> put s++from True cap ts
+        BIND:ts -> from False cap ts
+        SOFT_BIND:ts -> from False cap ts
+        CAPIT:ts -> from space True ts
+        TP alts def:ts -> from space cap (pick alts def r++[TK r]) -- hmm
+          where r = fromStr ts
+      where
+        put s = [' '|space]++up s
+        up = if cap then toUpper1 else id
+
+    toUpper1 (c:s) = toUpper c:s
+    toUpper1 s     = s
+
+    pick alts def r = head ([str|(ps,str)<-alts,any (`isPrefixOf` r) ps]++[def])