Translating linearization functions to Haskell: support for variants

By adding the flag -haskell=variants to the command line, GF will now generate linearization functions in Haskell that support variants. Variants are represented as lists in Haskell. Variants inside pre { ... } expressions are still ignored. TODO: apply some monad laws to generate more compact code (using an intermediate representation of the generated Haskell code, instead of pretty printing directly from the GF code).
2015-02-09 16:24:33 +00:00
parent 3509ee650d
commit 8e4e8da105
3 changed files with 91 additions and 49 deletions
--- a/src/compiler/GF/Compile/ConcreteToHaskell.hs
+++ b/src/compiler/GF/Compile/ConcreteToHaskell.hs
@@ -8,7 +8,7 @@ import GF.Data.Utilities(mapSnd)
 import GF.Text.Pretty
 import GF.Grammar.Grammar
 import GF.Grammar.Lookup(lookupFunType,lookupOrigInfo,allOrigInfos)--,allParamValues
-import GF.Grammar.Macros(typeForm,collectOp,mkAbs,mkApp)
+import GF.Grammar.Macros(typeForm,collectOp,collectPattOp,mkAbs,mkApp)
 import GF.Grammar.Lockfield(isLockLabel)
 import GF.Grammar.Predef(cPredef,cInts)
 import GF.Compile.Compute.Predef(predef)
@@ -28,7 +28,7 @@ concretes2haskell opts absname gr =

 concrete2haskell opts gr cenv absname cnc modinfo =
    render $
-      haskPreamble absname cnc $$ "" $$
+      haskPreamble va absname cnc $$ "" $$
      "--- Parameter types ---" $$
      vcat (neededParamTypes S.empty (params defs)) $$ "" $$
      "--- Type signatures for linearization functions ---" $$
@@ -54,7 +54,9 @@ concrete2haskell opts gr cenv absname cnc modinfo =
           M.toList $
           jments modinfo

-    signature c = "lin"<>c<+>"::"<+>"A."<>gId c<+>"->"<+>"Lin"<>c
+--  signature c = "lin"<>c<+>"::"<+>"A."<>gId c<+>"->"<+>"Lin"<>c
+--  signature c = "--lin"<>c<+>":: (Applicative f,Monad f) =>"<+>"A."<>gId c<+>"->"<+>"f Lin"<>c
+    signature c = "lin"<>c<+>"::"<+>"A."<>gId c<+>"->"<+>pure ("Lin"<>c)

    emptydefs = map emptydef (S.toList emptyCats)
    emptydef c = "lin"<>c<+>"_"<+>"="<+>"undefined"
@@ -67,38 +69,44 @@ concrete2haskell opts gr cenv absname cnc modinfo =
    params1 (Nothing,(_,rhs)) = paramTypes gr rhs
    params1 (_,(_,rhs)) = tableTypes gr [rhs]

-    ppDef (Nothing,(lhs,rhs)) = hang (lhs<+>"=") 4 (convType gId rhs)
-    ppDef (_,(lhs,rhs)) = hang (lhs<+>"=") 4 (convert gId gr rhs)
+    ppDef (Nothing,(lhs,rhs)) = hang (lhs<+>"=") 4 (convType va gId rhs)
+    ppDef (_,(lhs,rhs)) = hang (lhs<+>"=") 4 (convert va gId gr rhs)

    gId :: Ident -> Doc
    gId = if haskellOption opts HaskellNoPrefix then pp else  ("G"<>).pp
+    va = haskellOption opts HaskellVariants
+    pure = if va then brackets else pp

    neededParamTypes have [] = []
    neededParamTypes have (q:qs) =
        if q `S.member` have
        then neededParamTypes have qs
-        else let ((got,need),def) = paramType gId gr q
+        else let ((got,need),def) = paramType va gId gr q
             in def:neededParamTypes (S.union got have) (S.toList need++qs)

-haskPreamble :: ModuleName -> ModuleName -> Doc
-haskPreamble absname cncname =
+haskPreamble :: Bool -> ModuleName -> ModuleName -> Doc
+haskPreamble va absname cncname =
  "{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, LambdaCase #-}" $$
  "module" <+> cncname <+> "where" $$
  "import Prelude hiding (Ordering(..))" $$
-  "import Control.Applicative((<$>),(<*>))" $$
+  "import Control.Applicative(Applicative,pure,empty,(<$>),(<*>))" $$
+--"import Data.Foldable(asum)" $$
+--"import Control.Monad(join)" $$
  "import qualified Data.Map as M" $$
  "import Data.Map((!))" $$
  "import PGF.Haskell" $$
  "import qualified" <+> absname <+> "as A" $$
  "" $$
  "--- Standard definitions ---" $$
-  "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)]" $$
+  "linString (A.GString s) ="<+>pure "R_s [TK s]" $$
+  "linInt (A.GInt i) ="<+>pure "R_s [TK (show i)]" $$
+  "linFloat (A.GFloat x) ="<+>pure "R_s [TK (show x)]" $$
  "" $$
  "----------------------------------------------------" $$
  "-- Automatic translation from GF to Haskell follows" $$
  "----------------------------------------------------"
+  where
+    pure = if va then brackets else pp

 toHaskell gId gr absname cenv (name,jment) =
  case jment of
@@ -195,32 +203,36 @@ coerce env ty t =
    extend env (x,(Just ty,rhs)) = (x,ty):env
    extend env _ = env

-convert gId = convert' False gId
-convertA gId = convert' True gId
+convert va gId = convert' False va gId []
+convertA va gId = convert' True va gId []

-convert' atomic gId gr = if atomic then ppA else ppT
+convert' atomic va gId vs gr = if atomic then ppA else ppT
  where
+    ppT0 = convert' False False gId vs gr
+    ppA0 = convert' True False gId vs gr
+    ppTv vs' = convert' atomic va gId vs' gr
+
    ppT = ppT' False
    ppT' loop t =
      case t of
-        Let (x,(_,xt)) t -> sep ["let"<+>x<+>"="<+>ppT xt,"in"<+>ppT t]
-        Abs b x t -> "\\"<+>x<+>"->"<+>ppT t
+        Let (x,(_,xt)) t -> sep ["let"<+>x<+>"="<+>ppT0 xt,"in"<+>ppT t]
+--      Abs b x t -> "\\"<+>x<+>"->"<+>ppT t
 --      V ty ts -> hang "table" 4 (sep [list (enumAll ty),list ts])
-        V ty ts -> hang "table" 4 (dedup ts)
-        T (TTyped ty) cs -> hang "\\case" 2 (vcat (map ppCase cs))
-        S t p -> hang (ppB t) 4 (ppA p)
-        C t1 t2 -> hang (ppA t1<+>"++") 4 (ppA t2)
+        V ty ts -> pure (hang "table" 4 (dedup ts))
+        T (TTyped ty) cs -> pure (hang "\\case" 2 (vcat (map ppCase cs)))
+        S t p -> join (ap t p)
+        C t1 t2 -> hang (ppA t1<+>concat) 4 (ppA t2)
        _ -> ppB' loop t

-    ppCase (p,t) = hang (ppP p <+> "->") 4 (ppT t)
+    ppCase (p,t) = hang (ppP p <+> "->") 4 (ppTv (patVars p++vs) t)

    ppB = ppB' False
    ppB' loop t =
      case t of
-        App f a -> ppB f<+>ppA a
-        R r -> rcon (map fst r)<+>fsep (fields r)
-        P t l -> ppB (proj l)<+>ppA t
-        FV [] -> "error"<+>doubleQuotes "empty variant"
+        App f a -> ap f a
+        R r -> aps (ppA (rcon (map fst r))) (fields r)
+        P t l -> ap (proj l) t
+        FV [] -> empty
        _ -> ppA' loop t

    ppA = ppA' False
@@ -228,19 +240,19 @@ convert' atomic gId gr = if atomic then ppA else ppT
    ppA' True t = error $ "Missing case in convert': "++show t
    ppA' loop t =
      case t of
-        Vr x -> pp x
-        Cn x -> pp x
-        Con c -> gId c
-        Sort k -> pp k
-        EInt n -> pp n
+        Vr x -> if x `elem` vs then pureA (pp x) else pp x
+        Cn x -> pureA (pp x)
+        Con c -> pureA (gId c)
+        Sort k -> pureA (pp k)
+        EInt n -> pureA (pp n)
        Q (m,n) -> if m==cPredef
-                   then ppPredef n
+                   then pureA (ppPredef n)
                   else pp (qual m n)
-        QC (m,n) -> gId (qual m n)
-        K s -> token s
-        Empty -> pp "[]"
-        FV (t:ts) -> "{-variants-}"<>ppA t -- !!
-        Alts t' vs -> alts t' vs
+        QC (m,n) -> pureA (gId (qual m n))
+        K s -> pureA (token s)
+        Empty -> pureA (pp "[]")
+        FV ts@(_:_) -> variants ts
+        Alts t' vs -> pureA (alts t' vs)
        _ -> parens (ppT' True t)

    ppPredef n =
@@ -270,9 +282,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) <+> ppT t')
+    alts t' vs = brackets ("TP" <+> list' (map alt vs) <+> ppA0 t')
      where
-        alt (t,p) = parens (show (pre p)<>","<>ppT t)
+        alt (t,p) = parens (show (pre p)<>","<>ppT0 t)

        pre (K s) = [s]
        pre (Strs ts) = concatMap pre ts
@@ -285,6 +297,22 @@ convert' atomic gId gr = if atomic then ppA else ppT

    fields = map (ppA.snd.snd) . sort . filter (not.isLockLabel.fst)

+    concat = if va then "+++" else "++"
+--  pure = if va then \ x -> "pure"<+>parens x else id
+--  pureA = if va then \ x -> parens ("pure"<+>x) else id
+    pure = if va then \ x -> brackets x else id -- forcing the list monad
+    pureA = pure
+    ap = if va then \ f x -> hang (ppA f<+>"<*>") 4 (ppA x)
+               else \ f x -> hang (ppB f) 4 (ppA x)
+    join = if va then \ x -> parens ("concat"<+>parens x) else id
+--  sequence = if va then \ x -> parens ("sequence"<+>parens x) else id
+    empty = if va then pp "[]" else "error"<+>doubleQuotes "empty variant"
+    variants = if va then \ ts -> "concat"<+>list ts
+                     else \ (t:_) -> "{-variants-}"<>ppA t -- !!
+
+    aps f [] = f
+    aps f (a:as) = aps (if va then hang (f<+>"<*>") 4 a else hang f 4 a) as
+
 --  enumAll ty = case allParamValues gr ty of Ok ts -> ts

    list = brackets . fsep . punctuate "," . map ppT
@@ -306,15 +334,22 @@ convert' atomic gId gr = if atomic then ppA else ppT
        m = fmap sort (M.fromListWith (++) (zip ts [[i]|i<-is]))
        is = [0..]::[Int]

+patVars p =
+  case p of
+    PV x -> [x]
+    PAs x p -> x:patVars p
+    _ -> collectPattOp patVars p
+
 convType = convType' False
 convTypeA = convType' True

-convType' atomic gId = if atomic then ppA else ppT
+convType' atomic va gId = if atomic then ppA else ppT
  where
    ppT = ppT' False
    ppT' loop t =
      case t of
-        Table ti tv -> ppB ti <+> "->" <+> ppT tv
+        Table ti tv -> ppB ti <+> "->" <+>
+                       if va then brackets (ppT tv) else ppT tv
        _ -> ppB' loop t

    ppB = ppB' False
@@ -372,7 +407,7 @@ labelClass l =
    hang ("class"<+>"Has_"<>l<+>"r"<+>"a"<+>"| r -> a"<+>"where") 4
         (proj l<+>"::"<+>"r -> a")

-paramType gId gr q@(_,n) =
+paramType va gId gr q@(_,n) =
    case lookupOrigInfo gr q of
      Ok (m,ResParam (Just (L _ ps)) _)
       {- - | m/=cPredef && m/=moduleNameS "Prelude"-} ->
@@ -389,10 +424,10 @@ paramType gId gr q@(_,n) =
            "type"<+>gId (qual m n)<+>"n = Int")
        | otherwise ->
           ((S.singleton (m,n),paramTypes gr t),
-            "type"<+>gId (qual m n)<+>"="<+>convType gId t)
+            "type"<+>gId (qual m n)<+>"="<+>convType va gId t)
      _ -> ((S.empty,S.empty),empty)
  where
-    param m (n,ctx) = gId (qual m n)<+>[convTypeA gId t|(_,_,t)<-ctx]
+    param m (n,ctx) = gId (qual m n)<+>[convTypeA va gId t|(_,_,t)<-ctx]
    argTypes = S.unions . map argTypes1
    argTypes1 (n,ctx) = S.unions [paramTypes gr t|(_,_,t)<-ctx]

--- a/src/compiler/GF/Infra/Option.hs
+++ b/src/compiler/GF/Infra/Option.hs
@@ -126,7 +126,7 @@ data CFGTransform = CFGNoLR
  deriving (Show,Eq,Ord)

 data HaskellOption = HaskellNoPrefix | HaskellGADT | HaskellLexical
-                   | HaskellConcrete
+                   | HaskellConcrete | HaskellVariants
  deriving (Show,Eq,Ord)

 data Warning = WarnMissingLincat
@@ -521,7 +521,8 @@ haskellOptionNames =
    [("noprefix", HaskellNoPrefix),
     ("gadt",     HaskellGADT),
     ("lexical",  HaskellLexical),
-     ("concrete", HaskellConcrete)]
+     ("concrete", HaskellConcrete),
+     ("variants", HaskellVariants)]

 -- | This is for bacward compatibility. Since GHC 6.12 we
 -- started using the native Unicode support in GHC but it
--- a/src/runtime/haskell/PGF/Haskell.hs
+++ b/src/runtime/haskell/PGF/Haskell.hs
@@ -2,7 +2,7 @@
 -- with @gf -output-format=haskell -haskell=concrete@
 {-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances #-}
 module PGF.Haskell where
-import Control.Applicative((<$>))
+import Control.Applicative((<$>),(<*>))
 import Data.Char(toUpper)
 import Data.List(isPrefixOf)
 import qualified Data.Map as M
@@ -54,9 +54,15 @@ 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 (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)
+
+
+-- *** Variants
+
+infixr 5 +++
+
+xs +++ ys = (++) <$> xs <*> ys