More work on translating linearization functions to Haskell

Many Phrasebook languages can now be converted to compilable Haskell code.
Some languages (Fre, Hin, Snd, Urd) generate too much Haskell code to be
practically useful (e.g. 338MB for Fre). One language (Fin) took too long
to convert to Haskell. One language (Pes) has problems with name clashes in
the generated Haskell code.

STILL TODO:

  	- variants
  	- pre { ... }
  	- reduce code duplication for large tables
	- generate qualified names to avoid name clashes

src/compiler/GF/Compile/ConcreteToHaskell.hs

@@ -1,5 +1,5 @@
 module GF.Compile.ConcreteToHaskell where
-import Data.List(sort,sortBy,(\\))
+import Data.List(sort,sortBy)
 import Data.Function(on)
 import qualified Data.Map as M
 import qualified Data.Set as S
@@ -8,14 +8,13 @@ import GF.Data.Utilities(mapSnd)
 import GF.Text.Pretty
 import GF.Grammar.Grammar
 import GF.Grammar.Lookup(lookupFunType,allParamValues,lookupOrigInfo,allOrigInfos)
-import GF.Grammar.Macros(typeForm,collectOp)
+import GF.Grammar.Macros(typeForm,collectOp,mkAbs,mkApp)
 import GF.Grammar.Lockfield(isLockLabel)
-import GF.Grammar.Predef(cPredef)
+import GF.Grammar.Predef(cPredef,cInts)
 import GF.Compile.Compute.Predef(predef)
 import GF.Compile.Compute.Value(Predefined(..))
-import GF.Infra.Ident(Ident,identS) --,moduleNameS
+import GF.Infra.Ident(Ident,identS,prefixIdent) --,moduleNameS
 import GF.Infra.Option
-import GF.Grammar.Printer(getAbs)
 import GF.Compile.Compute.ConcreteNew(normalForm,resourceValues)
 import Debug.Trace
 
@@ -93,18 +92,21 @@ toHaskell gId gr absname cenv (name,jment) =
     CncCat (Just (L loc typ)) _ _ pprn _ ->
         [(Nothing,("type"<+>"Lin"<>name,nf loc typ))]
     CncFun (Just r@(cat,ctx,lincat)) (Just (L loc def)) pprn _ ->
-        [(Just cat,("lin"<>cat<+>lhs,coerce lincat rhs))]
+--      trace (render (name<+>hcat[parens (x<>"::"<>t)|(_,x,t)<-ctx]<+>"::"<+>cat)) $
+        [(Just cat,("lin"<>cat<+>lhs,coerce [] lincat rhs))]
       where
         Ok abstype = lookupFunType gr absname name
         (absctx,abscat,absargs) = typeForm abstype
 
-        (xs,e') = getAbs (nf loc def)
-        args = map snd xs
+        e' = unAbs (length params) $
+             nf loc (mkAbs params (mkApp def (map Vr args)))
+        params = [(b,prefixIdent "g" x)|(b,x,_)<-ctx]
+        args = map snd params
         abs_args = map ("abs_"<>) args
         lhs = if null args then aId name else parens (aId name<+>hsep abs_args)
         rhs = foldr letlin e' (zip args absctx)
         letlin (a,(_,_,at)) =
-           Let (a,(Nothing,(App (con ("lin"++render at)) (con ("abs_"++render a)))))
+           Let (a,(Just (con ("Lin"++render at)),(App (con ("lin"++render at)) (con ("abs_"++render a)))))
     AnyInd _ m  -> case lookupOrigInfo gr (m,name) of
                      Ok (m,jment) -> toHaskell gId gr absname cenv (name,jment)
                      _ -> []
@@ -113,6 +115,11 @@ toHaskell gId gr absname cenv (name,jment) =
     nf loc = normalForm cenv (L loc name)
     aId n = "A."<>gId n
 
+    unAbs 0 t = t
+    unAbs n (Abs _ _ t) = unAbs (n-1) t
+    unAbs _ t = t
+
+
 con = Cn . identS
 
 tableTypes gr ts = S.unions (map tabtys ts)
@@ -127,13 +134,17 @@ paramTypes gr t =
   case t of
     RecType fs -> S.unions (map (paramTypes gr.snd) fs)
     Table t1 t2 -> S.union (paramTypes gr t1) (paramTypes gr t2)
+    App tf ta -> S.union (paramTypes gr tf) (paramTypes gr ta)
     Sort _ -> S.empty
+    EInt _ -> S.empty
     Q q -> lookup q
     QC q -> lookup q
+    FV ts -> S.unions (map (paramTypes gr) ts)
     _ -> ignore
   where
     lookup q = case lookupOrigInfo gr q of
-                 Ok (_,ResOper  _ (Just (L _ t))) -> paramTypes gr t
+                 Ok (_,ResOper  _ (Just (L _ t))) ->
+                                       S.insert q (paramTypes gr t)
                  Ok (_,ResParam {}) -> S.singleton q
                  _ -> ignore
 
@@ -152,23 +163,33 @@ records ts = S.unions (map recs ts)
     labels = sort . filter (not . isLockLabel) . map fst
 
 
-coerce ty t =
+coerce env ty t =
   case (ty,t) of 
-    (_,Let d t) -> Let d (coerce ty t)
-    (_,FV ts) -> FV (map (coerce ty) ts)
-    (Table ti tv,V _ ts) -> V ti (map (coerce tv) ts)
-    (Table ti tv,T (TTyped _) cs) -> T (TTyped ti) (mapSnd (coerce tv) cs)
+    (_,Let d t) -> Let d (coerce (extend env d) ty t)
+    (_,FV ts) -> FV (map (coerce env ty) ts)
+    (Table ti tv,V _ ts) -> V ti (map (coerce env tv) ts)
+    (Table ti tv,T (TTyped _) cs) -> T (TTyped ti) (mapSnd (coerce env tv) cs)
     (RecType rt,R r) ->
-      R [(l,(Just ft,coerce ft f))|(l,(_,f))<-r,Just ft<-[lookup l rt]]
+      R [(l,(Just ft,coerce env ft f))|(l,(_,f))<-r,Just ft<-[lookup l rt]]
+    (RecType rt,Vr x)->
+      case lookup x env of
+        Just ty' | ty'/=ty ->
+          --trace ("coerce "++render ty'++" to "++render ty) $
+          App (to_rcon (map fst rt)) t
+        _ -> trace ("no coerce to "++render ty) t
+        _ -> t
     _ -> t
-
+  where
+    extend env (x,(Just ty,rhs)) = (x,ty):env
+    extend env _ = env
 
 convert gId = convert' False gId
 convertA gId = convert' True gId
 
 convert' atomic gId gr = if atomic then ppA else ppT
   where
-    ppT t =
+    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
@@ -176,33 +197,38 @@ convert' atomic gId gr = if atomic then ppA else ppT
         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)
-        _ -> ppB t
+        _ -> ppB' loop t
 
     ppCase (p,t) = hang (ppP p <+> "->") 4 (ppT t)
 
-    ppB 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"
-        _ -> ppA t
+        _ -> ppA' loop t
 
-    ppA t =
+    ppA = ppA' False
+
+    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
         Q (m,n) -> if m==cPredef
                    then ppPredef n
                    else pp n
         QC (m,n) -> gId n
         K s -> token s
         Empty -> pp "[]"
-        FV (t:ts) -> ppA t -- !!
-        Alts t _ -> ppA t -- !!!
-        _ -> {-trace (show t) $-} parens (ppT t)
+        FV (t:ts) -> "{-variants-}"<>ppA t -- !!
+        Alts t _ -> "{-alts-}"<>ppA t -- !!!
+        _ -> parens (ppT' True t)
 
     ppPredef n =
       case predef n of
@@ -238,39 +264,58 @@ convert' atomic gId gr = if atomic then ppA else ppT
     enumAll ty = case allParamValues gr ty of
                    Ok ts -> ts
 
-convType gId = ppT
+convType = convType' False
+convTypeA = convType' True
+
+convType' atomic gId = if atomic then ppA else ppT
   where
-    ppT t =
+    ppT = ppT' False
+    ppT' loop t =
       case t of
         Table ti tv -> ppB ti <+> "->" <+> ppT tv
-        _ -> ppB t
+        _ -> ppB' loop t
 
-    ppB t =
+    ppB = ppB' False
+    ppB' loop t =
       case t of
         RecType rt -> rcon (map fst rt)<+>fsep (fields rt)
-        _ -> ppA t
+        App tf ta -> ppB tf <+> ppA ta
+        FV [] -> pp "({-empty variant-})"
+        _ -> ppA' loop t
 
-    ppA t =
+    ppA = ppA' False
+    ppA' True t = error $ "Missing case in convType for: "++show t
+    ppA' loop t =
       case t of
         Sort k -> pp k
+        EInt n -> parens ("{-"<>n<>"-}") -- type level numeric literal
+        FV (t:ts) -> "{-variants-}"<>ppA t -- !!
         QC (m,n) -> gId n
-        _ -> {-trace (show t) $-} parens (ppT t)
+        Q (m,n) -> gId n
+        _ -> {-trace (show t) $-} parens (ppT' True t)
 
     fields = map (ppA.snd) . sort . filter (not.isLockLabel.fst)
 
 proj l = con ("proj_"++render l)
-rcon ls = con ("R"++concat (sort ['_':render l|l<-ls,not (isLockLabel l)]))
+rcon = con . rcon_name
+rcon_name ls = "R"++concat (sort ['_':render l|l<-ls,not (isLockLabel l)])
+to_rcon = con . ("to_"++) . rcon_name
 
 recordType ls =
     "data"<+>app<+>"="<+>app <+> "deriving (Eq,Ord,Show)" $+$
-    vcat (map projection ls) $+$ ""
+    vcat (zipWith projection vs ls) $+$
+    to_rcon ls<+>"r"<+>"="<+>cn<+>fsep [parens (proj l<+>"r")|l<-ls] $+$ ""
   where
-    n = rcon ls
-    app = n<+>ls
+    cn = rcon ls
+ -- Not all record labels are syntactically correct as type variables in Haskell
+ -- app = cn<+>ls
+    app = cn<+>hsep vs -- don't reuse record labels
+    vs = ["t"<>i|i<-[1..n]]
+    n = length ls
 
-    projection l = 
-       hang ("instance"<+>"Has_"<>l<+>parens app<+>l<+>"where") 4
-            (proj l<+>parens app<+>"="<+>l)
+    projection v l =
+       hang ("instance"<+>"Has_"<>l<+>parens app<+>v<+>"where") 4
+            (proj l<+>parens app<+>"="<+>v)
 
 labelClass l =
     hang ("class"<+>"Has_"<>l<+>"r"<+>"a"<+>"| r -> a"<+>"where") 4
@@ -279,13 +324,19 @@ labelClass l =
 paramType gId gr q@(_,n) =
     case lookupOrigInfo gr q of
       Ok (m,ResParam (Just (L _ ps)) _)
-       | True {-m/=cPredef && m/=moduleNameS "Prelude"-} ->
+       {- - | m/=cPredef && m/=moduleNameS "Prelude"-} ->
          ((S.singleton (m,n),argTypes ps),
-          "data"<+>gId (snd q)<+>"="<+>
+          "data"<+>gId n<+>"="<+>
                sep [fsep (punctuate " |" (map param ps)),
                     pp "deriving (Eq,Ord,Show)"])
+      Ok (m,ResOper  _ (Just (L _ t)))
+        | m==cPredef && n==cInts ->
+           ((S.singleton (m,n),S.empty),pp "type GInts n = Int")
+        | otherwise ->
+           ((S.singleton (m,n),paramTypes gr t),
+            "type"<+>gId n<+>"="<+>convType gId t)
       _ -> ((S.empty,S.empty),empty)
   where
-    param (n,ctx) = gId n<+>[convertA gId gr t|(_,_,t)<-ctx]
+    param (n,ctx) = gId n<+>[convTypeA gId t|(_,_,t)<-ctx]
     argTypes = S.unions . map argTypes1
     argTypes1 (n,ctx) = S.unions [paramTypes gr t|(_,_,t)<-ctx]