From 20b271a2383d81806efdbf8d35f17f989ce770a6 Mon Sep 17 00:00:00 2001
From: hallgren <hallgren@chalmers.se>
Date: Wed, 14 Jan 2015 14:35:39 +0000
Subject: [PATCH] Translating linearization functions to Haskell: better
 treatment of special tokens

Common code has been lifted out from the generated Haskell modules to
an auxiliary module PGF.Haskell, which is currently included in the
regular PGF library, although it is independent of it and probably belongs
in a separate library.

The type Str used by linearization functions is now based on a token
type Tok, which is defined in PGF.Haskell.

PGF.Haskell.Tok is similar to the type GF.Data.Str.Tok, but it has
constructors for the special tokens BIND, SOFT_BIND and CAPIT, and there is
a function

	fromStr :: Str -> String

that computes the effects of these special tokens.
---
 src/compiler/GF/Compile/ConcreteToHaskell.hs | 31 ++++----------
 src/runtime/haskell/PGF/Haskell.hs           | 44 ++++++++++++++++++++
 2 files changed, 52 insertions(+), 23 deletions(-)
 create mode 100644 src/runtime/haskell/PGF/Haskell.hs

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])