full disjunctive patterns ; more prec levels for Exp

doc/tutorial/gf-tutorial2.txt

@@ -1704,6 +1704,36 @@ Product types and tuples are syntactic sugar for record types and records:
 Thus the labels ``p1, p2,...``` are hard-coded.
 
 
+===Record and tuple patterns===
+
+Record types of parameter types are also parameter types.
+A typical example is a record of agreement features, e.g. French
+```
+  oper Agr : PType = {g : Gender ; n : Number ; p : Person} ;
+```
+Notice the term ``PType`` rather than just ``Type`` referring to
+parameter types. Every ``PType`` is also a ``Type``.
+
+Pattern matching is done in the expected way, but it can moreover
+utilize partial records: the branch
+```
+  {g = Fem} => t
+```
+in a table of type ``Agr => T`` means the same as
+```
+  {g = Fem ; n = _ ; p = _} => t
+```
+Tuple patterns are translated to record patterns in the
+same way as tuples to records; partial patterns make it
+possible to write, slightly surprisingly,
+```
+  case <g,n,p> of {
+    <Fem> => t
+    ...
+    }
+```
+
+
 %--!
 ===Prefix-dependent choices===
 

examples/systemS/ProofSymb.gf

@@ -18,7 +18,7 @@ concrete ProofSymb of Proof = FormulaSymb ** open Prelude, Precedence in {
     RedAbs form = continue ["Reductio ad absurdum"] (task neg abs)
       where { neg = useTop (prefixR 4 "~" form) } ;
 
-    ExFalso form = finish (["Ex falso quodlibet"] ++ form.s) "Ø" ; --- form
+    ExFalso form = finish (["Ex falso quodlibet"] ++ toProve form) "Ø" ; --- form
 
     ConjSplit a b c = 
       continue ["Conjunction split"] 
@@ -81,4 +81,10 @@ concrete ProofSymb of Proof = FormulaSymb ** open Prelude, Precedence in {
 
     abs = "_|_" ;
  
+    toProve : PrecExp -> Str = \c -> 
+      variants {
+        [] ;      -- for generation
+        useTop c  -- for parsing
+        } ;
+
 }

src/GF/Source/AbsGF.hs

@@ -1,5 +1,4 @@
-
+module GF.Source.AbsGF where --H
-module GF.Source.AbsGF where
 
 import GF.Infra.Ident --H
 
@@ -189,16 +188,17 @@ data Exp =
  | ESelect Exp Exp
  | ETupTyp Exp Exp
  | EExtend Exp Exp
+ | EGlue Exp Exp
+ | EConcat Exp Exp
  | EAbstr [Bind] Exp
  | ECTable [Bind] Exp
  | EProd Decl Exp
  | ETType Exp Exp
- | EConcat Exp Exp
- | EGlue Exp Exp
  | ELet [LocDef] Exp
  | ELetb [LocDef] Exp
  | EWhere Exp [LocDef]
  | EEqs [Equation]
+ | EExample Exp String
  | ELString LString
  | ELin Ident
   deriving (Eq,Ord,Show)
@@ -220,6 +220,7 @@ data Patt =
  | PTup [PattTupleComp]
  | PC Ident [Patt]
  | PQC Ident Ident [Patt]
+ | PDisj Patt Patt
   deriving (Eq,Ord,Show)
 
 data PattAss =
@@ -239,10 +240,6 @@ data Sort =
  | Sort_Strs
   deriving (Eq,Ord,Show)
 
-data PattAlt =
-   AltP Patt
-  deriving (Eq,Ord,Show)
-
 data Bind =
    BIdent Ident
  | BWild
@@ -262,7 +259,7 @@ data PattTupleComp =
   deriving (Eq,Ord,Show)
 
 data Case =
-   Case [PattAlt] Exp
+   Case Patt Exp
   deriving (Eq,Ord,Show)
 
 data Equation =

src/GF/Source/GF.cf

@@ -150,75 +150,80 @@ separator LocDef ";" ;
 
 -- terms and types
 
-EIdent.    Exp4 ::= Ident ;
+EIdent.    Exp6 ::= Ident ;
-EConstr.   Exp4 ::= "{" Ident "}" ;
+EConstr.   Exp6 ::= "{" Ident "}" ;
-ECons.     Exp4 ::= "%" Ident "%" ;
+ECons.     Exp6 ::= "%" Ident "%" ;
-ESort.     Exp4 ::= Sort ;
+ESort.     Exp6 ::= Sort ;
-EString.   Exp4 ::= String ;
+EString.   Exp6 ::= String ;
-EInt.      Exp4 ::= Integer ;
+EInt.      Exp6 ::= Integer ;
-EFloat.    Exp4 ::= Double ;
+EFloat.    Exp6 ::= Double ;
-EMeta.     Exp4 ::= "?" ;
+EMeta.     Exp6 ::= "?" ;
-EEmpty.    Exp4 ::= "[" "]" ;
+EEmpty.    Exp6 ::= "[" "]" ;
-EData.     Exp4 ::= "data" ;
+EData.     Exp6 ::= "data" ;
-EList.     Exp4 ::= "[" Ident Exps "]" ;
+EList.     Exp6 ::= "[" Ident Exps "]" ;
-EStrings.  Exp4 ::= "[" String "]" ;
+EStrings.  Exp6 ::= "[" String "]" ;
-ERecord.   Exp4 ::= "{" [LocDef] "}" ; -- !
+ERecord.   Exp6 ::= "{" [LocDef] "}" ; -- !
-ETuple.    Exp4 ::= "<" [TupleComp] ">" ;  --- needed for separator ","
+ETuple.    Exp6 ::= "<" [TupleComp] ">" ;  --- needed for separator ","
-EIndir.    Exp4 ::= "(" "in" Ident ")" ;   -- indirection, used in judgements
+EIndir.    Exp6 ::= "(" "in" Ident ")" ;   -- indirection, used in judgements
-ETyped.    Exp4 ::= "<" Exp ":" Exp ">" ;  -- typing, used for annotations
+ETyped.    Exp6 ::= "<" Exp ":" Exp ">" ;  -- typing, used for annotations
 
-EProj.     Exp3 ::= Exp3 "." Label ;
+EProj.     Exp5 ::= Exp5 "." Label ;
-EQConstr.  Exp3 ::= "{" Ident "." Ident "}" ;  -- qualified constructor
+EQConstr.  Exp5 ::= "{" Ident "." Ident "}" ;  -- qualified constructor
-EQCons.    Exp3 ::= "%" Ident "." Ident  ;     -- qualified constant
+EQCons.    Exp5 ::= "%" Ident "." Ident  ;     -- qualified constant
 
-EApp.      Exp2 ::= Exp2 Exp3 ;
+EApp.      Exp4 ::= Exp4 Exp5 ;
-ETable.    Exp2 ::= "table" "{" [Case] "}" ;
+ETable.    Exp4 ::= "table" "{" [Case] "}" ;
-ETTable.   Exp2 ::= "table" Exp4 "{" [Case] "}" ;
+ETTable.   Exp4 ::= "table" Exp6 "{" [Case] "}" ;
-EVTable.   Exp2 ::= "table" Exp4 "[" [Exp] "]" ;
+EVTable.   Exp4 ::= "table" Exp6 "[" [Exp] "]" ;
-ECase.     Exp2 ::= "case" Exp "of" "{" [Case] "}" ;
+ECase.     Exp4 ::= "case" Exp "of" "{" [Case] "}" ;
-EVariants. Exp2 ::= "variants" "{" [Exp] "}" ;
+EVariants. Exp4 ::= "variants" "{" [Exp] "}" ;
-EPre.      Exp2 ::= "pre" "{" Exp ";" [Altern] "}" ;
+EPre.      Exp4 ::= "pre" "{" Exp ";" [Altern] "}" ;
-EStrs.     Exp2 ::= "strs" "{" [Exp] "}" ;
+EStrs.     Exp4 ::= "strs" "{" [Exp] "}" ;
-EConAt.    Exp2 ::= Ident "@" Exp4 ;
+EConAt.    Exp4 ::= Ident "@" Exp6 ;
 
-ESelect.   Exp1 ::= Exp1 "!" Exp2 ;
+ESelect.   Exp3 ::= Exp3 "!" Exp4 ;
-ETupTyp.   Exp1 ::= Exp1 "*" Exp2 ;
+ETupTyp.   Exp3 ::= Exp3 "*" Exp4 ;
-EExtend.   Exp1 ::= Exp1 "**" Exp2 ;
+EExtend.   Exp3 ::= Exp3 "**" Exp4 ;
+
+EGlue.     Exp1 ::= Exp2 "+"  Exp1 ;
+
+EConcat.   Exp  ::= Exp1 "++" Exp ;
 
 EAbstr.    Exp  ::= "\\" [Bind] "->" Exp ;
 ECTable.   Exp  ::= "\\""\\" [Bind] "=>" Exp ;
 EProd.     Exp  ::= Decl "->" Exp ;
-ETType.    Exp  ::= Exp1 "=>" Exp ; -- these are thus right associative
+ETType.    Exp  ::= Exp3 "=>" Exp ; -- these are thus right associative
-EConcat.   Exp  ::= Exp1 "++" Exp ;
-EGlue.     Exp  ::= Exp1 "+"  Exp ;
 ELet.      Exp  ::= "let" "{" [LocDef] "}" "in" Exp ;
 ELetb.     Exp  ::= "let" [LocDef] "in" Exp ;
-EWhere.    Exp  ::= Exp1 "where" "{" [LocDef] "}" ;
+EWhere.    Exp  ::= Exp3 "where" "{" [LocDef] "}" ;
 EEqs.      Exp  ::= "fn" "{" [Equation] "}" ;
 
+EExample.  Exp  ::= "in" Exp5 String ;
+
 coercions Exp 4 ;
 
 separator Exp ";" ; -- in variants
 
 -- list of arguments to category
 NilExp. Exps ::= ;
-ConsExp. Exps ::= Exp4 Exps ; -- Exp4 to force parantheses
+ConsExp. Exps ::= Exp6 Exps ; -- Exp6 to force parantheses
 
 -- patterns
 
-PW.    Patt1 ::= "_" ;
+PW.     Patt2  ::= "_" ;
-PV.    Patt1 ::= Ident ;
+PV.     Patt2  ::= Ident ;
-PCon.  Patt1 ::= "{" Ident "}" ;
+PCon.   Patt2  ::= "{" Ident "}" ;
-PQ.    Patt1 ::= Ident "." Ident ;
+PQ.     Patt2  ::= Ident "." Ident ;
-PInt.  Patt1 ::= Integer ;
+PInt.   Patt2  ::= Integer ;
-PFloat. Patt1 ::= Double ;
+PFloat. Patt2  ::= Double ;
-PStr.  Patt1 ::= String ;
+PStr.   Patt2  ::= String ;
-PR.    Patt1 ::= "{" [PattAss] "}" ;
+PR.     Patt2  ::= "{" [PattAss] "}" ;
-PTup.  Patt1 ::= "<" [PattTupleComp] ">" ;
+PTup.   Patt2  ::= "<" [PattTupleComp] ">" ;
-PC.    Patt  ::= Ident [Patt] ;
+PC.     Patt1  ::= Ident [Patt] ;
-PQC.   Patt  ::= Ident "." Ident [Patt] ;
+PQC.    Patt1  ::= Ident "." Ident [Patt] ;
+PDisj.  Patt   ::= Patt "|" Patt1 ;
 
-coercions Patt 1 ;
+coercions Patt 2 ;
 
 PA.  PattAss ::= [Ident] "=" Patt ;
 
@@ -233,13 +238,10 @@ rules Sort ::= "Type" | "PType" | "Tok" | "Str" | "Strs" ;
 
 separator PattAss ";" ;
 
-AltP. PattAlt ::= Patt ;
-
 -- this is explicit to force higher precedence level on rhs
-(:[]). [Patt] ::= Patt1 ;
+(:[]). [Patt] ::= Patt2 ;
-(:).   [Patt] ::= Patt1 [Patt] ;
+(:).   [Patt] ::= Patt2 [Patt] ;
 
-separator nonempty PattAlt "|" ;
 
 -- binds in lambdas and lin rules
 
@@ -252,7 +254,7 @@ separator Bind "," ;
 -- declarations in function types
 
 DDec.  Decl ::= "(" [Bind] ":" Exp ")" ;
-DExp.  Decl ::= Exp2 ; -- can thus be an application
+DExp.  Decl ::= Exp4 ; -- can thus be an application
 
 -- tuple component (term or pattern)
 
@@ -264,7 +266,7 @@ separator PattTupleComp "," ;
 
 -- case branches
 
-Case. Case ::= [PattAlt] "=>" Exp ;
+Case. Case ::= Patt "=>" Exp ;
 
 separator nonempty Case ";" ;
 
@@ -283,7 +285,7 @@ separator Altern ";" ;
 -- in a context, higher precedence is required than in function types
 
 DDDec.  DDecl ::= "(" [Bind] ":" Exp ")" ;
-DDExp.  DDecl ::= Exp4 ;  -- can thus *not* be an application
+DDExp.  DDecl ::= Exp6 ;  -- can thus *not* be an application
 
 separator DDecl "" ;
 
@@ -308,8 +310,8 @@ FMinus.  FileName ::= "-" FileName ;
 FAddId.  FileName ::= Ident FileName ;
 
 token LString '\'' (char - '\'')* '\'' ;
-ELString.  Exp4 ::= LString ;
+ELString.  Exp6 ::= LString ;
-ELin.      Exp2 ::= "Lin" Ident ;
+ELin.      Exp4 ::= "Lin" Ident ;
 
 DefPrintOld.  TopDef ::= "printname" [PrintDef] ;
 DefLintype.   TopDef ::= "lintype"   [Def] ;

src/GF/Source/GrammarToSource.hs

@@ -205,8 +205,8 @@ trAssign (lab, (mty, t)) = maybe (P.LDDef x t') (\ty -> P.LDFull x (trt ty) t')
 
 trLabelling (lab,ty) = P.LDDecl [trLabelIdent lab] (trt ty)
 
-trCase  (patt, trm) = P.Case [P.AltP (trp patt)] (trt trm)
+trCase  (patt, trm) = P.Case (trp patt) (trt trm)
-trCases (patts,trm) = P.Case (map (P.AltP . trp) patts) (trt trm)
+trCases (patts,trm) = P.Case (foldl1 P.PDisj (map trp patts)) (trt trm)
 
 trDecl (x,ty) = P.DDDec [trb x] (trt ty)
 

src/GF/Source/PrintGF.hs

@@ -1,11 +1,10 @@
-
+module GF.Source.PrintGF where --H
-module GF.Source.PrintGF where
 
 -- pretty-printer generated by the BNF converter, except --H
 
 import GF.Infra.Ident --H
-import GF.Source.AbsGF
+import GF.Source.AbsGF --H
-import Data.Char
+import Data.Char --H
 
 -- the top-level printing method
 printTree :: Print a => a -> String
@@ -27,13 +26,11 @@ render d = rend 0 (map ($ "") $ d []) "" where
 
     "["      :ts -> showChar '[' . rend i ts
     "("      :ts -> showChar '(' . rend i ts
-    "%"      :ts -> showChar '%' . rend i ts
     "{"      :ts -> showChar '{' . new (i+1) . rend (i+1) ts
     "}" : ";":ts -> new (i-1) . space "}" . showChar ';' . new (i-1) . rend (i-1) ts
     "}"      :ts -> new (i-1) . showChar '}' . new (i-1) . rend (i-1) ts
     ";"      :ts -> showChar ';' . new i . rend i ts
     t  : "," :ts -> showString t . space "," . rend i ts
-    t  : "%" :ts -> showString t . showChar '%' . rend i ts
     t  : ")" :ts -> showString t . showChar ')' . rend i ts
     t  : "]" :ts -> showString t . showChar ']' . rend i ts
     t        :ts -> space t . rend i ts
@@ -62,12 +59,6 @@ class Print a where
 instance Print a => Print [a] where
   prt _ = prtList
 
-instance Print Integer where
-  prt _ x = doc (shows x)
-
-instance Print Double where
-  prt _ x = doc (shows x)
-
 instance Print Char where
   prt _ s = doc (showChar '\'' . mkEsc '\'' s . showChar '\'')
   prtList s = doc (showChar '"' . concatS (map (mkEsc '"') s) . showChar '"')
@@ -84,8 +75,16 @@ prPrec :: Int -> Int -> Doc -> Doc
 prPrec i j = if j<i then parenth else id
 
 
+instance Print Integer where
+  prt _ x = doc (shows x)
+
+
+instance Print Double where
+  prt _ x = doc (shows x)
+
+
 instance Print Ident where
-  prt _ i = doc (showString $ prIdent i)
+  prt _ i = doc (showString $ prIdent i) --H
   prtList es = case es of
    [x] -> (concatD [prt 0 x])
    x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs])
@@ -192,6 +191,7 @@ instance Print Included where
   prt i e = case e of
    IAll id -> prPrec i 0 (concatD [prt 0 id])
    ISome id ids -> prPrec i 0 (concatD [prt 0 id , doc (showString "[") , prt 0 ids , doc (showString "]")])
+   IMinus id ids -> prPrec i 0 (concatD [prt 0 id , doc (showString "-") , doc (showString "[") , prt 0 ids , doc (showString "]")])
 
   prtList es = case es of
    [] -> (concatD [])
@@ -329,49 +329,50 @@ instance Print LocDef where
 
 instance Print Exp where
   prt i e = case e of
-   EIdent id -> prPrec i 4 (concatD [prt 0 id])
+   EIdent id -> prPrec i 6 (concatD [prt 0 id])
-   EConstr id -> prPrec i 4 (concatD [doc (showString "{0") , prt 0 id , doc (showString "}0")]) -- H
+   EConstr id -> prPrec i 6 (concatD [doc (showString "{0") , prt 0 id , doc (showString "}0")]) --H
-   ECons id -> prPrec i 4 (concatD [doc (showString "%") , prt 0 id , doc (showString "%")])
+   ECons id -> prPrec i 6 (concatD [doc (showString "%") , prt 0 id , doc (showString "%")])
-   ESort sort -> prPrec i 4 (concatD [prt 0 sort])
+   ESort sort -> prPrec i 6 (concatD [prt 0 sort])
-   EString str -> prPrec i 4 (concatD [prt 0 str])
+   EString str -> prPrec i 6 (concatD [prt 0 str])
-   EInt n -> prPrec i 4 (concatD [prt 0 n])
+   EInt n -> prPrec i 6 (concatD [prt 0 n])
-   EFloat n -> prPrec i 4 (concatD [prt 0 n])
+   EFloat d -> prPrec i 6 (concatD [prt 0 d])
-   EMeta  -> prPrec i 4 (concatD [doc (showString "?")])
+   EMeta  -> prPrec i 6 (concatD [doc (showString "?")])
-   EEmpty  -> prPrec i 4 (concatD [doc (showString "[") , doc (showString "]")])
+   EEmpty  -> prPrec i 6 (concatD [doc (showString "[") , doc (showString "]")])
-   EData  -> prPrec i 4 (concatD [doc (showString "data")])
+   EData  -> prPrec i 6 (concatD [doc (showString "data")])
-   EList id exps -> prPrec i 4 (concatD [doc (showString "[") , prt 0 id , prt 0 exps , doc (showString "]")])
+   EList id exps -> prPrec i 6 (concatD [doc (showString "[") , prt 0 id , prt 0 exps , doc (showString "]")])
-   EStrings str -> prPrec i 4 (concatD [doc (showString "[") , prt 0 str , doc (showString "]")])
+   EStrings str -> prPrec i 6 (concatD [doc (showString "[") , prt 0 str , doc (showString "]")])
-   ERecord locdefs -> prPrec i 4 (concatD [doc (showString "{") , prt 0 locdefs , doc (showString "}")])
+   ERecord locdefs -> prPrec i 6 (concatD [doc (showString "{") , prt 0 locdefs , doc (showString "}")])
-   ETuple tuplecomps -> prPrec i 4 (concatD [doc (showString "<") , prt 0 tuplecomps , doc (showString ">")])
+   ETuple tuplecomps -> prPrec i 6 (concatD [doc (showString "<") , prt 0 tuplecomps , doc (showString ">")])
-   EIndir id -> prPrec i 4 (concatD [doc (showString "(") , doc (showString "in") , prt 0 id , doc (showString ")")])
+   EIndir id -> prPrec i 6 (concatD [doc (showString "(") , doc (showString "in") , prt 0 id , doc (showString ")")])
-   ETyped exp0 exp -> prPrec i 4 (concatD [doc (showString "<") , prt 0 exp0 , doc (showString ":") , prt 0 exp , doc (showString ">")])
+   ETyped exp0 exp -> prPrec i 6 (concatD [doc (showString "<") , prt 0 exp0 , doc (showString ":") , prt 0 exp , doc (showString ">")])
-   EProj exp label -> prPrec i 3 (concatD [prt 3 exp , doc (showString ".") , prt 0 label])
+   EProj exp label -> prPrec i 5 (concatD [prt 5 exp , doc (showString ".") , prt 0 label])
-   EQConstr id0 id -> prPrec i 3 (concatD [doc (showString "{0") , prt 0 id0 , doc (showString ".") , prt 0 id , doc (showString "}0")]) -- H
+   EQConstr id0 id -> prPrec i 5 (concatD [doc (showString "{0") , prt 0 id0 , doc (showString ".") , prt 0 id , doc (showString "}0")]) --H
-   EQCons id0 id -> prPrec i 3 (concatD [doc (showString "%") , prt 0 id0 , doc (showString ".") , prt 0 id])
+   EQCons id0 id -> prPrec i 5 (concatD [doc (showString "%") , prt 0 id0 , doc (showString ".") , prt 0 id])
-   EApp exp0 exp -> prPrec i 2 (concatD [prt 2 exp0 , prt 3 exp])
+   EApp exp0 exp -> prPrec i 4 (concatD [prt 4 exp0 , prt 5 exp])
-   ETable cases -> prPrec i 2 (concatD [doc (showString "table") , doc (showString "{") , prt 0 cases , doc (showString "}")])
+   ETable cases -> prPrec i 4 (concatD [doc (showString "table") , doc (showString "{") , prt 0 cases , doc (showString "}")])
-   ETTable exp cases -> prPrec i 2 (concatD [doc (showString "table") , prt 4 exp , doc (showString "{") , prt 0 cases , doc (showString "}")])
+   ETTable exp cases -> prPrec i 4 (concatD [doc (showString "table") , prt 6 exp , doc (showString "{") , prt 0 cases , doc (showString "}")])
-   EVTable exp exps -> prPrec i 2 (concatD [doc (showString "table") , prt 4 exp , doc (showString "[") , prt 0 exps , doc (showString "]")])
+   EVTable exp exps -> prPrec i 4 (concatD [doc (showString "table") , prt 6 exp , doc (showString "[") , prt 0 exps , doc (showString "]")])
-   ECase exp cases -> prPrec i 2 (concatD [doc (showString "case") , prt 0 exp , doc (showString "of") , doc (showString "{") , prt 0 cases , doc (showString "}")])
+   ECase exp cases -> prPrec i 4 (concatD [doc (showString "case") , prt 0 exp , doc (showString "of") , doc (showString "{") , prt 0 cases , doc (showString "}")])
-   EVariants exps -> prPrec i 2 (concatD [doc (showString "variants") , doc (showString "{") , prt 0 exps , doc (showString "}")])
+   EVariants exps -> prPrec i 4 (concatD [doc (showString "variants") , doc (showString "{") , prt 0 exps , doc (showString "}")])
-   EPre exp alterns -> prPrec i 2 (concatD [doc (showString "pre") , doc (showString "{") , prt 0 exp , doc (showString ";") , prt 0 alterns , doc (showString "}")])
+   EPre exp alterns -> prPrec i 4 (concatD [doc (showString "pre") , doc (showString "{") , prt 0 exp , doc (showString ";") , prt 0 alterns , doc (showString "}")])
-   EStrs exps -> prPrec i 2 (concatD [doc (showString "strs") , doc (showString "{") , prt 0 exps , doc (showString "}")])
+   EStrs exps -> prPrec i 4 (concatD [doc (showString "strs") , doc (showString "{") , prt 0 exps , doc (showString "}")])
-   EConAt id exp -> prPrec i 2 (concatD [prt 0 id , doc (showString "@") , prt 4 exp])
+   EConAt id exp -> prPrec i 4 (concatD [prt 0 id , doc (showString "@") , prt 6 exp])
-   ESelect exp0 exp -> prPrec i 1 (concatD [prt 1 exp0 , doc (showString "!") , prt 2 exp])
+   ESelect exp0 exp -> prPrec i 3 (concatD [prt 3 exp0 , doc (showString "!") , prt 4 exp])
-   ETupTyp exp0 exp -> prPrec i 1 (concatD [prt 1 exp0 , doc (showString "*") , prt 2 exp])
+   ETupTyp exp0 exp -> prPrec i 3 (concatD [prt 3 exp0 , doc (showString "*") , prt 4 exp])
-   EExtend exp0 exp -> prPrec i 1 (concatD [prt 1 exp0 , doc (showString "**") , prt 2 exp])
+   EExtend exp0 exp -> prPrec i 3 (concatD [prt 3 exp0 , doc (showString "**") , prt 4 exp])
+   EGlue exp0 exp -> prPrec i 1 (concatD [prt 2 exp0 , doc (showString "+") , prt 1 exp])
+   EConcat exp0 exp -> prPrec i 0 (concatD [prt 1 exp0 , doc (showString "++") , prt 0 exp])
    EAbstr binds exp -> prPrec i 0 (concatD [doc (showString "\\") , prt 0 binds , doc (showString "->") , prt 0 exp])
    ECTable binds exp -> prPrec i 0 (concatD [doc (showString "\\") , doc (showString "\\") , prt 0 binds , doc (showString "=>") , prt 0 exp])
    EProd decl exp -> prPrec i 0 (concatD [prt 0 decl , doc (showString "->") , prt 0 exp])
-   ETType exp0 exp -> prPrec i 0 (concatD [prt 1 exp0 , doc (showString "=>") , prt 0 exp])
+   ETType exp0 exp -> prPrec i 0 (concatD [prt 3 exp0 , doc (showString "=>") , prt 0 exp])
-   EConcat exp0 exp -> prPrec i 0 (concatD [prt 1 exp0 , doc (showString "++") , prt 0 exp])
-   EGlue exp0 exp -> prPrec i 0 (concatD [prt 1 exp0 , doc (showString "+") , prt 0 exp])
    ELet locdefs exp -> prPrec i 0 (concatD [doc (showString "let") , doc (showString "{") , prt 0 locdefs , doc (showString "}") , doc (showString "in") , prt 0 exp])
    ELetb locdefs exp -> prPrec i 0 (concatD [doc (showString "let") , prt 0 locdefs , doc (showString "in") , prt 0 exp])
-   EWhere exp locdefs -> prPrec i 0 (concatD [prt 1 exp , doc (showString "where") , doc (showString "{") , prt 0 locdefs , doc (showString "}")])
+   EWhere exp locdefs -> prPrec i 0 (concatD [prt 3 exp , doc (showString "where") , doc (showString "{") , prt 0 locdefs , doc (showString "}")])
    EEqs equations -> prPrec i 0 (concatD [doc (showString "fn") , doc (showString "{") , prt 0 equations , doc (showString "}")])
-   ELString lstring -> prPrec i 4 (concatD [prt 0 lstring])
+   EExample exp str -> prPrec i 0 (concatD [doc (showString "in") , prt 5 exp , prt 0 str])
-   ELin id -> prPrec i 2 (concatD [doc (showString "Lin") , prt 0 id])
+   ELString lstring -> prPrec i 6 (concatD [prt 0 lstring])
+   ELin id -> prPrec i 4 (concatD [doc (showString "Lin") , prt 0 id])
 
   prtList es = case es of
    [] -> (concatD [])
@@ -381,26 +382,27 @@ instance Print Exp where
 instance Print Exps where
   prt i e = case e of
    NilExp  -> prPrec i 0 (concatD [])
-   ConsExp exp exps -> prPrec i 0 (concatD [prt 4 exp , prt 0 exps])
+   ConsExp exp exps -> prPrec i 0 (concatD [prt 6 exp , prt 0 exps])
 
 
 instance Print Patt where
   prt i e = case e of
-   PW  -> prPrec i 1 (concatD [doc (showString "_")])
+   PW  -> prPrec i 2 (concatD [doc (showString "_")])
-   PV id -> prPrec i 1 (concatD [prt 0 id])
+   PV id -> prPrec i 2 (concatD [prt 0 id])
-   PCon id -> prPrec i 1 (concatD [doc (showString "{0") , prt 0 id , doc (showString "}0")]) -- H
+   PCon id -> prPrec i 2 (concatD [doc (showString "{0") , prt 0 id , doc (showString "}0")]) --H
-   PQ id0 id -> prPrec i 1 (concatD [prt 0 id0 , doc (showString ".") , prt 0 id])
+   PQ id0 id -> prPrec i 2 (concatD [prt 0 id0 , doc (showString ".") , prt 0 id])
-   PInt n -> prPrec i 1 (concatD [prt 0 n])
+   PInt n -> prPrec i 2 (concatD [prt 0 n])
-   PFloat n -> prPrec i 1 (concatD [prt 0 n])
+   PFloat d -> prPrec i 2 (concatD [prt 0 d])
-   PStr str -> prPrec i 1 (concatD [prt 0 str])
+   PStr str -> prPrec i 2 (concatD [prt 0 str])
-   PR pattasss -> prPrec i 1 (concatD [doc (showString "{") , prt 0 pattasss , doc (showString "}")])
+   PR pattasss -> prPrec i 2 (concatD [doc (showString "{") , prt 0 pattasss , doc (showString "}")])
-   PTup patttuplecomps -> prPrec i 1 (concatD [doc (showString "<") , prt 0 patttuplecomps , doc (showString ">")])
+   PTup patttuplecomps -> prPrec i 2 (concatD [doc (showString "<") , prt 0 patttuplecomps , doc (showString ">")])
-   PC id patts -> prPrec i 0 (concatD [prt 0 id , prt 0 patts])
+   PC id patts -> prPrec i 1 (concatD [prt 0 id , prt 0 patts])
-   PQC id0 id patts -> prPrec i 0 (concatD [prt 0 id0 , doc (showString ".") , prt 0 id , prt 0 patts])
+   PQC id0 id patts -> prPrec i 1 (concatD [prt 0 id0 , doc (showString ".") , prt 0 id , prt 0 patts])
+   PDisj patt0 patt -> prPrec i 0 (concatD [prt 0 patt0 , doc (showString "|") , prt 1 patt])
 
   prtList es = case es of
-   [x] -> (concatD [prt 1 x])
+   [x] -> (concatD [prt 2 x])
-   x:xs -> (concatD [prt 1 x , prt 0 xs])
+   x:xs -> (concatD [prt 2 x , prt 0 xs])
 
 instance Print PattAss where
   prt i e = case e of
@@ -426,14 +428,6 @@ instance Print Sort where
    Sort_Strs  -> prPrec i 0 (concatD [doc (showString "Strs")])
 
 
-instance Print PattAlt where
-  prt i e = case e of
-   AltP patt -> prPrec i 0 (concatD [prt 0 patt])
-
-  prtList es = case es of
-   [x] -> (concatD [prt 0 x])
-   x:xs -> (concatD [prt 0 x , doc (showString "|") , prt 0 xs])
-
 instance Print Bind where
   prt i e = case e of
    BIdent id -> prPrec i 0 (concatD [prt 0 id])
@@ -447,7 +441,7 @@ instance Print Bind where
 instance Print Decl where
   prt i e = case e of
    DDec binds exp -> prPrec i 0 (concatD [doc (showString "(") , prt 0 binds , doc (showString ":") , prt 0 exp , doc (showString ")")])
-   DExp exp -> prPrec i 0 (concatD [prt 2 exp])
+   DExp exp -> prPrec i 0 (concatD [prt 4 exp])
 
 
 instance Print TupleComp where
@@ -470,7 +464,7 @@ instance Print PattTupleComp where
 
 instance Print Case where
   prt i e = case e of
-   Case pattalts exp -> prPrec i 0 (concatD [prt 0 pattalts , doc (showString "=>") , prt 0 exp])
+   Case patt exp -> prPrec i 0 (concatD [prt 0 patt , doc (showString "=>") , prt 0 exp])
 
   prtList es = case es of
    [x] -> (concatD [prt 0 x])
@@ -497,7 +491,7 @@ instance Print Altern where
 instance Print DDecl where
   prt i e = case e of
    DDDec binds exp -> prPrec i 0 (concatD [doc (showString "(") , prt 0 binds , doc (showString ":") , prt 0 exp , doc (showString ")")])
-   DDExp exp -> prPrec i 0 (concatD [prt 4 exp])
+   DDExp exp -> prPrec i 0 (concatD [prt 6 exp])
 
   prtList es = case es of
    [] -> (concatD [])

src/GF/Source/SourceToGrammar.hs

@@ -517,6 +517,24 @@ transSort :: Sort -> Err String
 transSort x = case x of
   _ -> return $ printTree x
 
+transPatts :: Patt -> Err [G.Patt]
+transPatts p = case p of
+  PDisj p1 p2 -> liftM2 (++) (transPatts p1) (transPatts p2)
+  PC id patts -> liftM (map (G.PC id) . combinations) $ mapM transPatts patts
+  PR pattasss -> do
+    let (lss,ps) = unzip [(ls,p) | PA ls p <- pattasss]
+        ls = map LIdent $ concat lss
+    ps0 <- mapM transPatts ps
+    let ps' = combinations ps0
+    lss' <- mapM trLabel ls
+    let rss = map (zip lss') ps'
+    return $ map G.PR rss
+  PTup pcs -> do
+    ps0 <- mapM transPatts [e | PTComp e <- pcs]
+    let ps' = combinations ps0
+    return $ map (G.PR . M.tuple2recordPatt) ps'
+  _ -> liftM singleton $ transPatt p
+
 transPatt :: Patt -> Err G.Patt
 transPatt x = case x of
   PW  -> return G.wildPatt
@@ -535,6 +553,7 @@ transPatt x = case x of
   PQ id0 id  -> liftM3 G.PP (transIdent id0) (transIdent id) (return [])
   PQC id0 id patts  -> 
     liftM3 G.PP (transIdent id0) (transIdent id) (mapM transPatt patts)
+  PDisj _ _ -> Bad $ "not allowed pattern" +++ printTree x
 
 transBind :: Bind -> Err Ident
 transBind x = case x of
@@ -553,8 +572,8 @@ transCases :: [Case] -> Err [G.Case]
 transCases = liftM concat . mapM transCase
 
 transCase :: Case -> Err [G.Case]
-transCase (Case pattalts exp) = do
+transCase (Case p exp) = do
-  patts <- mapM transPatt [p | AltP p <- pattalts]
+  patts <- transPatts p
   exp'  <- transExp exp  
   return [(p,exp') | p <- patts]