Merge branch 'master' of https://github.com/GrammaticalFramework/gf-core

8 files changed, 458 insertions, 452 deletions

diff --git a/src/compiler/GF/Grammar/Canonical.hs b/src/compiler/GF/Grammar/Canonical.hs
index 4adff02f2..e62424f6a 100644
--- a/src/compiler/GF/Grammar/Canonical.hs
+++ b/src/compiler/GF/Grammar/Canonical.hs
@@ -11,6 +11,7 @@
 module GF.Grammar.Canonical where
 import Prelude hiding ((<>))
 import GF.Text.Pretty
+import GF.Infra.Ident (RawIdent)
 
 -- | A Complete grammar
 data Grammar = Grammar Abstract [Concrete] deriving Show
@@ -44,12 +45,12 @@ data LincatDef = LincatDef CatId LinType  deriving Show
 data LinDef    = LinDef FunId [VarId] LinValue  deriving Show
 
 -- | Linearization type, RHS of @lincat@
-data LinType = FloatType 
-             | IntType 
+data LinType = FloatType
+             | IntType
              | ParamType ParamType
              | RecordType [RecordRowType]
-             | StrType 
-             | TableType LinType LinType 
+             | StrType
+             | TableType LinType LinType
              | TupleType [LinType]
               deriving (Eq,Ord,Show)
 
@@ -59,7 +60,7 @@ newtype ParamType = ParamTypeId ParamId deriving (Eq,Ord,Show)
 data LinValue = ConcatValue LinValue LinValue
               | LiteralValue LinLiteral
               | ErrorValue String
-              | ParamConstant ParamValue 
+              | ParamConstant ParamValue
               | PredefValue PredefId
               | RecordValue [RecordRowValue]
               | TableValue LinType [TableRowValue]
@@ -73,9 +74,9 @@ data LinValue = ConcatValue LinValue LinValue
               | CommentedValue String LinValue
               deriving (Eq,Ord,Show)
 
-data LinLiteral = FloatConstant Float 
-                | IntConstant Int 
-                | StrConstant String 
+data LinLiteral = FloatConstant Float
+                | IntConstant Int
+                | StrConstant String
                 deriving (Eq,Ord,Show)
 
 data LinPattern = ParamPattern ParamPattern
@@ -106,7 +107,7 @@ newtype PredefId = PredefId Id        deriving (Eq,Ord,Show)
 newtype LabelId  = LabelId Id         deriving (Eq,Ord,Show)
 data VarValueId  = VarValueId QualId  deriving (Eq,Ord,Show)
 
--- | Name of param type or param value 
+-- | Name of param type or param value
 newtype ParamId = ParamId QualId  deriving (Eq,Ord,Show)
 
 --------------------------------------------------------------------------------
@@ -126,7 +127,7 @@ data FlagValue = Str String | Int Int | Flt Double deriving Show
 
 -- *** Identifiers
 
-type Id = String
+type Id = RawIdent
 data QualId = Qual ModId Id | Unqual Id  deriving (Eq,Ord,Show)
 
 --------------------------------------------------------------------------------
@@ -249,7 +250,7 @@ instance PPA LinLiteral where
             FloatConstant f -> pp f
             IntConstant n -> pp n
             StrConstant s -> doubleQuotes s -- hmm
-  
+
 instance RhsSeparator LinValue where rhsSep _ = pp "="
 
 instance Pretty LinPattern where
@@ -264,8 +265,7 @@ instance PPA LinPattern where
       ParamPattern pv -> ppA pv
       RecordPattern r -> block r
       TuplePattern ps -> "<"<>punctuate "," ps<>">"
-      WildPattern     -> pp "_"                
-      _ -> parens p
+      WildPattern     -> pp "_"
 
 instance RhsSeparator LinPattern where rhsSep _ = pp "="
 
diff --git a/src/compiler/GF/Grammar/CanonicalJSON.hs b/src/compiler/GF/Grammar/CanonicalJSON.hs
index 0ec7f43e6..04c13df5e 100644
--- a/src/compiler/GF/Grammar/CanonicalJSON.hs
+++ b/src/compiler/GF/Grammar/CanonicalJSON.hs
@@ -7,6 +7,7 @@ import Control.Applicative ((<|>))
 import Data.Ratio (denominator, numerator)
 import GF.Grammar.Canonical
 import Control.Monad (guard)
+import GF.Infra.Ident (RawIdent,showRawIdent,rawIdentS)
 
 
 encodeJSON :: FilePath -> Grammar -> IO ()
@@ -29,7 +30,7 @@ instance JSON Grammar where
 -- ** Abstract Syntax
 
 instance JSON Abstract where
-  showJSON (Abstract absid flags cats funs) 
+  showJSON (Abstract absid flags cats funs)
     = makeObj [("abs", showJSON absid),
                ("flags", showJSON flags),
                ("cats", showJSON cats),
@@ -81,7 +82,7 @@ instance JSON TypeBinding where
 -- ** Concrete syntax
 
 instance JSON Concrete where
-  showJSON (Concrete cncid absid flags params lincats lins) 
+  showJSON (Concrete cncid absid flags params lincats lins)
     = makeObj [("cnc", showJSON cncid),
                ("abs", showJSON absid),
                ("flags", showJSON flags),
@@ -204,12 +205,12 @@ instance JSON a => JSON (RecordRow a) where
   -- record rows and lists of record rows are both encoded as JSON records (i.e., objects)
   showJSON  row  = showJSONs [row]
   showJSONs rows = makeObj (map toRow rows)
-    where toRow (RecordRow (LabelId lbl) val) = (lbl, showJSON val)
+    where toRow (RecordRow (LabelId lbl) val) = (showRawIdent lbl, showJSON val)
 
   readJSON  obj = head <$> readJSONs obj
   readJSONs obj = mapM fromRow (assocsJSObject obj)
     where fromRow (lbl, jsvalue) = do value <- readJSON jsvalue
-                                      return (RecordRow (LabelId lbl) value)
+                                      return (RecordRow (LabelId (rawIdentS lbl)) value)
 
 instance JSON rhs => JSON (TableRow rhs) where
   showJSON (TableRow l v) = makeObj [(".pattern", showJSON l), (".value", showJSON v)]
@@ -219,19 +220,19 @@ instance JSON rhs => JSON (TableRow rhs) where
 
 -- *** Identifiers in Concrete Syntax
 
-instance JSON PredefId   where showJSON (PredefId    s) = showJSON s ; readJSON = fmap PredefId    . readJSON 
-instance JSON LabelId    where showJSON (LabelId     s) = showJSON s ; readJSON = fmap LabelId     . readJSON 
-instance JSON VarValueId where showJSON (VarValueId  s) = showJSON s ; readJSON = fmap VarValueId  . readJSON 
-instance JSON ParamId    where showJSON (ParamId     s) = showJSON s ; readJSON = fmap ParamId     . readJSON 
-instance JSON ParamType  where showJSON (ParamTypeId s) = showJSON s ; readJSON = fmap ParamTypeId . readJSON 
+instance JSON PredefId   where showJSON (PredefId    s) = showJSON s ; readJSON = fmap PredefId    . readJSON
+instance JSON LabelId    where showJSON (LabelId     s) = showJSON s ; readJSON = fmap LabelId     . readJSON
+instance JSON VarValueId where showJSON (VarValueId  s) = showJSON s ; readJSON = fmap VarValueId  . readJSON
+instance JSON ParamId    where showJSON (ParamId     s) = showJSON s ; readJSON = fmap ParamId     . readJSON
+instance JSON ParamType  where showJSON (ParamTypeId s) = showJSON s ; readJSON = fmap ParamTypeId . readJSON
 
 
 --------------------------------------------------------------------------------
 -- ** Used in both Abstract and Concrete Syntax
 
-instance JSON ModId where showJSON (ModId s) = showJSON s ; readJSON = fmap ModId . readJSON 
-instance JSON CatId where showJSON (CatId s) = showJSON s ; readJSON = fmap CatId . readJSON 
-instance JSON FunId where showJSON (FunId s) = showJSON s ; readJSON = fmap FunId . readJSON 
+instance JSON ModId where showJSON (ModId s) = showJSON s ; readJSON = fmap ModId . readJSON
+instance JSON CatId where showJSON (CatId s) = showJSON s ; readJSON = fmap CatId . readJSON
+instance JSON FunId where showJSON (FunId s) = showJSON s ; readJSON = fmap FunId . readJSON
 
 instance JSON VarId where
   -- the anonymous variable is the underscore:
@@ -242,20 +243,24 @@ instance JSON VarId where
     <|>        VarId <$> readJSON o
 
 instance JSON QualId where
-  showJSON (Qual (ModId m) n) = showJSON (m++"."++n)
+  showJSON (Qual (ModId m) n) = showJSON (showRawIdent m++"."++showRawIdent n)
   showJSON (Unqual n) = showJSON n
 
   readJSON o = do qualid <- readJSON o
                   let (mod, id) = span (/= '.') qualid
-                  return $ if null mod then Unqual id else Qual (ModId mod) id
+                  return $ if null mod then Unqual (rawIdentS id) else Qual (ModId (rawIdentS mod)) (rawIdentS id)
+
+instance JSON RawIdent where
+  showJSON i = showJSON $ showRawIdent i
+  readJSON o = rawIdentS <$> readJSON o
 
 instance JSON Flags where
   -- flags are encoded directly as JSON records (i.e., objects):
-  showJSON (Flags fs) = makeObj [(f, showJSON v) | (f, v) <- fs]
+  showJSON (Flags fs) = makeObj [(showRawIdent f, showJSON v) | (f, v) <- fs]
 
   readJSON obj = Flags <$> mapM fromRow (assocsJSObject obj)
     where fromRow (lbl, jsvalue) = do value <- readJSON jsvalue
-                                      return (lbl, value)
+                                      return (rawIdentS lbl, value)
 
 instance JSON FlagValue where
   -- flag values are encoded as basic JSON types:
diff --git a/src/compiler/GF/Grammar/Lexer.x b/src/compiler/GF/Grammar/Lexer.x
index bde0aa064..365388726 100644
--- a/src/compiler/GF/Grammar/Lexer.x
+++ b/src/compiler/GF/Grammar/Lexer.x
@@ -267,7 +267,7 @@ type AlexInput2 = (AlexInput,AlexInput)
 
 data ParseResult a
   = POk AlexInput2 a
-  | PFailed Posn	-- The position of the error
+  | PFailed Posn        -- The position of the error
             String      -- The error message
 
 newtype P a = P { unP :: AlexInput2 -> ParseResult a }
diff --git a/src/compiler/GF/Grammar/Lookup.hs b/src/compiler/GF/Grammar/Lookup.hs
index 9f774fb2c..97aa5639e 100644
--- a/src/compiler/GF/Grammar/Lookup.hs
+++ b/src/compiler/GF/Grammar/Lookup.hs
@@ -6,7 +6,7 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/10/27 13:21:53 $ 
+-- > CVS $Date: 2005/10/27 13:21:53 $
 -- > CVS $Author: aarne $
 -- > CVS $Revision: 1.15 $
 --
@@ -20,17 +20,17 @@ module GF.Grammar.Lookup (
            lookupOrigInfo,
            allOrigInfos,
            lookupResDef, lookupResDefLoc,
-           lookupResType, 
+           lookupResType,
            lookupOverload,
            lookupOverloadTypes,
-           lookupParamValues, 
+           lookupParamValues,
            allParamValues,
-           lookupAbsDef, 
-           lookupLincat, 
+           lookupAbsDef,
+           lookupLincat,
            lookupFunType,
            lookupCatContext,
            allOpers, allOpersTo
-	      ) where
+          ) where
 
 import GF.Data.Operations
 import GF.Infra.Ident
@@ -69,7 +69,7 @@ lookupResDef gr x = fmap unLoc (lookupResDefLoc gr x)
 lookupResDefLoc gr (m,c)
   | isPredefCat c = fmap noLoc (lock c defLinType)
   | otherwise     = look m c
-  where 
+  where
     look m c = do
       info <- lookupQIdentInfo gr (m,c)
       case info of
@@ -77,7 +77,7 @@ lookupResDefLoc gr (m,c)
         ResOper _ Nothing  -> return (noLoc (Q (m,c)))
         CncCat (Just (L l ty)) _ _ _ _ -> fmap (L l) (lock c ty)
         CncCat _ _ _ _ _         -> fmap noLoc (lock c defLinType)
-      
+
         CncFun (Just (cat,_,_)) (Just (L l tr)) _ _ -> fmap (L l) (unlock cat tr)
         CncFun _                (Just ltr) _ _ -> return ltr
 
@@ -95,7 +95,7 @@ lookupResType gr (m,c) = do
     -- used in reused concrete
     CncCat _ _ _ _ _ -> return typeType
     CncFun (Just (cat,cont,val)) _ _ _ -> do
-          val' <- lock cat val 
+          val' <- lock cat val
           return $ mkProd cont val' []
     AnyInd _ n        -> lookupResType gr (n,c)
     ResParam _ _      -> return typePType
@@ -111,7 +111,7 @@ lookupOverloadTypes gr id@(m,c) = do
     -- used in reused concrete
     CncCat _ _ _ _ _ -> ret typeType
     CncFun (Just (cat,cont,val)) _ _ _ -> do
-          val' <- lock cat val 
+          val' <- lock cat val
           ret $ mkProd cont val' []
     ResParam _ _      -> ret typePType
     ResValue (L _ t)  -> ret t
@@ -130,8 +130,8 @@ lookupOverload gr (m,c) = do
     case info of
       ResOverload os tysts -> do
             tss <- mapM (\x -> lookupOverload gr (x,c)) os
-            return $ [let (args,val) = typeFormCnc ty in (map (\(b,x,t) -> t) args,(val,tr)) | 
-                      (L _ ty,L _ tr) <- tysts] ++ 
+            return $ [let (args,val) = typeFormCnc ty in (map (\(b,x,t) -> t) args,(val,tr)) |
+                      (L _ ty,L _ tr) <- tysts] ++
                      concat tss
 
       AnyInd _ n  -> lookupOverload gr (n,c)
@@ -216,7 +216,7 @@ lookupCatContext gr m c = do
 -- notice that it only gives the modules that are reachable and the opers that are included
 
 allOpers :: Grammar -> [(QIdent,Type,Location)]
-allOpers gr = 
+allOpers gr =
   [((m,op),typ,loc) |
       (m,mi)  <- maybe [] (allExtends gr) (greatestResource gr),
       (op,info)  <- Map.toList (jments mi),
diff --git a/src/compiler/GF/Grammar/Macros.hs b/src/compiler/GF/Grammar/Macros.hs
index b088fe49c..280aee141 100644
--- a/src/compiler/GF/Grammar/Macros.hs
+++ b/src/compiler/GF/Grammar/Macros.hs
@@ -5,7 +5,7 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/11/11 16:38:00 $ 
+-- > CVS $Date: 2005/11/11 16:38:00 $
 -- > CVS $Author: bringert $
 -- > CVS $Revision: 1.24 $
 --
@@ -51,14 +51,14 @@ typeForm t =
     _      -> error (render ("no normal form of type" <+> ppTerm Unqualified 0 t))
 
 typeFormCnc :: Type -> (Context, Type)
-typeFormCnc t = 
+typeFormCnc t =
   case t of
     Prod b x a t -> let (x', v) = typeFormCnc t
                     in ((b,x,a):x',v)
     _            -> ([],t)
 
 valCat :: Type -> Cat
-valCat typ = 
+valCat typ =
   let (_,cat,_) = typeForm typ
   in cat
 
@@ -99,7 +99,7 @@ isHigherOrderType t = fromErr True $ do  -- pessimistic choice
 contextOfType :: Monad m => Type -> m Context
 contextOfType typ = case typ of
   Prod b x a t -> liftM ((b,x,a):) $ contextOfType t
-  _            -> return [] 
+  _            -> return []
 
 termForm :: Monad m => Term -> m ([(BindType,Ident)], Term, [Term])
 termForm t = case t of
@@ -108,8 +108,8 @@ termForm t = case t of
         return ((b,x):x', fun, args)
    App c a ->
      do (_,fun, args) <- termForm c
-        return ([],fun,args ++ [a]) 
-   _       -> 
+        return ([],fun,args ++ [a])
+   _       ->
      return ([],t,[])
 
 termFormCnc :: Term -> ([(BindType,Ident)], Term)
@@ -254,7 +254,7 @@ mkTable :: [Term] -> Term -> Term
 mkTable tt t = foldr Table t tt
 
 mkCTable :: [(BindType,Ident)] -> Term -> Term
-mkCTable ids v = foldr ccase v ids where 
+mkCTable ids v = foldr ccase v ids where
   ccase (_,x) t = T TRaw [(PV x,t)]
 
 mkHypo :: Term -> Hypo
@@ -287,7 +287,7 @@ plusRecType t1 t2 = case (t1, t2) of
     filter (`elem` (map fst r1)) (map fst r2) of
       [] -> return (RecType (r1 ++ r2))
       ls -> raise $ render ("clashing labels" <+> hsep ls)
-  _ -> raise $ render ("cannot add record types" <+> ppTerm Unqualified 0 t1 <+> "and" <+> ppTerm Unqualified 0 t2) 
+  _ -> raise $ render ("cannot add record types" <+> ppTerm Unqualified 0 t1 <+> "and" <+> ppTerm Unqualified 0 t2)
 
 --plusRecord :: Term -> Term -> Err Term
 plusRecord t1 t2 =
@@ -304,7 +304,7 @@ defLinType = RecType [(theLinLabel,  typeStr)]
 
 -- | refreshing variables
 mkFreshVar :: [Ident] -> Ident
-mkFreshVar olds = varX (maxVarIndex olds + 1) 
+mkFreshVar olds = varX (maxVarIndex olds + 1)
 
 -- | trying to preserve a given symbol
 mkFreshVarX :: [Ident] -> Ident -> Ident
@@ -313,7 +313,7 @@ mkFreshVarX olds x = if (elem x olds) then (varX (maxVarIndex olds + 1)) else x
 maxVarIndex :: [Ident] -> Int
 maxVarIndex = maximum . ((-1):) . map varIndex
 
-mkFreshVars :: Int -> [Ident] -> [Ident] 
+mkFreshVars :: Int -> [Ident] -> [Ident]
 mkFreshVars n olds = [varX (maxVarIndex olds + i) | i <- [1..n]]
 
 -- | quick hack for refining with var in editor
@@ -413,11 +413,11 @@ patt2term pt = case pt of
   PC c pp   -> mkApp (Con c) (map patt2term pp)
   PP c pp   -> mkApp (QC  c) (map patt2term pp)
 
-  PR r      -> R [assign l (patt2term p) | (l,p) <- r] 
+  PR r      -> R [assign l (patt2term p) | (l,p) <- r]
   PT _ p    -> patt2term p
   PInt i    -> EInt i
   PFloat i  -> EFloat i
-  PString s -> K s 
+  PString s -> K s
 
   PAs x p   -> appCons cAs    [Vr x, patt2term p]            --- an encoding
   PChar     -> appCons cChar  []                             --- an encoding
@@ -436,7 +436,7 @@ composSafeOp op = runIdentity . composOp (return . op)
 
 -- | to define compositional term functions
 composOp :: Monad m => (Term -> m Term) -> Term -> m Term
-composOp co trm = 
+composOp co trm =
  case trm of
    App c a          -> liftM2 App (co c) (co a)
    Abs b x t        -> liftM (Abs b x) (co t)
@@ -552,13 +552,13 @@ strsFromTerm t = case t of
     v0 <- mapM (strsFromTerm . fst) vs
     c0 <- mapM (strsFromTerm . snd) vs
   --let vs' = zip v0 c0
-    return [strTok (str2strings def) vars | 
+    return [strTok (str2strings def) vars |
               def  <- d0,
-              vars <- [[(str2strings v, map sstr c) | (v,c) <- zip vv c0] | 
+              vars <- [[(str2strings v, map sstr c) | (v,c) <- zip vv c0] |
                                                           vv <- sequence v0]
            ]
   FV ts -> mapM strsFromTerm ts >>= return . concat
-  Strs ts -> mapM strsFromTerm ts >>= return . concat  
+  Strs ts -> mapM strsFromTerm ts >>= return . concat
   _ -> raise (render ("cannot get Str from term" <+> ppTerm Unqualified 0 t))
 
 getTableType :: TInfo -> Err Type
@@ -590,11 +590,11 @@ noExist = FV []
 defaultLinType :: Type
 defaultLinType = mkRecType linLabel [typeStr]
 
--- normalize records and record types; put s first
+-- | normalize records and record types; put s first
 
 sortRec :: [(Label,a)] -> [(Label,a)]
 sortRec = sortBy ordLabel where
-  ordLabel (r1,_) (r2,_) = 
+  ordLabel (r1,_) (r2,_) =
     case (showIdent (label2ident r1), showIdent (label2ident r2)) of
       ("s",_) -> LT
       (_,"s") -> GT
@@ -605,7 +605,7 @@ sortRec = sortBy ordLabel where
 -- | dependency check, detecting circularities and returning topo-sorted list
 
 allDependencies :: (ModuleName -> Bool) -> Map.Map Ident Info -> [(Ident,[Ident])]
-allDependencies ism b = 
+allDependencies ism b =
   [(f, nub (concatMap opty (pts i))) | (f,i) <- Map.toList b]
   where
     opersIn t = case t of
diff --git a/src/compiler/GF/Grammar/PatternMatch.hs b/src/compiler/GF/Grammar/PatternMatch.hs
index 9ef191554..dc0a5d3a5 100644
--- a/src/compiler/GF/Grammar/PatternMatch.hs
+++ b/src/compiler/GF/Grammar/PatternMatch.hs
@@ -5,18 +5,19 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/10/12 12:38:29 $ 
+-- > CVS $Date: 2005/10/12 12:38:29 $
 -- > CVS $Author: aarne $
 -- > CVS $Revision: 1.7 $
 --
 -- pattern matching for both concrete and abstract syntax. AR -- 16\/6\/2003
 -----------------------------------------------------------------------------
 
-module GF.Grammar.PatternMatch (matchPattern,
-		     testOvershadow, 
-		     findMatch,
-                     measurePatt
-		    ) where
+module GF.Grammar.PatternMatch (
+                                matchPattern,
+                                testOvershadow,
+                                findMatch,
+                                measurePatt
+                               ) where
 
 import GF.Data.Operations
 import GF.Grammar.Grammar
@@ -30,7 +31,7 @@ import GF.Text.Pretty
 --import Debug.Trace
 
 matchPattern :: ErrorMonad m => [(Patt,rhs)] -> Term -> m (rhs, Substitution)
-matchPattern pts term = 
+matchPattern pts term =
   if not (isInConstantForm term)
     then raise (render ("variables occur in" <+> pp term))
   else do
@@ -61,15 +62,15 @@ testOvershadow pts vs = do
 findMatch :: ErrorMonad m => [([Patt],rhs)] -> [Term] -> m (rhs, Substitution)
 findMatch cases terms = case cases of
    [] -> raise (render ("no applicable case for" <+> hsep (punctuate ',' terms)))
-   (patts,_):_ | length patts /= length terms -> 
-       raise (render ("wrong number of args for patterns :" <+> hsep patts <+> 
+   (patts,_):_ | length patts /= length terms ->
+       raise (render ("wrong number of args for patterns :" <+> hsep patts <+>
                     "cannot take" <+> hsep terms))
    (patts,val):cc -> case mapM tryMatch (zip patts terms) of
        Ok substs -> return (val, concat substs)
        _         -> findMatch cc terms
 
 tryMatch :: (Patt, Term) -> Err [(Ident, Term)]
-tryMatch (p,t) = do 
+tryMatch (p,t) = do
   t' <- termForm t
   trym p t'
  where
@@ -83,26 +84,26 @@ tryMatch (p,t) = do
       (PString s, ([],K i,[])) | s==i -> return []
       (PInt s, ([],EInt i,[])) | s==i -> return []
       (PFloat s,([],EFloat i,[])) | s==i -> return [] --- rounding?
-      (PC p pp, ([], Con f, tt)) | 
+      (PC p pp, ([], Con f, tt)) |
             p `eqStrIdent` f && length pp == length tt ->
          do matches <- mapM tryMatch (zip pp tt)
             return (concat matches)
 
-      (PP (q,p) pp, ([], QC (r,f), tt)) | 
+      (PP (q,p) pp, ([], QC (r,f), tt)) |
             -- q `eqStrIdent` r &&  --- not for inherited AR 10/10/2005
             p `eqStrIdent` f && length pp == length tt ->
          do matches <- mapM tryMatch (zip pp tt)
             return (concat matches)
       ---- hack for AppPredef bug
-      (PP (q,p) pp, ([], Q (r,f), tt)) | 
-            -- q `eqStrIdent` r && --- 
+      (PP (q,p) pp, ([], Q (r,f), tt)) |
+            -- q `eqStrIdent` r && ---
             p `eqStrIdent` f && length pp == length tt ->
          do matches <- mapM tryMatch (zip pp tt)
             return (concat matches)
 
       (PR r, ([],R r',[])) |
             all (`elem` map fst r') (map fst r) ->
-         do matches <- mapM tryMatch 
+         do matches <- mapM tryMatch
                             [(p,snd a) | (l,p) <- r, let Just a = lookup l r']
             return (concat matches)
       (PT _ p',_) -> trym p' t'
@@ -125,7 +126,7 @@ tryMatch (p,t) = do
       (PMSeq mp1 mp2, ([],K s, [])) -> matchPMSeq mp1 mp2 s
 
       (PRep p1, ([],K s, [])) -> checks [
-         trym (foldr (const (PSeq p1)) (PString "") 
+         trym (foldr (const (PSeq p1)) (PString "")
            [1..n]) t' | n <- [0 .. length s]
         ] >>
         return []
diff --git a/src/compiler/GF/Grammar/Printer.hs b/src/compiler/GF/Grammar/Printer.hs
index 341dae39b..74fd511b7 100644
--- a/src/compiler/GF/Grammar/Printer.hs
+++ b/src/compiler/GF/Grammar/Printer.hs
@@ -1,365 +1,364 @@
-----------------------------------------------------------------------

--- |

--- Module      : GF.Grammar.Printer

--- Maintainer  : Krasimir Angelov

--- Stability   : (stable)

--- Portability : (portable)

---

------------------------------------------------------------------------------

-

-{-# LANGUAGE FlexibleContexts #-}

-module GF.Grammar.Printer

-           ( -- ** Pretty printing

-             TermPrintQual(..)

-           , ppModule

-           , ppJudgement

-           , ppParams

-           , ppTerm

-           , ppPatt

-           , ppValue

-           , ppConstrs

-           , ppQIdent

-           , ppMeta

-           , getAbs

-           ) where

-import Prelude hiding ((<>)) -- GHC 8.4.1 clash with Text.PrettyPrint

-

-import GF.Infra.Ident

-import GF.Infra.Option

-import GF.Grammar.Values

-import GF.Grammar.Grammar

-

-import PGF.Internal (ppMeta, ppLit, ppFId, ppFunId, ppSeqId, ppSeq)

-

-import GF.Text.Pretty

-import Data.Maybe (isNothing)

-import Data.List  (intersperse)

-import qualified Data.Map as Map

---import qualified Data.IntMap as IntMap

---import qualified Data.Set as Set

-import qualified Data.Array.IArray as Array

-

-data TermPrintQual 

-  = Terse | Unqualified | Qualified | Internal

-  deriving Eq                 

-

-instance Pretty Grammar where

-  pp = vcat . map (ppModule Qualified) . modules

-

-ppModule :: TermPrintQual -> SourceModule -> Doc

-ppModule q (mn, ModInfo mtype mstat opts exts with opens _ _ mseqs jments) =

-    hdr $$ 

-    nest 2 (ppOptions opts $$ 

-            vcat (map (ppJudgement q) (Map.toList jments)) $$

-            maybe empty (ppSequences q) mseqs) $$

-    ftr

-    where

-      hdr = complModDoc <+> modTypeDoc <+> '=' <+> 

-            hsep (intersperse (pp "**") $

-                  filter (not . isEmpty)  $ [ commaPunct ppExtends exts

-                                            , maybe empty ppWith with

-                                            , if null opens

-                                                then pp '{'

-                                                else "open" <+> commaPunct ppOpenSpec opens <+> "in" <+> '{'

-                                            ])

-

-      ftr = '}'

-

-      complModDoc =

-        case mstat of

-          MSComplete   -> empty

-          MSIncomplete -> pp "incomplete"

-

-      modTypeDoc =

-        case mtype of

-          MTAbstract         -> "abstract"  <+> mn

-          MTResource         -> "resource"  <+> mn

-          MTConcrete abs     -> "concrete"  <+> mn <+> "of" <+> abs

-          MTInterface        -> "interface" <+> mn

-          MTInstance ie      -> "instance"  <+> mn <+> "of" <+> ppExtends ie

-

-      ppExtends (id,MIAll        ) = pp id

-      ppExtends (id,MIOnly   incs) = id         <+> brackets (commaPunct pp incs)

-      ppExtends (id,MIExcept incs) = id <+> '-' <+> brackets (commaPunct pp incs)

-      

-      ppWith (id,ext,opens) = ppExtends (id,ext) <+> "with" <+> commaPunct ppInstSpec opens

-

-ppOptions opts = 

-  "flags" $$

-  nest 2 (vcat [option <+> '=' <+> ppLit value <+> ';' | (option,value) <- optionsGFO opts])

-

-ppJudgement q (id, AbsCat pcont ) =

-  "cat" <+> id <+>

-  (case pcont of

-     Just (L _ cont) -> hsep (map (ppDecl q) cont)

-     Nothing         -> empty) <+> ';'

-ppJudgement q (id, AbsFun ptype _ pexp poper) =

-  let kind | isNothing pexp      = "data"

-           | poper == Just False = "oper"

-           | otherwise           = "fun"

-  in

-  (case ptype of

-     Just (L _ typ) -> kind <+> id <+> ':' <+> ppTerm q 0 typ <+> ';'

-     Nothing        -> empty) $$

-  (case pexp of

-     Just []  -> empty

-     Just eqs -> "def" <+> vcat [id <+> hsep (map (ppPatt q 2) ps) <+> '=' <+> ppTerm q 0 e <+> ';' | L _ (ps,e) <- eqs]

-     Nothing  -> empty)

-ppJudgement q (id, ResParam pparams _) = 

-  "param" <+> id <+>

-  (case pparams of

-     Just (L _ ps) -> '=' <+> ppParams q ps

-     _             -> empty) <+> ';'

-ppJudgement q (id, ResValue pvalue) = 

-  "-- param constructor" <+> id <+> ':' <+> 

-  (case pvalue of

-     (L _ ty) -> ppTerm q 0 ty) <+> ';'

-ppJudgement q (id, ResOper  ptype pexp) =

-  "oper" <+> id <+>

-  (case ptype of {Just (L _ t) -> ':'  <+> ppTerm q 0 t; Nothing -> empty} $$

-   case pexp  of {Just (L _ e) -> '=' <+> ppTerm q 0 e; Nothing -> empty}) <+> ';'

-ppJudgement q (id, ResOverload ids defs) =

-  "oper" <+> id <+> '=' <+> 

-  ("overload" <+> '{' $$

-   nest 2 (vcat [id <+> (':' <+> ppTerm q 0 ty $$ '=' <+> ppTerm q 0 e <+> ';') | (L _ ty,L _ e) <- defs]) $$

-   '}') <+> ';'

-ppJudgement q (id, CncCat pcat pdef pref pprn mpmcfg) =

-  (case pcat of

-     Just (L _ typ) -> "lincat" <+> id <+> '=' <+> ppTerm q 0 typ <+> ';'

-     Nothing        -> empty) $$

-  (case pdef of

-     Just (L _ exp) -> "lindef" <+> id <+> '=' <+> ppTerm q 0 exp <+> ';'

-     Nothing        -> empty) $$

-  (case pref of

-     Just (L _ exp) -> "linref" <+> id <+> '=' <+> ppTerm q 0 exp <+> ';'

-     Nothing        -> empty) $$

-  (case pprn of

-     Just (L _ prn) -> "printname" <+> id <+> '=' <+> ppTerm q 0 prn <+> ';'

-     Nothing        -> empty) $$

-  (case (mpmcfg,q) of

-     (Just (PMCFG prods funs),Internal)

-                    -> "pmcfg" <+> id <+> '=' <+> '{' $$

-                       nest 2 (vcat (map ppProduction prods) $$

-                               ' ' $$

-                               vcat (map (\(funid,arr) -> ppFunId funid <+> ":=" <+> 

-                                                          parens (hcat (punctuate ',' (map ppSeqId (Array.elems arr)))))

-                                         (Array.assocs funs))) $$

-                       '}'

-     _              -> empty)

-ppJudgement q (id, CncFun  ptype pdef pprn mpmcfg) =

-  (case pdef of

-     Just (L _ e) -> let (xs,e') = getAbs e

-                     in "lin" <+> id <+> hsep (map ppBind xs) <+> '=' <+> ppTerm q 0 e' <+> ';'

-     Nothing      -> empty) $$

-  (case pprn of

-     Just (L _ prn) -> "printname" <+> id <+> '=' <+> ppTerm q 0 prn <+> ';'

-     Nothing        -> empty) $$

-  (case (mpmcfg,q) of

-     (Just (PMCFG prods funs),Internal)

-                    -> "pmcfg" <+> id <+> '=' <+> '{' $$

-                       nest 2 (vcat (map ppProduction prods) $$

-                               ' ' $$

-                               vcat (map (\(funid,arr) -> ppFunId funid <+> ":=" <+> 

-                                                          parens (hcat (punctuate ',' (map ppSeqId (Array.elems arr)))))

-                                         (Array.assocs funs))) $$

-                       '}'

-     _              -> empty)

-ppJudgement q (id, AnyInd cann mid) =

-  case q of

-    Internal -> "ind" <+> id <+> '=' <+> (if cann then pp "canonical" else empty) <+> mid <+> ';'

-    _        -> empty

-

-instance Pretty Term where pp = ppTerm Unqualified 0

-

-ppTerm q d (Abs b v e)   = let (xs,e') = getAbs (Abs b v e)

-                           in prec d 0 ('\\' <> commaPunct ppBind xs <+> "->" <+> ppTerm q 0 e')

-ppTerm q d (T TRaw xs) = case getCTable (T TRaw xs) of

-                           ([],_) -> "table" <+> '{' $$

-	  		             nest 2 (vcat (punctuate ';' (map (ppCase q) xs))) $$

-			             '}'

-                           (vs,e) -> prec d 0 ("\\\\" <> commaPunct pp vs <+> "=>" <+> ppTerm q 0 e)

-ppTerm q d (T (TTyped t) xs) = "table" <+> ppTerm q 0 t <+> '{' $$

-			       nest 2 (vcat (punctuate ';' (map (ppCase q) xs))) $$

-			       '}'

-ppTerm q d (T (TComp  t) xs) = "table" <+> ppTerm q 0 t <+> '{' $$

-		 	       nest 2 (vcat (punctuate ';' (map (ppCase q) xs))) $$

-			       '}'

-ppTerm q d (T (TWild  t) xs) = "table" <+> ppTerm q 0 t <+> '{' $$

-			       nest 2 (vcat (punctuate ';' (map (ppCase q) xs))) $$

-			       '}'

-ppTerm q d (Prod bt x a b)= if x == identW && bt == Explicit

-                              then prec d 0 (ppTerm q 4 a <+> "->" <+> ppTerm q 0 b)

-                              else prec d 0 (parens (ppBind (bt,x) <+> ':' <+> ppTerm q 0 a) <+> "->" <+> ppTerm q 0 b)

-ppTerm q d (Table kt vt)=prec d 0 (ppTerm q 3 kt <+> "=>" <+> ppTerm q 0 vt)

-ppTerm q d (Let l e)    = let (ls,e') = getLet e

-                          in prec d 0 ("let" <+> vcat (map (ppLocDef q) (l:ls)) $$ "in" <+> ppTerm q 0 e')

-ppTerm q d (Example e s)=prec d 0 ("in" <+> ppTerm q 5 e <+> str s)

-ppTerm q d (C e1 e2)    =prec d 1 (hang (ppTerm q 2 e1) 2 ("++" <+> ppTerm q 1 e2))

-ppTerm q d (Glue e1 e2) =prec d 2 (ppTerm q 3 e1 <+> '+'  <+> ppTerm q 2 e2)

-ppTerm q d (S x y)     = case x of

-                           T annot xs -> let e = case annot of

-			                           TRaw     -> y

-			                           TTyped t -> Typed y t

-			                           TComp  t -> Typed y t

-			                           TWild  t -> Typed y t

-			                 in "case" <+> ppTerm q 0 e <+>"of" <+> '{' $$

-			                    nest 2 (vcat (punctuate ';' (map (ppCase q) xs))) $$

-			                   '}'

-			   _          -> prec d 3 (hang (ppTerm q 3 x) 2 ("!" <+> ppTerm q 4 y))

-ppTerm q d (ExtR x y)  = prec d 3 (ppTerm q 3 x <+> "**" <+> ppTerm q 4 y)

-ppTerm q d (App x y)   = prec d 4 (ppTerm q 4 x <+> ppTerm q 5 y)

-ppTerm q d (V e es)    = hang "table" 2 (sep [ppTerm q 6 e,brackets (fsep (punctuate ';' (map (ppTerm q 0) es)))])

-ppTerm q d (FV es)     = prec d 4 ("variants" <+> braces (fsep (punctuate ';' (map (ppTerm q 0) es))))

-ppTerm q d (AdHocOverload es)     = "overload" <+> braces (fsep (punctuate ';' (map (ppTerm q 0) es)))

-ppTerm q d (Alts e xs) = prec d 4 ("pre" <+> braces (ppTerm q 0 e <> ';' <+> fsep (punctuate ';' (map (ppAltern q) xs))))

-ppTerm q d (Strs es)   = "strs" <+> braces (fsep (punctuate ';' (map (ppTerm q 0) es)))

-ppTerm q d (EPatt p)   = prec d 4 ('#' <+> ppPatt q 2 p)

-ppTerm q d (EPattType t)=prec d 4 ("pattern" <+> ppTerm q 0 t)

-ppTerm q d (P t l)     = prec d 5 (ppTerm q 5 t <> '.' <> l)

-ppTerm q d (Cn id)     = pp id

-ppTerm q d (Vr id)     = pp id

-ppTerm q d (Q  id)     = ppQIdent q id

-ppTerm q d (QC id)     = ppQIdent q id

-ppTerm q d (Sort id)   = pp id

-ppTerm q d (K s)       = str s

-ppTerm q d (EInt n)    = pp n

-ppTerm q d (EFloat f)  = pp f

-ppTerm q d (Meta i)    = ppMeta i

-ppTerm q d (Empty)     = pp "[]"

-ppTerm q d (R [])      = pp "<>" -- to distinguish from {} empty RecType

-ppTerm q d (R xs)      = braces (fsep (punctuate ';' [l <+> 

-                                                       fsep [case mb_t of {Just t -> ':' <+> ppTerm q 0 t; Nothing -> empty},

-                                                             '=' <+> ppTerm q 0 e] | (l,(mb_t,e)) <- xs]))

-ppTerm q d (RecType xs)

-  | q == Terse         = case [cat | (l,_) <- xs, let (p,cat) = splitAt 5 (showIdent (label2ident l)), p == "lock_"] of

-                           [cat] -> pp cat

-                           _     -> doc

-  | otherwise          = doc

-  where

-    doc = braces (fsep (punctuate ';' [l <+> ':' <+> ppTerm q 0 t | (l,t) <- xs]))

-ppTerm q d (Typed e t) = '<' <> ppTerm q 0 e <+> ':' <+> ppTerm q 0 t <> '>'

-ppTerm q d (ImplArg e) = braces (ppTerm q 0 e)

-ppTerm q d (ELincat cat t) = prec d 4 ("lincat" <+> cat <+> ppTerm q 5 t)

-ppTerm q d (ELin cat t) = prec d 4 ("lin" <+> cat <+> ppTerm q 5 t)

-ppTerm q d (Error s)   = prec d 4 ("Predef.error" <+> str s)

-

-ppEquation q (ps,e) = hcat (map (ppPatt q 2) ps) <+> "->" <+> ppTerm q 0 e

-

-ppCase q (p,e) = ppPatt q 0 p <+> "=>" <+> ppTerm q 0 e

-

-instance Pretty Patt where pp = ppPatt Unqualified 0

-

-ppPatt q d (PAlt p1 p2) = prec d 0 (ppPatt q 0 p1 <+> '|' <+> ppPatt q 1 p2)

-ppPatt q d (PSeq p1 p2) = prec d 0 (ppPatt q 0 p1 <+> '+' <+> ppPatt q 1 p2)

-ppPatt q d (PMSeq (_,p1) (_,p2)) = prec d 0 (ppPatt q 0 p1 <+> '+' <+> ppPatt q 1 p2)

-ppPatt q d (PC f ps)    = if null ps

-                            then pp f

-                            else prec d 1 (f <+> hsep (map (ppPatt q 3) ps))

-ppPatt q d (PP f ps)    = if null ps

-                            then ppQIdent q f

-                            else prec d 1 (ppQIdent q f <+> hsep (map (ppPatt q 3) ps))

-ppPatt q d (PRep p)     = prec d 1 (ppPatt q 3 p <> '*')

-ppPatt q d (PAs f p)    = prec d 2 (f <> '@' <> ppPatt q 3 p)

-ppPatt q d (PNeg p)     = prec d 2 ('-' <> ppPatt q 3 p)

-ppPatt q d (PChar)      = pp '?'

-ppPatt q d (PChars s)   = brackets (str s)

-ppPatt q d (PMacro id)  = '#' <> id

-ppPatt q d (PM id)      = '#' <> ppQIdent q id

-ppPatt q d PW           = pp '_'

-ppPatt q d (PV id)      = pp id

-ppPatt q d (PInt n)     = pp n

-ppPatt q d (PFloat f)   = pp f

-ppPatt q d (PString s)  = str s

-ppPatt q d (PR xs)      = braces (hsep (punctuate ';' [l <+> '=' <+> ppPatt q 0 e | (l,e) <- xs]))

-ppPatt q d (PImplArg p) = braces (ppPatt q 0 p)

-ppPatt q d (PTilde t)   = prec d 2 ('~' <> ppTerm q 6 t)

-

-ppValue :: TermPrintQual -> Int -> Val -> Doc

-ppValue q d (VGen i x)    = x <> "{-" <> i <> "-}" ---- latter part for debugging

-ppValue q d (VApp u v)    = prec d 4 (ppValue q 4 u <+> ppValue q 5 v)

-ppValue q d (VCn (_,c))   = pp c

-ppValue q d (VClos env e) = case e of

-                              Meta _ -> ppTerm q d e <> ppEnv env

-                              _      -> ppTerm q d e ---- ++ prEnv env ---- for debugging

-ppValue q d (VRecType xs) = braces (hsep (punctuate ',' [l <> '=' <> ppValue q 0 v | (l,v) <- xs]))

-ppValue q d VType         = pp "Type"

-

-ppConstrs :: Constraints -> [Doc]

-ppConstrs = map (\(v,w) -> braces (ppValue Unqualified 0 v <+> "<>" <+> ppValue Unqualified 0 w))

-

-ppEnv :: Env -> Doc

-ppEnv e = hcat (map (\(x,t) -> braces (x <> ":=" <> ppValue Unqualified 0 t)) e)

-

-str s = doubleQuotes s

-

-ppDecl q (_,id,typ)

-  | id == identW = ppTerm q 3 typ

-  | otherwise    = parens (id <+> ':' <+> ppTerm q 0 typ)

-

-ppDDecl q (_,id,typ)

-  | id == identW = ppTerm q 6 typ

-  | otherwise    = parens (id <+> ':' <+> ppTerm q 0 typ)

-

-ppQIdent :: TermPrintQual -> QIdent -> Doc

-ppQIdent q (m,id) =

-  case q of

-    Terse       ->          pp id

-    Unqualified ->          pp id

-    Qualified   -> m <> '.' <> id

-    Internal    -> m <> '.' <> id

-    

-

-instance Pretty Label where pp = pp . label2ident

-

-ppOpenSpec (OSimple id)   = pp id

-ppOpenSpec (OQualif id n) = parens (id <+> '=' <+> n)

-

-ppInstSpec (id,n) = parens (id <+> '=' <+> n)

-

-ppLocDef q (id, (mbt, e)) =

-  id <+>

-  (case mbt of {Just t -> ':' <+> ppTerm q 0 t; Nothing -> empty} <+> '=' <+> ppTerm q 0 e) <+> ';'

-

-ppBind (Explicit,v) = pp v

-ppBind (Implicit,v) = braces v

-

-ppAltern q (x,y) = ppTerm q 0 x <+> '/' <+> ppTerm q 0 y

-

-ppParams q ps = fsep (intersperse (pp '|') (map (ppParam q) ps))

-ppParam q (id,cxt) = id <+> hsep (map (ppDDecl q) cxt)

-

-ppProduction (Production fid funid args) =

-  ppFId fid <+> "->" <+> ppFunId funid <> 

-  brackets (hcat (punctuate "," (map (hsep . intersperse (pp '|') . map ppFId) args)))

-

-ppSequences q seqsArr

-  | null seqs || q /= Internal = empty

-  | otherwise                  = "sequences" <+> '{' $$

-                                 nest 2 (vcat (map ppSeq seqs)) $$

-                                 '}'

-  where

-    seqs = Array.assocs seqsArr

-

-commaPunct f ds = (hcat (punctuate "," (map f ds)))

-

-prec d1 d2 doc

-  | d1 > d2   = parens doc

-  | otherwise = doc

-

-getAbs :: Term -> ([(BindType,Ident)], Term)

-getAbs (Abs bt v e) = let (xs,e') = getAbs e

-                      in ((bt,v):xs,e')

-getAbs e            = ([],e)

-

-getCTable :: Term -> ([Ident], Term)

-getCTable (T TRaw [(PV v,e)]) = let (vs,e') = getCTable e

-                                in (v:vs,e')

-getCTable (T TRaw [(PW,  e)]) = let (vs,e') = getCTable e

-                                in (identW:vs,e')

-getCTable e                   = ([],e)

-

-getLet :: Term -> ([LocalDef], Term)

-getLet (Let l e) = let (ls,e') = getLet e

-                   in (l:ls,e')

-getLet e         = ([],e)

-

+----------------------------------------------------------------------
+-- |
+-- Module      : GF.Grammar.Printer
+-- Maintainer  : Krasimir Angelov
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-----------------------------------------------------------------------------
+
+{-# LANGUAGE FlexibleContexts #-}
+module GF.Grammar.Printer
+           ( -- ** Pretty printing
+             TermPrintQual(..)
+           , ppModule
+           , ppJudgement
+           , ppParams
+           , ppTerm
+           , ppPatt
+           , ppValue
+           , ppConstrs
+           , ppQIdent
+           , ppMeta
+           , getAbs
+           ) where
+import Prelude hiding ((<>)) -- GHC 8.4.1 clash with Text.PrettyPrint
+
+import GF.Infra.Ident
+import GF.Infra.Option
+import GF.Grammar.Values
+import GF.Grammar.Grammar
+
+import PGF.Internal (ppMeta, ppLit, ppFId, ppFunId, ppSeqId, ppSeq)
+
+import GF.Text.Pretty
+import Data.Maybe (isNothing)
+import Data.List  (intersperse)
+import qualified Data.Map as Map
+--import qualified Data.IntMap as IntMap
+--import qualified Data.Set as Set
+import qualified Data.Array.IArray as Array
+
+data TermPrintQual
+  = Terse | Unqualified | Qualified | Internal
+  deriving Eq
+
+instance Pretty Grammar where
+  pp = vcat . map (ppModule Qualified) . modules
+
+ppModule :: TermPrintQual -> SourceModule -> Doc
+ppModule q (mn, ModInfo mtype mstat opts exts with opens _ _ mseqs jments) =
+    hdr $$
+    nest 2 (ppOptions opts $$
+            vcat (map (ppJudgement q) (Map.toList jments)) $$
+            maybe empty (ppSequences q) mseqs) $$
+    ftr
+    where
+      hdr = complModDoc <+> modTypeDoc <+> '=' <+>
+            hsep (intersperse (pp "**") $
+                  filter (not . isEmpty)  $ [ commaPunct ppExtends exts
+                                            , maybe empty ppWith with
+                                            , if null opens
+                                                then pp '{'
+                                                else "open" <+> commaPunct ppOpenSpec opens <+> "in" <+> '{'
+                                            ])
+
+      ftr = '}'
+
+      complModDoc =
+        case mstat of
+          MSComplete   -> empty
+          MSIncomplete -> pp "incomplete"
+
+      modTypeDoc =
+        case mtype of
+          MTAbstract         -> "abstract"  <+> mn
+          MTResource         -> "resource"  <+> mn
+          MTConcrete abs     -> "concrete"  <+> mn <+> "of" <+> abs
+          MTInterface        -> "interface" <+> mn
+          MTInstance ie      -> "instance"  <+> mn <+> "of" <+> ppExtends ie
+
+      ppExtends (id,MIAll        ) = pp id
+      ppExtends (id,MIOnly   incs) = id         <+> brackets (commaPunct pp incs)
+      ppExtends (id,MIExcept incs) = id <+> '-' <+> brackets (commaPunct pp incs)
+
+      ppWith (id,ext,opens) = ppExtends (id,ext) <+> "with" <+> commaPunct ppInstSpec opens
+
+ppOptions opts =
+  "flags" $$
+  nest 2 (vcat [option <+> '=' <+> ppLit value <+> ';' | (option,value) <- optionsGFO opts])
+
+ppJudgement q (id, AbsCat pcont ) =
+  "cat" <+> id <+>
+  (case pcont of
+     Just (L _ cont) -> hsep (map (ppDecl q) cont)
+     Nothing         -> empty) <+> ';'
+ppJudgement q (id, AbsFun ptype _ pexp poper) =
+  let kind | isNothing pexp      = "data"
+           | poper == Just False = "oper"
+           | otherwise           = "fun"
+  in
+  (case ptype of
+     Just (L _ typ) -> kind <+> id <+> ':' <+> ppTerm q 0 typ <+> ';'
+     Nothing        -> empty) $$
+  (case pexp of
+     Just []  -> empty
+     Just eqs -> "def" <+> vcat [id <+> hsep (map (ppPatt q 2) ps) <+> '=' <+> ppTerm q 0 e <+> ';' | L _ (ps,e) <- eqs]
+     Nothing  -> empty)
+ppJudgement q (id, ResParam pparams _) =
+  "param" <+> id <+>
+  (case pparams of
+     Just (L _ ps) -> '=' <+> ppParams q ps
+     _             -> empty) <+> ';'
+ppJudgement q (id, ResValue pvalue) =
+  "-- param constructor" <+> id <+> ':' <+>
+  (case pvalue of
+     (L _ ty) -> ppTerm q 0 ty) <+> ';'
+ppJudgement q (id, ResOper  ptype pexp) =
+  "oper" <+> id <+>
+  (case ptype of {Just (L _ t) -> ':'  <+> ppTerm q 0 t; Nothing -> empty} $$
+   case pexp  of {Just (L _ e) -> '=' <+> ppTerm q 0 e; Nothing -> empty}) <+> ';'
+ppJudgement q (id, ResOverload ids defs) =
+  "oper" <+> id <+> '=' <+>
+  ("overload" <+> '{' $$
+   nest 2 (vcat [id <+> (':' <+> ppTerm q 0 ty $$ '=' <+> ppTerm q 0 e <+> ';') | (L _ ty,L _ e) <- defs]) $$
+   '}') <+> ';'
+ppJudgement q (id, CncCat pcat pdef pref pprn mpmcfg) =
+  (case pcat of
+     Just (L _ typ) -> "lincat" <+> id <+> '=' <+> ppTerm q 0 typ <+> ';'
+     Nothing        -> empty) $$
+  (case pdef of
+     Just (L _ exp) -> "lindef" <+> id <+> '=' <+> ppTerm q 0 exp <+> ';'
+     Nothing        -> empty) $$
+  (case pref of
+     Just (L _ exp) -> "linref" <+> id <+> '=' <+> ppTerm q 0 exp <+> ';'
+     Nothing        -> empty) $$
+  (case pprn of
+     Just (L _ prn) -> "printname" <+> id <+> '=' <+> ppTerm q 0 prn <+> ';'
+     Nothing        -> empty) $$
+  (case (mpmcfg,q) of
+     (Just (PMCFG prods funs),Internal)
+                    -> "pmcfg" <+> id <+> '=' <+> '{' $$
+                       nest 2 (vcat (map ppProduction prods) $$
+                               ' ' $$
+                               vcat (map (\(funid,arr) -> ppFunId funid <+> ":=" <+>
+                                                          parens (hcat (punctuate ',' (map ppSeqId (Array.elems arr)))))
+                                         (Array.assocs funs))) $$
+                       '}'
+     _              -> empty)
+ppJudgement q (id, CncFun  ptype pdef pprn mpmcfg) =
+  (case pdef of
+     Just (L _ e) -> let (xs,e') = getAbs e
+                     in "lin" <+> id <+> hsep (map ppBind xs) <+> '=' <+> ppTerm q 0 e' <+> ';'
+     Nothing      -> empty) $$
+  (case pprn of
+     Just (L _ prn) -> "printname" <+> id <+> '=' <+> ppTerm q 0 prn <+> ';'
+     Nothing        -> empty) $$
+  (case (mpmcfg,q) of
+     (Just (PMCFG prods funs),Internal)
+                    -> "pmcfg" <+> id <+> '=' <+> '{' $$
+                       nest 2 (vcat (map ppProduction prods) $$
+                               ' ' $$
+                               vcat (map (\(funid,arr) -> ppFunId funid <+> ":=" <+>
+                                                          parens (hcat (punctuate ',' (map ppSeqId (Array.elems arr)))))
+                                         (Array.assocs funs))) $$
+                       '}'
+     _              -> empty)
+ppJudgement q (id, AnyInd cann mid) =
+  case q of
+    Internal -> "ind" <+> id <+> '=' <+> (if cann then pp "canonical" else empty) <+> mid <+> ';'
+    _        -> empty
+
+instance Pretty Term where pp = ppTerm Unqualified 0
+
+ppTerm q d (Abs b v e)   = let (xs,e') = getAbs (Abs b v e)
+                           in prec d 0 ('\\' <> commaPunct ppBind xs <+> "->" <+> ppTerm q 0 e')
+ppTerm q d (T TRaw xs) = case getCTable (T TRaw xs) of
+                           ([],_) -> "table" <+> '{' $$
+                                       nest 2 (vcat (punctuate ';' (map (ppCase q) xs))) $$
+                                     '}'
+                           (vs,e) -> prec d 0 ("\\\\" <> commaPunct pp vs <+> "=>" <+> ppTerm q 0 e)
+ppTerm q d (T (TTyped t) xs) = "table" <+> ppTerm q 0 t <+> '{' $$
+                                 nest 2 (vcat (punctuate ';' (map (ppCase q) xs))) $$
+                                '}'
+ppTerm q d (T (TComp  t) xs) = "table" <+> ppTerm q 0 t <+> '{' $$
+                                 nest 2 (vcat (punctuate ';' (map (ppCase q) xs))) $$
+                               '}'
+ppTerm q d (T (TWild  t) xs) = "table" <+> ppTerm q 0 t <+> '{' $$
+                                 nest 2 (vcat (punctuate ';' (map (ppCase q) xs))) $$
+                                '}'
+ppTerm q d (Prod bt x a b)= if x == identW && bt == Explicit
+                              then prec d 0 (ppTerm q 4 a <+> "->" <+> ppTerm q 0 b)
+                              else prec d 0 (parens (ppBind (bt,x) <+> ':' <+> ppTerm q 0 a) <+> "->" <+> ppTerm q 0 b)
+ppTerm q d (Table kt vt)=prec d 0 (ppTerm q 3 kt <+> "=>" <+> ppTerm q 0 vt)
+ppTerm q d (Let l e)    = let (ls,e') = getLet e
+                          in prec d 0 ("let" <+> vcat (map (ppLocDef q) (l:ls)) $$ "in" <+> ppTerm q 0 e')
+ppTerm q d (Example e s)=prec d 0 ("in" <+> ppTerm q 5 e <+> str s)
+ppTerm q d (C e1 e2)    =prec d 1 (hang (ppTerm q 2 e1) 2 ("++" <+> ppTerm q 1 e2))
+ppTerm q d (Glue e1 e2) =prec d 2 (ppTerm q 3 e1 <+> '+'  <+> ppTerm q 2 e2)
+ppTerm q d (S x y)     = case x of
+                           T annot xs -> let e = case annot of
+                                                   TRaw     -> y
+                                                   TTyped t -> Typed y t
+                                                   TComp  t -> Typed y t
+                                                   TWild  t -> Typed y t
+                                         in "case" <+> ppTerm q 0 e <+>"of" <+> '{' $$
+                                            nest 2 (vcat (punctuate ';' (map (ppCase q) xs))) $$
+                                           '}'
+                           _          -> prec d 3 (hang (ppTerm q 3 x) 2 ("!" <+> ppTerm q 4 y))
+ppTerm q d (ExtR x y)  = prec d 3 (ppTerm q 3 x <+> "**" <+> ppTerm q 4 y)
+ppTerm q d (App x y)   = prec d 4 (ppTerm q 4 x <+> ppTerm q 5 y)
+ppTerm q d (V e es)    = hang "table" 2 (sep [ppTerm q 6 e,brackets (fsep (punctuate ';' (map (ppTerm q 0) es)))])
+ppTerm q d (FV es)     = prec d 4 ("variants" <+> braces (fsep (punctuate ';' (map (ppTerm q 0) es))))
+ppTerm q d (AdHocOverload es)     = "overload" <+> braces (fsep (punctuate ';' (map (ppTerm q 0) es)))
+ppTerm q d (Alts e xs) = prec d 4 ("pre" <+> braces (ppTerm q 0 e <> ';' <+> fsep (punctuate ';' (map (ppAltern q) xs))))
+ppTerm q d (Strs es)   = "strs" <+> braces (fsep (punctuate ';' (map (ppTerm q 0) es)))
+ppTerm q d (EPatt p)   = prec d 4 ('#' <+> ppPatt q 2 p)
+ppTerm q d (EPattType t)=prec d 4 ("pattern" <+> ppTerm q 0 t)
+ppTerm q d (P t l)     = prec d 5 (ppTerm q 5 t <> '.' <> l)
+ppTerm q d (Cn id)     = pp id
+ppTerm q d (Vr id)     = pp id
+ppTerm q d (Q  id)     = ppQIdent q id
+ppTerm q d (QC id)     = ppQIdent q id
+ppTerm q d (Sort id)   = pp id
+ppTerm q d (K s)       = str s
+ppTerm q d (EInt n)    = pp n
+ppTerm q d (EFloat f)  = pp f
+ppTerm q d (Meta i)    = ppMeta i
+ppTerm q d (Empty)     = pp "[]"
+ppTerm q d (R [])      = pp "<>" -- to distinguish from {} empty RecType
+ppTerm q d (R xs)      = braces (fsep (punctuate ';' [l <+>
+                                                       fsep [case mb_t of {Just t -> ':' <+> ppTerm q 0 t; Nothing -> empty},
+                                                             '=' <+> ppTerm q 0 e] | (l,(mb_t,e)) <- xs]))
+ppTerm q d (RecType xs)
+  | q == Terse         = case [cat | (l,_) <- xs, let (p,cat) = splitAt 5 (showIdent (label2ident l)), p == "lock_"] of
+                           [cat] -> pp cat
+                           _     -> doc
+  | otherwise          = doc
+  where
+    doc = braces (fsep (punctuate ';' [l <+> ':' <+> ppTerm q 0 t | (l,t) <- xs]))
+ppTerm q d (Typed e t) = '<' <> ppTerm q 0 e <+> ':' <+> ppTerm q 0 t <> '>'
+ppTerm q d (ImplArg e) = braces (ppTerm q 0 e)
+ppTerm q d (ELincat cat t) = prec d 4 ("lincat" <+> cat <+> ppTerm q 5 t)
+ppTerm q d (ELin cat t) = prec d 4 ("lin" <+> cat <+> ppTerm q 5 t)
+ppTerm q d (Error s)   = prec d 4 ("Predef.error" <+> str s)
+
+ppEquation q (ps,e) = hcat (map (ppPatt q 2) ps) <+> "->" <+> ppTerm q 0 e
+
+ppCase q (p,e) = ppPatt q 0 p <+> "=>" <+> ppTerm q 0 e
+
+instance Pretty Patt where pp = ppPatt Unqualified 0
+
+ppPatt q d (PAlt p1 p2) = prec d 0 (ppPatt q 0 p1 <+> '|' <+> ppPatt q 1 p2)
+ppPatt q d (PSeq p1 p2) = prec d 0 (ppPatt q 0 p1 <+> '+' <+> ppPatt q 1 p2)
+ppPatt q d (PMSeq (_,p1) (_,p2)) = prec d 0 (ppPatt q 0 p1 <+> '+' <+> ppPatt q 1 p2)
+ppPatt q d (PC f ps)    = if null ps
+                            then pp f
+                            else prec d 1 (f <+> hsep (map (ppPatt q 3) ps))
+ppPatt q d (PP f ps)    = if null ps
+                            then ppQIdent q f
+                            else prec d 1 (ppQIdent q f <+> hsep (map (ppPatt q 3) ps))
+ppPatt q d (PRep p)     = prec d 1 (ppPatt q 3 p <> '*')
+ppPatt q d (PAs f p)    = prec d 2 (f <> '@' <> ppPatt q 3 p)
+ppPatt q d (PNeg p)     = prec d 2 ('-' <> ppPatt q 3 p)
+ppPatt q d (PChar)      = pp '?'
+ppPatt q d (PChars s)   = brackets (str s)
+ppPatt q d (PMacro id)  = '#' <> id
+ppPatt q d (PM id)      = '#' <> ppQIdent q id
+ppPatt q d PW           = pp '_'
+ppPatt q d (PV id)      = pp id
+ppPatt q d (PInt n)     = pp n
+ppPatt q d (PFloat f)   = pp f
+ppPatt q d (PString s)  = str s
+ppPatt q d (PR xs)      = braces (hsep (punctuate ';' [l <+> '=' <+> ppPatt q 0 e | (l,e) <- xs]))
+ppPatt q d (PImplArg p) = braces (ppPatt q 0 p)
+ppPatt q d (PTilde t)   = prec d 2 ('~' <> ppTerm q 6 t)
+
+ppValue :: TermPrintQual -> Int -> Val -> Doc
+ppValue q d (VGen i x)    = x <> "{-" <> i <> "-}" ---- latter part for debugging
+ppValue q d (VApp u v)    = prec d 4 (ppValue q 4 u <+> ppValue q 5 v)
+ppValue q d (VCn (_,c))   = pp c
+ppValue q d (VClos env e) = case e of
+                              Meta _ -> ppTerm q d e <> ppEnv env
+                              _      -> ppTerm q d e ---- ++ prEnv env ---- for debugging
+ppValue q d (VRecType xs) = braces (hsep (punctuate ',' [l <> '=' <> ppValue q 0 v | (l,v) <- xs]))
+ppValue q d VType         = pp "Type"
+
+ppConstrs :: Constraints -> [Doc]
+ppConstrs = map (\(v,w) -> braces (ppValue Unqualified 0 v <+> "<>" <+> ppValue Unqualified 0 w))
+
+ppEnv :: Env -> Doc
+ppEnv e = hcat (map (\(x,t) -> braces (x <> ":=" <> ppValue Unqualified 0 t)) e)
+
+str s = doubleQuotes s
+
+ppDecl q (_,id,typ)
+  | id == identW = ppTerm q 3 typ
+  | otherwise    = parens (id <+> ':' <+> ppTerm q 0 typ)
+
+ppDDecl q (_,id,typ)
+  | id == identW = ppTerm q 6 typ
+  | otherwise    = parens (id <+> ':' <+> ppTerm q 0 typ)
+
+ppQIdent :: TermPrintQual -> QIdent -> Doc
+ppQIdent q (m,id) =
+  case q of
+    Terse       ->          pp id
+    Unqualified ->          pp id
+    Qualified   -> m <> '.' <> id
+    Internal    -> m <> '.' <> id
+
+
+instance Pretty Label where pp = pp . label2ident
+
+ppOpenSpec (OSimple id)   = pp id
+ppOpenSpec (OQualif id n) = parens (id <+> '=' <+> n)
+
+ppInstSpec (id,n) = parens (id <+> '=' <+> n)
+
+ppLocDef q (id, (mbt, e)) =
+  id <+>
+  (case mbt of {Just t -> ':' <+> ppTerm q 0 t; Nothing -> empty} <+> '=' <+> ppTerm q 0 e) <+> ';'
+
+ppBind (Explicit,v) = pp v
+ppBind (Implicit,v) = braces v
+
+ppAltern q (x,y) = ppTerm q 0 x <+> '/' <+> ppTerm q 0 y
+
+ppParams q ps = fsep (intersperse (pp '|') (map (ppParam q) ps))
+ppParam q (id,cxt) = id <+> hsep (map (ppDDecl q) cxt)
+
+ppProduction (Production fid funid args) =
+  ppFId fid <+> "->" <+> ppFunId funid <>
+  brackets (hcat (punctuate "," (map (hsep . intersperse (pp '|') . map ppFId) args)))
+
+ppSequences q seqsArr
+  | null seqs || q /= Internal = empty
+  | otherwise                  = "sequences" <+> '{' $$
+                                 nest 2 (vcat (map ppSeq seqs)) $$
+                                 '}'
+  where
+    seqs = Array.assocs seqsArr
+
+commaPunct f ds = (hcat (punctuate "," (map f ds)))
+
+prec d1 d2 doc
+  | d1 > d2   = parens doc
+  | otherwise = doc
+
+getAbs :: Term -> ([(BindType,Ident)], Term)
+getAbs (Abs bt v e) = let (xs,e') = getAbs e
+                      in ((bt,v):xs,e')
+getAbs e            = ([],e)
+
+getCTable :: Term -> ([Ident], Term)
+getCTable (T TRaw [(PV v,e)]) = let (vs,e') = getCTable e
+                                in (v:vs,e')
+getCTable (T TRaw [(PW,  e)]) = let (vs,e') = getCTable e
+                                in (identW:vs,e')
+getCTable e                   = ([],e)
+
+getLet :: Term -> ([LocalDef], Term)
+getLet (Let l e) = let (ls,e') = getLet e
+                   in (l:ls,e')
+getLet e         = ([],e)
diff --git a/src/compiler/GF/Grammar/Values.hs b/src/compiler/GF/Grammar/Values.hs
index 3cfd79ad7..c8fcb3945 100644
--- a/src/compiler/GF/Grammar/Values.hs
+++ b/src/compiler/GF/Grammar/Values.hs
@@ -5,22 +5,23 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/04/21 16:22:32 $ 
+-- > CVS $Date: 2005/04/21 16:22:32 $
 -- > CVS $Author: bringert $
 -- > CVS $Revision: 1.7 $
 --
 -- (Description of the module)
 -----------------------------------------------------------------------------
 
-module GF.Grammar.Values (-- ** Values used in TC type checking
-	       Val(..), Env,
-	       -- ** Annotated tree used in editing
+module GF.Grammar.Values (
+               -- ** Values used in TC type checking
+               Val(..), Env,
+               -- ** Annotated tree used in editing
                Binds, Constraints, MetaSubst,
-	       -- ** For TC
-	       valAbsInt, valAbsFloat, valAbsString, vType,
-	       isPredefCat,
-	       eType, 
-	      ) where
+               -- ** For TC
+               valAbsInt, valAbsFloat, valAbsString, vType,
+               isPredefCat,
+               eType,
+              ) where
 
 import GF.Infra.Ident
 import GF.Grammar.Grammar