Export of concrete syntax to Haskell now goes via Canonical GF

TODO: better treatment of Predef functions and record subtyping coercions

src/compiler/GF/Compile/ConcreteToCanonical.hs

@@ -13,7 +13,7 @@ import GF.Grammar.Lockfield(isLockLabel)
 import GF.Grammar.Predef(cPredef,cInts)
 import GF.Compile.Compute.Predef(predef)
 import GF.Compile.Compute.Value(Predefined(..))
-import GF.Infra.Ident(ModuleName(..),Ident,identS,prefixIdent,showIdent,isWildIdent)
+import GF.Infra.Ident(ModuleName(..),Ident,prefixIdent,showIdent,isWildIdent)
 import GF.Infra.Option(optionsPGF)
 import PGF.Internal(Literal(..))
 import GF.Compile.Compute.ConcreteNew(normalForm,resourceValues)
@@ -95,15 +95,11 @@ toCanonical gr absname cenv (name,jment) =
         [(tts,Right (LinDef (gId name) (map gId args) (convert gr e')))]
       where
         tts = tableTypes gr [e']
---      Ok abstype = lookupFunType gr absname name
+
---      (absctx,_abscat,_absargs) = typeForm abstype
         e' = unAbs (length params) $
              nf loc (mkAbs params (mkApp def (map Vr args)))
         params = [(b,x)|(b,x,_)<-ctx]
         args = map snd params
---      abs_args = map (prefixIdent "abs_") args
---      lhs = [ConP (aId name) (map VarP abs_args)]
---      rhs = foldr letlin e' (zip args absctx)
 
     AnyInd _ m  -> case lookupOrigInfo gr (m,name) of
                      Ok (m,jment) -> toCanonical gr absname cenv (name,jment)
@@ -117,23 +113,6 @@ toCanonical gr absname cenv (name,jment) =
     unAbs n (Abs _ _ t) = unAbs (n-1) t
     unAbs _ t = t
 
-
-con = Cn . identS
-{-
-tableTypes gr ts = S.unions (map tabtys ts)
-  where
-    tabtys t =
-      case t of
-        ConcatValue v1 v2 -> S.union (tabtys v1) (tabtys v2)
-        TableValue t tvs -> S.unions (paramTypes gr t:[tabtys t|TableRowValue _ t<-tvs])
-        VTableValue t ts -> (S.unions (paramTypes gr t:map tabtys ts))
-        Projection lv l -> tabtys lv
-        Selection tv pv -> S.union (tabtys tv) (tabtys pv)
-        VariantValue vs -> S.unions (map tabtys vs)
-        RecordValue rvs -> S.unions [tabtys t|RecordRowValue _ t<-rvs]
-        TupleValue lvs -> S.unions (map tabtys lvs)
-        _ -> S.empty
--}
 tableTypes gr ts = S.unions (map tabtys ts)
   where
     tabtys t =
@@ -163,37 +142,6 @@ paramTypes gr t =
     ignore = trace ("Ignore: "++show t) S.empty
 
 
-{-
-records ts = S.unions (map recs ts)
-  where
-    recs t =
-      case t of
-        R r -> S.insert (labels r) (records (map (snd.snd) r))
-        RecType r -> S.insert (labels r) (records (map snd r))
-        _ -> collectOp recs t
-
-    labels = sort . filter (not . isLockLabel) . map fst
-
-
-coerce env ty t =
-  case (ty,t) of 
-    (_,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 env ft f))|(l,(_,f))<-r,Just ft<-[lookup l rt]]
-    (RecType rt,Vr x)->
-      case lookup x env of
-        Just ty' | ty'/=ty -> -- better to compare to normal form of ty'
-          --trace ("coerce "++render ty'++" to "++render ty) $
-          App (to_rcon (map fst rt)) t
-        _ -> trace ("no coerce to "++render ty) t
-    _ -> t
-  where
-    extend env (x,(Just ty,rhs)) = (x,ty):env
-    extend env _ = env
--}
 convert gr = convert' gr []
 
 convert' gr vs = ppT
@@ -203,8 +151,6 @@ convert' gr vs = ppT
 
     ppT t =
       case t of
-         -- Only for 'let' inserted on the top-level by this converter:
---      Let (x,(_,xt)) t -> let1 x (ppT0 xt) (ppT t)
 --      Abs b x t -> ...
 --      V ty ts -> VTableValue (convType ty) (map ppT ts)
         V ty ts -> TableValue (convType ty) [TableRowValue (ppP p) (ppT t)|(p,t)<-zip ps ts]
@@ -234,13 +180,15 @@ convert' gr vs = ppT
 
     ppPredef n =
       case predef n of
-        Ok BIND       -> c "Predef.BIND"
+        Ok BIND       -> p "BIND"
-        Ok SOFT_BIND  -> c "Predef.SOFT_BIND"
+        Ok SOFT_BIND  -> p "SOFT_BIND"
-        Ok SOFT_SPACE -> c "Predef.SOFT_SPACE"
+        Ok SOFT_SPACE -> p "SOFT_SPACE"
-        Ok CAPIT      -> c "Predef.CAPIT"
+        Ok CAPIT      -> p "CAPIT"
-        Ok ALL_CAPIT  -> c "Predef.ALL_CAPIT"
+        Ok ALL_CAPIT  -> p "ALL_CAPIT"
         _ -> VarValue (gId n)
-
+      where
+       p = PredefValue . PredefId
+      
     ppP p =
       case p of
         PC c ps -> ParamPattern (Param (gId c) (map ppP ps))
@@ -277,38 +225,14 @@ convert' gr vs = ppT
     fields = map field . filter (not.isLockLabel.fst)
     field (l,(_,t)) = RecordRow (lblId l) (ppT t)
   --c = Const
-    c = VarValue . VarValueId
+  --c = VarValue . VarValueId
-    lit s = c (show s) -- hmm
+  --lit s = c (show s) -- hmm
 
     ap f a = case f of
                ParamConstant (Param p ps) ->
                  ParamConstant (Param p (ps++[a]))
                _ -> error $ "convert' ap: "++render (ppA f <+> ppA a)
 
-    join = id
-
---  empty = if va then List [] else c "error" `Ap` c (show "empty variant")
---  variants = if va then \ ts -> join' (List (map ppT ts))
---                   else \ (t:_) -> ppT t
-{-
-    aps f [] = f
-    aps f (a:as) = aps (ap f a) as
-
-    dedup ts =
-        if M.null dups
-        then List (map ppT ts)
-        else Lets [(ev i,ppT t)|(i,t)<-defs] (List (zipWith entry ts is))
-      where
-        entry t i = maybe (ppT t) (Var . ev) (M.lookup i dups)
-        ev i = identS ("e'"++show i)
-
-        defs = [(i1,t)|(t,i1:_:_)<-ms]
-        dups = M.fromList [(i2,i1)|(_,i1:is@(_:_))<-ms,i2<-i1:is]
-        ms = M.toList m
-        m = fmap sort (M.fromListWith (++) (zip ts [[i]|i<-is]))
-        is = [0..]::[Int]
--}
-
 concatValue v1 v2 =
   case (v1,v2) of
     (StrConstant "",_) -> v2

src/compiler/GF/Compile/ConcreteToHaskell.hs

@@ -1,370 +1,346 @@
 -- | Translate concrete syntax to Haskell
 module GF.Compile.ConcreteToHaskell(concretes2haskell,concrete2haskell) where
-import Data.List(sort,sortBy)
+import Data.List(isPrefixOf,sort,sortOn)
-import Data.Function(on)
 import qualified Data.Map as M
 import qualified Data.Set as S
-import GF.Data.ErrM
-import GF.Data.Utilities(mapSnd)
 import GF.Text.Pretty
-import GF.Grammar.Grammar
+--import GF.Grammar.Predef(cPredef,cInts)
-import GF.Grammar.Lookup(lookupFunType,lookupOrigInfo,allOrigInfos)--,allParamValues
+--import GF.Compile.Compute.Predef(predef)
-import GF.Grammar.Macros(typeForm,collectOp,collectPattOp,mkAbs,mkApp)
+--import GF.Compile.Compute.Value(Predefined(..))
-import GF.Grammar.Lockfield(isLockLabel)
+import GF.Infra.Ident(Ident,identS,identW,prefixIdent)
-import GF.Grammar.Predef(cPredef,cInts)
-import GF.Compile.Compute.Predef(predef)
-import GF.Compile.Compute.Value(Predefined(..))
-import GF.Infra.Ident(Ident,identS,prefixIdent) --,moduleNameS
 import GF.Infra.Option
-import GF.Compile.Compute.ConcreteNew(normalForm,resourceValues)
+import GF.Haskell as H
-import GF.Haskell
+import GF.Grammar.Canonical as C
---import GF.Grammar.Canonical
+import GF.Compile.ConcreteToCanonical
---import GF.Compile.ConcreteToCanonical
+import Debug.Trace(trace)
-import Debug.Trace
 
 -- | Generate Haskell code for the all concrete syntaxes associated with
 -- the named abstract syntax in given the grammar.
 concretes2haskell opts absname gr =
-  [(cncname,concrete2haskell opts gr cenv absname cnc cncmod)
+  [(filename,render80 $ concrete2haskell opts abstr cncmod)
-     | let cenv = resourceValues opts gr,
+     | let Grammar abstr cncs = grammar2canonical opts absname gr,
-       cnc<-allConcretes gr absname,
+       cncmod<-cncs,
-       let cncname = render cnc ++ ".hs" :: FilePath
+       let ModId name = concName cncmod
-           Ok cncmod = lookupModule gr cnc
+           filename = name ++ ".hs" :: FilePath
-{-     (_,cnc)<-concretes2canonical opt absname gr,
-       let ModId name = concName cnc
-           cncname = name ++ ".hs" :: FilePath--}
   ]
 
 -- | Generate Haskell code for the given concrete module.
 -- The only options that make a difference are
 -- @-haskell=noprefix@ and @-haskell=variants@.
-concrete2haskell opts gr cenv absname cnc modinfo =
+concrete2haskell opts
-    renderStyle style{lineLength=80,ribbonsPerLine=1} $
+                 abstr@(Abstract _ _ cats funs)
-      haskPreamble va absname cnc $$ vcat (
+                 modinfo@(Concrete cnc absname _ ps lcs lns) =
-      nl:Comment "--- Parameter types ---":
+  haskPreamble absname cnc $$
-      neededParamTypes S.empty (params defs) ++
+  vcat (
-      nl:Comment "--- Type signatures for linearization functions ---":
+    nl:Comment "--- Parameter types ---":
-      map signature (S.toList allcats)++
+    map paramDef ps ++
-      nl:Comment "--- Linearization functions for empty categories ---":
+    nl:Comment "--- Type signatures for linearization functions ---":
-      emptydefs ++
+    map signature cats ++
-      nl:Comment "--- Linearization types and linearization functions ---":
+    nl:Comment "--- Linearization functions for empty categories ---":
-      map ppDef defs ++
+    emptydefs ++
-      nl:Comment "--- Type classes for projection functions ---":
+    nl:Comment "--- Linearization types ---":
-      map labelClass (S.toList labels) ++
+    map lincatDef lcs ++
-      nl:Comment "--- Record types ---":
+    nl:Comment "--- Linearization functions ---":
-      concatMap recordType recs)
+    lindefs ++
+    nl:Comment "--- Type classes for projection functions ---":
+    map labelClass (S.toList labels) ++
+    nl:Comment "--- Record types ---":
+    concatMap recordType recs)
   where
     nl = Comment ""
+    recs = S.toList (S.difference (records (lcs,lns)) common_records)
+
     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")
+    label_s = LabelId "s"
 
-    rhss = map (either snd (snd.snd)) defs
+    signature (CatDef c _) = TypeSig lf (Fun abs (pure lin))
-    defs = sortBy (compare `on` either (const Nothing) (Just . fst)) .
-           concatMap (toHaskell gId gr absname cenv) . 
-           M.toList $
-           jments modinfo
-
---  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 = TypeSig lf (Fun abs (pure lin))
       where
         abs = tcon0 (prefixIdent "A." (gId c))
         lin = tcon0 lc
-        lf = prefixIdent "lin" c
+        lf = linfunName c
-        lc = prefixIdent "Lin" c
+        lc = lincatName c
 
     emptydefs = map emptydef (S.toList emptyCats)
-    emptydef c = Eqn (prefixIdent "lin" c,[WildP]) (Const "undefined")
+    emptydef c = Eqn (linfunName c,[WildP]) (Const "undefined")
 
-    emptyCats = allcats `S.difference` cats
+    emptyCats = allcats `S.difference` linfuncats
-    cats = S.fromList [c|Right (c,_)<-defs]
+      where
-    allcats = S.fromList [c|((_,c),AbsCat (Just _))<-allOrigInfos gr absname]
+     --funcats = S.fromList [c | FunDef f (C.Type _ (TypeApp c _))<-funs]
+       allcats = S.fromList [c | CatDef c _<-cats]
+      
+    gId :: ToIdent i => i -> Ident
+    gId = (if haskellOption opts HaskellNoPrefix then id else prefixIdent "G")
+          . toIdent
 
-    params = S.toList . S.unions . map params1
-    params1 (Left (_,rhs)) = paramTypes gr rhs
-    params1 (Right (_,(_,rhs))) = tableTypes gr [rhs]
-
-    ppDef (Left (lhs,rhs)) = lhs (convType va gId rhs)
-    ppDef (Right (_,(lhs,rhs))) = lhs (convert va gId gr rhs)
-
-    gId :: Ident -> Ident
-    gId = if haskellOption opts HaskellNoPrefix then id else prefixIdent "G"
     va = haskellOption opts HaskellVariants
     pure = if va then ListT else id
 
-    neededParamTypes have [] = []
+    haskPreamble :: ModId -> ModId -> Doc
-    neededParamTypes have (q:qs) =
+    haskPreamble absname cncname =
-        if q `S.member` have
+      "{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, LambdaCase #-}" $$
-        then neededParamTypes have qs
+      "module" <+> cncname <+> "where" $$
-        else let ((got,need),def) = paramType va gId gr q
+      "import Prelude hiding (Ordering(..))" $$
-             in def++neededParamTypes (S.union got have) (S.toList need++qs)
+      "import Control.Applicative((<$>),(<*>))" $$
-
+      "import PGF.Haskell" $$
-haskPreamble :: Bool -> ModuleName -> ModuleName -> Doc
+      "import qualified" <+> absname <+> "as A" $$
-haskPreamble va absname cncname =
+      "" $$
-  "{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, LambdaCase #-}" $$
+      "--- Standard definitions ---" $$
-  "module" <+> cncname <+> "where" $$
+      "linString (A.GString s) ="<+>pure "R_s [TK s]" $$
-  "import Prelude hiding (Ordering(..))" $$
+      "linInt (A.GInt i) ="<+>pure "R_s [TK (show i)]" $$
-  "import Control.Applicative((<$>),(<*>))" $$
+      "linFloat (A.GFloat x) ="<+>pure "R_s [TK (show x)]" $$
-  "import PGF.Haskell" $$
+      "" $$
-  "import qualified" <+> absname <+> "as A" $$
+      "----------------------------------------------------" $$
-  "" $$
+      "-- Automatic translation from GF to Haskell follows" $$
-  "--- Standard definitions ---" $$
+      "----------------------------------------------------"
-  "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
-    CncCat (Just (L loc typ)) _ _ pprn _ ->
-        [Left (tsyn0 (prefixIdent "Lin" name),nf loc typ)]
-    CncFun (Just r@(cat,ctx,lincat)) (Just (L loc def)) pprn _ ->
---      trace (render (name<+>hcat[parens (x<>"::"<>t)|(_,x,t)<-ctx]<+>"::"<+>cat)) $
-        [Right (cat,(Eqn (prefixIdent "lin" cat,lhs),coerce [] lincat rhs))]
       where
-        Ok abstype = lookupFunType gr absname name
+        pure = if va then brackets else pp
-        (absctx,_abscat,_absargs) = typeForm abstype
 
-        e' = unAbs (length params) $
+    paramDef pd =
-             nf loc (mkAbs params (mkApp def (map Vr args)))
+      case pd of
-        params = [(b,prefixIdent "g" x)|(b,x,_)<-ctx]
+        ParamAliasDef p t -> H.Type (conap0 (gId p)) (convLinType t)
-        args = map snd params
+        ParamDef p pvs -> Data (conap0 (gId p)) (map paramCon pvs) derive
-        abs_args = map (prefixIdent "abs_") args
+          where
-        lhs = [ConP (aId name) (map VarP abs_args)]
+            paramCon (Param c cs) = ConAp (gId c) (map (tcon0.gId) cs)
-        rhs = foldr letlin e' (zip args absctx)
+            derive = ["Eq","Ord","Show"]
-        letlin (a,(_,_,at)) =
-           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)
-                     _ -> []
-    _ -> []
-  where
-    nf loc = normalForm cenv (L loc name)
-    aId n = prefixIdent "A." (gId n)
 
-    unAbs 0 t = t
+    convLinType = ppT
-    unAbs n (Abs _ _ t) = unAbs (n-1) t
+      where
-    unAbs _ t = t
+        ppT t =
+          case t of
+            FloatType -> tcon0 (identS "Float")
+            IntType -> tcon0 (identS "Int")
+            ParamType (ParamTypeId p) -> tcon0 (gId p)
+            RecordType rs -> tcon (rcon' ls) (map ppT ts)
+              where (ls,ts) = unzip $ sortOn fst [(l,t)|RecordRow l t<-rs]
+            StrType -> tcon0 (identS "Str")
+            TableType pt lt -> Fun (ppT pt) (ppT lt)
+--          TupleType lts -> 
+
+    lincatDef (LincatDef c t) = tsyn0 (lincatName c) (convLinType t)
+
+    linfuncats = S.fromList linfuncatl
+    (linfuncatl,lindefs) = unzip (linDefs lns)
+
+    linDefs = map eqn . sortOn fst . map linDef
+      where eqn (cat,(f,(ps,rhs))) = (cat,Eqn (f,ps) rhs)
+
+    linDef (LinDef f xs rhs0) = 
+        (cat,(linfunName cat,(lhs,rhs)))
+      where
+        lhs = [ConP (aId f) (map VarP abs_args)]
+        aId f = prefixIdent "A." (gId f)
+
+        [lincat] = [lincat | LincatDef c lincat<-lcs,c==cat]
+        [C.Type absctx (TypeApp cat _)] = [t | FunDef f' t<-funs, f'==f]
+
+        abs_args = map abs_arg args
+        abs_arg = prefixIdent "abs_"
+        args = map (prefixIdent "g" . toIdent) xs
+
+        rhs = lets (zipWith letlin args absctx)
+                   (convert vs (coerce env lincat rhs0))
+          where
+            vs = [(VarValueId x,a)|(VarId x,a)<-zip xs args]
+            env= [(VarValueId x,lc)|(VarId x,lc)<-zip xs (map arglincat absctx)]
+            
+        letlin a (TypeBinding _ (C.Type _ (TypeApp acat _))) =
+          (a,Ap (Var (linfunName acat)) (Var (abs_arg a)))
+
+        arglincat (TypeBinding _ (C.Type _ (TypeApp acat _))) = lincat
+          where
+            [lincat] = [lincat | LincatDef c lincat<-lcs,c==acat]
+
+    convert = convert' va
+
+    convert' va vs = ppT
+      where
+        ppT0 = convert' False vs
+        ppTv vs' = convert' va vs'
+
+        pure = if va then single else id
+
+        ppT t =
+          case t of
+            TableValue ty cs -> pure (table cs)
+            Selection t p -> select (ppT t) (ppT p)
+            ConcatValue t1 t2 -> concat (ppT t1) (ppT t2)
+            RecordValue r -> aps (rcon ls) (map ppT ts)
+              where (ls,ts) = unzip $ sortOn fst [(l,t)|RecordRow l t<-r]
+            PredefValue p -> single (Var (toIdent p)) -- hmm
+            Projection t l -> ap (proj l) (ppT t)
+            VariantValue [] -> empty
+            VariantValue ts@(_:_) -> variants ts
+            VarValue x -> maybe (Var (gId x)) (pure . Var) $ lookup x vs
+            IntConstant n -> pure (lit n)
+            StrConstant s -> pure (token s)
+            PreValue vs t' -> pure (alts t' vs)
+            ParamConstant (Param c vs) -> aps (Var (pId c)) (map ppT vs)
+            ErrorValue s -> ap (Const "error") (Const (show s)) -- !!
+            _ -> error ("convert "++show t)
+
+        pId p@(ParamId s) =
+          if "to_R_" `isPrefixOf` s then toIdent p else gId p -- !! a hack
+          
+        table cs =
+            if all (null.patVars) ps
+            then lets ds (LambdaCase [(ppP p,t')|(p,t')<-zip ps ts'])
+            else LambdaCase (map ppCase cs)
+          where
+            (ds,ts') = dedup ts
+            (ps,ts) = unzip [(p,t)|TableRowValue p t<-cs]
+        ppCase (TableRowValue p t) = (ppP p,ppTv (patVars p++vs) t)
+{-
+        ppPredef n =
+          case predef n of
+            Ok BIND       -> single (c "BIND")
+            Ok SOFT_BIND  -> single (c "SOFT_BIND")
+            Ok SOFT_SPACE -> single (c "SOFT_SPACE")
+            Ok CAPIT      -> single (c "CAPIT")
+            Ok ALL_CAPIT  -> single (c "ALL_CAPIT")
+            _ -> Var n
+-}
+        ppP p =
+          case p of
+            ParamPattern (Param c ps) -> ConP (gId c) (map ppP ps)
+            RecordPattern r -> ConP (rcon' ls) (map ppP ps)
+              where (ls,ps) = unzip $ sortOn fst [(l,p)|RecordRow l p<-r]
+            WildPattern -> WildP
+
+        token s = single (c "TK" `Ap` lit s)
+
+        alts t' vs = single (c "TP" `Ap` List (map alt vs) `Ap` ppT0 t')
+          where
+            alt (s,t) = Pair (List (pre s)) (ppT0 t)
+            pre s = map lit s
+
+        c = Const
+        lit s = c (show s) -- hmm
+        concat = if va then concat' else plusplus
+          where
+            concat' (List [List ts1]) (List [List ts2]) = List [List (ts1++ts2)]
+            concat' t1 t2 = Op t1 "+++" t2
+
+        pure' = single -- forcing the list monad
+
+        select = if va then select' else Ap
+        select' (List [t]) (List [p]) = Op t "!" p
+        select' (List [t]) p = Op t "!$" p
+        select' t p = Op t "!*" p
+
+        ap = if va then ap' else Ap
+          where
+            ap' (List [f]) x = fmap f x
+            ap' f x = Op f "<*>" x
+            fmap f (List [x]) = pure' (Ap f x)
+            fmap f x = Op f "<$>" x
+
+    --  join = if va then join' else id
+        join' (List [x]) = x
+        join' x = c "concat" `Ap` x
+
+        empty = if va then List [] else c "error" `Ap` c (show "empty variant")
+        variants = if va then \ ts -> join' (List (map ppT ts))
+                         else \ (t:_) -> ppT t
+
+        aps f [] = f
+        aps f (a:as) = aps (ap f a) as
+
+        dedup ts =
+            if M.null dups
+            then ([],map ppT ts)
+            else ([(ev i,ppT t)|(i,t)<-defs],zipWith entry ts is)
+          where
+            entry t i = maybe (ppT t) (Var . ev) (M.lookup i dups)
+            ev i = identS ("e'"++show i)
+
+            defs = [(i1,t)|(t,i1:_:_)<-ms]
+            dups = M.fromList [(i2,i1)|(_,i1:is@(_:_))<-ms,i2<-i1:is]
+            ms = M.toList m
+            m = fmap sort (M.fromListWith (++) (zip ts [[i]|i<-is]))
+            is = [0..]::[Int]
 
 
-con = Cn . identS
+--con = Cn . identS
 
-tableTypes gr ts = S.unions (map tabtys ts)
+class Records t where
-  where
+  records :: t -> S.Set [LabelId]
-    tabtys t =
-      case t of
-        V t cc -> S.union (paramTypes gr t) (tableTypes gr cc)
-        T (TTyped t) cs -> S.union (paramTypes gr t) (tableTypes gr (map snd cs))
-        _ -> collectOp tabtys t
 
-paramTypes gr t =
+instance Records t => Records [t] where
-  case t of
+  records = S.unions . map records
-    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))) ->
-                                       S.insert q (paramTypes gr t)
-                 Ok (_,ResParam {}) -> S.singleton q
-                 _ -> ignore
 
-    ignore = trace ("Ignore: "++show t) S.empty
+instance (Records t1,Records t2) => Records (t1,t2) where
-
+  records (t1,t2) = S.union (records t1) (records t2)
-
+
-
+instance Records LincatDef where
-records ts = S.unions (map recs ts)
+  records (LincatDef _ lt) = records lt
-  where
+
-    recs t =
+instance Records LinDef where
-      case t of
+  records (LinDef _ _ lv) = records lv
-        R r -> S.insert (labels r) (records (map (snd.snd) r))
+
-        RecType r -> S.insert (labels r) (records (map snd r))
+instance Records LinType where
-        _ -> collectOp recs t
+  records t =
-
+    case t of
-    labels = sort . filter (not . isLockLabel) . map fst
+      RecordType r -> rowRecords r
+      TableType pt lt -> records (pt,lt)
+      TupleType ts -> records ts
+      _ -> S.empty
+
+rowRecords r = S.insert (sort ls) (records ts)
+  where (ls,ts) = unzip [(l,t)|RecordRow l t<-r]
+
+instance Records LinValue where
+  records v =
+    case v of
+      ConcatValue v1 v2 -> records (v1,v2)
+      ParamConstant (Param c vs) -> records vs
+      RecordValue r -> rowRecords r
+      TableValue t r -> records (t,r)
+      TupleValue vs -> records vs
+      VariantValue vs -> records vs
+      PreValue alts d -> records (map snd alts,d)
+      Projection v l -> records v
+      Selection v1 v2 -> records (v1,v2)
+      _ -> S.empty
+
+instance Records TableRowValue where
+  records (TableRowValue _ v) = records v
 
 
+-- | Record subtyping is converted into explicit coercions in Haskell
 coerce env ty t =
   case (ty,t) of 
-    (_,Let d t) -> Let d (coerce (extend env d) ty t)
+    (_,VariantValue ts) -> VariantValue (map (coerce env ty) ts)
-    (_,FV ts) -> FV (map (coerce env ty) ts)
+    (TableType ti tv,TableValue _ cs) ->
-    (Table ti tv,V _ ts) -> V ti (map (coerce env tv) ts)
+      TableValue ti [TableRowValue p (coerce env tv t)|TableRowValue p t<-cs]
-    (Table ti tv,T (TTyped _) cs) -> T (TTyped ti) (mapSnd (coerce env tv) cs)
+    (RecordType rt,RecordValue r) ->
-    (RecType rt,R r) ->
+      RecordValue [RecordRow l (coerce env ft f) |
-      R [(l,(Just ft,coerce env ft f))|(l,(_,f))<-r,Just ft<-[lookup l rt]]
+                     RecordRow l f<-r,ft<-[ft|RecordRow l' ft<-rt,l'==l]]
-    (RecType rt,Vr x)->
+    (RecordType rt,VarValue x)->
       case lookup x env of
         Just ty' | ty'/=ty -> -- better to compare to normal form of ty'
-          --trace ("coerce "++render ty'++" to "++render ty) $
+                            --trace ("coerce "++render ty'++" to "++render ty) $
-          App (to_rcon (map fst rt)) t
+                            app (to_rcon rt) [t]
-        _ -> trace ("no coerce to "++render ty) t
+                 | otherwise -> t -- types match, no coercion needed
+        _ -> trace (render ("missing type to coerce"<+>x<+>"to"<+>render ty
+                            $$ "in" <+> map fst env))
+                   t
     _ -> t
   where
-    extend env (x,(Just ty,rhs)) = (x,ty):env
+    app f ts = ParamConstant (Param f ts) -- !! a hack
-    extend env _ = env
+    to_rcon = ParamId . to_rcon' . labels
 
-convert va gId gr = convert' va gId [] gr
+patVars p = []
 
-convert' va gId vs gr = ppT
+labels r = [l|RecordRow l _<-r]
-  where
-    ppT0 = convert' False gId vs gr
-    ppTv vs' = convert' va gId vs' gr
 
-    ppT t =
+proj = Var . identS . proj'
-      case t of
+proj' (LabelId l) = "proj_"++l
-         -- Only for 'let' inserted on the top-level by this converter:
+rcon = Var . rcon'
-        Let (x,(_,xt)) t -> let1 x (ppT0 xt) (ppT t)
---      Abs b x t -> ...
-        V ty ts -> pure (c "table" `Ap` dedup ts)
-        T (TTyped ty) cs -> pure (LambdaCase (map ppCase cs))
-        S t p -> select (ppT t) (ppT p)
-        C t1 t2 -> concat (ppT t1) (ppT t2)
-        App f a -> ap (ppT f) (ppT a)
-        R r -> aps (ppT (rcon (map fst r))) (fields r)
-        P t l -> ap (ppT (proj l)) (ppT t)
-        FV [] -> empty
-        Vr x -> if x `elem` vs then pure (Var x) else Var x
-        Cn x -> pure (Var x)
-        Con c -> pure (Var (gId c))
-        Sort k -> pure (Var k)
-        EInt n -> pure (lit n)
-        Q (m,n) -> if m==cPredef then pure (ppPredef n) else Var (qual m n)
-        QC (m,n) -> pure (Var (gId (qual m n)))
-        K s -> pure (token s)
-        Empty -> pure (List [])
-        FV ts@(_:_) -> variants ts
-        Alts t' vs -> pure (alts t' vs)
-
-    ppCase (p,t) = (ppP p,ppTv (patVars p++vs) t)
-
-    ppPredef n =
-      case predef n of
-        Ok BIND       -> single (c "BIND")
-        Ok SOFT_BIND  -> single (c "SOFT_BIND")
-        Ok SOFT_SPACE -> single (c "SOFT_SPACE")
-        Ok CAPIT      -> single (c "CAPIT")
-        Ok ALL_CAPIT  -> single (c "ALL_CAPIT")
-        _ -> Var n
-
-    ppP p =
-      case p of
-        PC c ps -> ConP (gId c) (map ppP ps)
-        PP (_,c) ps -> ConP (gId c) (map ppP ps)
-        PR r -> ConP (rcon' (map fst r)) (map (ppP.snd) (filter (not.isLockLabel.fst) r))
-        PW -> WildP
-        PV x -> VarP x
-        PString s -> Lit (show s) -- !!
-        PInt i -> Lit (show i)
-        PFloat x -> Lit (show x)
-        PT _ p -> ppP p
-        PAs x p -> AsP x (ppP p)
-        
-    token s = single (c "TK" `Ap` lit s)
-
-    alts t' vs = single (c "TP" `Ap` List (map alt vs) `Ap` ppT0 t')
-      where
-        alt (t,p) = Pair (List (pre p)) (ppT0 t)
-
-        pre (K s) = [lit s]
-        pre (Strs ts) = concatMap pre ts
-        pre (EPatt p) = pat p
-        pre t = error $ "pre "++show t
-
-        pat (PString s) = [lit s]
-        pat (PAlt p1 p2) = pat p1++pat p2
-        pat p = error $ "pat "++show p
-
-    fields = map (ppT.snd.snd) . sort . filter (not.isLockLabel.fst)
-
-    c = Const
-    lit s = c (show s) -- hmm
-    concat = if va then concat' else plusplus
-      where
-        concat' (List [List ts1]) (List [List ts2]) = List [List (ts1++ts2)]
-        concat' t1 t2 = Op t1 "+++" t2
-    pure = if va then single else id
-    pure' = single -- forcing the list monad
-
-    select = if va then select' else Ap
-    select' (List [t]) (List [p]) = Op t "!" p
-    select' (List [t]) p = Op t "!$" p
-    select' t p = Op t "!*" p
-
-    ap = if va then ap' else Ap
-      where
-        ap' (List [f]) x = fmap f x
-        ap' f x = Op f "<*>" x
-        fmap f (List [x]) = pure' (Ap f x)
-        fmap f x = Op f "<$>" x
-
---  join = if va then join' else id
-    join' (List [x]) = x
-    join' x = c "concat" `Ap` x
-
-    empty = if va then List [] else c "error" `Ap` c (show "empty variant")
-    variants = if va then \ ts -> join' (List (map ppT ts))
-                     else \ (t:_) -> ppT t
-
-    aps f [] = f
-    aps f (a:as) = aps (ap f a) as
-
-    dedup ts =
-        if M.null dups
-        then List (map ppT ts)
-        else Lets [(ev i,ppT t)|(i,t)<-defs] (List (zipWith entry ts is))
-      where
-        entry t i = maybe (ppT t) (Var . ev) (M.lookup i dups)
-        ev i = identS ("e'"++show i)
-
-        defs = [(i1,t)|(t,i1:_:_)<-ms]
-        dups = M.fromList [(i2,i1)|(_,i1:is@(_:_))<-ms,i2<-i1:is]
-        ms = M.toList m
-        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 va gId = ppT
-  where
-    ppT t =
-      case t of
-        Table ti tv -> Fun (ppT ti) (if va then ListT (ppT tv) else ppT tv)
-        RecType rt -> tcon (rcon' (map fst rt)) (fields rt)
-        App tf ta -> TAp (ppT tf) (ppT ta)
-        FV [] -> tcon0 (identS "({-empty variant-})")
-        Sort k -> tcon0 k
-        EInt n -> tcon0 (identS ("({-"++show n++"-})")) -- type level numeric literal
-        FV (t:ts) -> ppT t -- !!
-        QC (m,n) -> tcon0 (gId (qual m n))
-        Q (m,n) -> tcon0 (gId (qual m n))
-        _ -> error $ "Missing case in convType for: "++show t
-
-    fields = map (ppT.snd) . sort . filter (not.isLockLabel.fst)
-
-proj = con . proj'
-proj' l = "proj_"++render l
-rcon = con . rcon_name
 rcon' = identS . rcon_name
-rcon_name ls = "R"++concat (sort ['_':render l|l<-ls,not (isLockLabel l)])
+rcon_name ls = "R"++concat (sort ['_':l|LabelId l<-ls])
-to_rcon = con . to_rcon'
+
 to_rcon' = ("to_"++) . rcon_name
 
 recordType ls =
@@ -405,31 +381,6 @@ labelClass l =
     r = identS "r"
     a = identS "a"
 
-paramType va gId gr q@(_,n) =
-    case lookupOrigInfo gr q of
-      Ok (m,ResParam (Just (L _ ps)) _)
-       {- - | m/=cPredef && m/=moduleNameS "Prelude"-} ->
-         ((S.singleton (m,n),argTypes ps),
-          [Data (conap0 name) (map (param m) ps)["Eq","Ord","Show"],
-           Instance [] (TId (identS "EnumAll") `TAp` TId name)
-              [(lhs0 "enumAll",foldr1 plusplus (map (enumParam m) ps))]]
-         )
-       where name = gId (qual m n)
-      Ok (m,ResOper  _ (Just (L _ t)))
-        | m==cPredef && n==cInts ->
-           ((S.singleton (m,n),S.empty),
-            [Type (ConAp (gId (qual m n)) [identS "n"]) (TId (identS "Int"))])
-        | otherwise ->
-           ((S.singleton (m,n),paramTypes gr t),
-            [Type (conap0 (gId (qual m n))) (convType va gId t)])
-      _ -> ((S.empty,S.empty),[])
-  where
-    param m (n,ctx) = ConAp (gId (qual m n)) [convType va gId t|(_,_,t)<-ctx]
-    argTypes = S.unions . map argTypes1
-    argTypes1 (n,ctx) = S.unions [paramTypes gr t|(_,_,t)<-ctx]
-
-    enumParam m (n,ctx) = enumCon (gId (qual m n)) (length ctx)
-
 enumCon name arity =
     if arity==0
     then single (Var name)
@@ -438,5 +389,18 @@ enumCon name arity =
     ap (List [f]) a = Op f "<$>" a
     ap f a = Op f "<*>" a
 
-qual :: ModuleName -> Ident -> Ident
+lincatName,linfunName :: CatId -> Ident
-qual m = prefixIdent (render m++"_")
+lincatName c = prefixIdent "Lin" (toIdent c)
+linfunName c = prefixIdent "lin" (toIdent c)
+
+class ToIdent i where toIdent :: i -> Ident
+
+instance ToIdent ParamId where toIdent (ParamId s) = identS s
+instance ToIdent PredefId where toIdent (PredefId s) = identS s
+instance ToIdent CatId   where toIdent (CatId s) = identS s
+instance ToIdent C.FunId where toIdent (FunId s) = identS s
+instance ToIdent VarValueId where toIdent (VarValueId s) = identS s
+
+instance ToIdent VarId where
+  toIdent Anonymous = identW
+  toIdent (VarId s) = identS s

src/compiler/GF/Grammar/Canonical.hs

@@ -14,6 +14,7 @@ data Grammar = Grammar Abstract [Concrete] deriving Show
 
 -- | Abstract Syntax
 data Abstract = Abstract ModId Flags [CatDef] [FunDef] deriving Show
+abstrName (Abstract mn _ _ _) = mn
 
 data CatDef   = CatDef CatId [CatId]        deriving Show
 data FunDef   = FunDef FunId Type           deriving Show
@@ -54,6 +55,7 @@ data LinValue = ConcatValue LinValue LinValue
               | FloatConstant Float 
               | IntConstant Int 
               | ParamConstant ParamValue 
+              | PredefValue PredefId
               | RecordValue [RecordRowValue]
               | StrConstant String 
               | TableValue LinType [TableRowValue]
@@ -64,29 +66,30 @@ data LinValue = ConcatValue LinValue LinValue
               | PreValue [([String], LinValue)] LinValue
               | Projection LinValue LabelId
               | Selection LinValue LinValue
-               deriving (Eq,Show)
+               deriving (Eq,Ord,Show)
 
 data LinPattern = ParamPattern ParamPattern
                 | RecordPattern [RecordRow LinPattern]
                 | WildPattern
-                deriving (Eq,Show)
+                deriving (Eq,Ord,Show)
 
 type ParamValue = Param LinValue
 type ParamPattern = Param LinPattern
 type ParamValueDef = Param ParamId
 
-data Param arg = Param ParamId [arg] deriving (Eq,Show)
+data Param arg = Param ParamId [arg] deriving (Eq,Ord,Show)
 
 type RecordRowType = RecordRow LinType
 type RecordRowValue = RecordRow LinValue
 
 data RecordRow rhs  = RecordRow LabelId rhs  deriving (Eq,Ord,Show)
-data TableRowValue  = TableRowValue LinPattern LinValue  deriving (Eq,Show)
+data TableRowValue  = TableRowValue LinPattern LinValue  deriving (Eq,Ord,Show)
 
 -- *** Identifiers in Concrete Syntax
 
-newtype LabelId = LabelId String  deriving (Eq,Ord,Show)
+newtype PredefId = PredefId String    deriving (Eq,Ord,Show)
-data VarValueId = VarValueId String  deriving (Eq,Show)
+newtype LabelId  = LabelId String     deriving (Eq,Ord,Show)
+data VarValueId  = VarValueId String  deriving (Eq,Ord,Show)
 
 -- | Name of param type or param value 
 newtype ParamId = ParamId String  deriving (Eq,Ord,Show)
@@ -96,7 +99,7 @@ newtype ParamId = ParamId String  deriving (Eq,Ord,Show)
 
 newtype ModId = ModId String  deriving (Eq,Show)
 
-newtype CatId = CatId String  deriving (Eq,Show)
+newtype CatId = CatId String  deriving (Eq,Ord,Show)
 newtype FunId = FunId String  deriving (Eq,Show)
 
 data VarId = Anonymous | VarId String  deriving Show
@@ -203,6 +206,7 @@ instance PPA LinValue where
              FloatConstant f -> pp f
              IntConstant n -> pp n
              ParamConstant pv -> ppA pv
+             PredefValue p -> ppA p
              RecordValue [] -> pp "<>"
              RecordValue rvs -> block rvs
              PreValue alts def ->
@@ -245,6 +249,8 @@ instance Pretty ModId where pp (ModId s) = pp s
 instance Pretty CatId where pp (CatId s) = pp s
 instance Pretty FunId where pp (FunId s) = pp s
 instance Pretty LabelId where pp (LabelId s) = pp s
+instance Pretty PredefId where pp = ppA
+instance PPA    PredefId where ppA (PredefId s) = pp s
 instance Pretty ParamId where pp = ppA
 instance PPA    ParamId where ppA (ParamId s) = pp s
 instance Pretty VarValueId where pp (VarValueId s) = pp s

src/compiler/GF/Haskell.hs

@@ -40,6 +40,9 @@ tvar = TId
 tcon0 = TId
 tcon c = foldl TAp (TId c)
 
+lets [] e = e
+lets ds e = Lets ds e
+
 let1 x xe e = Lets [(x,xe)] e
 single x = List [x]
 
@@ -113,7 +116,8 @@ instance Pretty Exp where
           Op e1 op e2 -> hang (ppB e1<+>op) 2 (ppB e2)
           Lets bs e -> sep ["let"<+>vcat [hang (x<+>"=") 2 xe|(x,xe)<-bs],
                             "in" <+>e]
-          LambdaCase alts -> hang "\\case" 4 (vcat [p<+>"->"<+>e|(p,e)<-alts])
+          LambdaCase alts ->
+              hang "\\case" 2 (vcat [hang (p<+>"->") 2 e|(p,e)<-alts])
           _ -> ppB e
 
       ppB e = case flatAp e of f:as -> hang (ppA f) 2 (sep (map ppA as))