From bfcab16de603a33ffef7f3da1174844f0ab11daa Mon Sep 17 00:00:00 2001
From: Inari Listenmaa <inari.listenmaa@gmail.com>
Date: Sat, 6 Jun 2020 11:35:05 +0200
Subject: Hotfix for https://github.com/GrammaticalFramework/gf-core/issues/56

---
 src/compiler/GF/Compile/Rename.hs | 22 +++++++++++++++++++++-
 1 file changed, 21 insertions(+), 1 deletion(-)

(limited to 'src')

diff --git a/src/compiler/GF/Compile/Rename.hs b/src/compiler/GF/Compile/Rename.hs
index 5eb83cd4b..c12fd862c 100644
--- a/src/compiler/GF/Compile/Rename.hs
+++ b/src/compiler/GF/Compile/Rename.hs
@@ -39,6 +39,7 @@ import GF.Data.Operations
 
 import Control.Monad
 import Data.List (nub,(\\))
+import qualified Data.List as L
 import qualified Data.Map as Map
 import Data.Maybe(mapMaybe)
 import GF.Text.Pretty
@@ -105,7 +106,26 @@ renameIdentTerm' env@(act,imps) t0 =
                               ts@(t:_) -> do checkWarn ("atomic term" <+> ppTerm Qualified 0 t0 $$
                                                         "conflict" <+> hsep (punctuate ',' (map (ppTerm Qualified 0) ts)) $$
                                                         "given" <+> fsep (punctuate ',' (map fst qualifs)))
-                                             return t
+                                             return (bestTerm ts) -- Heuristic for resource grammar. Returns t for all others.
+       where
+        -- Hotfix for https://github.com/GrammaticalFramework/gf-core/issues/56
+        -- Real bug is probably somewhere deeper in recognising excluded functions. /IL 2020-06-06
+        notFromCommonModule :: Term -> Bool
+        notFromCommonModule term =
+          let t = render $ ppTerm Qualified 0 term :: String
+           in not $ any (\moduleName -> moduleName `L.isPrefixOf` t)
+                        ["CommonX", "ConstructX", "ExtendFunctor"
+                        ,"MarkHTMLX", "ParamX", "TenseX", "TextX"]
+
+        -- If one of the terms comes from the common modules,
+        -- we choose the other one, because that's defined in the grammar.
+        bestTerm :: [Term] -> Term
+        bestTerm [] = error "constant not found" -- not reached: bestTerm is only called for case ts@(t:_)
+        bestTerm ts@(t:_) =
+          let notCommon = [t | t <- ts, notFromCommonModule t]
+           in case notCommon of
+                []    -> t -- All terms are from common modules, return first of original list
+                (u:_) -> u -- ≥1 terms are not from common modules, return first of those
 
 info2status :: Maybe ModuleName -> Ident -> Info -> StatusInfo
 info2status mq c i = case i of
-- 
cgit v1.2.3


From ac81b418d61e150376485a5956421e8e6967a651 Mon Sep 17 00:00:00 2001
From: Liyana <nliyanaam@smu.edu.sg>
Date: Tue, 10 Nov 2020 16:57:33 +0800
Subject: Added readJSON error messages

---
 src/compiler/SimpleEditor/JSON.hs | 19 ++++++++++++++++---
 1 file changed, 16 insertions(+), 3 deletions(-)

(limited to 'src')

diff --git a/src/compiler/SimpleEditor/JSON.hs b/src/compiler/SimpleEditor/JSON.hs
index 8f607dc84..06586c5eb 100644
--- a/src/compiler/SimpleEditor/JSON.hs
+++ b/src/compiler/SimpleEditor/JSON.hs
@@ -9,14 +9,24 @@ instance JSON Grammar where
   showJSON (Grammar name extends abstract concretes) =
     makeObj ["basename".=name, "extends".=extends,
              "abstract".=abstract, "concretes".=concretes]
+  readJSON = error "Grammar.readJSON intentionally not defined"
 
 instance JSON Abstract where
   showJSON (Abstract startcat cats funs) =
     makeObj ["startcat".=startcat, "cats".=cats, "funs".=funs]
+  readJSON = error "Abstract.readJSON intentionally not defined"
 
-instance JSON Fun   where showJSON (Fun   name typ) = signature  name typ
-instance JSON Param where showJSON (Param name rhs) = definition name rhs
-instance JSON Oper  where showJSON (Oper  name rhs) = definition name rhs
+instance JSON Fun where 
+  showJSON (Fun   name typ) = signature  name typ
+  readJSON = error "Fun.readJSON intentionally not defined"
+
+instance JSON Param where 
+  showJSON (Param name rhs) = definition name rhs
+  readJSON = error "Param.readJSON intentionally not defined"
+
+instance JSON Oper where 
+  showJSON (Oper  name rhs) = definition name rhs
+  readJSON = error "Oper.readJSON intentionally not defined"
 
 signature  name typ = makeObj ["name".=name,"type".=typ]
 definition name rhs = makeObj ["name".=name,"rhs".=rhs]
@@ -26,12 +36,15 @@ instance JSON Concrete where
     makeObj ["langcode".=langcode, "opens".=opens,
               "params".=params, "opers".=opers,
              "lincats".=lincats, "lins".=lins]
+  readJSON = error "Concrete.readJSON intentionally not defined"
 
 instance JSON Lincat where
   showJSON (Lincat cat lintype) = makeObj ["cat".=cat, "type".=lintype]
+  readJSON = error "Lincat.readJSON intentionally not defined"
 
 instance JSON Lin where
   showJSON (Lin fun args lin) = makeObj ["fun".=fun, "args".=args, "lin".=lin]
+  readJSON = error "Lin.readJSON intentionally not defined"
 
 infix 1 .=
 name .= v = (name,showJSON v)
-- 
cgit v1.2.3


From dc6dd988bc77bc95bc5a5855e1031f4169c1b4b8 Mon Sep 17 00:00:00 2001
From: Liyana <nliyanaam@smu.edu.sg>
Date: Tue, 10 Nov 2020 17:01:47 +0800
Subject: Replaced inlinePerformIO with accursedUnutterablePerformIO

---
 src/runtime/haskell/Data/Binary/Builder.hs | 4 ++--
 src/runtime/haskell/Data/Binary/Get.hs     | 2 +-
 2 files changed, 3 insertions(+), 3 deletions(-)

(limited to 'src')

diff --git a/src/runtime/haskell/Data/Binary/Builder.hs b/src/runtime/haskell/Data/Binary/Builder.hs
index b69371f0e..a74428f20 100644
--- a/src/runtime/haskell/Data/Binary/Builder.hs
+++ b/src/runtime/haskell/Data/Binary/Builder.hs
@@ -68,7 +68,7 @@ import qualified Data.ByteString.Lazy as L
 import Data.ByteString.Base (inlinePerformIO)
 import qualified Data.ByteString.Base as S
 #else
-import Data.ByteString.Internal (inlinePerformIO)
+import Data.ByteString.Internal (accursedUnutterablePerformIO)
 import qualified Data.ByteString.Internal as S
 --import qualified Data.ByteString.Lazy.Internal as L
 #endif
@@ -199,7 +199,7 @@ defaultSize = 32 * k - overhead
 
 -- | Sequence an IO operation on the buffer
 unsafeLiftIO :: (Buffer -> IO Buffer) -> Builder
-unsafeLiftIO f =  Builder $ \ k buf -> inlinePerformIO $ do
+unsafeLiftIO f =  Builder $ \ k buf -> accursedUnutterablePerformIO $ do
     buf' <- f buf
     return (k buf')
 {-# INLINE unsafeLiftIO #-}
diff --git a/src/runtime/haskell/Data/Binary/Get.hs b/src/runtime/haskell/Data/Binary/Get.hs
index 01561d7d9..54f17ae95 100644
--- a/src/runtime/haskell/Data/Binary/Get.hs
+++ b/src/runtime/haskell/Data/Binary/Get.hs
@@ -423,7 +423,7 @@ readN n f = fmap f $ getBytes n
 getPtr :: Storable a => Int -> Get a
 getPtr n = do
     (fp,o,_) <- readN n B.toForeignPtr
-    return . B.inlinePerformIO $ withForeignPtr fp $ \p -> peek (castPtr $ p `plusPtr` o)
+    return . B.accursedUnutterablePerformIO $ withForeignPtr fp $ \p -> peek (castPtr $ p `plusPtr` o)
 {- INLINE getPtr -}
 
 ------------------------------------------------------------------------
-- 
cgit v1.2.3


From 33aad1b8de0b8387426155870c98adf35e400962 Mon Sep 17 00:00:00 2001
From: Liyana <nliyanaam@smu.edu.sg>
Date: Tue, 10 Nov 2020 17:06:35 +0800
Subject: Deleted redundant pattern match

---
 src/compiler/GF/Grammar/Canonical.hs | 1 -
 1 file changed, 1 deletion(-)

(limited to 'src')

diff --git a/src/compiler/GF/Grammar/Canonical.hs b/src/compiler/GF/Grammar/Canonical.hs
index 4adff02f2..0df3236ff 100644
--- a/src/compiler/GF/Grammar/Canonical.hs
+++ b/src/compiler/GF/Grammar/Canonical.hs
@@ -265,7 +265,6 @@ instance PPA LinPattern where
       RecordPattern r -> block r
       TuplePattern ps -> "<"<>punctuate "," ps<>">"
       WildPattern     -> pp "_"                
-      _ -> parens p
 
 instance RhsSeparator LinPattern where rhsSep _ = pp "="
 
-- 
cgit v1.2.3


From 4364b1d9fb62551fb6361be36cf2563e6d2d93a5 Mon Sep 17 00:00:00 2001
From: Liyana <nliyanaam@smu.edu.sg>
Date: Tue, 10 Nov 2020 17:11:41 +0800
Subject: Replaced Control.Monad.Error with Control.Monad.Except

---
 src/runtime/haskell/PGF/TypeCheck.hs | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

(limited to 'src')

diff --git a/src/runtime/haskell/PGF/TypeCheck.hs b/src/runtime/haskell/PGF/TypeCheck.hs
index 5db4ef439..c5cc44b4e 100644
--- a/src/runtime/haskell/PGF/TypeCheck.hs
+++ b/src/runtime/haskell/PGF/TypeCheck.hs
@@ -41,7 +41,7 @@ import Control.Applicative
 import Control.Monad
 --import Control.Monad.Identity
 import Control.Monad.State
-import Control.Monad.Error
+import Control.Monad.Except
 import Text.PrettyPrint
 
 -----------------------------------------------------
-- 
cgit v1.2.3


From 1f7584bf98346c6d044df631a82353fd1c5972af Mon Sep 17 00:00:00 2001
From: Liyana <nliyanaam@smu.edu.sg>
Date: Tue, 10 Nov 2020 17:14:31 +0800
Subject: Added explicit implementation for 'fromValue' in instance declaration
 for 'Predef Bool'

---
 src/compiler/GF/Compile/Compute/Predef.hs | 1 +
 1 file changed, 1 insertion(+)

(limited to 'src')

diff --git a/src/compiler/GF/Compile/Compute/Predef.hs b/src/compiler/GF/Compile/Compute/Predef.hs
index 609a17798..69df3792c 100644
--- a/src/compiler/GF/Compile/Compute/Predef.hs
+++ b/src/compiler/GF/Compile/Compute/Predef.hs
@@ -27,6 +27,7 @@ instance Predef Int where
 
 instance Predef Bool where
   toValue = boolV
+  fromValue boolV = return (boolV == boolV) 
 
 instance Predef String where
   toValue = string
-- 
cgit v1.2.3


From 8ca4baf470da2fd607d89e7679f7376a56b3f8fb Mon Sep 17 00:00:00 2001
From: Liyana <nliyanaam@smu.edu.sg>
Date: Tue, 10 Nov 2020 17:15:20 +0800
Subject: Deleted redundant pattern match

---
 src/compiler/GF/Compile/Compute/ConcreteNew.hs | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

(limited to 'src')

diff --git a/src/compiler/GF/Compile/Compute/ConcreteNew.hs b/src/compiler/GF/Compile/Compute/ConcreteNew.hs
index ea55e77cb..6f00c45e1 100644
--- a/src/compiler/GF/Compile/Compute/ConcreteNew.hs
+++ b/src/compiler/GF/Compile/Compute/ConcreteNew.hs
@@ -528,7 +528,7 @@ value2term' stop loc xs v0 =
 --  VGlue v1 v2    -> Glue (v2t v1) (v2t v2)
 --  VExtR v1 v2    -> ExtR (v2t v1) (v2t v2)
     VError err     -> return (Error err)
-    _              -> bug ("value2term "++show loc++" : "++show v0)
+  
   where
     v2t = v2txs xs
     v2txs = value2term' stop loc
-- 
cgit v1.2.3


From 54e5fb6645d4c99900136e7c909ca7905e441912 Mon Sep 17 00:00:00 2001
From: Liyana <nliyanaam@smu.edu.sg>
Date: Tue, 10 Nov 2020 17:19:18 +0800
Subject: Added explicit implementation for 'readJSON' in the instance
 declaration for 'JSON PGF.Trie'

---
 src/server/PGFService.hs | 1 +
 1 file changed, 1 insertion(+)

(limited to 'src')

diff --git a/src/server/PGFService.hs b/src/server/PGFService.hs
index e30ff8652..7edfa9c44 100644
--- a/src/server/PGFService.hs
+++ b/src/server/PGFService.hs
@@ -1024,6 +1024,7 @@ instance JSON PGF.Trie where
     showJSON (PGF.Ap f [[]]) = makeObj ["fun".=f] -- leaf
 --  showJSON (PGF.Ap f [es]) = makeObj ["fun".=f,"children".=es] -- one alternative
     showJSON (PGF.Ap f alts) = makeObj ["fun".=f,"alts".=alts]
+    readJSON = error "PGF.Trie.readJSON intentionally not defined"
 
 instance JSON PGF.CId where
     readJSON x = readJSON x >>= maybe (fail "Bad language.") return . PGF.readLanguage
-- 
cgit v1.2.3


From 9b02385e3efcadf39a171f65eaba871b1897360e Mon Sep 17 00:00:00 2001
From: Liyana <nliyanaam@smu.edu.sg>
Date: Tue, 10 Nov 2020 17:26:56 +0800
Subject: Removed fromValue for boolV

---
 src/compiler/GF/Compile/Compute/Predef.hs | 1 -
 1 file changed, 1 deletion(-)

(limited to 'src')

diff --git a/src/compiler/GF/Compile/Compute/Predef.hs b/src/compiler/GF/Compile/Compute/Predef.hs
index 69df3792c..609a17798 100644
--- a/src/compiler/GF/Compile/Compute/Predef.hs
+++ b/src/compiler/GF/Compile/Compute/Predef.hs
@@ -27,7 +27,6 @@ instance Predef Int where
 
 instance Predef Bool where
   toValue = boolV
-  fromValue boolV = return (boolV == boolV) 
 
 instance Predef String where
   toValue = string
-- 
cgit v1.2.3


From 2dc179239f915420a5e9485d87a2fa1adb413e4e Mon Sep 17 00:00:00 2001
From: Liyana <nliyanaam@smu.edu.sg>
Date: Tue, 10 Nov 2020 17:32:43 +0800
Subject: Replaced Control.Monad.Error with Control.Monad.Except

---
 src/compiler/GF/Server.hs | 13 +++++--------
 1 file changed, 5 insertions(+), 8 deletions(-)

(limited to 'src')

diff --git a/src/compiler/GF/Server.hs b/src/compiler/GF/Server.hs
index c287e8001..d930d277c 100644
--- a/src/compiler/GF/Server.hs
+++ b/src/compiler/GF/Server.hs
@@ -6,7 +6,7 @@ import qualified Data.Map as M
 import Control.Applicative -- for GHC<7.10
 import Control.Monad(when)
 import Control.Monad.State(StateT(..),get,gets,put)
-import Control.Monad.Error(ErrorT(..),Error(..))
+import Control.Monad.Except(ExceptT(..),Except(..),runExceptT)
 import System.Random(randomRIO)
 --import System.IO(stderr,hPutStrLn)
 import GF.System.Catch(try)
@@ -108,9 +108,9 @@ handle_fcgi execute1 state0 stateM cache =
 
 -- * Request handler
 -- | Handler monad
-type HM s a = StateT (Q,s) (ErrorT Response IO) a
+type HM s a = StateT (Q,s) (ExceptT Response IO) a
 run :: HM s Response -> (Q,s) -> IO (s,Response)
-run m s = either bad ok =<< runErrorT (runStateT m s)
+run m s = either bad ok =<< runExceptT (runStateT m s)
   where
     bad resp = return (snd s,resp)
     ok (resp,(qs,state)) = return (state,resp)
@@ -123,12 +123,12 @@ put_qs qs = do state <- get_state; put (qs,state)
 put_state state = do qs <- get_qs; put (qs,state)
 
 err :: Response -> HM s a
-err e = StateT $ \ s -> ErrorT $ return $ Left e
+err e = StateT $ \ s -> ExceptT $ return $ Left e
 
 hmbracket_ :: IO () -> IO () -> HM s a -> HM s a
 hmbracket_ pre post m =
     do s <- get
-       e <- liftIO $ bracket_ pre post $ runErrorT $ runStateT m s
+       e <- liftIO $ bracket_ pre post $ runExceptT $ runStateT m s
        case e of
          Left resp -> err resp
          Right (a,s) -> do put s;return a
@@ -407,9 +407,6 @@ resp404 path = Response 404 [plain,xo] $ "Not found: "++path++"\n"
 resp500 msg  = Response 500 [plain,xo] $ "Internal error: "++msg++"\n"
 resp501 msg  = Response 501 [plain,xo] $ "Not implemented: "++msg++"\n"
 
-instance Error Response where
-  noMsg = resp500 "no message"
-  strMsg = resp500
 
 -- * Content types
 plain = ct "text/plain" ""
-- 
cgit v1.2.3


From 76bec6d71e7c4fdffa2e618ec6578e0858166465 Mon Sep 17 00:00:00 2001
From: Liyana <nliyanaam@smu.edu.sg>
Date: Thu, 12 Nov 2020 09:48:15 +0800
Subject: Omitted import Except(..)

---
 src/compiler/GF/Server.hs | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

(limited to 'src')

diff --git a/src/compiler/GF/Server.hs b/src/compiler/GF/Server.hs
index d930d277c..2e8b8b056 100644
--- a/src/compiler/GF/Server.hs
+++ b/src/compiler/GF/Server.hs
@@ -6,7 +6,7 @@ import qualified Data.Map as M
 import Control.Applicative -- for GHC<7.10
 import Control.Monad(when)
 import Control.Monad.State(StateT(..),get,gets,put)
-import Control.Monad.Except(ExceptT(..),Except(..),runExceptT)
+import Control.Monad.Except(ExceptT(..),runExceptT)
 import System.Random(randomRIO)
 --import System.IO(stderr,hPutStrLn)
 import GF.System.Catch(try)
-- 
cgit v1.2.3


From b1ed63b089cbe0ba8530475ff6a1b2582de37d7e Mon Sep 17 00:00:00 2001
From: Andreas Källberg <anka.213@gmail.com>
Date: Wed, 16 Jun 2021 14:26:22 +0800
Subject: Don't print stack traces in Command.hs

They don't provide useful info anyways and they are needlessly verbose.
---
 src/compiler/GF/Command/Commands.hs | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

(limited to 'src')

diff --git a/src/compiler/GF/Command/Commands.hs b/src/compiler/GF/Command/Commands.hs
index 0e5c61404..48d8cb85a 100644
--- a/src/compiler/GF/Command/Commands.hs
+++ b/src/compiler/GF/Command/Commands.hs
@@ -741,7 +741,7 @@ pgfCommands = Map.fromList [
                                      Nothing   -> do putStrLn ("unknown category of function identifier "++show id)
                                                      return void
          [e]         -> case inferExpr pgf e of
-                          Left tcErr   -> error $ render (ppTcError tcErr)
+                          Left tcErr   -> errorWithoutStackTrace $ render (ppTcError tcErr)
                           Right (e,ty) -> do putStrLn ("Expression:  "++showExpr [] e)
                                              putStrLn ("Type:        "++showType [] ty)
                                              putStrLn ("Probability: "++show (probTree pgf e))
-- 
cgit v1.2.3


From 2c37e7dfad66bbfb13cef87fdcef479ce9fd9e93 Mon Sep 17 00:00:00 2001
From: Andreas Källberg <anka.213@gmail.com>
Date: Wed, 16 Jun 2021 14:54:36 +0800
Subject: Fix build for ghc-7.10.3

---
 src/compiler/GF/Command/Commands.hs | 6 +++++-
 1 file changed, 5 insertions(+), 1 deletion(-)

(limited to 'src')

diff --git a/src/compiler/GF/Command/Commands.hs b/src/compiler/GF/Command/Commands.hs
index 48d8cb85a..2f2e802e0 100644
--- a/src/compiler/GF/Command/Commands.hs
+++ b/src/compiler/GF/Command/Commands.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE FlexibleInstances, UndecidableInstances #-}
+{-# LANGUAGE FlexibleInstances, UndecidableInstances, CPP #-}
 module GF.Command.Commands (
   PGFEnv,HasPGFEnv(..),pgf,mos,pgfEnv,pgfCommands,
   options,flags,
@@ -1019,3 +1019,7 @@ stanzas = map unlines . chop . lines where
   chop ls = case break (=="") ls of
     (ls1,[])  -> [ls1]
     (ls1,_:ls2) -> ls1 : chop ls2
+
+#if !(MIN_VERSION_base(4,9,0))
+errorWithoutStackTrace = error
+#endif
\ No newline at end of file
-- 
cgit v1.2.3


From 1ba5449d210b2b5565e1a3179548cfb2df9fce1b Mon Sep 17 00:00:00 2001
From: "John J. Camilleri" <john@digitalgrammars.com>
Date: Thu, 24 Jun 2021 09:31:37 +0200
Subject: Update pgf.cabal, and minors to other cabal files

---
 gf.cabal                            |  4 ++--
 src/runtime/haskell-bind/pgf2.cabal |  3 +--
 src/runtime/haskell/pgf.cabal       | 30 +++++++++++++++---------------
 3 files changed, 18 insertions(+), 19 deletions(-)

(limited to 'src')

diff --git a/gf.cabal b/gf.cabal
index 608a5d636..9a9e3903e 100644
--- a/gf.cabal
+++ b/gf.cabal
@@ -72,7 +72,7 @@ flag c-runtime
   Description: Include functionality from the C run-time library (which must be installed already)
   Default:     False
 
-Library
+library
   default-language:    Haskell2010
   build-depends: base >= 4.6 && <5,
                  array,
@@ -320,7 +320,7 @@ Library
   if impl(ghc>=8.2)
     ghc-options: -fhide-source-paths
 
-Executable gf
+executable gf
   hs-source-dirs: src/programs
   main-is: gf-main.hs
   default-language:    Haskell2010
diff --git a/src/runtime/haskell-bind/pgf2.cabal b/src/runtime/haskell-bind/pgf2.cabal
index 91e77c77b..c8d5d8c6c 100644
--- a/src/runtime/haskell-bind/pgf2.cabal
+++ b/src/runtime/haskell-bind/pgf2.cabal
@@ -9,8 +9,7 @@ homepage: https://www.grammaticalframework.org
 license: LGPL-3
 license-file: LICENSE
 author: Krasimir Angelov
-maintainer: kr.angelov@gmail.com
-category: Language
+category: Natural Language Processing
 build-type: Simple
 extra-source-files: CHANGELOG.md, README.md
 cabal-version: >=1.10
diff --git a/src/runtime/haskell/pgf.cabal b/src/runtime/haskell/pgf.cabal
index 76e12bd2c..86faf8f01 100644
--- a/src/runtime/haskell/pgf.cabal
+++ b/src/runtime/haskell/pgf.cabal
@@ -1,5 +1,5 @@
 name: pgf
-version: 3.10
+version: 3.10.1-git
 
 cabal-version: >= 1.20
 build-type: Simple
@@ -9,20 +9,21 @@ synopsis: Grammatical Framework
 description: A library for interpreting the Portable Grammar Format (PGF)
 homepage: http://www.grammaticalframework.org/
 bug-reports: https://github.com/GrammaticalFramework/gf-core/issues
-maintainer: Thomas Hallgren
-tested-with: GHC==7.6.3, GHC==7.8.3, GHC==7.10.3, GHC==8.0.2
+tested-with: GHC==7.6.3, GHC==7.8.3, GHC==7.10.3, GHC==8.0.2, GHC=8.4.4
 
-Library
-  default-language:    Haskell2010
-  build-depends: base >= 4.6 && <5,
-                 array,
-                 containers,
-                 bytestring,
-                 utf8-string,
-                 random,
-                 pretty,
-                 mtl,
-                 exceptions
+library
+  default-language: Haskell2010
+  build-depends:
+    array,
+    base >= 4.6 && <5,
+    bytestring,
+    containers,
+    -- exceptions,
+    ghc-prim,
+    mtl,
+    pretty,
+    random,
+    utf8-string
 
   other-modules:
     -- not really part of GF but I have changed the original binary library
@@ -37,7 +38,6 @@ Library
 --if impl(ghc>=7.8)
 --  ghc-options: +RTS -A20M -RTS
   ghc-prof-options: -fprof-auto
-  extensions:
 
   exposed-modules:
     PGF
-- 
cgit v1.2.3


From 3a27fa0d390b86cab3ecc68418e4116ea5c4f8ba Mon Sep 17 00:00:00 2001
From: "John J. Camilleri" <john@digitalgrammars.com>
Date: Thu, 24 Jun 2021 09:34:27 +0200
Subject: Add another =

---
 src/runtime/haskell/pgf.cabal | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

(limited to 'src')

diff --git a/src/runtime/haskell/pgf.cabal b/src/runtime/haskell/pgf.cabal
index 86faf8f01..f829a6e35 100644
--- a/src/runtime/haskell/pgf.cabal
+++ b/src/runtime/haskell/pgf.cabal
@@ -9,7 +9,7 @@ synopsis: Grammatical Framework
 description: A library for interpreting the Portable Grammar Format (PGF)
 homepage: http://www.grammaticalframework.org/
 bug-reports: https://github.com/GrammaticalFramework/gf-core/issues
-tested-with: GHC==7.6.3, GHC==7.8.3, GHC==7.10.3, GHC==8.0.2, GHC=8.4.4
+tested-with: GHC==7.6.3, GHC==7.8.3, GHC==7.10.3, GHC==8.0.2, GHC==8.4.4
 
 library
   default-language: Haskell2010
-- 
cgit v1.2.3


From 0a70eca6e2913c462c5c65361131f3ed341e539d Mon Sep 17 00:00:00 2001
From: "John J. Camilleri" <john@digitalgrammars.com>
Date: Wed, 30 Jun 2021 10:58:23 +0200
Subject: Make GF.Grammar.Canonical.Id a type synonym for
 GF.Infra.Ident.RawIdent

This avoids a lot of conversion back and forth between Strings and ByteStrings

This commit was cherry-picked from d0c27cdaae78c670b098740bfb49b428d900e640 (lpgf branch)
---
 src/compiler/GF/Compile/ConcreteToHaskell.hs  | 47 +++++++++++++--------------
 src/compiler/GF/Compile/GrammarToCanonical.hs | 36 +++++++++++---------
 src/compiler/GF/Grammar/Canonical.hs          |  3 +-
 src/compiler/GF/Grammar/CanonicalJSON.hs      | 37 ++++++++++++---------
 src/compiler/GF/Infra/Ident.hs                | 39 +++++++++++-----------
 5 files changed, 86 insertions(+), 76 deletions(-)

(limited to 'src')

diff --git a/src/compiler/GF/Compile/ConcreteToHaskell.hs b/src/compiler/GF/Compile/ConcreteToHaskell.hs
index d74fcdacd..c9f0438e6 100644
--- a/src/compiler/GF/Compile/ConcreteToHaskell.hs
+++ b/src/compiler/GF/Compile/ConcreteToHaskell.hs
@@ -7,7 +7,7 @@ import GF.Text.Pretty
 --import GF.Grammar.Predef(cPredef,cInts)
 --import GF.Compile.Compute.Predef(predef)
 --import GF.Compile.Compute.Value(Predefined(..))
-import GF.Infra.Ident(Ident,identS,identW,prefixIdent)
+import GF.Infra.Ident(Ident,identC,identS,identW,prefixIdent,showRawIdent,rawIdentS)
 import GF.Infra.Option
 import GF.Haskell as H
 import GF.Grammar.Canonical as C
@@ -21,7 +21,7 @@ concretes2haskell opts absname gr =
      | let Grammar abstr cncs = grammar2canonical opts absname gr,
        cncmod<-cncs,
        let ModId name = concName cncmod
-           filename = name ++ ".hs" :: FilePath
+           filename = showRawIdent name ++ ".hs" :: FilePath
   ]
 
 -- | Generate Haskell code for the given concrete module.
@@ -53,7 +53,7 @@ concrete2haskell opts
     labels = S.difference (S.unions (map S.fromList recs)) common_labels
     common_records = S.fromList [[label_s]]
     common_labels = S.fromList [label_s]
-    label_s = LabelId "s"
+    label_s = LabelId (rawIdentS "s")
 
     signature (CatDef c _) = TypeSig lf (Fun abs (pure lin))
       where
@@ -69,7 +69,7 @@ concrete2haskell opts
       where
      --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
@@ -116,7 +116,7 @@ concrete2haskell opts
               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 -> 
+--          TupleType lts ->
 
     lincatDef (LincatDef c t) = tsyn0 (lincatName c) (convLinType t)
 
@@ -126,7 +126,7 @@ concrete2haskell opts
     linDefs = map eqn . sortOn fst . map linDef
       where eqn (cat,(f,(ps,rhs))) = (cat,Eqn (f,ps) rhs)
 
-    linDef (LinDef f xs rhs0) = 
+    linDef (LinDef f xs rhs0) =
         (cat,(linfunName cat,(lhs,rhs)))
       where
         lhs = [ConP (aId f) (map VarP abs_args)]
@@ -144,7 +144,7 @@ concrete2haskell opts
           where
             vs = [(VarValueId (Unqual x),a)|(VarId x,a)<-zip xs args]
             env= [(VarValueId (Unqual 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)))
 
@@ -187,7 +187,7 @@ concrete2haskell opts
 
         pId p@(ParamId s) =
           if "to_R_" `isPrefixOf` unqual 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'])
@@ -315,13 +315,13 @@ instance Records rhs => Records (TableRow rhs) where
 
 -- | Record subtyping is converted into explicit coercions in Haskell
 coerce env ty t =
-  case (ty,t) of 
+  case (ty,t) of
     (_,VariantValue ts) -> VariantValue (map (coerce env ty) ts)
     (TableType ti tv,TableValue _ cs) ->
       TableValue ti [TableRow p (coerce env tv t)|TableRow p t<-cs]
     (RecordType rt,RecordValue r) ->
       RecordValue [RecordRow l (coerce env ft f) |
-                     RecordRow l f<-r,ft<-[ft|RecordRow l' ft<-rt,l'==l]]
+                     RecordRow l f<-r,ft<-[ft | RecordRow l' ft <- rt, l'==l]]
     (RecordType rt,VarValue x)->
       case lookup x env of
         Just ty' | ty'/=ty -> -- better to compare to normal form of ty'
@@ -334,18 +334,17 @@ coerce env ty t =
     _ -> t
   where
     app f ts = ParamConstant (Param f ts) -- !! a hack
-    to_rcon = ParamId . Unqual . to_rcon' . labels
+    to_rcon = ParamId . Unqual . rawIdentS . to_rcon' . labels
 
 patVars p = []
 
-labels r = [l|RecordRow l _<-r]
+labels r = [l | RecordRow l _ <- r]
 
 proj = Var . identS . proj'
-proj' (LabelId l) = "proj_"++l
+proj' (LabelId l) = "proj_" ++ showRawIdent l
 rcon = Var . rcon'
 rcon' = identS . rcon_name
-rcon_name ls = "R"++concat (sort ['_':l|LabelId l<-ls])
-
+rcon_name ls = "R"++concat (sort ['_':showRawIdent l | LabelId l <- ls])
 to_rcon' = ("to_"++) . rcon_name
 
 recordType ls =
@@ -400,17 +399,17 @@ linfunName c = prefixIdent "lin" (toIdent c)
 
 class ToIdent i where toIdent :: i -> Ident
 
-instance ToIdent ParamId where toIdent (ParamId q) = qIdentS q
-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 q) = qIdentS q
+instance ToIdent ParamId where toIdent (ParamId q) = qIdentC q
+instance ToIdent PredefId where toIdent (PredefId s) = identC s
+instance ToIdent CatId   where toIdent (CatId s) = identC s
+instance ToIdent C.FunId where toIdent (FunId s) = identC s
+instance ToIdent VarValueId where toIdent (VarValueId q) = qIdentC q
 
-qIdentS = identS . unqual
+qIdentC = identS . unqual
 
-unqual (Qual (ModId m) n) = m++"_"++n
-unqual (Unqual n) = n
+unqual (Qual (ModId m) n) = showRawIdent m++"_"++ showRawIdent n
+unqual (Unqual n) = showRawIdent n
 
 instance ToIdent VarId where
   toIdent Anonymous = identW
-  toIdent (VarId s) = identS s
+  toIdent (VarId s) = identC s
diff --git a/src/compiler/GF/Compile/GrammarToCanonical.hs b/src/compiler/GF/Compile/GrammarToCanonical.hs
index 33f35ad08..2b701382c 100644
--- a/src/compiler/GF/Compile/GrammarToCanonical.hs
+++ b/src/compiler/GF/Compile/GrammarToCanonical.hs
@@ -16,7 +16,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,prefixIdent,showIdent,isWildIdent)
+import GF.Infra.Ident(ModuleName(..),Ident,ident2raw,rawIdentS,prefixIdent,showIdent,isWildIdent)
 import GF.Infra.Option(optionsPGF)
 import PGF.Internal(Literal(..))
 import GF.Compile.Compute.ConcreteNew(normalForm,resourceValues)
@@ -69,10 +69,10 @@ concretes2canonical opts absname gr =
 concrete2canonical gr cenv absname cnc modinfo =
   Concrete (modId cnc) (modId absname) (convFlags gr cnc)
       (neededParamTypes S.empty (params defs))
-      [lincat|(_,Left lincat)<-defs]
-      [lin|(_,Right lin)<-defs]
+      [lincat | (_,Left lincat) <- defs]
+      [lin | (_,Right lin) <- defs]
   where
-    defs = concatMap (toCanonical gr absname cenv) . 
+    defs = concatMap (toCanonical gr absname cenv) .
            M.toList $
            jments modinfo
 
@@ -188,8 +188,8 @@ convert' gr vs = ppT
         Ok ALL_CAPIT  -> p "ALL_CAPIT"
         _ -> VarValue (gQId cPredef n) -- hmm
       where
-       p = PredefValue . PredefId
-      
+       p = PredefValue . PredefId . rawIdentS
+
     ppP p =
       case p of
         PC c ps -> ParamPattern (Param (gId c) (map ppP ps))
@@ -247,7 +247,7 @@ projection r l = maybe (Projection r l) id (proj r l)
 
 proj r l =
   case r of
-    RecordValue r -> case [v|RecordRow l' v<-r,l'==l] of
+    RecordValue r -> case [v | RecordRow l' v <- r, l'==l] of
                           [v] -> Just v
                           _ -> Nothing
     _ -> Nothing
@@ -257,7 +257,7 @@ selection t v =
   -- Note: impossible cases can become possible after grammar transformation
   case t of
     TableValue tt r ->
-        case nub [rv|TableRow _ rv<-keep] of
+        case nub [rv | TableRow _ rv <- keep] of
           [rv] -> rv
           _ -> Selection (TableValue tt r') v
       where
@@ -357,16 +357,20 @@ paramType gr q@(_,n) =
     argTypes = S.unions . map argTypes1
     argTypes1 (n,ctx) = S.unions [paramTypes gr t|(_,_,t)<-ctx]
 
-lblId = LabelId . render -- hmm
-modId (MN m) = ModId (showIdent m)
+lblId :: Label -> C.LabelId
+lblId (LIdent ri) = LabelId ri
+lblId (LVar i) = LabelId (rawIdentS (show i)) -- hmm
+
+modId :: ModuleName -> C.ModId
+modId (MN m) = ModId (ident2raw m)
 
 class FromIdent i where gId :: Ident -> i
 
 instance FromIdent VarId where
-  gId i = if isWildIdent i then Anonymous else VarId (showIdent i)
+  gId i = if isWildIdent i then Anonymous else VarId (ident2raw i)
 
-instance FromIdent C.FunId where gId = C.FunId . showIdent
-instance FromIdent CatId where gId = CatId . showIdent
+instance FromIdent C.FunId where gId = C.FunId . ident2raw
+instance FromIdent CatId where gId = CatId . ident2raw
 instance FromIdent ParamId where gId = ParamId . unqual
 instance FromIdent VarValueId where gId = VarValueId . unqual
 
@@ -375,11 +379,11 @@ class FromIdent i => QualIdent i where gQId :: ModuleName -> Ident -> i
 instance QualIdent ParamId    where gQId m n = ParamId (qual m n)
 instance QualIdent VarValueId where gQId m n = VarValueId (qual m n)
 
-qual m n = Qual (modId m) (showIdent n)
-unqual n = Unqual (showIdent n)
+qual m n = Qual (modId m) (ident2raw n)
+unqual n = Unqual (ident2raw n)
 
 convFlags gr mn =
-  Flags [(n,convLit v) |
+  Flags [(rawIdentS n,convLit v) |
          (n,v)<-err (const []) (optionsPGF.mflags) (lookupModule gr mn)]
   where
     convLit l =
diff --git a/src/compiler/GF/Grammar/Canonical.hs b/src/compiler/GF/Grammar/Canonical.hs
index 0df3236ff..80e9f5e7b 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
@@ -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)
 
 --------------------------------------------------------------------------------
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/Infra/Ident.hs b/src/compiler/GF/Infra/Ident.hs
index b856d3995..ad47d91cd 100644
--- a/src/compiler/GF/Infra/Ident.hs
+++ b/src/compiler/GF/Infra/Ident.hs
@@ -5,7 +5,7 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/11/15 11:43:33 $ 
+-- > CVS $Date: 2005/11/15 11:43:33 $
 -- > CVS $Author: aarne $
 -- > CVS $Revision: 1.8 $
 --
@@ -13,18 +13,18 @@
 -----------------------------------------------------------------------------
 
 module GF.Infra.Ident (-- ** Identifiers
-              ModuleName(..), moduleNameS,
-	      Ident, ident2utf8, showIdent, prefixIdent,
-              -- *** Normal identifiers (returned by the parser)
-	      identS, identC, identW,
-              -- *** Special identifiers for internal use
-              identV, identA, identAV,
-	      argIdent, isArgIdent, getArgIndex,
-              varStr, varX, isWildIdent, varIndex,
-              -- *** Raw identifiers
-              RawIdent, rawIdentS, rawIdentC, ident2raw, prefixRawIdent,
-              isPrefixOf, showRawIdent
-	     ) where
+  ModuleName(..), moduleNameS,
+  Ident, ident2utf8, showIdent, prefixIdent,
+  -- *** Normal identifiers (returned by the parser)
+  identS, identC, identW,
+  -- *** Special identifiers for internal use
+  identV, identA, identAV,
+  argIdent, isArgIdent, getArgIndex,
+  varStr, varX, isWildIdent, varIndex,
+  -- *** Raw identifiers
+  RawIdent, rawIdentS, rawIdentC, ident2raw, prefixRawIdent,
+  isPrefixOf, showRawIdent
+) where
 
 import qualified Data.ByteString.UTF8 as UTF8
 import qualified Data.ByteString.Char8 as BS(append,isPrefixOf)
@@ -46,7 +46,7 @@ instance Pretty ModuleName where pp (MN m) = pp m
 
 -- | the constructors labelled /INTERNAL/ are
 -- internal representation never returned by the parser
-data Ident = 
+data Ident =
    IC  {-# UNPACK #-} !RawIdent                                           -- ^ raw identifier after parsing, resolved in Rename
  | IW                                                                     -- ^ wildcard
 --
@@ -54,7 +54,7 @@ data Ident =
  | IV  {-# UNPACK #-} !RawIdent {-# UNPACK #-} !Int                       -- ^ /INTERNAL/ variable
  | IA  {-# UNPACK #-} !RawIdent {-# UNPACK #-} !Int                       -- ^ /INTERNAL/ argument of cat at position
  | IAV {-# UNPACK #-} !RawIdent {-# UNPACK #-} !Int {-# UNPACK #-} !Int   -- ^ /INTERNAL/ argument of cat with bindings at position
--- 
+--
   deriving (Eq, Ord, Show, Read)
 
 -- | Identifiers are stored as UTF-8-encoded bytestrings.
@@ -70,14 +70,13 @@ rawIdentS = Id . pack
 rawIdentC = Id
 showRawIdent = unpack . rawId2utf8
 
-prefixRawIdent (Id x) (Id y) = Id (BS.append x y) 
+prefixRawIdent (Id x) (Id y) = Id (BS.append x y)
 isPrefixOf (Id x) (Id y) = BS.isPrefixOf x y
 
 instance Binary RawIdent where
   put = put . rawId2utf8
   get = fmap rawIdentC get
 
-
 -- | This function should be used with care, since the returned ByteString is
 -- UTF-8-encoded.
 ident2utf8 :: Ident -> UTF8.ByteString
@@ -88,6 +87,7 @@ ident2utf8 i = case i of
   IAV (Id s) b j -> BS.append s (pack ('_':show b ++ '_':show j))
   IW -> pack "_"
 
+ident2raw :: Ident -> RawIdent
 ident2raw = Id . ident2utf8
 
 showIdent :: Ident -> String
@@ -95,13 +95,14 @@ showIdent i = unpack $! ident2utf8 i
 
 instance Pretty Ident where pp = pp . showIdent
 
+instance Pretty RawIdent where pp = pp . showRawIdent
+
 identS :: String -> Ident
 identS = identC . rawIdentS
 
 identC :: RawIdent -> Ident
 identW :: Ident
 
-
 prefixIdent :: String -> Ident -> Ident
 prefixIdent pref = identC . Id . BS.append (pack pref) . ident2utf8
 
@@ -112,7 +113,7 @@ identV :: RawIdent -> Int -> Ident
 identA :: RawIdent -> Int -> Ident
 identAV:: RawIdent -> Int -> Int -> Ident
 
-(identC, identV, identA, identAV, identW) = 
+(identC, identV, identA, identAV, identW) =
     (IC,     IV,     IA,     IAV,     IW)
 
 -- | to mark argument variables
-- 
cgit v1.2.3


From 587004f985b9a0172b531abd76253a224b8cf77d Mon Sep 17 00:00:00 2001
From: "John J. Camilleri" <john@digitalgrammars.com>
Date: Wed, 30 Jun 2021 14:14:54 +0200
Subject: Sort record fields in lin definitions

Fixes #102
---
 src/compiler/GF/Compile/GrammarToCanonical.hs |  4 +--
 src/compiler/GF/Grammar/Macros.hs             | 38 +++++++++++++--------------
 testsuite/canonical/gold/FoodsFin.gf          |  2 +-
 3 files changed, 22 insertions(+), 22 deletions(-)

(limited to 'src')

diff --git a/src/compiler/GF/Compile/GrammarToCanonical.hs b/src/compiler/GF/Compile/GrammarToCanonical.hs
index 2b701382c..8810c5911 100644
--- a/src/compiler/GF/Compile/GrammarToCanonical.hs
+++ b/src/compiler/GF/Compile/GrammarToCanonical.hs
@@ -11,7 +11,7 @@ import GF.Data.ErrM
 import GF.Text.Pretty
 import GF.Grammar.Grammar
 import GF.Grammar.Lookup(lookupOrigInfo,allOrigInfos,allParamValues)
-import GF.Grammar.Macros(typeForm,collectOp,collectPattOp,mkAbs,mkApp,term2patt)
+import GF.Grammar.Macros(typeForm,collectOp,collectPattOp,mkAbs,mkApp,term2patt,sortRec)
 import GF.Grammar.Lockfield(isLockLabel)
 import GF.Grammar.Predef(cPredef,cInts)
 import GF.Compile.Compute.Predef(predef)
@@ -162,7 +162,7 @@ convert' gr vs = ppT
         S t p -> selection (ppT t) (ppT p)
         C t1 t2 -> concatValue (ppT t1) (ppT t2)
         App f a -> ap (ppT f) (ppT a)
-        R r -> RecordValue (fields r)
+        R r -> RecordValue (fields (sortRec r))
         P t l -> projection (ppT t) (lblId l)
         Vr x -> VarValue (gId x)
         Cn x -> VarValue (gId x) -- hmm
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/testsuite/canonical/gold/FoodsFin.gf b/testsuite/canonical/gold/FoodsFin.gf
index 55c2fa6c9..de63d2b36 100644
--- a/testsuite/canonical/gold/FoodsFin.gf
+++ b/testsuite/canonical/gold/FoodsFin.gf
@@ -99,4 +99,4 @@ lin Expensive =
                            ResFin_NPossIllat ParamX_Pl => "kalliisii";
                            ResFin_NCompound => "kallis"}};
          hasPrefix = Prelude_False; p = ""};
-}
+}
\ No newline at end of file
-- 
cgit v1.2.3


From 13575b093f265eb8c089df0f40b43ba5fd0f67af Mon Sep 17 00:00:00 2001
From: "John J. Camilleri" <john@digitalgrammars.com>
Date: Thu, 1 Jul 2021 10:13:42 +0200
Subject: Add top-level signatures and general code cleanup

---
 src/compiler/GF/Compile/GrammarToCanonical.hs | 91 +++++++++++++++++++--------
 1 file changed, 64 insertions(+), 27 deletions(-)

(limited to 'src')

diff --git a/src/compiler/GF/Compile/GrammarToCanonical.hs b/src/compiler/GF/Compile/GrammarToCanonical.hs
index 8810c5911..547f7416a 100644
--- a/src/compiler/GF/Compile/GrammarToCanonical.hs
+++ b/src/compiler/GF/Compile/GrammarToCanonical.hs
@@ -6,30 +6,35 @@ module GF.Compile.GrammarToCanonical(
        ) where
 import Data.List(nub,partition)
 import qualified Data.Map as M
+import Data.Maybe(fromMaybe)
 import qualified Data.Set as S
 import GF.Data.ErrM
 import GF.Text.Pretty
-import GF.Grammar.Grammar
+import GF.Grammar.Grammar as G
 import GF.Grammar.Lookup(lookupOrigInfo,allOrigInfos,allParamValues)
 import GF.Grammar.Macros(typeForm,collectOp,collectPattOp,mkAbs,mkApp,term2patt,sortRec)
 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,ident2raw,rawIdentS,prefixIdent,showIdent,isWildIdent)
-import GF.Infra.Option(optionsPGF)
+import GF.Infra.Ident(ModuleName(..),Ident,ident2raw,rawIdentS,{-prefixIdent,-}showIdent,isWildIdent)
+import GF.Infra.Option(Options,optionsPGF)
 import PGF.Internal(Literal(..))
-import GF.Compile.Compute.ConcreteNew(normalForm,resourceValues)
+import GF.Compile.Compute.ConcreteNew(GlobalEnv,normalForm,resourceValues)
 import GF.Grammar.Canonical as C
-import Debug.Trace
+import System.FilePath ((</>), (<.>))
+import Debug.Trace(trace,traceShow)
+
 
 -- | Generate Canonical code for the named abstract syntax and all associated
 -- concrete syntaxes
+grammar2canonical :: Options -> ModuleName -> G.Grammar -> C.Grammar
 grammar2canonical opts absname gr =
    Grammar (abstract2canonical absname gr)
            (map snd (concretes2canonical opts absname gr))
 
 -- | Generate Canonical code for the named abstract syntax
+abstract2canonical :: ModuleName -> G.Grammar -> Abstract
 abstract2canonical absname gr =
     Abstract (modId absname) (convFlags gr absname) cats funs
   where
@@ -44,6 +49,7 @@ abstract2canonical absname gr =
     convHypo (bt,name,t) =
       case typeForm t of
         ([],(_,cat),[]) -> gId cat -- !!
+        tf -> error $ "abstract2canonical convHypo: " ++ show tf
 
     convType t =
       case typeForm t of
@@ -57,15 +63,17 @@ abstract2canonical absname gr =
 
 -- | Generate Canonical code for the all concrete syntaxes associated with
 -- the named abstract syntax in given the grammar.
+concretes2canonical :: Options -> ModuleName -> G.Grammar -> [(FilePath, Concrete)]
 concretes2canonical opts absname gr =
   [(cncname,concrete2canonical gr cenv absname cnc cncmod)
      | let cenv = resourceValues opts gr,
        cnc<-allConcretes gr absname,
-       let cncname = "canonical/"++render cnc ++ ".gf" :: FilePath
+       let cncname = "canonical" </> render cnc <.> "gf"
            Ok cncmod = lookupModule gr cnc
   ]
 
 -- | Generate Canonical GF for the given concrete module.
+concrete2canonical :: G.Grammar -> GlobalEnv -> ModuleName -> ModuleName -> ModuleInfo -> Concrete
 concrete2canonical gr cenv absname cnc modinfo =
   Concrete (modId cnc) (modId absname) (convFlags gr cnc)
       (neededParamTypes S.empty (params defs))
@@ -85,6 +93,11 @@ concrete2canonical gr cenv absname cnc modinfo =
         else let ((got,need),def) = paramType gr q
              in def++neededParamTypes (S.union got have) (S.toList need++qs)
 
+toCanonical :: G.Grammar
+              -> ModuleName
+              -> GlobalEnv
+              -> (Ident, Info)
+              -> [(S.Set QIdent, Either LincatDef LinDef)]
 toCanonical gr absname cenv (name,jment) =
   case jment of
     CncCat (Just (L loc typ)) _ _ pprn _ ->
@@ -114,6 +127,7 @@ toCanonical gr absname cenv (name,jment) =
     unAbs n (Abs _ _ t) = unAbs (n-1) t
     unAbs _ t = t
 
+tableTypes :: G.Grammar -> [Term] -> S.Set QIdent
 tableTypes gr ts = S.unions (map tabtys ts)
   where
     tabtys t =
@@ -122,6 +136,7 @@ tableTypes gr ts = S.unions (map tabtys ts)
         T (TTyped t) cs -> S.union (paramTypes gr t) (tableTypes gr (map snd cs))
         _ -> collectOp tabtys t
 
+paramTypes :: G.Grammar -> G.Type -> S.Set QIdent
 paramTypes gr t =
   case t of
     RecType fs -> S.unions (map (paramTypes gr.snd) fs)
@@ -140,11 +155,12 @@ paramTypes gr t =
                  Ok (_,ResParam {}) -> S.singleton q
                  _ -> ignore
 
-    ignore = trace ("Ignore: "++show t) S.empty
-
+    ignore = trace ("Ignore: " ++ show t) S.empty
 
+convert :: G.Grammar -> Term -> LinValue
 convert gr = convert' gr []
 
+convert' :: G.Grammar -> [Ident] -> Term -> LinValue
 convert' gr vs = ppT
   where
     ppT0 = convert' gr vs
@@ -169,13 +185,13 @@ convert' gr vs = ppT
         Con c -> ParamConstant (Param (gId c) [])
         Sort k -> VarValue (gId k)
         EInt n -> LiteralValue (IntConstant n)
-        Q (m,n) -> if m==cPredef then ppPredef n else VarValue ((gQId m n))
-        QC (m,n) -> ParamConstant (Param ((gQId m n)) [])
+        Q (m,n) -> if m==cPredef then ppPredef n else VarValue (gQId m n)
+        QC (m,n) -> ParamConstant (Param (gQId m n) [])
         K s -> LiteralValue (StrConstant s)
         Empty -> LiteralValue (StrConstant "")
         FV ts -> VariantValue (map ppT ts)
         Alts t' vs -> alts vs (ppT t')
-        _ -> error $ "convert' "++show t
+        _ -> error $ "convert' ppT: " ++ show t
 
     ppCase (p,t) = TableRow (ppP p) (ppTv (patVars p++vs) t)
 
@@ -193,7 +209,7 @@ convert' gr vs = ppT
     ppP p =
       case p of
         PC c ps -> ParamPattern (Param (gId c) (map ppP ps))
-        PP (m,c) ps -> ParamPattern (Param ((gQId m c)) (map ppP ps))
+        PP (m,c) ps -> ParamPattern (Param (gQId m c) (map ppP ps))
         PR r -> RecordPattern (fields r) {-
         PW -> WildPattern
         PV x -> VarP x
@@ -202,6 +218,7 @@ convert' gr vs = ppT
         PFloat x -> Lit (show x)
         PT _ p -> ppP p
         PAs x p -> AsP x (ppP p) -}
+        _ -> error $ "convert' ppP: " ++ show p
       where
         fields = map field . filter (not.isLockLabel.fst)
         field (l,p) = RecordRow (lblId l) (ppP p)
@@ -218,12 +235,12 @@ convert' gr vs = ppT
         pre Empty = [""]  -- Empty == K ""
         pre (Strs ts) = concatMap pre ts
         pre (EPatt p) = pat p
-        pre t = error $ "pre "++show t
+        pre t = error $ "convert' alts pre: " ++ show t
 
         pat (PString s) = [s]
         pat (PAlt p1 p2) = pat p1++pat p2
         pat (PSeq p1 p2) = [s1++s2 | s1<-pat p1, s2<-pat p2]
-        pat p = error $ "pat "++show p
+        pat p = error $ "convert' alts pat: "++show p
 
     fields = map field . filter (not.isLockLabel.fst)
     field (l,(_,t)) = RecordRow (lblId l) (ppT t)
@@ -236,6 +253,7 @@ convert' gr vs = ppT
                  ParamConstant (Param p (ps++[a]))
                _ -> error $ "convert' ap: "++render (ppA f <+> ppA a)
 
+concatValue :: LinValue -> LinValue -> LinValue
 concatValue v1 v2 =
   case (v1,v2) of
     (LiteralValue (StrConstant ""),_) -> v2
@@ -243,8 +261,10 @@ concatValue v1 v2 =
     _ -> ConcatValue v1 v2
 
 -- | Smart constructor for projections
-projection r l = maybe (Projection r l) id (proj r l)
+projection :: LinValue -> LabelId -> LinValue
+projection r l = fromMaybe (Projection r l) (proj r l)
 
+proj :: LinValue -> LabelId -> Maybe LinValue
 proj r l =
   case r of
     RecordValue r -> case [v | RecordRow l' v <- r, l'==l] of
@@ -253,6 +273,7 @@ proj r l =
     _ -> Nothing
 
 -- | Smart constructor for selections
+selection :: LinValue -> LinValue -> LinValue
 selection t v =
   -- Note: impossible cases can become possible after grammar transformation
   case t of
@@ -276,13 +297,16 @@ selection t v =
         (keep,discard) = partition (mightMatchRow v) r
     _ -> Selection t v
 
+impossible :: LinValue -> LinValue
 impossible = CommentedValue "impossible"
 
+mightMatchRow :: LinValue -> TableRow rhs -> Bool
 mightMatchRow v (TableRow p _) =
   case p of
     WildPattern -> True
     _ -> mightMatch v p
 
+mightMatch :: LinValue -> LinPattern -> Bool
 mightMatch v p =
   case v of
     ConcatValue _ _ -> False
@@ -294,16 +318,18 @@ mightMatch v p =
     RecordValue rv ->
       case p of
         RecordPattern rp ->
-          and [maybe False (flip mightMatch p) (proj v l) | RecordRow l p<-rp]
+          and [maybe False (`mightMatch` p) (proj v l) | RecordRow l p<-rp]
         _ -> False
     _ -> True
 
+patVars :: Patt -> [Ident]
 patVars p =
   case p of
     PV x -> [x]
     PAs x p -> x:patVars p
     _ -> collectPattOp patVars p
 
+convType :: Term -> LinType
 convType = ppT
   where
     ppT t =
@@ -315,9 +341,9 @@ convType = ppT
         Sort k -> convSort k
 --      EInt n -> tcon0 (identS ("({-"++show n++"-})")) -- type level numeric literal
         FV (t:ts) -> ppT t -- !!
-        QC (m,n) -> ParamType (ParamTypeId ((gQId m n)))
-        Q (m,n) -> ParamType (ParamTypeId ((gQId m n)))
-        _ -> error $ "Missing case in convType for: "++show t
+        QC (m,n) -> ParamType (ParamTypeId (gQId m n))
+        Q (m,n) -> ParamType (ParamTypeId (gQId m n))
+        _ -> error $ "convType ppT: " ++ show t
 
     convFields = map convField . filter (not.isLockLabel.fst)
     convField (l,r) = RecordRow (lblId l) (ppT r)
@@ -326,15 +352,20 @@ convType = ppT
                    "Float" -> FloatType
                    "Int" -> IntType
                    "Str" -> StrType
-                   _ -> error ("convSort "++show k)
+                   _ -> error $ "convType convSort: " ++ show k
 
+toParamType :: Term -> ParamType
 toParamType t = case convType t of
                   ParamType pt -> pt
-                  _ -> error ("toParamType "++show t)
+                  _ -> error $ "toParamType: " ++ show t
 
+toParamId :: Term -> ParamId
 toParamId t = case toParamType t of
                    ParamTypeId p -> p
 
+paramType :: G.Grammar
+             -> (ModuleName, Ident)
+             -> ((S.Set (ModuleName, Ident), S.Set QIdent), [ParamDef])
 paramType gr q@(_,n) =
     case lookupOrigInfo gr q of
       Ok (m,ResParam (Just (L _ ps)) _)
@@ -342,7 +373,7 @@ paramType gr q@(_,n) =
          ((S.singleton (m,n),argTypes ps),
           [ParamDef name (map (param m) ps)]
          )
-       where name = (gQId m n)
+       where name = gQId m n
       Ok (m,ResOper  _ (Just (L _ t)))
         | m==cPredef && n==cInts ->
            ((S.empty,S.empty),[]) {-
@@ -350,10 +381,10 @@ paramType gr q@(_,n) =
             [Type (ConAp ((gQId m n)) [identS "n"]) (TId (identS "Int"))])-}
         | otherwise ->
            ((S.singleton (m,n),paramTypes gr t),
-            [ParamAliasDef ((gQId m n)) (convType t)])
+            [ParamAliasDef (gQId m n) (convType t)])
       _ -> ((S.empty,S.empty),[])
   where
-    param m (n,ctx) = Param ((gQId m n)) [toParamId t|(_,_,t)<-ctx]
+    param m (n,ctx) = Param (gQId m n) [toParamId t|(_,_,t)<-ctx]
     argTypes = S.unions . map argTypes1
     argTypes1 (n,ctx) = S.unions [paramTypes gr t|(_,_,t)<-ctx]
 
@@ -364,7 +395,8 @@ lblId (LVar i) = LabelId (rawIdentS (show i)) -- hmm
 modId :: ModuleName -> C.ModId
 modId (MN m) = ModId (ident2raw m)
 
-class FromIdent i where gId :: Ident -> i
+class FromIdent i where
+  gId :: Ident -> i
 
 instance FromIdent VarId where
   gId i = if isWildIdent i then Anonymous else VarId (ident2raw i)
@@ -374,14 +406,19 @@ instance FromIdent CatId where gId = CatId . ident2raw
 instance FromIdent ParamId where gId = ParamId . unqual
 instance FromIdent VarValueId where gId = VarValueId . unqual
 
-class FromIdent i => QualIdent i where gQId :: ModuleName -> Ident -> i
+class FromIdent i => QualIdent i where
+  gQId :: ModuleName -> Ident -> i
 
-instance QualIdent ParamId    where gQId m n = ParamId (qual m n)
+instance QualIdent ParamId where gQId m n = ParamId (qual m n)
 instance QualIdent VarValueId where gQId m n = VarValueId (qual m n)
 
+qual :: ModuleName -> Ident -> QualId
 qual m n = Qual (modId m) (ident2raw n)
+
+unqual :: Ident -> QualId
 unqual n = Unqual (ident2raw n)
 
+convFlags :: G.Grammar -> ModuleName -> Flags
 convFlags gr mn =
   Flags [(rawIdentS n,convLit v) |
          (n,v)<-err (const []) (optionsPGF.mflags) (lookupModule gr mn)]
-- 
cgit v1.2.3


From e5a2aed5b6e31fe89e94e9fd9c22e2488f85cae8 Mon Sep 17 00:00:00 2001
From: "John J. Camilleri" <john@digitalgrammars.com>
Date: Thu, 1 Jul 2021 11:47:14 +0200
Subject: Remove record fields not in lincat

Fixes #100, #101
---
 src/compiler/GF/Compile/GrammarToCanonical.hs | 30 +++++++++++++++++----------
 testsuite/canonical/gold/PhrasebookBul.gf     | 29 ++++++++++++++++++++++++++
 testsuite/canonical/gold/PhrasebookGer.gf     |  6 +++---
 testsuite/canonical/run.sh                    |  9 +++++++-
 4 files changed, 59 insertions(+), 15 deletions(-)
 create mode 100644 testsuite/canonical/gold/PhrasebookBul.gf

(limited to 'src')

diff --git a/src/compiler/GF/Compile/GrammarToCanonical.hs b/src/compiler/GF/Compile/GrammarToCanonical.hs
index 547f7416a..57a761a64 100644
--- a/src/compiler/GF/Compile/GrammarToCanonical.hs
+++ b/src/compiler/GF/Compile/GrammarToCanonical.hs
@@ -17,13 +17,13 @@ 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,ident2raw,rawIdentS,{-prefixIdent,-}showIdent,isWildIdent)
+import GF.Infra.Ident(ModuleName(..),Ident,ident2raw,rawIdentS,showIdent,isWildIdent)
 import GF.Infra.Option(Options,optionsPGF)
 import PGF.Internal(Literal(..))
 import GF.Compile.Compute.ConcreteNew(GlobalEnv,normalForm,resourceValues)
 import GF.Grammar.Canonical as C
 import System.FilePath ((</>), (<.>))
-import Debug.Trace(trace,traceShow)
+import qualified Debug.Trace as T
 
 
 -- | Generate Canonical code for the named abstract syntax and all associated
@@ -60,7 +60,6 @@ abstract2canonical absname gr =
 
     convHypo' (bt,name,t) = TypeBinding (gId name) (convType t)
 
-
 -- | Generate Canonical code for the all concrete syntaxes associated with
 -- the named abstract syntax in given the grammar.
 concretes2canonical :: Options -> ModuleName -> G.Grammar -> [(FilePath, Concrete)]
@@ -93,11 +92,7 @@ concrete2canonical gr cenv absname cnc modinfo =
         else let ((got,need),def) = paramType gr q
              in def++neededParamTypes (S.union got have) (S.toList need++qs)
 
-toCanonical :: G.Grammar
-              -> ModuleName
-              -> GlobalEnv
-              -> (Ident, Info)
-              -> [(S.Set QIdent, Either LincatDef LinDef)]
+toCanonical :: G.Grammar -> ModuleName -> GlobalEnv -> (Ident, Info) -> [(S.Set QIdent, Either LincatDef LinDef)]
 toCanonical gr absname cenv (name,jment) =
   case jment of
     CncCat (Just (L loc typ)) _ _ pprn _ ->
@@ -110,7 +105,8 @@ toCanonical gr absname cenv (name,jment) =
       where
         tts = tableTypes gr [e']
 
-        e' = unAbs (length params) $
+        e' = cleanupRecordFields lincat $
+             unAbs (length params) $
              nf loc (mkAbs params (mkApp def (map Vr args)))
         params = [(b,x)|(b,x,_)<-ctx]
         args = map snd params
@@ -121,7 +117,6 @@ toCanonical gr absname cenv (name,jment) =
     _ -> []
   where
     nf loc = normalForm cenv (L loc name)
---  aId n = prefixIdent "A." (gId n)
 
     unAbs 0 t = t
     unAbs n (Abs _ _ t) = unAbs (n-1) t
@@ -155,7 +150,20 @@ paramTypes gr t =
                  Ok (_,ResParam {}) -> S.singleton q
                  _ -> ignore
 
-    ignore = trace ("Ignore: " ++ show t) S.empty
+    ignore = T.trace ("Ignore: " ++ show t) S.empty
+
+-- | Filter out record fields from definitions which don't appear in lincat.
+cleanupRecordFields :: G.Type -> Term -> Term
+cleanupRecordFields (RecType ls) (R as) =
+  let defnFields = M.fromList ls
+  in R
+      [ (lbl, (mty, t'))
+      | (lbl, (mty, t)) <- as
+      , M.member lbl defnFields
+      , let Just ty = M.lookup lbl defnFields
+      , let t' = cleanupRecordFields ty t
+      ]
+cleanupRecordFields _ t = t
 
 convert :: G.Grammar -> Term -> LinValue
 convert gr = convert' gr []
diff --git a/testsuite/canonical/gold/PhrasebookBul.gf b/testsuite/canonical/gold/PhrasebookBul.gf
new file mode 100644
index 000000000..eb10cc48c
--- /dev/null
+++ b/testsuite/canonical/gold/PhrasebookBul.gf
@@ -0,0 +1,29 @@
+concrete PhrasebookBul of Phrasebook = {
+param Prelude_Bool = Prelude_False | Prelude_True;
+param ResBul_AGender = ResBul_AMasc ResBul_Animacy | ResBul_AFem | ResBul_ANeut;
+param ResBul_Animacy = ResBul_Human | ResBul_NonHuman;
+param ResBul_Case = ResBul_Acc | ResBul_Dat | ResBul_WithPrep | ResBul_CPrep;
+param ResBul_NForm =
+    ResBul_NF ParamX_Number ResBul_Species | ResBul_NFSgDefNom |
+    ResBul_NFPlCount | ResBul_NFVocative;
+param ParamX_Number = ParamX_Sg | ParamX_Pl;
+param ResBul_Species = ResBul_Indef | ResBul_Def;
+lincat PlaceKind =
+           {at : {s : Str; c : ResBul_Case}; isPl : Prelude_Bool;
+            name : {s : ResBul_NForm => Str; g : ResBul_AGender};
+            to : {s : Str; c : ResBul_Case}};
+       VerbPhrase = {s : Str};
+lin Airport =
+        {at = {s = "на"; c = ResBul_Acc}; isPl = Prelude_False;
+         name =
+           {s =
+              table {ResBul_NF ParamX_Sg ResBul_Indef => "летище";
+                     ResBul_NF ParamX_Sg ResBul_Def => "летището";
+                     ResBul_NF ParamX_Pl ResBul_Indef => "летища";
+                     ResBul_NF ParamX_Pl ResBul_Def => "летищата";
+                     ResBul_NFSgDefNom => "летището";
+                     ResBul_NFPlCount => "летища";
+                     ResBul_NFVocative => "летище"};
+            g = ResBul_ANeut};
+         to = {s = "до"; c = ResBul_CPrep}};
+}
\ No newline at end of file
diff --git a/testsuite/canonical/gold/PhrasebookGer.gf b/testsuite/canonical/gold/PhrasebookGer.gf
index 22d750b78..912f3b7b1 100644
--- a/testsuite/canonical/gold/PhrasebookGer.gf
+++ b/testsuite/canonical/gold/PhrasebookGer.gf
@@ -205,9 +205,9 @@ lin VRead =
                        "gelesener"};
             aux = ResGer_VHaben; particle = ""; prefix = "";
             vtype = ResGer_VAct};
-         a1 = ""; a2 = ""; adj = "";
-         ext = ""; inf = {s = ""; ctrl = ResGer_NoC; isAux = Prelude_True};
-         infExt = ""; isAux = Prelude_False;
+         a1 = ""; a2 = ""; adj = ""; ext = "";
+         inf = {s = ""; ctrl = ResGer_NoC; isAux = Prelude_True}; infExt = "";
+         isAux = Prelude_False;
          nn =
            table {ResGer_Ag ResGer_Masc ParamX_Sg ParamX_P1 =>
                     {p1 = ""; p2 = ""; p3 = ""; p4 = ""; p5 = ""; p6 = ""};
diff --git a/testsuite/canonical/run.sh b/testsuite/canonical/run.sh
index be7d1ff6c..c39f1e557 100755
--- a/testsuite/canonical/run.sh
+++ b/testsuite/canonical/run.sh
@@ -9,7 +9,14 @@ if [ $? -ne 0 ]; then
   echo "Canonical grammar doesn't compile: FAIL"
   FAILURES=$((FAILURES+1))
 else
-  echo "Canonical grammar compiles: OK"
+  # echo "Canonical grammar compiles: OK"
+  diff canonical/PhrasebookBul.gf gold/PhrasebookBul.gf
+  if [ $? -ne 0 ]; then
+    echo "Canonical grammar doesn't match gold version: FAIL"
+    FAILURES=$((FAILURES+1))
+  else
+    echo "Canonical grammar matches gold version: OK"
+  fi
 fi
 
 echo ""
-- 
cgit v1.2.3


From 78b73fba20d45ed8c3f1c87455795fbf7d670950 Mon Sep 17 00:00:00 2001
From: "John J. Camilleri" <john@digitalgrammars.com>
Date: Thu, 1 Jul 2021 13:53:33 +0200
Subject: Make cleanupRecordFields also recurse into variants

It's possible that more constructors need to be handled
---
 src/compiler/GF/Compile/GrammarToCanonical.hs | 3 ++-
 testsuite/canonical/run.sh                    | 9 ---------
 2 files changed, 2 insertions(+), 10 deletions(-)

(limited to 'src')

diff --git a/src/compiler/GF/Compile/GrammarToCanonical.hs b/src/compiler/GF/Compile/GrammarToCanonical.hs
index 57a761a64..a600573ac 100644
--- a/src/compiler/GF/Compile/GrammarToCanonical.hs
+++ b/src/compiler/GF/Compile/GrammarToCanonical.hs
@@ -12,7 +12,7 @@ import GF.Data.ErrM
 import GF.Text.Pretty
 import GF.Grammar.Grammar as G
 import GF.Grammar.Lookup(lookupOrigInfo,allOrigInfos,allParamValues)
-import GF.Grammar.Macros(typeForm,collectOp,collectPattOp,mkAbs,mkApp,term2patt,sortRec)
+import GF.Grammar.Macros(typeForm,collectOp,collectPattOp,composSafeOp,mkAbs,mkApp,term2patt,sortRec)
 import GF.Grammar.Lockfield(isLockLabel)
 import GF.Grammar.Predef(cPredef,cInts)
 import GF.Compile.Compute.Predef(predef)
@@ -163,6 +163,7 @@ cleanupRecordFields (RecType ls) (R as) =
       , let Just ty = M.lookup lbl defnFields
       , let t' = cleanupRecordFields ty t
       ]
+cleanupRecordFields ty t@(FV _) = composSafeOp (cleanupRecordFields ty) t
 cleanupRecordFields _ t = t
 
 convert :: G.Grammar -> Term -> LinValue
diff --git a/testsuite/canonical/run.sh b/testsuite/canonical/run.sh
index c39f1e557..81c03c5d1 100755
--- a/testsuite/canonical/run.sh
+++ b/testsuite/canonical/run.sh
@@ -23,15 +23,6 @@ echo ""
 
 # https://github.com/GrammaticalFramework/gf-core/issues/101
 stack run -- --batch --output-format=canonical_gf grammars/PhrasebookGer.gf
-# for s in c2 objCtrl; do
-#   grep VRead --after-context=216 canonical/PhrasebookGer.gf | grep "$s" > /dev/null
-#   if [ $? -ne 1 ]; then
-#     echo "Canonical grammar contains \`$s\`: FAIL"
-#     FAILURES=$((FAILURES+1))
-#   else
-#     echo "Canonical grammar does not contain \`$s\`: OK"
-#   fi
-# done
 diff canonical/PhrasebookGer.gf gold/PhrasebookGer.gf
 if [ $? -ne 0 ]; then
   echo "Canonical grammar doesn't match gold version: FAIL"
-- 
cgit v1.2.3


From 71d99b9ecb2f59a5591bfdd9ab4695b00acbfd1c Mon Sep 17 00:00:00 2001
From: "John J. Camilleri" <john@digitalgrammars.com>
Date: Thu, 1 Jul 2021 14:21:29 +0200
Subject: Rename GF.Compile.Compute.ConcreteNew to GF.Compile.Compute.Concrete

---
 gf.cabal                                         |   2 +-
 src/compiler/GF/Command/SourceCommands.hs        |   4 +-
 src/compiler/GF/Compile/CheckGrammar.hs          |  46 +-
 src/compiler/GF/Compile/Compute/Concrete.hs      | 591 ++++++++++++++++++++++-
 src/compiler/GF/Compile/Compute/ConcreteNew.hs   | 588 ----------------------
 src/compiler/GF/Compile/Compute/Value.hs         |   8 +-
 src/compiler/GF/Compile/GeneratePMCFG.hs         |  12 +-
 src/compiler/GF/Compile/GrammarToCanonical.hs    |   6 +-
 src/compiler/GF/Compile/Optimize.hs              |  16 +-
 src/compiler/GF/Compile/TypeCheck/ConcreteNew.hs |  38 +-
 10 files changed, 654 insertions(+), 657 deletions(-)
 delete mode 100644 src/compiler/GF/Compile/Compute/ConcreteNew.hs

(limited to 'src')

diff --git a/gf.cabal b/gf.cabal
index 9a9e3903e..854f8cfbf 100644
--- a/gf.cabal
+++ b/gf.cabal
@@ -178,7 +178,7 @@ library
     GF.Command.TreeOperations
     GF.Compile.CFGtoPGF
     GF.Compile.CheckGrammar
-    GF.Compile.Compute.ConcreteNew
+    GF.Compile.Compute.Concrete
     GF.Compile.Compute.Predef
     GF.Compile.Compute.Value
     GF.Compile.ExampleBased
diff --git a/src/compiler/GF/Command/SourceCommands.hs b/src/compiler/GF/Command/SourceCommands.hs
index 0ba60d245..daf3f7f1e 100644
--- a/src/compiler/GF/Command/SourceCommands.hs
+++ b/src/compiler/GF/Command/SourceCommands.hs
@@ -18,7 +18,7 @@ import GF.Grammar.Parser (runP, pExp)
 import GF.Grammar.ShowTerm
 import GF.Grammar.Lookup (allOpers,allOpersTo)
 import GF.Compile.Rename(renameSourceTerm)
-import qualified GF.Compile.Compute.ConcreteNew as CN(normalForm,resourceValues)
+import GF.Compile.Compute.Concrete(normalForm,resourceValues)
 import GF.Compile.TypeCheck.RConcrete as TC(inferLType,ppType)
 import GF.Infra.Dependencies(depGraph)
 import GF.Infra.CheckM(runCheck)
@@ -259,7 +259,7 @@ checkComputeTerm os sgr t =
      ((t,_),_) <- runCheck $ do t <- renameSourceTerm sgr mo t
                                 inferLType sgr [] t
      let opts = modifyFlags (\fs->fs{optTrace=isOpt "trace" os})
-         t1 = CN.normalForm (CN.resourceValues opts sgr) (L NoLoc identW) t
+         t1 = normalForm (resourceValues opts sgr) (L NoLoc identW) t
          t2 = evalStr t1
      checkPredefError t2
   where
diff --git a/src/compiler/GF/Compile/CheckGrammar.hs b/src/compiler/GF/Compile/CheckGrammar.hs
index 24582bba2..e7839da34 100644
--- a/src/compiler/GF/Compile/CheckGrammar.hs
+++ b/src/compiler/GF/Compile/CheckGrammar.hs
@@ -5,7 +5,7 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/11/11 23:24:33 $ 
+-- > CVS $Date: 2005/11/11 23:24:33 $
 -- > CVS $Author: aarne $
 -- > CVS $Revision: 1.31 $
 --
@@ -29,7 +29,7 @@ import GF.Infra.Option
 import GF.Compile.TypeCheck.Abstract
 import GF.Compile.TypeCheck.RConcrete
 import qualified GF.Compile.TypeCheck.ConcreteNew as CN
-import qualified GF.Compile.Compute.ConcreteNew as CN
+import qualified GF.Compile.Compute.Concrete as CN
 
 import GF.Grammar
 import GF.Grammar.Lexer
@@ -74,9 +74,9 @@ checkRestrictedInheritance cwd sgr (name,mo) = checkInModule cwd mo NoLoc empty
      let (incl,excl) = partition (isInherited mi) (Map.keys (jments m))
      let incld c   = Set.member c (Set.fromList incl)
      let illegal c = Set.member c (Set.fromList excl)
-     let illegals = [(f,is) | 
+     let illegals = [(f,is) |
            (f,cs) <- allDeps, incld f, let is = filter illegal cs, not (null is)]
-     case illegals of 
+     case illegals of
        [] -> return ()
        cs -> checkWarn ("In inherited module" <+> i <> ", dependence of excluded constants:" $$
                          nest 2 (vcat [f <+> "on" <+> fsep is | (f,is) <- cs]))
@@ -92,12 +92,12 @@ checkCompleteGrammar opts cwd gr (am,abs) (cm,cnc) = checkInModule cwd cnc NoLoc
 
   -- check that all abstract constants are in concrete; build default lin and lincats
   jsc <- foldM checkAbs jsc (Map.toList jsa)
-  
+
   return (cm,cnc{jments=jsc})
   where
    checkAbs js i@(c,info) =
      case info of
-       AbsFun (Just (L loc ty)) _ _ _ 
+       AbsFun (Just (L loc ty)) _ _ _
            -> do let mb_def = do
                        let (cxt,(_,i),_) = typeForm ty
                        info <- lookupIdent i js
@@ -136,11 +136,11 @@ checkCompleteGrammar opts cwd gr (am,abs) (cm,cnc) = checkInModule cwd cnc NoLoc
            checkWarn ("no linearization type for" <+> c <> ", inserting default {s : Str}")
            return $ Map.insert c (CncCat (Just (L NoLoc defLinType)) Nothing Nothing Nothing Nothing) js
        _ -> return js
-     
+
    checkCnc js (c,info) =
      case info of
        CncFun _ d mn mf -> case lookupOrigInfo gr (am,c) of
-                             Ok (_,AbsFun (Just (L _ ty)) _ _ _) -> 
+                             Ok (_,AbsFun (Just (L _ ty)) _ _ _) ->
                                         do (cont,val) <- linTypeOfType gr cm ty
                                            let linty = (snd (valCat ty),cont,val)
                                            return $ Map.insert c (CncFun (Just linty) d mn mf) js
@@ -159,14 +159,14 @@ checkCompleteGrammar opts cwd gr (am,abs) (cm,cnc) = checkInModule cwd cnc NoLoc
        _ -> return $ Map.insert c info js
 
 
--- | General Principle: only Just-values are checked. 
+-- | General Principle: only Just-values are checked.
 -- A May-value has always been checked in its origin module.
 checkInfo :: Options -> FilePath -> SourceGrammar -> SourceModule -> Ident -> Info -> Check Info
 checkInfo opts cwd sgr (m,mo) c info = checkInModule cwd mo NoLoc empty $ do
   checkReservedId c
   case info of
-    AbsCat (Just (L loc cont)) -> 
-      mkCheck loc "the category" $ 
+    AbsCat (Just (L loc cont)) ->
+      mkCheck loc "the category" $
         checkContext gr cont
 
     AbsFun (Just (L loc typ0)) ma md moper -> do
@@ -181,7 +181,7 @@ checkInfo opts cwd sgr (m,mo) c info = checkInModule cwd mo NoLoc empty $ do
 
     CncCat mty mdef mref mpr mpmcfg -> do
       mty  <- case mty of
-                Just (L loc typ) -> chIn loc "linearization type of" $ 
+                Just (L loc typ) -> chIn loc "linearization type of" $
                                      (if False --flag optNewComp opts
                                         then do (typ,_) <- CN.checkLType (CN.resourceValues opts gr) typ typeType
                                                 typ  <- computeLType gr [] typ
@@ -191,19 +191,19 @@ checkInfo opts cwd sgr (m,mo) c info = checkInModule cwd mo NoLoc empty $ do
                                                 return (Just (L loc typ)))
                 Nothing          -> return Nothing
       mdef <- case (mty,mdef) of
-                (Just (L _ typ),Just (L loc def)) -> 
+                (Just (L _ typ),Just (L loc def)) ->
                     chIn loc "default linearization of" $ do
                        (def,_) <- checkLType gr [] def (mkFunType [typeStr] typ)
                        return (Just (L loc def))
                 _ -> return Nothing
       mref <- case (mty,mref) of
-                (Just (L _ typ),Just (L loc ref)) -> 
+                (Just (L _ typ),Just (L loc ref)) ->
                     chIn loc "reference linearization of" $ do
                        (ref,_) <- checkLType gr [] ref (mkFunType [typ] typeStr)
                        return (Just (L loc ref))
                 _ -> return Nothing
       mpr  <- case mpr of
-                (Just (L loc t)) -> 
+                (Just (L loc t)) ->
                     chIn loc "print name of" $ do
                        (t,_) <- checkLType gr [] t typeStr
                        return (Just (L loc t))
@@ -212,13 +212,13 @@ checkInfo opts cwd sgr (m,mo) c info = checkInModule cwd mo NoLoc empty $ do
 
     CncFun mty mt mpr mpmcfg -> do
       mt <- case (mty,mt) of
-              (Just (cat,cont,val),Just (L loc trm)) -> 
+              (Just (cat,cont,val),Just (L loc trm)) ->
                   chIn loc "linearization of" $ do
                      (trm,_) <- checkLType gr [] trm (mkFunType (map (\(_,_,ty) -> ty) cont) val)  -- erases arg vars
                      return (Just (L loc trm))
               _ -> return mt
       mpr  <- case mpr of
-                (Just (L loc t)) -> 
+                (Just (L loc t)) ->
                     chIn loc "print name of" $ do
                        (t,_) <- checkLType gr [] t typeStr
                        return (Just (L loc t))
@@ -251,16 +251,16 @@ checkInfo opts cwd sgr (m,mo) c info = checkInModule cwd mo NoLoc empty $ do
     ResOverload os tysts -> chIn NoLoc "overloading" $ do
       tysts' <- mapM (uncurry $ flip (\(L loc1 t) (L loc2 ty) -> checkLType gr [] t ty >>= \(t,ty) -> return (L loc1 t, L loc2 ty))) tysts  -- return explicit ones
       tysts0 <- lookupOverload gr (m,c)  -- check against inherited ones too
-      tysts1 <- mapM (uncurry $ flip (checkLType gr [])) 
+      tysts1 <- mapM (uncurry $ flip (checkLType gr []))
                   [(mkFunType args val,tr) | (args,(val,tr)) <- tysts0]
       --- this can only be a partial guarantee, since matching
       --- with value type is only possible if expected type is given
-      checkUniq $ 
+      checkUniq $
         sort [let (xs,t) = typeFormCnc x in t : map (\(b,x,t) -> t) xs | (_,x) <- tysts1]
       return (ResOverload os [(y,x) | (x,y) <- tysts'])
 
     ResParam (Just (L loc pcs)) _ -> do
-      ts <- chIn loc "parameter type" $ 
+      ts <- chIn loc "parameter type" $
               liftM concat $ mapM mkPar pcs
       return (ResParam (Just (L loc pcs)) (Just ts))
 
@@ -274,9 +274,9 @@ checkInfo opts cwd sgr (m,mo) c info = checkInModule cwd mo NoLoc empty $ do
        return $ map (mkApp (QC (m,f))) vs
 
    checkUniq xss = case xss of
-     x:y:xs 
+     x:y:xs
       | x == y    -> checkError $ "ambiguous for type" <+>
-                                  ppType (mkFunType (tail x) (head x))  
+                                  ppType (mkFunType (tail x) (head x))
       | otherwise -> checkUniq $ y:xs
      _ -> return ()
 
@@ -294,7 +294,7 @@ checkInfo opts cwd sgr (m,mo) c info = checkInModule cwd mo NoLoc empty $ do
        t' <- compAbsTyp ((x,Vr x):g) t
        return $ Prod b x a' t'
      Abs _ _ _ -> return t
-     _ -> composOp (compAbsTyp g) t  
+     _ -> composOp (compAbsTyp g) t
 
 
 -- | for grammars obtained otherwise than by parsing ---- update!!
diff --git a/src/compiler/GF/Compile/Compute/Concrete.hs b/src/compiler/GF/Compile/Compute/Concrete.hs
index f411f2ca0..4b54c8c84 100644
--- a/src/compiler/GF/Compile/Compute/Concrete.hs
+++ b/src/compiler/GF/Compile/Compute/Concrete.hs
@@ -1,3 +1,588 @@
-module GF.Compile.Compute.Concrete{-(module M)-} where
---import GF.Compile.Compute.ConcreteLazy as M -- New
---import GF.Compile.Compute.ConcreteStrict as M -- Old, inefficient
+-- | Functions for computing the values of terms in the concrete syntax, in
+-- | preparation for PMCFG generation.
+module GF.Compile.Compute.Concrete
+           (GlobalEnv, GLocation, resourceValues, geLoc, geGrammar,
+            normalForm,
+            Value(..), Bind(..), Env, value2term, eval, vapply
+           ) where
+import Prelude hiding ((<>)) -- GHC 8.4.1 clash with Text.PrettyPrint
+
+import GF.Grammar hiding (Env, VGen, VApp, VRecType)
+import GF.Grammar.Lookup(lookupResDefLoc,allParamValues)
+import GF.Grammar.Predef(cPredef,cErrorType,cTok,cStr,cTrace,cPBool)
+import GF.Grammar.PatternMatch(matchPattern,measurePatt)
+import GF.Grammar.Lockfield(isLockLabel,lockRecType) --unlockRecord,lockLabel
+import GF.Compile.Compute.Value hiding (Error)
+import GF.Compile.Compute.Predef(predef,predefName,delta)
+import GF.Data.Str(Str,glueStr,str2strings,str,sstr,plusStr,strTok)
+import GF.Data.Operations(Err,err,errIn,maybeErr,mapPairsM)
+import GF.Data.Utilities(mapFst,mapSnd)
+import GF.Infra.Option
+import Control.Monad(ap,liftM,liftM2) -- ,unless,mplus
+import Data.List (findIndex,intersect,nub,elemIndex,(\\)) --,isInfixOf
+--import Data.Char (isUpper,toUpper,toLower)
+import GF.Text.Pretty
+import qualified Data.Map as Map
+import Debug.Trace(trace)
+
+-- * Main entry points
+
+normalForm :: GlobalEnv -> L Ident -> Term -> Term
+normalForm (GE gr rv opts _) loc = err (bugloc loc) id . nfx (GE gr rv opts loc)
+
+nfx env@(GE _ _ _ loc) t = do
+  v <- eval env [] t
+  case value2term loc [] v of
+    Left i  -> fail ("variable #"++show i++" is out of scope")
+    Right t -> return t
+
+eval :: GlobalEnv -> Env -> Term -> Err Value
+eval (GE gr rvs opts loc) env t = ($ (map snd env)) # value cenv t
+  where
+    cenv = CE gr rvs opts loc (map fst env)
+
+--apply env = apply' env
+
+--------------------------------------------------------------------------------
+
+-- * Environments
+
+type ResourceValues = Map.Map ModuleName (Map.Map Ident (Err Value))
+
+data GlobalEnv = GE Grammar ResourceValues Options GLocation
+data CompleteEnv = CE {srcgr::Grammar,rvs::ResourceValues,
+                       opts::Options,
+                       gloc::GLocation,local::LocalScope}
+type GLocation = L Ident
+type LocalScope = [Ident]
+type Stack = [Value]
+type OpenValue = Stack->Value
+
+geLoc     (GE _ _ _ loc) = loc
+geGrammar (GE gr _ _ _)  = gr
+
+ext b env = env{local=b:local env}
+extend bs env = env{local=bs++local env}
+global env = GE (srcgr env) (rvs env) (opts env) (gloc env)
+
+var :: CompleteEnv -> Ident -> Err OpenValue
+var env x = maybe unbound pick' (elemIndex x (local env))
+  where
+    unbound = fail ("Unknown variable: "++showIdent x)
+    pick' i = return $ \ vs -> maybe (err i vs) ok (pick i vs)
+    err i vs = bug $ "Stack problem: "++showIdent x++": "
+                    ++unwords (map showIdent (local env))
+                    ++" => "++show (i,length vs)
+    ok v = --trace ("var "++show x++" = "++show v) $
+           v
+
+pick :: Int -> Stack -> Maybe Value
+pick 0 (v:_) = Just v
+pick i (_:vs) = pick (i-1) vs
+pick i vs = Nothing -- bug $ "pick "++show (i,vs)
+
+resource env (m,c) =
+--  err bug id $
+    if isPredefCat c
+    then value0 env =<< lockRecType c defLinType -- hmm
+    else maybe e id $ Map.lookup c =<< Map.lookup m (rvs env)
+  where e = fail $ "Not found: "++render m++"."++showIdent c
+
+-- | Convert operators once, not every time they are looked up
+resourceValues :: Options -> SourceGrammar -> GlobalEnv
+resourceValues opts gr = env
+  where
+    env = GE gr rvs opts (L NoLoc identW)
+    rvs = Map.mapWithKey moduleResources (moduleMap gr)
+    moduleResources m = Map.mapWithKey (moduleResource m) . jments
+    moduleResource m c _info = do L l t <- lookupResDefLoc gr (m,c)
+                                  let loc = L l c
+                                      qloc = L l (Q (m,c))
+                                  eval (GE gr rvs opts loc) [] (traceRes qloc t)
+
+    traceRes = if flag optTrace opts
+               then traceResource
+               else const id
+
+-- * Tracing
+
+-- | Insert a call to the trace function under the top-level lambdas
+traceResource (L l q) t =
+  case termFormCnc t of
+    (abs,body) -> mkAbs abs (mkApp traceQ [args,body])
+      where
+        args = R $ tuple2record (K lstr:[Vr x|(bt,x)<-abs,bt==Explicit])
+        lstr = render (l<>":"<>ppTerm Qualified 0 q)
+        traceQ = Q (cPredef,cTrace)
+
+-- * Computing values
+
+-- | Computing the value of a top-level term
+value0 :: CompleteEnv -> Term -> Err Value
+value0 env = eval (global env) []
+
+-- | Computing the value of a term
+value :: CompleteEnv -> Term -> Err OpenValue
+value env t0 =
+  -- Each terms is traversed only once by this function, using only statically
+  -- available information. Notably, the values of lambda bound variables
+  -- will be unknown during the term traversal phase.
+  -- The result is an OpenValue, which is a function that may be applied many
+  -- times to different dynamic values, but without the term traversal overhead
+  -- and without recomputing other statically known information.
+  -- For this to work, there should be no recursive calls under lambdas here.
+  -- Whenever we need to construct the OpenValue function with an explicit
+  -- lambda, we have to lift the recursive calls outside the lambda.
+  -- (See e.g. the rules for Let, Prod and Abs)
+{-
+  trace (render $ text "value"<+>sep [ppL (gloc env)<>text ":",
+                                      brackets (fsep (map ppIdent (local env))),
+                                      ppTerm Unqualified 10 t0]) $
+--}
+  errIn (render t0) $
+  case t0 of
+    Vr x   -> var env x
+    Q x@(m,f)
+      | m == cPredef -> if f==cErrorType                -- to be removed
+                        then let p = identS "P"
+                             in const # value0 env (mkProd [(Implicit,p,typeType)] (Vr p) [])
+                        else if f==cPBool
+                               then const # resource env x
+                               else const . flip VApp [] # predef f
+      | otherwise    -> const # resource env x --valueResDef (fst env) x
+    QC x   -> return $ const (VCApp x [])
+    App e1 e2 -> apply' env e1 . (:[]) =<< value env e2
+    Let (x,(oty,t)) body -> do vb <- value (ext x env) body
+                               vt <- value env t
+                               return $ \ vs -> vb (vt vs:vs)
+    Meta i -> return $ \ vs -> VMeta i (zip (local env) vs) []
+    Prod bt x t1 t2 ->
+       do vt1 <- value env t1
+          vt2 <- value (ext x env) t2
+          return $ \ vs -> VProd bt (vt1 vs) x $ Bind $ \ vx -> vt2 (vx:vs)
+    Abs bt x t -> do vt <- value (ext x env) t
+                     return $ VAbs bt x . Bind . \ vs vx -> vt (vx:vs)
+    EInt n -> return $ const (VInt n)
+    EFloat f -> return $ const (VFloat f)
+    K s -> return $ const (VString s)
+    Empty -> return $ const (VString "")
+    Sort s | s == cTok -> return $ const (VSort cStr)        -- to be removed
+           | otherwise -> return $ const (VSort s)
+    ImplArg t -> (VImplArg.) # value env t
+    Table p res -> liftM2 VTblType # value env p <# value env res
+    RecType rs -> do lovs <- mapPairsM (value env) rs
+                     return $ \vs->VRecType $ mapSnd ($vs) lovs
+    t@(ExtR t1 t2) -> ((extR t.)# both id) # both (value env) (t1,t2)
+    FV ts   -> ((vfv .) # sequence) # mapM (value env) ts
+    R as    -> do lovs <- mapPairsM (value env.snd) as
+                  return $ \ vs->VRec $ mapSnd ($vs) lovs
+    T i cs  -> valueTable env i cs
+    V ty ts -> do pvs <- paramValues env ty
+                  ((VV ty pvs .) . sequence) # mapM (value env) ts
+    C t1 t2 -> ((ok2p vconcat.) # both id) # both (value env) (t1,t2)
+    S t1 t2 -> ((select env.) # both id) # both (value env) (t1,t2)
+    P t l   -> --maybe (bug $ "project "++show l++" from "++show v) id $
+               do ov <- value env t
+                  return $ \ vs -> let v = ov vs
+                                   in maybe (VP v l) id (proj l v)
+    Alts t tts -> (\v vts -> VAlts # v <# mapM (both id) vts) # value env t <# mapM (both (value env)) tts
+    Strs ts    -> ((VStrs.) # sequence) # mapM (value env) ts
+    Glue t1 t2 -> ((ok2p (glue env).) # both id) # both (value env) (t1,t2)
+    ELin c r -> (unlockVRec (gloc env) c.) # value env r
+    EPatt p  -> return $ const (VPatt p) -- hmm
+    EPattType ty -> do vt <- value env ty
+                       return (VPattType . vt)
+    Typed t ty -> value env t
+    t -> fail.render $ "value"<+>ppTerm Unqualified 10 t $$ show t
+
+vconcat vv@(v1,v2) =
+    case vv of
+      (VString "",_) -> v2
+      (_,VString "") -> v1
+      (VApp NonExist _,_) -> v1
+      (_,VApp NonExist _) -> v2
+      _ -> VC v1 v2
+
+proj l v | isLockLabel l = return (VRec [])
+                ---- a workaround 18/2/2005: take this away and find the reason
+                ---- why earlier compilation destroys the lock field
+proj l v =
+    case v of
+      VFV vs -> liftM vfv (mapM (proj l) vs)
+      VRec rs -> lookup l rs
+--    VExtR v1 v2 -> proj l v2 `mplus` proj l v1 -- hmm
+      VS (VV pty pvs rs) v2 -> flip VS v2 . VV pty pvs # mapM (proj l) rs
+      _ -> return (ok1 VP v l)
+
+ok1 f v1@(VError {}) _ = v1
+ok1 f v1 v2 = f v1 v2
+
+ok2 f v1@(VError {}) _ = v1
+ok2 f _ v2@(VError {}) = v2
+ok2 f v1 v2 = f v1 v2
+
+ok2p f (v1@VError {},_) = v1
+ok2p f (_,v2@VError {}) = v2
+ok2p f vv = f vv
+
+unlockVRec loc c0 v0 = v0
+{-
+unlockVRec loc c0 v0 = unlockVRec' c0 v0
+  where
+    unlockVRec' ::Ident -> Value -> Value
+    unlockVRec' c v =
+        case v of
+    --    VClosure env t -> err bug (VClosure env) (unlockRecord c t)
+          VAbs bt x (Bind f) -> VAbs bt x (Bind $ \ v -> unlockVRec' c (f v))
+          VRec rs        -> plusVRec rs lock
+    --    _              -> VExtR v (VRec lock) -- hmm
+          _              -> {-trace (render $ ppL loc $ "unlock non-record "++show v0)-} v -- hmm
+    --    _              -> bugloc loc $ "unlock non-record "++show v0
+      where
+        lock = [(lockLabel c,VRec [])]
+-}
+
+-- suspicious, but backwards compatible
+plusVRec rs1 rs2 = VRec ([(l,v)|(l,v)<-rs1,l `notElem` ls2] ++ rs2)
+  where ls2 = map fst rs2
+
+extR t vv =
+    case vv of
+      (VFV vs,v2) -> vfv [extR t (v1,v2)|v1<-vs]
+      (v1,VFV vs) -> vfv [extR t (v1,v2)|v2<-vs]
+      (VRecType rs1, VRecType rs2) ->
+          case intersect (map fst rs1) (map fst rs2) of
+            [] -> VRecType (rs1 ++ rs2)
+            ls -> error $ "clash"<+>show ls
+      (VRec     rs1, VRec     rs2) -> plusVRec rs1 rs2
+      (v1          , VRec [(l,_)]) | isLockLabel l -> v1 -- hmm
+      (VS (VV t pvs vs) s,v2) -> VS (VV t pvs [extR t (v1,v2)|v1<-vs]) s
+--    (v1,v2) -> ok2 VExtR v1 v2 -- hmm
+      (v1,v2) -> error $ "not records" $$ show v1 $$ show v2
+  where
+    error explain = ppbug $ "The term" <+> t
+                            <+> "is not reducible" $$ explain
+
+glue env (v1,v2) = glu v1 v2
+  where
+    glu v1 v2 =
+        case (v1,v2) of
+          (VFV vs,v2) -> vfv [glu v1 v2|v1<-vs]
+          (v1,VFV vs) -> vfv [glu v1 v2|v2<-vs]
+          (VString s1,VString s2) -> VString (s1++s2)
+          (v1,VAlts d vs) -> VAlts (glx d) [(glx v,c) | (v,c) <- vs]
+             where glx v2 = glu v1 v2
+          (v1@(VAlts {}),v2) ->
+           --err (const (ok2 VGlue v1 v2)) id $
+             err bug id $
+             do y' <- strsFromValue v2
+                x' <- strsFromValue v1
+                return $ vfv [foldr1 VC (map VString (str2strings (glueStr v u))) | v <- x', u <- y']
+          (VC va vb,v2) -> VC va (glu vb v2)
+          (v1,VC va vb) -> VC (glu v1 va) vb
+          (VS (VV ty pvs vs) vb,v2) -> VS (VV ty pvs [glu v v2|v<-vs]) vb
+          (v1,VS (VV ty pvs vs) vb) -> VS (VV ty pvs [glu v1 v|v<-vs]) vb
+          (v1@(VApp NonExist _),_) -> v1
+          (_,v2@(VApp NonExist _)) -> v2
+--        (v1,v2) -> ok2 VGlue v1 v2
+          (v1,v2) -> if flag optPlusAsBind (opts env)
+                       then VC v1 (VC (VApp BIND []) v2)
+                       else let loc  = gloc env
+                                vt v = case value2term loc (local env) v of
+                                         Left i  -> Error ('#':show i)
+                                         Right t -> t
+                                originalMsg = render $ ppL loc (hang "unsupported token gluing" 4
+                                                               (Glue (vt v1) (vt v2)))
+                                term = render $ pp  $ Glue (vt v1) (vt v2)
+                            in error $ unlines
+                                [originalMsg
+                                ,""
+                                ,"There was a problem in the expression `"++term++"`, either:"
+                                ,"1) You are trying to use + on runtime arguments, possibly via an oper."
+                                ,"2) One of the arguments in `"++term++"` is a bound variable from pattern matching a string, but the cases are non-exhaustive."
+                                ,"For more help see https://github.com/GrammaticalFramework/gf-core/tree/master/doc/errors/gluing.md"
+                                ]
+
+
+-- | to get a string from a value that represents a sequence of terminals
+strsFromValue :: Value -> Err [Str]
+strsFromValue t = case t of
+  VString s   -> return [str s]
+  VC s t -> do
+    s' <- strsFromValue s
+    t' <- strsFromValue t
+    return [plusStr x y | x <- s', y <- t']
+{-
+  VGlue s t -> do
+    s' <- strsFromValue s
+    t' <- strsFromValue t
+    return [glueStr x y | x <- s', y <- t']
+-}
+  VAlts d vs -> do
+    d0 <- strsFromValue d
+    v0 <- mapM (strsFromValue . fst) vs
+    c0 <- mapM (strsFromValue . snd) vs
+  --let vs' = zip v0 c0
+    return [strTok (str2strings def) vars |
+              def  <- d0,
+              vars <- [[(str2strings v, map sstr c) | (v,c) <- zip vv c0] |
+                                                          vv <- sequence v0]
+           ]
+  VFV ts -> concat # mapM strsFromValue ts
+  VStrs ts -> concat # mapM strsFromValue ts
+
+  _ -> fail ("cannot get Str from value " ++ show t)
+
+vfv vs = case nub vs of
+           [v] -> v
+           vs -> VFV vs
+
+select env vv =
+    case vv of
+      (v1,VFV vs) -> vfv [select env (v1,v2)|v2<-vs]
+      (VFV vs,v2) -> vfv [select env (v1,v2)|v1<-vs]
+      (v1@(VV pty vs rs),v2) ->
+         err (const (VS v1 v2)) id $
+         do --ats <- allParamValues (srcgr env) pty
+            --let vs = map (value0 env) ats
+            i <- maybeErr "no match" $ findIndex (==v2) vs
+            return (ix (gloc env) "select" rs i)
+      (VT _ _ [(PW,Bind b)],_) -> {-trace "eliminate wild card table" $-} b []
+      (v1@(VT _ _ cs),v2) ->
+                 err (\_->ok2 VS v1 v2) (err bug id . valueMatch env) $
+                 match (gloc env) cs v2
+      (VS (VV pty pvs rs) v12,v2) -> VS (VV pty pvs [select env (v11,v2)|v11<-rs]) v12
+      (v1,v2) -> ok2 VS v1 v2
+
+match loc cs v =
+  case value2term loc [] v of
+    Left i  -> bad ("variable #"++show i++" is out of scope")
+    Right t -> err bad return (matchPattern cs t)
+  where
+    bad = fail . ("In pattern matching: "++)
+
+valueMatch :: CompleteEnv -> (Bind Env,Substitution) -> Err Value
+valueMatch env (Bind f,env') = f # mapPairsM (value0 env) env'
+
+valueTable :: CompleteEnv -> TInfo -> [Case] -> Err OpenValue
+valueTable env i cs =
+    case i of
+      TComp ty -> do pvs <- paramValues env ty
+                     ((VV ty pvs .) # sequence) # mapM (value env.snd) cs
+      _ -> do ty <- getTableType i
+              cs' <- mapM valueCase cs
+              err (dynamic cs' ty) return (convert cs' ty)
+  where
+    dynamic cs' ty _ = cases cs' # value env ty
+
+    cases cs' vty vs = err keep ($vs) (convertv cs' (vty vs))
+      where
+        keep msg = --trace (msg++"\n"++render (ppTerm Unqualified 0 (T i cs))) $
+                   VT wild (vty vs) (mapSnd ($vs) cs')
+
+    wild = case i of TWild _ -> True; _ -> False
+
+    convertv cs' vty =
+      case value2term (gloc env) [] vty of
+        Left i    -> fail ("variable #"++show i++" is out of scope")
+        Right pty -> convert' cs' =<< paramValues'' env pty
+
+    convert cs' ty = convert' cs' =<< paramValues' env ty
+
+    convert' cs' ((pty,vs),pvs) =
+      do sts  <- mapM (matchPattern cs') vs
+         return $ \ vs -> VV pty pvs $ map (err bug id . valueMatch env)
+                                           (mapFst ($vs) sts)
+
+    valueCase (p,t) = do p' <- measurePatt # inlinePattMacro p
+                         pvs <- linPattVars p'
+                         vt <- value (extend pvs env) t
+                         return (p',\vs-> Bind $ \bs-> vt (push' p' bs pvs vs))
+
+    inlinePattMacro p =
+        case p of
+          PM qc -> do r <- resource env qc
+                      case r of
+                        VPatt p' -> inlinePattMacro p'
+                        _ -> ppbug $ hang "Expected pattern macro:" 4
+                                          (show r)
+          _ -> composPattOp inlinePattMacro p
+
+
+paramValues env ty = snd # paramValues' env ty
+
+paramValues' env ty = paramValues'' env =<< nfx (global env) ty
+
+paramValues'' env pty = do ats <- allParamValues (srcgr env) pty
+                           pvs <- mapM (eval (global env) []) ats
+                           return ((pty,ats),pvs)
+
+push' p bs xs = if length bs/=length xs
+                then bug $ "push "++show (p,bs,xs)
+                else push bs xs
+
+push :: Env -> LocalScope -> Stack -> Stack
+push bs [] vs = vs
+push bs (x:xs) vs = maybe err id (lookup x bs):push bs xs vs
+  where  err = bug $ "Unbound pattern variable "++showIdent x
+
+apply' :: CompleteEnv -> Term -> [OpenValue] -> Err OpenValue
+apply' env t [] = value env t
+apply' env t vs =
+  case t of
+    QC x                   -> return $ \ svs -> VCApp x (map ($svs) vs)
+{-
+    Q x@(m,f) | m==cPredef -> return $
+                              let constr = --trace ("predef "++show x) .
+                                           VApp x
+                              in \ svs -> maybe constr id (Map.lookup f predefs)
+                                          $ map ($svs) vs
+              | otherwise  -> do r <- resource env x
+                                 return $ \ svs -> vapply (gloc env) r (map ($svs) vs)
+-}
+    App t1 t2              -> apply' env t1 . (:vs) =<< value env t2
+    _                      -> do fv <- value env t
+                                 return $ \ svs -> vapply (gloc env) (fv svs) (map ($svs) vs)
+
+vapply :: GLocation -> Value -> [Value] -> Value
+vapply loc v [] = v
+vapply loc v vs =
+  case v of
+    VError {} -> v
+--  VClosure env (Abs b x t) -> beta gr env b x t vs
+    VAbs bt _ (Bind f) -> vbeta loc bt f vs
+    VApp pre vs1 -> delta' pre (vs1++vs)
+      where
+        delta' Trace (v1:v2:vs) = let vr = vapply loc v2 vs
+                                  in vtrace loc v1 vr
+        delta' pre vs = err msg vfv $ mapM (delta pre) (varyList vs)
+        --msg = const (VApp pre (vs1++vs))
+        msg = bug . (("Applying Predef."++showIdent (predefName pre)++": ")++)
+    VS (VV t pvs fs) s -> VS (VV t pvs [vapply loc f vs|f<-fs]) s
+    VFV fs -> vfv [vapply loc f vs|f<-fs]
+    VCApp f vs0 -> VCApp f (vs0++vs)
+    VMeta i env vs0 -> VMeta i env (vs0++vs)
+    VGen i vs0 -> VGen i (vs0++vs)
+    v -> bug $ "vapply "++show v++" "++show vs
+
+vbeta loc bt f (v:vs) =
+  case (bt,v) of
+    (Implicit,VImplArg v) -> ap v
+    (Explicit,         v) -> ap v
+  where
+    ap (VFV avs) = vfv [vapply loc (f v) vs|v<-avs]
+    ap v         = vapply loc (f v) vs
+
+vary (VFV vs) = vs
+vary v = [v]
+varyList = mapM vary
+
+{-
+beta env b x t (v:vs) =
+  case (b,v) of
+    (Implicit,VImplArg v) -> apply' (ext (x,v) env) t vs
+    (Explicit,         v) -> apply' (ext (x,v) env) t vs
+-}
+
+vtrace loc arg res = trace (render (hang (pv arg) 4 ("->"<+>pv res))) res
+  where
+    pv v = case v of
+             VRec (f:as) -> hang (pf f) 4 (fsep (map pa as))
+             _ -> ppV v
+    pf (_,VString n) = pp n
+    pf (_,v) = ppV v
+    pa (_,v) = ppV v
+    ppV v = case value2term' True loc [] v of
+              Left i  -> "variable #" <> pp i <+> "is out of scope"
+              Right t -> ppTerm Unqualified 10 t
+
+-- | Convert a value back to a term
+value2term :: GLocation -> [Ident] -> Value -> Either Int Term
+value2term = value2term' False
+value2term' stop loc xs v0 =
+  case v0 of
+    VApp pre vs    -> liftM (foldl App (Q (cPredef,predefName pre))) (mapM v2t vs)
+    VCApp f vs     -> liftM  (foldl App (QC f))   (mapM v2t vs)
+    VGen j vs      -> liftM2 (foldl App) (var j)  (mapM v2t vs)
+    VMeta j env vs -> liftM  (foldl App (Meta j)) (mapM v2t vs)
+    VProd bt v x f -> liftM2 (Prod bt x) (v2t v) (v2t' x f)
+    VAbs  bt   x f -> liftM  (Abs  bt x)         (v2t' x f)
+    VInt n         -> return (EInt n)
+    VFloat f       -> return (EFloat f)
+    VString s      -> return (if null s then Empty else K s)
+    VSort s        -> return (Sort s)
+    VImplArg v     -> liftM  ImplArg (v2t v)
+    VTblType p res -> liftM2 Table (v2t p) (v2t res)
+    VRecType rs    -> liftM  RecType (mapM (\(l,v) -> fmap ((,) l) (v2t v)) rs)
+    VRec as        -> liftM  R       (mapM (\(l,v) -> v2t v >>= \t -> return (l,(Nothing,t))) as)
+    VV t _ vs      -> liftM  (V t)   (mapM v2t vs)
+    VT wild v cs   -> v2t v >>= \t -> liftM (T ((if wild then TWild else TTyped) t)) (mapM nfcase cs)
+    VFV vs         -> liftM  FV (mapM v2t vs)
+    VC v1 v2       -> liftM2 C (v2t v1) (v2t v2)
+    VS v1 v2       -> liftM2 S (v2t v1) (v2t v2)
+    VP v l         -> v2t v >>= \t -> return (P t l)
+    VPatt p        -> return (EPatt p)
+    VPattType v    -> v2t v >>= return . EPattType
+    VAlts v vvs    -> liftM2 Alts (v2t v) (mapM (\(x,y) -> liftM2 (,) (v2t x) (v2t y)) vvs)
+    VStrs vs       -> liftM  Strs (mapM v2t vs)
+--  VGlue v1 v2    -> Glue (v2t v1) (v2t v2)
+--  VExtR v1 v2    -> ExtR (v2t v1) (v2t v2)
+    VError err     -> return (Error err)
+
+  where
+    v2t = v2txs xs
+    v2txs = value2term' stop loc
+    v2t' x f = v2txs (x:xs) (bind f (gen xs))
+
+    var j
+      | j<length xs = Right (Vr (reverse xs !! j))
+      | otherwise   = Left  j
+
+
+    pushs xs e = foldr push e xs
+    push x (env,xs) = ((x,gen xs):env,x:xs)
+    gen xs = VGen (length xs) []
+
+    nfcase (p,f) = liftM ((,) p) (v2txs xs' (bind f env'))
+      where (env',xs') = pushs (pattVars p) ([],xs)
+
+    bind (Bind f) x = if stop
+                      then VSort (identS "...") -- hmm
+                      else f x
+
+
+linPattVars p =
+    if null dups
+    then return pvs
+    else fail.render $ hang "Pattern is not linear. All variable names on the left-hand side must be distinct." 4 (ppPatt Unqualified 0 p)
+  where
+    allpvs = allPattVars p
+    pvs = nub allpvs
+    dups = allpvs \\ pvs
+
+pattVars = nub . allPattVars
+allPattVars p =
+    case p of
+      PV i    -> [i]
+      PAs i p -> i:allPattVars p
+      _       -> collectPattOp allPattVars p
+
+---
+ix loc fn xs i =
+    if i<n
+    then xs !! i
+    else bugloc loc $ "(!!): index too large in "++fn++", "++show i++"<"++show n
+  where n = length xs
+
+infixl 1 #,<# --,@@
+
+f # x = fmap f x
+mf <# mx  = ap mf mx
+--m1 @@ m2 = (m1 =<<) . m2
+
+both f (x,y) = (,) # f x <# f y
+
+bugloc loc s = ppbug $ ppL loc s
+
+bug msg = ppbug msg
+ppbug doc = error $ render $ hang "Internal error in Compute.Concrete:" 4 doc
diff --git a/src/compiler/GF/Compile/Compute/ConcreteNew.hs b/src/compiler/GF/Compile/Compute/ConcreteNew.hs
deleted file mode 100644
index 6f00c45e1..000000000
--- a/src/compiler/GF/Compile/Compute/ConcreteNew.hs
+++ /dev/null
@@ -1,588 +0,0 @@
--- | Functions for computing the values of terms in the concrete syntax, in
--- | preparation for PMCFG generation.
-module GF.Compile.Compute.ConcreteNew
-           (GlobalEnv, GLocation, resourceValues, geLoc, geGrammar,
-            normalForm,
-            Value(..), Bind(..), Env, value2term, eval, vapply
-           ) where
-import Prelude hiding ((<>)) -- GHC 8.4.1 clash with Text.PrettyPrint
-
-import GF.Grammar hiding (Env, VGen, VApp, VRecType)
-import GF.Grammar.Lookup(lookupResDefLoc,allParamValues)
-import GF.Grammar.Predef(cPredef,cErrorType,cTok,cStr,cTrace,cPBool)
-import GF.Grammar.PatternMatch(matchPattern,measurePatt)
-import GF.Grammar.Lockfield(isLockLabel,lockRecType) --unlockRecord,lockLabel
-import GF.Compile.Compute.Value hiding (Error)
-import GF.Compile.Compute.Predef(predef,predefName,delta)
-import GF.Data.Str(Str,glueStr,str2strings,str,sstr,plusStr,strTok)
-import GF.Data.Operations(Err,err,errIn,maybeErr,mapPairsM)
-import GF.Data.Utilities(mapFst,mapSnd)
-import GF.Infra.Option
-import Control.Monad(ap,liftM,liftM2) -- ,unless,mplus
-import Data.List (findIndex,intersect,nub,elemIndex,(\\)) --,isInfixOf
---import Data.Char (isUpper,toUpper,toLower)
-import GF.Text.Pretty
-import qualified Data.Map as Map
-import Debug.Trace(trace)
-
--- * Main entry points
-
-normalForm :: GlobalEnv -> L Ident -> Term -> Term
-normalForm (GE gr rv opts _) loc = err (bugloc loc) id . nfx (GE gr rv opts loc)
-
-nfx env@(GE _ _ _ loc) t = do
-  v <- eval env [] t
-  case value2term loc [] v of
-    Left i  -> fail ("variable #"++show i++" is out of scope")
-    Right t -> return t
-
-eval :: GlobalEnv -> Env -> Term -> Err Value
-eval (GE gr rvs opts loc) env t = ($ (map snd env)) # value cenv t
-  where
-    cenv = CE gr rvs opts loc (map fst env)
-
---apply env = apply' env
-
---------------------------------------------------------------------------------
-
--- * Environments
-
-type ResourceValues = Map.Map ModuleName (Map.Map Ident (Err Value))
-
-data GlobalEnv = GE Grammar ResourceValues Options GLocation
-data CompleteEnv = CE {srcgr::Grammar,rvs::ResourceValues,
-                       opts::Options,
-                       gloc::GLocation,local::LocalScope}
-type GLocation = L Ident
-type LocalScope = [Ident]
-type Stack = [Value]
-type OpenValue = Stack->Value
-
-geLoc     (GE _ _ _ loc) = loc
-geGrammar (GE gr _ _ _)  = gr
-
-ext b env = env{local=b:local env}
-extend bs env = env{local=bs++local env}
-global env = GE (srcgr env) (rvs env) (opts env) (gloc env)
-
-var :: CompleteEnv -> Ident -> Err OpenValue
-var env x = maybe unbound pick' (elemIndex x (local env))
-  where
-    unbound = fail ("Unknown variable: "++showIdent x)
-    pick' i = return $ \ vs -> maybe (err i vs) ok (pick i vs)
-    err i vs = bug $ "Stack problem: "++showIdent x++": "
-                    ++unwords (map showIdent (local env))
-                    ++" => "++show (i,length vs)
-    ok v = --trace ("var "++show x++" = "++show v) $
-           v
-
-pick :: Int -> Stack -> Maybe Value
-pick 0 (v:_) = Just v
-pick i (_:vs) = pick (i-1) vs
-pick i vs = Nothing -- bug $ "pick "++show (i,vs)
-
-resource env (m,c) =
---  err bug id $
-    if isPredefCat c
-    then value0 env =<< lockRecType c defLinType -- hmm
-    else maybe e id $ Map.lookup c =<< Map.lookup m (rvs env)
-  where e = fail $ "Not found: "++render m++"."++showIdent c
-
--- | Convert operators once, not every time they are looked up
-resourceValues :: Options -> SourceGrammar -> GlobalEnv
-resourceValues opts gr = env
-  where
-    env = GE gr rvs opts (L NoLoc identW)
-    rvs = Map.mapWithKey moduleResources (moduleMap gr)
-    moduleResources m = Map.mapWithKey (moduleResource m) . jments
-    moduleResource m c _info = do L l t <- lookupResDefLoc gr (m,c)
-                                  let loc = L l c
-                                      qloc = L l (Q (m,c))
-                                  eval (GE gr rvs opts loc) [] (traceRes qloc t)
-
-    traceRes = if flag optTrace opts
-               then traceResource
-               else const id
-
--- * Tracing
-
--- | Insert a call to the trace function under the top-level lambdas
-traceResource (L l q) t =
-  case termFormCnc t of
-    (abs,body) -> mkAbs abs (mkApp traceQ [args,body])
-      where
-        args = R $ tuple2record (K lstr:[Vr x|(bt,x)<-abs,bt==Explicit])
-        lstr = render (l<>":"<>ppTerm Qualified 0 q)
-        traceQ = Q (cPredef,cTrace)
-
--- * Computing values
-
--- | Computing the value of a top-level term
-value0 :: CompleteEnv -> Term -> Err Value
-value0 env = eval (global env) []
-
--- | Computing the value of a term
-value :: CompleteEnv -> Term -> Err OpenValue
-value env t0 =
-  -- Each terms is traversed only once by this function, using only statically
-  -- available information. Notably, the values of lambda bound variables 
-  -- will be unknown during the term traversal phase.
-  -- The result is an OpenValue, which is a function that may be applied many
-  -- times to different dynamic values, but without the term traversal overhead
-  -- and without recomputing other statically known information.
-  -- For this to work, there should be no recursive calls under lambdas here.
-  -- Whenever we need to construct the OpenValue function with an explicit
-  -- lambda, we have to lift the recursive calls outside the lambda.
-  -- (See e.g. the rules for Let, Prod and Abs)
-{-
-  trace (render $ text "value"<+>sep [ppL (gloc env)<>text ":",
-                                      brackets (fsep (map ppIdent (local env))),
-                                      ppTerm Unqualified 10 t0]) $
---}
-  errIn (render t0) $
-  case t0 of
-    Vr x   -> var env x
-    Q x@(m,f)
-      | m == cPredef -> if f==cErrorType                -- to be removed
-                        then let p = identS "P"
-                             in const # value0 env (mkProd [(Implicit,p,typeType)] (Vr p) [])
-                        else if f==cPBool
-                               then const # resource env x
-                               else const . flip VApp [] # predef f
-      | otherwise    -> const # resource env x --valueResDef (fst env) x
-    QC x   -> return $ const (VCApp x [])
-    App e1 e2 -> apply' env e1 . (:[]) =<< value env e2
-    Let (x,(oty,t)) body -> do vb <- value (ext x env) body
-                               vt <- value env t
-                               return $ \ vs -> vb (vt vs:vs)
-    Meta i -> return $ \ vs -> VMeta i (zip (local env) vs) []
-    Prod bt x t1 t2 ->
-       do vt1 <- value env t1
-          vt2 <- value (ext x env) t2
-          return $ \ vs -> VProd bt (vt1 vs) x $ Bind $ \ vx -> vt2 (vx:vs)
-    Abs bt x t -> do vt <- value (ext x env) t
-                     return $ VAbs bt x . Bind . \ vs vx -> vt (vx:vs)
-    EInt n -> return $ const (VInt n)
-    EFloat f -> return $ const (VFloat f)
-    K s -> return $ const (VString s)
-    Empty -> return $ const (VString "")
-    Sort s | s == cTok -> return $ const (VSort cStr)        -- to be removed 
-           | otherwise -> return $ const (VSort s)
-    ImplArg t -> (VImplArg.) # value env t
-    Table p res -> liftM2 VTblType # value env p <# value env res
-    RecType rs -> do lovs <- mapPairsM (value env) rs
-                     return $ \vs->VRecType $ mapSnd ($vs) lovs
-    t@(ExtR t1 t2) -> ((extR t.)# both id) # both (value env) (t1,t2)
-    FV ts   -> ((vfv .) # sequence) # mapM (value env) ts
-    R as    -> do lovs <- mapPairsM (value env.snd) as
-                  return $ \ vs->VRec $ mapSnd ($vs) lovs
-    T i cs  -> valueTable env i cs
-    V ty ts -> do pvs <- paramValues env ty
-                  ((VV ty pvs .) . sequence) # mapM (value env) ts
-    C t1 t2 -> ((ok2p vconcat.) # both id) # both (value env) (t1,t2)
-    S t1 t2 -> ((select env.) # both id) # both (value env) (t1,t2)
-    P t l   -> --maybe (bug $ "project "++show l++" from "++show v) id $
-               do ov <- value env t
-                  return $ \ vs -> let v = ov vs
-                                   in maybe (VP v l) id (proj l v)
-    Alts t tts -> (\v vts -> VAlts # v <# mapM (both id) vts) # value env t <# mapM (both (value env)) tts
-    Strs ts    -> ((VStrs.) # sequence) # mapM (value env) ts
-    Glue t1 t2 -> ((ok2p (glue env).) # both id) # both (value env) (t1,t2)
-    ELin c r -> (unlockVRec (gloc env) c.) # value env r
-    EPatt p  -> return $ const (VPatt p) -- hmm
-    EPattType ty -> do vt <- value env ty
-                       return (VPattType . vt)
-    Typed t ty -> value env t
-    t -> fail.render $ "value"<+>ppTerm Unqualified 10 t $$ show t
-
-vconcat vv@(v1,v2) =
-    case vv of
-      (VString "",_) -> v2
-      (_,VString "") -> v1
-      (VApp NonExist _,_) -> v1
-      (_,VApp NonExist _) -> v2
-      _ -> VC v1 v2
-
-proj l v | isLockLabel l = return (VRec [])
-                ---- a workaround 18/2/2005: take this away and find the reason
-                ---- why earlier compilation destroys the lock field
-proj l v =
-    case v of
-      VFV vs -> liftM vfv (mapM (proj l) vs)
-      VRec rs -> lookup l rs
---    VExtR v1 v2 -> proj l v2 `mplus` proj l v1 -- hmm
-      VS (VV pty pvs rs) v2 -> flip VS v2 . VV pty pvs # mapM (proj l) rs
-      _ -> return (ok1 VP v l)
-
-ok1 f v1@(VError {}) _ = v1
-ok1 f v1 v2 = f v1 v2
- 
-ok2 f v1@(VError {}) _ = v1
-ok2 f _ v2@(VError {}) = v2
-ok2 f v1 v2 = f v1 v2
-
-ok2p f (v1@VError {},_) = v1
-ok2p f (_,v2@VError {}) = v2
-ok2p f vv = f vv
-
-unlockVRec loc c0 v0 = v0
-{-
-unlockVRec loc c0 v0 = unlockVRec' c0 v0
-  where
-    unlockVRec' ::Ident -> Value -> Value
-    unlockVRec' c v =
-        case v of
-    --    VClosure env t -> err bug (VClosure env) (unlockRecord c t)
-          VAbs bt x (Bind f) -> VAbs bt x (Bind $ \ v -> unlockVRec' c (f v))
-          VRec rs        -> plusVRec rs lock
-    --    _              -> VExtR v (VRec lock) -- hmm
-          _              -> {-trace (render $ ppL loc $ "unlock non-record "++show v0)-} v -- hmm
-    --    _              -> bugloc loc $ "unlock non-record "++show v0
-      where
-        lock = [(lockLabel c,VRec [])]
--}
-
--- suspicious, but backwards compatible
-plusVRec rs1 rs2 = VRec ([(l,v)|(l,v)<-rs1,l `notElem` ls2] ++ rs2)
-  where ls2 = map fst rs2
-
-extR t vv =
-    case vv of
-      (VFV vs,v2) -> vfv [extR t (v1,v2)|v1<-vs]
-      (v1,VFV vs) -> vfv [extR t (v1,v2)|v2<-vs]
-      (VRecType rs1, VRecType rs2) ->
-          case intersect (map fst rs1) (map fst rs2) of
-            [] -> VRecType (rs1 ++ rs2)
-            ls -> error $ "clash"<+>show ls
-      (VRec     rs1, VRec     rs2) -> plusVRec rs1 rs2
-      (v1          , VRec [(l,_)]) | isLockLabel l -> v1 -- hmm
-      (VS (VV t pvs vs) s,v2) -> VS (VV t pvs [extR t (v1,v2)|v1<-vs]) s
---    (v1,v2) -> ok2 VExtR v1 v2 -- hmm
-      (v1,v2) -> error $ "not records" $$ show v1 $$ show v2
-  where
-    error explain = ppbug $ "The term" <+> t
-                            <+> "is not reducible" $$ explain
-
-glue env (v1,v2) = glu v1 v2
-  where
-    glu v1 v2 =
-        case (v1,v2) of
-          (VFV vs,v2) -> vfv [glu v1 v2|v1<-vs]
-          (v1,VFV vs) -> vfv [glu v1 v2|v2<-vs]
-          (VString s1,VString s2) -> VString (s1++s2)
-          (v1,VAlts d vs) -> VAlts (glx d) [(glx v,c) | (v,c) <- vs]
-             where glx v2 = glu v1 v2
-          (v1@(VAlts {}),v2) ->
-           --err (const (ok2 VGlue v1 v2)) id $
-             err bug id $
-             do y' <- strsFromValue v2
-                x' <- strsFromValue v1
-                return $ vfv [foldr1 VC (map VString (str2strings (glueStr v u))) | v <- x', u <- y']
-          (VC va vb,v2) -> VC va (glu vb v2)
-          (v1,VC va vb) -> VC (glu v1 va) vb
-          (VS (VV ty pvs vs) vb,v2) -> VS (VV ty pvs [glu v v2|v<-vs]) vb
-          (v1,VS (VV ty pvs vs) vb) -> VS (VV ty pvs [glu v1 v|v<-vs]) vb
-          (v1@(VApp NonExist _),_) -> v1
-          (_,v2@(VApp NonExist _)) -> v2
---        (v1,v2) -> ok2 VGlue v1 v2
-          (v1,v2) -> if flag optPlusAsBind (opts env)
-                       then VC v1 (VC (VApp BIND []) v2)
-                       else let loc  = gloc env
-                                vt v = case value2term loc (local env) v of
-                                         Left i  -> Error ('#':show i)
-                                         Right t -> t
-                                originalMsg = render $ ppL loc (hang "unsupported token gluing" 4
-                                                               (Glue (vt v1) (vt v2)))
-                                term = render $ pp  $ Glue (vt v1) (vt v2)
-                            in error $ unlines
-                                [originalMsg
-                                ,""
-                                ,"There was a problem in the expression `"++term++"`, either:"
-                                ,"1) You are trying to use + on runtime arguments, possibly via an oper."
-                                ,"2) One of the arguments in `"++term++"` is a bound variable from pattern matching a string, but the cases are non-exhaustive."
-                                ,"For more help see https://github.com/GrammaticalFramework/gf-core/tree/master/doc/errors/gluing.md"
-                                ]
-
-
--- | to get a string from a value that represents a sequence of terminals
-strsFromValue :: Value -> Err [Str]
-strsFromValue t = case t of
-  VString s   -> return [str s]
-  VC s t -> do
-    s' <- strsFromValue s
-    t' <- strsFromValue t
-    return [plusStr x y | x <- s', y <- t']
-{-
-  VGlue s t -> do
-    s' <- strsFromValue s
-    t' <- strsFromValue t
-    return [glueStr x y | x <- s', y <- t']
--}
-  VAlts d vs -> do
-    d0 <- strsFromValue d
-    v0 <- mapM (strsFromValue . fst) vs
-    c0 <- mapM (strsFromValue . snd) vs
-  --let vs' = zip v0 c0
-    return [strTok (str2strings def) vars | 
-              def  <- d0,
-              vars <- [[(str2strings v, map sstr c) | (v,c) <- zip vv c0] | 
-                                                          vv <- sequence v0]
-           ]
-  VFV ts -> concat # mapM strsFromValue ts
-  VStrs ts -> concat # mapM strsFromValue ts
-
-  _ -> fail ("cannot get Str from value " ++ show t)
-
-vfv vs = case nub vs of
-           [v] -> v
-           vs -> VFV vs
-
-select env vv =
-    case vv of
-      (v1,VFV vs) -> vfv [select env (v1,v2)|v2<-vs]
-      (VFV vs,v2) -> vfv [select env (v1,v2)|v1<-vs]
-      (v1@(VV pty vs rs),v2) ->
-         err (const (VS v1 v2)) id $
-         do --ats <- allParamValues (srcgr env) pty
-            --let vs = map (value0 env) ats
-            i <- maybeErr "no match" $ findIndex (==v2) vs
-            return (ix (gloc env) "select" rs i)
-      (VT _ _ [(PW,Bind b)],_) -> {-trace "eliminate wild card table" $-} b []
-      (v1@(VT _ _ cs),v2) ->
-                 err (\_->ok2 VS v1 v2) (err bug id . valueMatch env) $
-                 match (gloc env) cs v2
-      (VS (VV pty pvs rs) v12,v2) -> VS (VV pty pvs [select env (v11,v2)|v11<-rs]) v12
-      (v1,v2) -> ok2 VS v1 v2
-
-match loc cs v = 
-  case value2term loc [] v of
-    Left i  -> bad ("variable #"++show i++" is out of scope")
-    Right t -> err bad return (matchPattern cs t)
-  where
-    bad = fail . ("In pattern matching: "++)
-
-valueMatch :: CompleteEnv -> (Bind Env,Substitution) -> Err Value
-valueMatch env (Bind f,env') = f # mapPairsM (value0 env) env'
-
-valueTable :: CompleteEnv -> TInfo -> [Case] -> Err OpenValue
-valueTable env i cs =
-    case i of
-      TComp ty -> do pvs <- paramValues env ty
-                     ((VV ty pvs .) # sequence) # mapM (value env.snd) cs
-      _ -> do ty <- getTableType i
-              cs' <- mapM valueCase cs
-              err (dynamic cs' ty) return (convert cs' ty)
-  where
-    dynamic cs' ty _ = cases cs' # value env ty
-
-    cases cs' vty vs = err keep ($vs) (convertv cs' (vty vs))
-      where
-        keep msg = --trace (msg++"\n"++render (ppTerm Unqualified 0 (T i cs))) $
-                   VT wild (vty vs) (mapSnd ($vs) cs')
-
-    wild = case i of TWild _ -> True; _ -> False
-
-    convertv cs' vty = 
-      case value2term (gloc env) [] vty of
-        Left i    -> fail ("variable #"++show i++" is out of scope")
-        Right pty -> convert' cs' =<< paramValues'' env pty
-
-    convert cs' ty = convert' cs' =<< paramValues' env ty
-
-    convert' cs' ((pty,vs),pvs) =
-      do sts  <- mapM (matchPattern cs') vs
-         return $ \ vs -> VV pty pvs $ map (err bug id . valueMatch env)
-                                           (mapFst ($vs) sts)
-
-    valueCase (p,t) = do p' <- measurePatt # inlinePattMacro p
-                         pvs <- linPattVars p'
-                         vt <- value (extend pvs env) t
-                         return (p',\vs-> Bind $ \bs-> vt (push' p' bs pvs vs))
-
-    inlinePattMacro p =
-        case p of
-          PM qc -> do r <- resource env qc
-                      case r of
-                        VPatt p' -> inlinePattMacro p'
-                        _ -> ppbug $ hang "Expected pattern macro:" 4
-                                          (show r)
-          _ -> composPattOp inlinePattMacro p
-
-
-paramValues env ty = snd # paramValues' env ty
-
-paramValues' env ty = paramValues'' env =<< nfx (global env) ty
-
-paramValues'' env pty = do ats <- allParamValues (srcgr env) pty
-                           pvs <- mapM (eval (global env) []) ats
-                           return ((pty,ats),pvs)
-
-push' p bs xs = if length bs/=length xs
-                then bug $ "push "++show (p,bs,xs)
-                else push bs xs
-
-push :: Env -> LocalScope -> Stack -> Stack
-push bs [] vs = vs
-push bs (x:xs) vs = maybe err id (lookup x bs):push bs xs vs
-  where  err = bug $ "Unbound pattern variable "++showIdent x
-
-apply' :: CompleteEnv -> Term -> [OpenValue] -> Err OpenValue
-apply' env t [] = value env t
-apply' env t vs =
-  case t of
-    QC x                   -> return $ \ svs -> VCApp x (map ($svs) vs)
-{-
-    Q x@(m,f) | m==cPredef -> return $
-                              let constr = --trace ("predef "++show x) .
-                                           VApp x 
-                              in \ svs -> maybe constr id (Map.lookup f predefs)
-                                          $ map ($svs) vs
-              | otherwise  -> do r <- resource env x
-                                 return $ \ svs -> vapply (gloc env) r (map ($svs) vs)
--}
-    App t1 t2              -> apply' env t1 . (:vs) =<< value env t2
-    _                      -> do fv <- value env t
-                                 return $ \ svs -> vapply (gloc env) (fv svs) (map ($svs) vs)
-
-vapply :: GLocation -> Value -> [Value] -> Value
-vapply loc v [] = v
-vapply loc v vs =
-  case v of
-    VError {} -> v
---  VClosure env (Abs b x t) -> beta gr env b x t vs
-    VAbs bt _ (Bind f) -> vbeta loc bt f vs
-    VApp pre vs1 -> delta' pre (vs1++vs)
-      where
-        delta' Trace (v1:v2:vs) = let vr = vapply loc v2 vs
-                                  in vtrace loc v1 vr
-        delta' pre vs = err msg vfv $ mapM (delta pre) (varyList vs)
-        --msg = const (VApp pre (vs1++vs))
-        msg = bug . (("Applying Predef."++showIdent (predefName pre)++": ")++)
-    VS (VV t pvs fs) s -> VS (VV t pvs [vapply loc f vs|f<-fs]) s
-    VFV fs -> vfv [vapply loc f vs|f<-fs]
-    VCApp f vs0 -> VCApp f (vs0++vs)
-    VMeta i env vs0 -> VMeta i env (vs0++vs)
-    VGen i vs0 -> VGen i (vs0++vs)
-    v -> bug $ "vapply "++show v++" "++show vs
-
-vbeta loc bt f (v:vs) =
-  case (bt,v) of
-    (Implicit,VImplArg v) -> ap v
-    (Explicit,         v) -> ap v
-  where
-    ap (VFV avs) = vfv [vapply loc (f v) vs|v<-avs]
-    ap v         = vapply loc (f v) vs
-
-vary (VFV vs) = vs
-vary v = [v]
-varyList = mapM vary
-
-{-
-beta env b x t (v:vs) =
-  case (b,v) of
-    (Implicit,VImplArg v) -> apply' (ext (x,v) env) t vs
-    (Explicit,         v) -> apply' (ext (x,v) env) t vs
--}
-
-vtrace loc arg res = trace (render (hang (pv arg) 4 ("->"<+>pv res))) res
-  where
-    pv v = case v of
-             VRec (f:as) -> hang (pf f) 4 (fsep (map pa as))
-             _ -> ppV v
-    pf (_,VString n) = pp n
-    pf (_,v) = ppV v
-    pa (_,v) = ppV v
-    ppV v = case value2term' True loc [] v of
-              Left i  -> "variable #" <> pp i <+> "is out of scope"
-              Right t -> ppTerm Unqualified 10 t
-
--- | Convert a value back to a term
-value2term :: GLocation -> [Ident] -> Value -> Either Int Term
-value2term = value2term' False
-value2term' stop loc xs v0 =
-  case v0 of
-    VApp pre vs    -> liftM (foldl App (Q (cPredef,predefName pre))) (mapM v2t vs)
-    VCApp f vs     -> liftM  (foldl App (QC f))   (mapM v2t vs)
-    VGen j vs      -> liftM2 (foldl App) (var j)  (mapM v2t vs)
-    VMeta j env vs -> liftM  (foldl App (Meta j)) (mapM v2t vs)
-    VProd bt v x f -> liftM2 (Prod bt x) (v2t v) (v2t' x f)
-    VAbs  bt   x f -> liftM  (Abs  bt x)         (v2t' x f)
-    VInt n         -> return (EInt n)
-    VFloat f       -> return (EFloat f)
-    VString s      -> return (if null s then Empty else K s)
-    VSort s        -> return (Sort s)
-    VImplArg v     -> liftM  ImplArg (v2t v)
-    VTblType p res -> liftM2 Table (v2t p) (v2t res)
-    VRecType rs    -> liftM  RecType (mapM (\(l,v) -> fmap ((,) l) (v2t v)) rs)
-    VRec as        -> liftM  R       (mapM (\(l,v) -> v2t v >>= \t -> return (l,(Nothing,t))) as)
-    VV t _ vs      -> liftM  (V t)   (mapM v2t vs)
-    VT wild v cs   -> v2t v >>= \t -> liftM (T ((if wild then TWild else TTyped) t)) (mapM nfcase cs)
-    VFV vs         -> liftM  FV (mapM v2t vs)
-    VC v1 v2       -> liftM2 C (v2t v1) (v2t v2)
-    VS v1 v2       -> liftM2 S (v2t v1) (v2t v2)
-    VP v l         -> v2t v >>= \t -> return (P t l)
-    VPatt p        -> return (EPatt p)
-    VPattType v    -> v2t v >>= return . EPattType
-    VAlts v vvs    -> liftM2 Alts (v2t v) (mapM (\(x,y) -> liftM2 (,) (v2t x) (v2t y)) vvs)
-    VStrs vs       -> liftM  Strs (mapM v2t vs)
---  VGlue v1 v2    -> Glue (v2t v1) (v2t v2)
---  VExtR v1 v2    -> ExtR (v2t v1) (v2t v2)
-    VError err     -> return (Error err)
-  
-  where
-    v2t = v2txs xs
-    v2txs = value2term' stop loc
-    v2t' x f = v2txs (x:xs) (bind f (gen xs))
-
-    var j
-      | j<length xs = Right (Vr (reverse xs !! j))
-      | otherwise   = Left  j
-
-
-    pushs xs e = foldr push e xs
-    push x (env,xs) = ((x,gen xs):env,x:xs)
-    gen xs = VGen (length xs) []
-
-    nfcase (p,f) = liftM ((,) p) (v2txs xs' (bind f env'))
-      where (env',xs') = pushs (pattVars p) ([],xs)
-
-    bind (Bind f) x = if stop
-                      then VSort (identS "...") -- hmm
-                      else f x
-
-
-linPattVars p =
-    if null dups
-    then return pvs
-    else fail.render $ hang "Pattern is not linear. All variable names on the left-hand side must be distinct." 4 (ppPatt Unqualified 0 p)
-  where
-    allpvs = allPattVars p
-    pvs = nub allpvs
-    dups = allpvs \\ pvs
-
-pattVars = nub . allPattVars
-allPattVars p =
-    case p of
-      PV i    -> [i]
-      PAs i p -> i:allPattVars p
-      _       -> collectPattOp allPattVars p
-
----
-ix loc fn xs i =
-    if i<n
-    then xs !! i
-    else bugloc loc $ "(!!): index too large in "++fn++", "++show i++"<"++show n
-  where n = length xs
-
-infixl 1 #,<# --,@@
-
-f # x = fmap f x
-mf <# mx  = ap mf mx
---m1 @@ m2 = (m1 =<<) . m2
-
-both f (x,y) = (,) # f x <# f y
-
-bugloc loc s = ppbug $ ppL loc s
-
-bug msg = ppbug msg
-ppbug doc = error $ render $ hang "Internal error in Compute.ConcreteNew:" 4 doc
diff --git a/src/compiler/GF/Compile/Compute/Value.hs b/src/compiler/GF/Compile/Compute/Value.hs
index 7eb0c3bfb..c3fb83b4b 100644
--- a/src/compiler/GF/Compile/Compute/Value.hs
+++ b/src/compiler/GF/Compile/Compute/Value.hs
@@ -12,8 +12,8 @@ data Value
   | VGen Int [Value] -- for lambda bound variables, possibly applied
   | VMeta MetaId Env [Value]
 -- -- | VClosure Env Term -- used in Typecheck.ConcreteNew
-  | VAbs BindType Ident Binding -- used in Compute.ConcreteNew
-  | VProd BindType Value Ident Binding -- used in Compute.ConcreteNew
+  | VAbs BindType Ident Binding -- used in Compute.Concrete
+  | VProd BindType Value Ident Binding -- used in Compute.Concrete
   | VInt Int
   | VFloat Double
   | VString String
@@ -47,10 +47,10 @@ type Env = [(Ident,Value)]
 
 -- | Predefined functions
 data Predefined = Drop | Take | Tk | Dp | EqStr | Occur | Occurs | ToUpper
-                | ToLower | IsUpper | Length | Plus | EqInt | LessInt 
+                | ToLower | IsUpper | Length | Plus | EqInt | LessInt
              {- | Show | Read | ToStr | MapStr | EqVal -}
                 | Error | Trace
                 -- Canonical values below:
-                | PBool | PFalse | PTrue | Int | Float | Ints | NonExist 
+                | PBool | PFalse | PTrue | Int | Float | Ints | NonExist
                 | BIND | SOFT_BIND | SOFT_SPACE | CAPIT | ALL_CAPIT
                 deriving (Show,Eq,Ord,Ix,Bounded,Enum)
diff --git a/src/compiler/GF/Compile/GeneratePMCFG.hs b/src/compiler/GF/Compile/GeneratePMCFG.hs
index ab6476b31..8383f0624 100644
--- a/src/compiler/GF/Compile/GeneratePMCFG.hs
+++ b/src/compiler/GF/Compile/GeneratePMCFG.hs
@@ -25,7 +25,7 @@ import GF.Data.BacktrackM
 import GF.Data.Operations
 import GF.Infra.UseIO (ePutStr,ePutStrLn) -- IOE,
 import GF.Data.Utilities (updateNthM) --updateNth
-import GF.Compile.Compute.ConcreteNew(normalForm,resourceValues)
+import GF.Compile.Compute.Concrete(normalForm,resourceValues)
 import qualified Data.Map as Map
 import qualified Data.Set as Set
 import qualified Data.List as List
@@ -82,7 +82,7 @@ addPMCFG opts gr cenv opath am cm seqs id (GF.Grammar.CncFun mty@(Just (cat,cont
                           (goB b1 CNil [])
                           (pres,pargs)
       pmcfg      = getPMCFG pmcfgEnv1
-      
+
       stats      = let PMCFG prods funs = pmcfg
                        (s,e)            = bounds funs
                        !prods_cnt       = length prods
@@ -103,7 +103,7 @@ addPMCFG opts gr cenv opath am cm seqs id (GF.Grammar.CncFun mty@(Just (cat,cont
           newArgs  = map getFIds newArgs'
       in addFunction env0 newCat fun newArgs
 
-addPMCFG opts gr cenv opath am cm seqs id (GF.Grammar.CncCat mty@(Just (L _ lincat)) 
+addPMCFG opts gr cenv opath am cm seqs id (GF.Grammar.CncCat mty@(Just (L _ lincat))
                                                              mdef@(Just (L loc1 def))
                                                              mref@(Just (L loc2 ref))
                                                              mprn
@@ -162,7 +162,7 @@ pgfCncCat :: SourceGrammar -> Type -> Int -> CncCat
 pgfCncCat gr lincat index =
   let ((_,size),schema) = computeCatRange gr lincat
   in PGF.CncCat index (index+size-1)
-                      (mkArray (map (renderStyle style{mode=OneLineMode} . ppPath) 
+                      (mkArray (map (renderStyle style{mode=OneLineMode} . ppPath)
                                     (getStrPaths schema)))
   where
     getStrPaths :: Schema Identity s c -> [Path]
@@ -243,7 +243,7 @@ choices nr path = do (args,_) <- get
                                                                                                                     | (value,index) <- values])
     descend schema       path              rpath = bug $ "descend "++show (schema,path,rpath)
 
-    updateEnv path value gr c (args,seq) = 
+    updateEnv path value gr c (args,seq) =
       case updateNthM (restrictProtoFCat path value) nr args of
         Just args -> c value (args,seq)
         Nothing   -> bug "conflict in updateEnv"
@@ -606,7 +606,7 @@ restrictProtoFCat path v (PFCat cat f schema) = do
                                                        Just index -> return (CPar (m,[(v,index)]))
                                                        Nothing    -> mzero
     addConstraint CNil             v (CStr _)      = bug "restrictProtoFCat: string path"
-    
+
     update k0 f [] = return []
     update k0 f (x@(k,Identity v):xs)
       | k0 == k    = do v <- f v
diff --git a/src/compiler/GF/Compile/GrammarToCanonical.hs b/src/compiler/GF/Compile/GrammarToCanonical.hs
index 33f35ad08..d43256177 100644
--- a/src/compiler/GF/Compile/GrammarToCanonical.hs
+++ b/src/compiler/GF/Compile/GrammarToCanonical.hs
@@ -19,7 +19,7 @@ import GF.Compile.Compute.Value(Predefined(..))
 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)
+import GF.Compile.Compute.Concrete(normalForm,resourceValues)
 import GF.Grammar.Canonical as C
 import Debug.Trace
 
@@ -72,7 +72,7 @@ concrete2canonical gr cenv absname cnc modinfo =
       [lincat|(_,Left lincat)<-defs]
       [lin|(_,Right lin)<-defs]
   where
-    defs = concatMap (toCanonical gr absname cenv) . 
+    defs = concatMap (toCanonical gr absname cenv) .
            M.toList $
            jments modinfo
 
@@ -189,7 +189,7 @@ convert' gr vs = ppT
         _ -> VarValue (gQId cPredef n) -- hmm
       where
        p = PredefValue . PredefId
-      
+
     ppP p =
       case p of
         PC c ps -> ParamPattern (Param (gId c) (map ppP ps))
diff --git a/src/compiler/GF/Compile/Optimize.hs b/src/compiler/GF/Compile/Optimize.hs
index 393deb020..ac3fa357c 100644
--- a/src/compiler/GF/Compile/Optimize.hs
+++ b/src/compiler/GF/Compile/Optimize.hs
@@ -6,7 +6,7 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/09/16 13:56:13 $ 
+-- > CVS $Date: 2005/09/16 13:56:13 $
 -- > CVS $Author: aarne $
 -- > CVS $Revision: 1.18 $
 --
@@ -21,7 +21,7 @@ import GF.Grammar.Printer
 import GF.Grammar.Macros
 import GF.Grammar.Lookup
 import GF.Grammar.Predef
-import GF.Compile.Compute.ConcreteNew(GlobalEnv,normalForm,resourceValues)
+import GF.Compile.Compute.Concrete(GlobalEnv,normalForm,resourceValues)
 import GF.Data.Operations
 import GF.Infra.Option
 
@@ -90,7 +90,7 @@ evalInfo opts resenv sgr m c info = do
     let ppr' = fmap (evalPrintname resenv c) ppr
     return $ CncFun mt pde' ppr' mpmcfg -- only cat in type actually needed
 {-
-  ResOper pty pde 
+  ResOper pty pde
     | not new && OptExpand `Set.member` optim -> do
          pde' <- case pde of
                    Just (L loc de) -> do de <- computeConcrete gr de
@@ -171,13 +171,13 @@ mkLinDefault gr typ = liftM (Abs Explicit varStr) $ mkDefField typ
      _ -> Bad (render ("linearization type field cannot be" <+> typ))
 
 mkLinReference :: SourceGrammar -> Type -> Err Term
-mkLinReference gr typ = 
- liftM (Abs Explicit varStr) $ 
+mkLinReference gr typ =
+ liftM (Abs Explicit varStr) $
    case mkDefField typ (Vr varStr) of
      Bad "no string" -> return Empty
      x               -> x
  where
-   mkDefField ty trm = 
+   mkDefField ty trm =
      case ty of
        Table pty ty -> do ps <- allParamValues gr pty
                           case ps of
@@ -203,7 +203,7 @@ factor param c i t =
     T (TComp ty) cs -> factors ty [(p, factor param c (i+1) v) | (p, v) <- cs]
     _               -> composSafeOp (factor param c i) t
   where
-    factors ty pvs0  
+    factors ty pvs0
                  | not param = V ty (map snd pvs0)
     factors ty []            = V ty []
     factors ty pvs0@[(p,v)]  = V ty [v]
@@ -224,7 +224,7 @@ factor param c i t =
 replace :: Term -> Term -> Term -> Term
 replace old new trm =
   case trm of
-    -- these are the important cases, since they can correspond to patterns  
+    -- these are the important cases, since they can correspond to patterns
     QC _     | trm == old -> new
     App _ _  | trm == old -> new
     R _      | trm == old -> new
diff --git a/src/compiler/GF/Compile/TypeCheck/ConcreteNew.hs b/src/compiler/GF/Compile/TypeCheck/ConcreteNew.hs
index b35aaf9ed..c32afa7a5 100644
--- a/src/compiler/GF/Compile/TypeCheck/ConcreteNew.hs
+++ b/src/compiler/GF/Compile/TypeCheck/ConcreteNew.hs
@@ -10,7 +10,7 @@ import GF.Grammar hiding (Env, VGen, VApp, VRecType)
 import GF.Grammar.Lookup
 import GF.Grammar.Predef
 import GF.Grammar.Lockfield
-import GF.Compile.Compute.ConcreteNew
+import GF.Compile.Compute.Concrete
 import GF.Compile.Compute.Predef(predef,predefName)
 import GF.Infra.CheckM
 import GF.Data.Operations
@@ -133,7 +133,7 @@ tcRho ge scope t@(RecType rs) (Just ty) = do
                          [] -> unifyVar ge scope i env vs vtypePType
                          _  -> return ()
     ty              -> do ty <- zonkTerm =<< tc_value2term (geLoc ge) (scopeVars scope) ty
-                          tcError ("The record type" <+> ppTerm Unqualified 0 t $$ 
+                          tcError ("The record type" <+> ppTerm Unqualified 0 t $$
                                    "cannot be of type" <+> ppTerm Unqualified 0 ty)
   (rs,mb_ty) <- tcRecTypeFields ge scope rs (Just ty')
   return (f (RecType rs),ty)
@@ -187,7 +187,7 @@ tcRho ge scope (R rs) (Just ty) = do
   case ty' of
     (VRecType ltys) -> do lttys <- checkRecFields ge scope rs ltys
                           rs <- mapM (\(l,t,ty) -> tc_value2term (geLoc ge) (scopeVars scope) ty >>= \ty -> return (l, (Just ty, t))) lttys
-                          return ((f . R)  rs, 
+                          return ((f . R)  rs,
                                   VRecType [(l, ty) | (l,t,ty) <- lttys]
                                  )
     ty              -> do lttys <- inferRecFields ge scope rs
@@ -277,11 +277,11 @@ tcApp ge scope (App fun arg) =                                  -- APP2
         varg <- liftErr (eval ge (scopeEnv scope) arg)
         return (App fun arg, res_ty varg)
 tcApp ge scope (Q id) =                                          -- VAR (global)
-  mkTcA (lookupOverloadTypes (geGrammar ge) id) `bindTcA` \(t,ty) -> 
+  mkTcA (lookupOverloadTypes (geGrammar ge) id) `bindTcA` \(t,ty) ->
      do ty <- liftErr (eval ge [] ty)
         return (t,ty)
 tcApp ge scope (QC id) =                                         -- VAR (global)
-  mkTcA (lookupOverloadTypes (geGrammar ge) id) `bindTcA` \(t,ty) -> 
+  mkTcA (lookupOverloadTypes (geGrammar ge) id) `bindTcA` \(t,ty) ->
      do ty <- liftErr (eval ge [] ty)
         return (t,ty)
 tcApp ge scope t =
@@ -350,7 +350,7 @@ tcPatt ge scope (PM q) ty0 = do
     Bad err -> tcError (pp err)
 tcPatt ge scope p ty = unimplemented ("tcPatt "++show p)
 
-inferRecFields ge scope rs = 
+inferRecFields ge scope rs =
   mapM (\(l,r) -> tcRecField ge scope l r Nothing) rs
 
 checkRecFields ge scope []          ltys
@@ -368,7 +368,7 @@ checkRecFields ge scope ((l,t):lts) ltys =
   where
     takeIt l1 []  = (Nothing, [])
     takeIt l1 (lty@(l2,ty):ltys)
-      | l1 == l2  = (Just ty,ltys) 
+      | l1 == l2  = (Just ty,ltys)
       | otherwise = let (mb_ty,ltys') = takeIt l1 ltys
                     in (mb_ty,lty:ltys')
 
@@ -390,7 +390,7 @@ tcRecTypeFields ge scope ((l,ty):rs) mb_ty = do
                | s == cPType -> return mb_ty
              VMeta _ _ _     -> return mb_ty
              _               -> do sort <- zonkTerm =<< tc_value2term (geLoc ge) (scopeVars scope) sort
-                                   tcError ("The record type field" <+> l <+> ':' <+> ppTerm Unqualified 0 ty $$ 
+                                   tcError ("The record type field" <+> l <+> ':' <+> ppTerm Unqualified 0 ty $$
                                             "cannot be of type" <+> ppTerm Unqualified 0 sort)
   (rs,mb_ty) <- tcRecTypeFields ge scope rs mb_ty
   return ((l,ty):rs,mb_ty)
@@ -444,11 +444,11 @@ subsCheckRho ge scope t (VApp p1 _) (VApp p2 _)                         -- Rule
   | predefName p1 == cInts && predefName p2 == cInt = return t
 subsCheckRho ge scope t (VApp p1 [VInt i]) (VApp p2 [VInt j])           -- Rule INT2
   | predefName p1 == cInts && predefName p2 == cInts =
-      if i <= j 
+      if i <= j
         then return t
         else tcError ("Ints" <+> i <+> "is not a subtype of" <+> "Ints" <+> j)
 subsCheckRho ge scope t ty1@(VRecType rs1) ty2@(VRecType rs2) = do      -- Rule REC
-  let mkAccess scope t = 
+  let mkAccess scope t =
         case t of
           ExtR t1 t2 -> do (scope,mkProj1,mkWrap1) <- mkAccess scope t1
                            (scope,mkProj2,mkWrap2) <- mkAccess scope t2
@@ -557,7 +557,7 @@ unify ge scope v (VMeta i env vs) = unifyVar ge scope i env vs v
 unify ge scope v1 v2 = do
   t1 <- zonkTerm =<< tc_value2term (geLoc ge) (scopeVars scope) v1
   t2 <- zonkTerm =<< tc_value2term (geLoc ge) (scopeVars scope) v2
-  tcError ("Cannot unify terms:" <+> (ppTerm Unqualified 0 t1 $$ 
+  tcError ("Cannot unify terms:" <+> (ppTerm Unqualified 0 t1 $$
                                       ppTerm Unqualified 0 t2))
 
 -- | Invariant: tv1 is a flexible type variable
@@ -609,7 +609,7 @@ quantify ge scope t tvs ty0 = do
   ty <- tc_value2term (geLoc ge) (scopeVars scope) ty0
   let used_bndrs = nub (bndrs ty)  -- Avoid quantified type variables in use
       new_bndrs  = take (length tvs) (allBinders \\ used_bndrs)
-  mapM_ bind (tvs `zip` new_bndrs)   -- 'bind' is just a cunning way 
+  mapM_ bind (tvs `zip` new_bndrs)   -- 'bind' is just a cunning way
   ty <- zonkTerm ty                  -- of doing the substitution
   vty <- liftErr (eval ge [] (foldr (\v ty -> Prod Implicit v typeType ty) ty new_bndrs))
   return (foldr (Abs Implicit) t new_bndrs,vty)
@@ -619,7 +619,7 @@ quantify ge scope t tvs ty0 = do
     bndrs (Prod _ x t1 t2) = [x] ++ bndrs t1  ++ bndrs t2
     bndrs _                = []
 
-allBinders :: [Ident]    -- a,b,..z, a1, b1,... z1, a2, b2,... 
+allBinders :: [Ident]    -- a,b,..z, a1, b1,... z1, a2, b2,...
 allBinders = [ identS [x]          | x <- ['a'..'z'] ] ++
              [ identS (x : show i) | i <- [1 :: Integer ..], x <- ['a'..'z']]
 
@@ -688,12 +688,12 @@ runTcM f = case unTcM f IntMap.empty [] of
              TcFail (msg:msgs) -> do checkWarnings msgs; checkError msg
 
 newMeta :: Scope -> Sigma -> TcM MetaId
-newMeta scope ty = TcM (\ms msgs -> 
+newMeta scope ty = TcM (\ms msgs ->
   let i = IntMap.size ms
   in TcOk i (IntMap.insert i (Unbound scope ty) ms) msgs)
 
 getMeta :: MetaId -> TcM MetaValue
-getMeta i = TcM (\ms msgs -> 
+getMeta i = TcM (\ms msgs ->
   case IntMap.lookup i ms of
     Just mv -> TcOk mv ms msgs
     Nothing -> TcFail (("Unknown metavariable" <+> ppMeta i) : msgs))
@@ -702,7 +702,7 @@ setMeta :: MetaId -> MetaValue -> TcM ()
 setMeta i mv = TcM (\ms msgs -> TcOk () (IntMap.insert i mv ms) msgs)
 
 newVar :: Scope -> Ident
-newVar scope = head [x | i <- [1..], 
+newVar scope = head [x | i <- [1..],
                          let x = identS ('v':show i),
                          isFree scope x]
   where
@@ -721,7 +721,7 @@ getMetaVars loc sc_tys = do
   return (foldr go [] tys)
   where
     -- Get the MetaIds from a term; no duplicates in result
-    go (Vr tv)    acc = acc 
+    go (Vr tv)    acc = acc
     go (App x y)  acc = go x (go y acc)
     go (Meta i)   acc
 	  | i `elem` acc  = acc
@@ -741,7 +741,7 @@ getFreeVars loc sc_tys = do
   tys <- mapM (\(scope,ty) -> zonkTerm =<< tc_value2term loc (scopeVars scope) ty) sc_tys
   return (foldr (go []) [] tys)
   where
-    go bound (Vr tv)            acc 
+    go bound (Vr tv)            acc
 	  | tv `elem` bound             = acc
 	  | tv `elem` acc               = acc
 	  | otherwise                   = tv : acc
@@ -771,7 +771,7 @@ tc_value2term loc xs v =
 
 
 
-data TcA x a 
+data TcA x a
   = TcSingle   (MetaStore -> [Message] -> TcResult a)
   | TcMany [x] (MetaStore -> [Message] -> [(a,MetaStore,[Message])])
 
-- 
cgit v1.2.3


From 376b1234a2cb510aab62fefb59821557595c6ecb Mon Sep 17 00:00:00 2001
From: "John J. Camilleri" <john@digitalgrammars.com>
Date: Thu, 1 Jul 2021 14:27:11 +0200
Subject: Rename GF.Compile.TypeCheck.RConcrete to
 GF.Compile.TypeCheck.Concrete

---
 gf.cabal                                       |   1 -
 src/compiler/GF/Command/SourceCommands.hs      |   2 +-
 src/compiler/GF/Compile/CheckGrammar.hs        |   2 +-
 src/compiler/GF/Compile/TypeCheck/Concrete.hs  | 366 ++++++-----
 src/compiler/GF/Compile/TypeCheck/RConcrete.hs | 801 -------------------------
 5 files changed, 225 insertions(+), 947 deletions(-)
 delete mode 100644 src/compiler/GF/Compile/TypeCheck/RConcrete.hs

(limited to 'src')

diff --git a/gf.cabal b/gf.cabal
index 854f8cfbf..fe9fb05b3 100644
--- a/gf.cabal
+++ b/gf.cabal
@@ -207,7 +207,6 @@ library
     GF.Compile.TypeCheck.Concrete
     GF.Compile.TypeCheck.ConcreteNew
     GF.Compile.TypeCheck.Primitives
-    GF.Compile.TypeCheck.RConcrete
     GF.Compile.TypeCheck.TC
     GF.Compile.Update
     GF.Data.BacktrackM
diff --git a/src/compiler/GF/Command/SourceCommands.hs b/src/compiler/GF/Command/SourceCommands.hs
index daf3f7f1e..91ada899d 100644
--- a/src/compiler/GF/Command/SourceCommands.hs
+++ b/src/compiler/GF/Command/SourceCommands.hs
@@ -19,7 +19,7 @@ import GF.Grammar.ShowTerm
 import GF.Grammar.Lookup (allOpers,allOpersTo)
 import GF.Compile.Rename(renameSourceTerm)
 import GF.Compile.Compute.Concrete(normalForm,resourceValues)
-import GF.Compile.TypeCheck.RConcrete as TC(inferLType,ppType)
+import GF.Compile.TypeCheck.Concrete as TC(inferLType,ppType)
 import GF.Infra.Dependencies(depGraph)
 import GF.Infra.CheckM(runCheck)
 
diff --git a/src/compiler/GF/Compile/CheckGrammar.hs b/src/compiler/GF/Compile/CheckGrammar.hs
index e7839da34..a657fd020 100644
--- a/src/compiler/GF/Compile/CheckGrammar.hs
+++ b/src/compiler/GF/Compile/CheckGrammar.hs
@@ -27,7 +27,7 @@ import GF.Infra.Ident
 import GF.Infra.Option
 
 import GF.Compile.TypeCheck.Abstract
-import GF.Compile.TypeCheck.RConcrete
+import GF.Compile.TypeCheck.Concrete
 import qualified GF.Compile.TypeCheck.ConcreteNew as CN
 import qualified GF.Compile.Compute.Concrete as CN
 
diff --git a/src/compiler/GF/Compile/TypeCheck/Concrete.hs b/src/compiler/GF/Compile/TypeCheck/Concrete.hs
index 2afff7c6a..380970405 100644
--- a/src/compiler/GF/Compile/TypeCheck/Concrete.hs
+++ b/src/compiler/GF/Compile/TypeCheck/Concrete.hs
@@ -1,6 +1,7 @@
 {-# LANGUAGE PatternGuards #-}
-module GF.Compile.TypeCheck.Concrete( {-checkLType, inferLType, computeLType, ppType-} ) where
-{-
+module GF.Compile.TypeCheck.Concrete( checkLType, inferLType, computeLType, ppType ) where
+import Prelude hiding ((<>)) -- GHC 8.4.1 clash with Text.PrettyPrint
+
 import GF.Infra.CheckM
 import GF.Data.Operations
 
@@ -22,10 +23,16 @@ computeLType gr g0 t = comp (reverse [(b,x, Vr x) | (b,x,_) <- g0] ++ g0) t
     _ | Just _ <- isTypeInts ty -> return ty ---- shouldn't be needed
       | isPredefConstant ty     -> return ty ---- shouldn't be needed
 
-    Q (m,ident) -> checkIn (text "module" <+> ppIdent m) $ do
+    Q (m,ident) -> checkIn ("module" <+> m) $ do
       ty' <- lookupResDef gr (m,ident)
       if ty' == ty then return ty else comp g ty' --- is this necessary to test?
 
+    AdHocOverload ts -> do
+     over <- getOverload gr g (Just typeType) t
+     case over of
+       Just (tr,_) -> return tr
+       _ -> checkError ("unresolved overloading of constants" <+> ppTerm Qualified 0 t)
+
     Vr ident  -> checkLookup ident g -- never needed to compute!
 
     App f a -> do
@@ -73,26 +80,26 @@ inferLType gr g trm = case trm of
 
    Q (m,ident) | isPredef m -> termWith trm $ case typPredefined ident of
                                                 Just ty -> return ty
-                                                Nothing -> checkError (text "unknown in Predef:" <+> ppIdent ident)
+                                                Nothing -> checkError ("unknown in Predef:" <+> ident)
 
    Q ident -> checks [
      termWith trm $ lookupResType gr ident >>= computeLType gr g
      ,
      lookupResDef gr ident >>= inferLType gr g
      ,
-     checkError (text "cannot infer type of constant" <+> ppTerm Unqualified 0 trm)
+     checkError ("cannot infer type of constant" <+> ppTerm Unqualified 0 trm)
      ]
 
    QC (m,ident) | isPredef m -> termWith trm $ case typPredefined ident of
                                                  Just ty -> return ty
-                                                 Nothing -> checkError (text "unknown in Predef:" <+> ppIdent ident)
+                                                 Nothing -> checkError ("unknown in Predef:" <+> ident)
 
    QC ident -> checks [
        termWith trm $ lookupResType gr ident >>= computeLType gr g
        ,
        lookupResDef gr ident >>= inferLType gr g
        ,
-       checkError (text "cannot infer type of canonical constant" <+> ppTerm Unqualified 0 trm)
+       checkError ("cannot infer type of canonical constant" <+> ppTerm Unqualified 0 trm)
        ]
 
    Vr ident -> termWith trm $ checkLookup ident g
@@ -100,7 +107,12 @@ inferLType gr g trm = case trm of
    Typed e t -> do
      t' <- computeLType gr g t
      checkLType gr g e t'
-     return (e,t')
+
+   AdHocOverload ts -> do
+     over <- getOverload gr g Nothing trm
+     case over of
+       Just trty -> return trty
+       _ -> checkError ("unresolved overloading of constants" <+> ppTerm Qualified 0 trm)
 
    App f a -> do
      over <- getOverload gr g Nothing trm
@@ -110,13 +122,17 @@ inferLType gr g trm = case trm of
          (f',fty) <- inferLType gr g f
          fty' <- computeLType gr g fty
          case fty' of
-           Prod bt z arg val -> do 
+           Prod bt z arg val -> do
              a' <- justCheck g a arg
-             ty <- if isWildIdent z 
+             ty <- if isWildIdent z
                       then return val
                       else substituteLType [(bt,z,a')] val
-             return (App f' a',ty) 
-           _ -> checkError (text "A function type is expected for" <+> ppTerm Unqualified 0 f <+> text "instead of type" <+> ppType fty)
+             return (App f' a',ty)
+           _ ->
+             let term = ppTerm Unqualified 0 f
+                 funName = pp . head . words .render $ term
+              in checkError ("A function type is expected for" <+> term <+> "instead of type" <+> ppType fty $$
+                             "\n   ** Maybe you gave too many arguments to" <+> funName <+> "\n")
 
    S f x -> do
      (f', fty) <- inferLType gr g f
@@ -124,7 +140,7 @@ inferLType gr g trm = case trm of
        Table arg val -> do
          x'<- justCheck g x arg
          return (S f' x', val)
-       _ -> checkError (text "table lintype expected for the table in" $$ nest 2 (ppTerm Unqualified 0 trm))
+       _ -> checkError ("table lintype expected for the table in" $$ nest 2 (ppTerm Unqualified 0 trm))
 
    P t i -> do
      (t',ty) <- inferLType gr g t   --- ??
@@ -132,16 +148,16 @@ inferLType gr g trm = case trm of
      let tr2 = P t' i
      termWith tr2 $ case ty' of
        RecType ts -> case lookup i ts of
-                       Nothing -> checkError (text "unknown label" <+> ppLabel i <+> text "in" $$ nest 2 (ppTerm Unqualified 0 ty'))
+                       Nothing -> checkError ("unknown label" <+> i <+> "in" $$ nest 2 (ppTerm Unqualified 0 ty'))
                        Just x  -> return x
-       _          -> checkError (text "record type expected for:" <+> ppTerm Unqualified 0 t $$
-                                 text " instead of the inferred:" <+> ppTerm Unqualified 0 ty')
+       _          -> checkError ("record type expected for:" <+> ppTerm Unqualified 0 t $$
+                                 " instead of the inferred:" <+> ppTerm Unqualified 0 ty')
 
    R r -> do
      let (ls,fs) = unzip r
      fsts <- mapM inferM fs
      let ts = [ty | (Just ty,_) <- fsts]
-     checkCond (text "cannot infer type of record" $$ nest 2 (ppTerm Unqualified 0 trm)) (length ts == length fsts)
+     checkCond ("cannot infer type of record" $$ nest 2 (ppTerm Unqualified 0 trm)) (length ts == length fsts)
      return $ (R (zip ls fsts), RecType (zip ls ts))
 
    T (TTyped arg) pts -> do
@@ -152,10 +168,10 @@ inferLType gr g trm = case trm of
      checkLType gr g trm (Table arg val)
    T ti pts -> do  -- tries to guess: good in oper type inference
      let pts' = [pt | pt@(p,_) <- pts, isConstPatt p]
-     case pts' of 
-       [] -> checkError (text "cannot infer table type of" <+> ppTerm Unqualified 0 trm)
-----       PInt k : _ -> return $ Ints $ max [i | PInt i <- pts'] 
-       _  -> do 
+     case pts' of
+       [] -> checkError ("cannot infer table type of" <+> ppTerm Unqualified 0 trm)
+----       PInt k : _ -> return $ Ints $ max [i | PInt i <- pts']
+       _  -> do
          (arg,val) <- checks $ map (inferCase Nothing) pts'
          checkLType gr g trm (Table arg val)
    V arg pts -> do
@@ -166,9 +182,9 @@ inferLType gr g trm = case trm of
    K s  -> do
      if elem ' ' s
         then do
-          let ss = foldr C Empty (map K (words s))  
+          let ss = foldr C Empty (map K (words s))
           ----- removed irritating warning AR 24/5/2008
-          ----- checkWarn ("token \"" ++ s ++ 
+          ----- checkWarn ("token \"" ++ s ++
           -----              "\" converted to token list" ++ prt ss)
           return (ss, typeStr)
         else return (trm, typeStr)
@@ -179,50 +195,56 @@ inferLType gr g trm = case trm of
 
    Empty -> return (trm, typeStr)
 
-   C s1 s2 -> 
+   C s1 s2 ->
      check2 (flip (justCheck g) typeStr) C s1 s2 typeStr
 
-   Glue s1 s2 -> 
+   Glue s1 s2 ->
      check2 (flip (justCheck g) typeStr) Glue s1 s2 typeStr ---- typeTok
 
 ---- hack from Rename.identRenameTerm, to live with files with naming conflicts 18/6/2007
    Strs (Cn c : ts) | c == cConflict -> do
-     checkWarn (text "unresolved constant, could be any of" <+> hcat (map (ppTerm Unqualified 0) ts))
+     checkWarn ("unresolved constant, could be any of" <+> hcat (map (ppTerm Unqualified 0) ts))
      inferLType gr g (head ts)
 
    Strs ts -> do
-     ts' <- mapM (\t -> justCheck g t typeStr) ts 
+     ts' <- mapM (\t -> justCheck g t typeStr) ts
      return (Strs ts', typeStrs)
 
    Alts t aa -> do
      t'  <- justCheck g t typeStr
      aa' <- flip mapM aa (\ (c,v) -> do
-        c' <- justCheck g c typeStr 
+        c' <- justCheck g c typeStr
         v' <- checks $ map (justCheck g v) [typeStrs, EPattType typeStr]
         return (c',v'))
      return (Alts t' aa', typeStr)
 
    RecType r -> do
      let (ls,ts) = unzip r
-     ts' <- mapM (flip (justCheck g) typeType) ts 
+     ts' <- mapM (flip (justCheck g) typeType) ts
      return (RecType (zip ls ts'), typeType)
 
    ExtR r s -> do
-     (r',rT) <- inferLType gr g r 
+
+---     over <- getOverload gr g Nothing r
+---     let r1 = maybe r fst over
+     let r1 = r ---
+
+     (r',rT) <- inferLType gr g r1
      rT'     <- computeLType gr g rT
+
      (s',sT) <- inferLType gr g s
      sT'     <- computeLType gr g sT
 
      let trm' = ExtR r' s'
-     ---- trm'    <- plusRecord r' s'
      case (rT', sT') of
        (RecType rs, RecType ss) -> do
-         rt <- plusRecType rT' sT'
+         let rt = RecType ([field | field@(l,_) <- rs, notElem l (map fst ss)] ++ ss) -- select types of later fields
          checkLType gr g trm' rt ---- return (trm', rt)
-       _ | rT' == typeType && sT' == typeType -> return (trm', typeType)
-       _ -> checkError (text "records or record types expected in" <+> ppTerm Unqualified 0 trm)
+       _ | rT' == typeType && sT' == typeType -> do
+         return (trm', typeType)
+       _ -> checkError ("records or record types expected in" <+> ppTerm Unqualified 0 trm)
 
-   Sort _     -> 
+   Sort _     ->
      termWith trm $ return typeType
 
    Prod bt x a b -> do
@@ -231,7 +253,7 @@ inferLType gr g trm = case trm of
      return (Prod bt x a' b', typeType)
 
    Table p t  -> do
-     p' <- justCheck g p typeType --- check p partype! 
+     p' <- justCheck g p typeType --- check p partype!
      t' <- justCheck g t typeType
      return $ (Table p' t', typeType)
 
@@ -250,9 +272,9 @@ inferLType gr g trm = case trm of
    ELin c trm -> do
      (trm',ty) <- inferLType gr g trm
      ty' <- lockRecType c ty ---- lookup c; remove lock AR 20/6/2009
-     return $ (ELin c trm', ty') 
+     return $ (ELin c trm', ty')
 
-   _ -> checkError (text "cannot infer lintype of" <+> ppTerm Unqualified 0 trm)
+   _ -> checkError ("cannot infer lintype of" <+> ppTerm Unqualified 0 trm)
 
  where
    isPredef m = elem m [cPredef,cPredefAbs]
@@ -299,7 +321,6 @@ inferLType gr g trm = case trm of
      PChars _ -> return $ typeStr
      _ -> inferLType gr g (patt2term p) >>= return . snd
 
-
 -- type inference: Nothing, type checking: Just t
 -- the latter permits matching with value type
 getOverload :: SourceGrammar -> Context -> Maybe Type -> Term -> Check (Maybe (Term,Type))
@@ -310,15 +331,28 @@ getOverload gr g mt ot = case appForm ot of
          v <- matchOverload f typs ttys
          return $ Just v
        _ -> return Nothing
+     (AdHocOverload cs@(f:_), ts) -> do     --- the function name f is only used in error messages
+       let typs = concatMap collectOverloads cs
+       ttys <- mapM (inferLType gr g) ts
+       v <- matchOverload f typs ttys
+       return $ Just v
      _ -> return Nothing
+
  where
+   collectOverloads tr@(Q c) = case lookupOverload gr c of
+     Ok typs -> typs
+     _ -> case lookupResType gr c of
+       Ok ty -> let (args,val) = typeFormCnc ty in [(map (\(b,x,t) -> t) args,(val,tr))]
+       _ -> []
+   collectOverloads _ = [] --- constructors QC
+
    matchOverload f typs ttys = do
      let (tts,tys) = unzip ttys
      let vfs = lookupOverloadInstance tys typs
      let matches = [vf | vf@((_,v,_),_) <- vfs, matchVal mt v]
      let showTypes ty = hsep (map ppType ty)
 
-    
+
      let (stys,styps) = (showTypes tys, [showTypes ty | (ty,_) <- typs])
 
      -- to avoid strange error msg e.g. in case of unmatch record extension, show whole types if needed AR 28/1/2013
@@ -329,50 +363,57 @@ getOverload gr g mt ot = case appForm ot of
      case ([vf | (vf,True) <- matches],[vf | (vf,False) <- matches]) of
        ([(_,val,fun)],_) -> return (mkApp fun tts, val)
        ([],[(pre,val,fun)]) -> do
-         checkWarn $  text "ignoring lock fields in resolving" <+> ppTerm Unqualified 0 ot $$
-                      text "for" $$
+         checkWarn $  "ignoring lock fields in resolving" <+> ppTerm Unqualified 0 ot $$
+                      "for" $$
                       nest 2 (showTypes tys) $$
-                      text "using" $$
+                      "using" $$
                       nest 2 (showTypes pre)
          return (mkApp fun tts, val)
        ([],[]) -> do
-         checkError $ text "no overload instance of" <+> ppTerm Unqualified 0 f $$
-                      text "for" $$
+         checkError $ "no overload instance of" <+> ppTerm Qualified 0 f $$
+                      maybe empty (\x -> "with value type" <+> ppType x) mt $$
+                      "for argument list" $$
                       nest 2 stysError $$
-                      text "among" $$
-                      nest 2 (vcat stypsError) $$
-                      maybe empty (\x -> text "with value type" <+> ppType x) mt
+                      "among alternatives" $$
+                      nest 2 (vcat stypsError)
+
 
        (vfs1,vfs2) -> case (noProds vfs1,noProds vfs2) of
          ([(val,fun)],_) -> do
            return (mkApp fun tts, val)
          ([],[(val,fun)]) -> do
-           checkWarn (text "ignoring lock fields in resolving" <+> ppTerm Unqualified 0 ot) 
+           checkWarn ("ignoring lock fields in resolving" <+> ppTerm Unqualified 0 ot)
            return (mkApp fun tts, val)
 
 ----- unsafely exclude irritating warning AR 24/5/2008
------           checkWarn $ "overloading of" +++ prt f +++ 
+-----           checkWarn $ "overloading of" +++ prt f +++
 -----             "resolved by excluding partial applications:" ++++
 -----             unlines [prtType env ty | (ty,_) <- vfs', not (noProd ty)]
 
-
-         _ -> checkError $ text "ambiguous overloading of" <+> ppTerm Unqualified 0 f <+>
-                           text "for" <+> hsep (map ppType tys) $$ 
-                           text "with alternatives" $$
-                           nest 2 (vcat [ppType ty | (_,ty,_) <- if null vfs1 then vfs2 else vfs2])
+--- now forgiving ambiguity with a warning AR 1/2/2014
+--  This gives ad hoc overloading the same behaviour as the choice of the first match in renaming did before.
+--  But it also gives a chance to ambiguous overloadings that were banned before.
+         (nps1,nps2) -> do
+              checkWarn $  "ambiguous overloading of" <+> ppTerm Unqualified 0 f <+>
+                  ----     "with argument types" <+> hsep (map (ppTerm Qualified 0) tys) $$
+                           "resolved by selecting the first of the alternatives" $$
+                           nest 2 (vcat [ppTerm Qualified 0 fun | (_,ty,fun) <- vfs1 ++ if null vfs1 then vfs2 else []])
+              case [(mkApp fun tts,val) | (val,fun) <- nps1 ++ nps2] of
+                 [] -> checkError $ "no alternatives left when resolving" <+> ppTerm Unqualified 0 f
+                 h:_ -> return h
 
    matchVal mt v = elem mt [Nothing,Just v,Just (unlocked v)]
 
    unlocked v = case v of
-     RecType fs -> RecType $ filter (not . isLockLabel . fst) fs
+     RecType fs -> RecType $ filter (not . isLockLabel . fst) (sortRec fs)
      _ -> v
    ---- TODO: accept subtypes
    ---- TODO: use a trie
-   lookupOverloadInstance tys typs = 
-     [((pre,mkFunType rest val, t),isExact) | 
+   lookupOverloadInstance tys typs =
+     [((pre,mkFunType rest val, t),isExact) |
        let lt = length tys,
        (ty,(val,t)) <- typs, length ty >= lt,
-       let (pre,rest) = splitAt lt ty, 
+       let (pre,rest) = splitAt lt ty,
        let isExact = pre == tys,
        isExact || map unlocked pre == map unlocked tys
      ]
@@ -385,20 +426,21 @@ getOverload gr g mt ot = case appForm ot of
 
 checkLType :: SourceGrammar -> Context -> Term -> Type -> Check (Term, Type)
 checkLType gr g trm typ0 = do
-
   typ <- computeLType gr g typ0
 
   case trm of
 
     Abs bt x c -> do
       case typ of
-        Prod bt' z a b -> do 
+        Prod bt' z a b -> do
           (c',b') <- if isWildIdent z
                        then checkLType gr ((bt,x,a):g) c b
-                       else do b' <- checkIn (text "abs") $ substituteLType [(bt',z,Vr x)] b
+                       else do b' <- checkIn (pp "abs") $ substituteLType [(bt',z,Vr x)] b
                                checkLType gr ((bt,x,a):g) c b'
-          return $ (Abs bt x c', Prod bt' x a b')
-        _ -> checkError $ text "function type expected instead of" <+> ppType typ
+          return $ (Abs bt x c', Prod bt' z a b')
+        _ -> checkError $ "function type expected instead of" <+> ppType typ $$
+                          "\n   ** Double-check that the type signature of the operation" $$
+                          "matches the number of arguments given to it.\n"
 
     App f a -> do
        over <- getOverload gr g (Just typ) trm
@@ -408,6 +450,12 @@ checkLType gr g trm typ0 = do
           (trm',ty') <- inferLType gr g trm
           termWith trm' $ checkEqLType gr g typ ty' trm'
 
+    AdHocOverload ts -> do
+      over <- getOverload gr g Nothing trm
+      case over of
+        Just trty -> return trty
+        _ -> checkError ("unresolved overloading of constants" <+> ppTerm Qualified 0 trm)
+
     Q _ -> do
        over <- getOverload gr g (Just typ) trm
        case over of
@@ -417,21 +465,21 @@ checkLType gr g trm typ0 = do
           termWith trm' $ checkEqLType gr g typ ty' trm'
 
     T _ [] ->
-      checkError (text "found empty table in type" <+> ppTerm Unqualified 0 typ)
-    T _ cs -> case typ of 
-      Table arg val -> do 
+      checkError ("found empty table in type" <+> ppTerm Unqualified 0 typ)
+    T _ cs -> case typ of
+      Table arg val -> do
         case allParamValues gr arg of
           Ok vs -> do
             let ps0 = map fst cs
             ps <- testOvershadow ps0 vs
-            if null ps 
-              then return () 
-              else checkWarn (text "patterns never reached:" $$
+            if null ps
+              then return ()
+              else checkWarn ("patterns never reached:" $$
                               nest 2 (vcat (map (ppPatt Unqualified 0) ps)))
           _ -> return () -- happens with variable types
         cs' <- mapM (checkCase arg val) cs
         return (T (TTyped arg) cs', typ)
-      _ -> checkError $ text "table type expected for table instead of" $$ nest 2 (ppType typ)
+      _ -> checkError $ "table type expected for table instead of" $$ nest 2 (ppType typ)
     V arg0 vs ->
       case typ of
         Table arg1 val ->
@@ -439,51 +487,54 @@ checkLType gr g trm typ0 = do
               vs1 <- allParamValues gr arg1
               if length vs1 == length vs
                  then return ()
-                 else checkError $ text "wrong number of values in table" <+> ppTerm Unqualified 0 trm
+                 else checkError $ "wrong number of values in table" <+> ppTerm Unqualified 0 trm
               vs' <- map fst `fmap` sequence [checkLType gr g v val|v<-vs]
               return (V arg' vs',typ)
 
     R r -> case typ of --- why needed? because inference may be too difficult
        RecType rr -> do
-         let (ls,_) = unzip rr        -- labels of expected type
+       --let (ls,_) = unzip rr        -- labels of expected type
          fsts <- mapM (checkM r) rr   -- check that they are found in the record
          return $ (R fsts, typ)       -- normalize record
 
-       _ -> checkError (text "record type expected in type checking instead of" $$ nest 2 (ppTerm Unqualified 0 typ))
+       _ -> checkError ("record type expected in type checking instead of" $$ nest 2 (ppTerm Unqualified 0 typ))
 
     ExtR r s -> case typ of
        _ | typ == typeType -> do
          trm' <- computeLType gr g trm
          case trm' of
-           RecType _ -> termWith trm $ return typeType
-           ExtR (Vr _) (RecType _) -> termWith trm $ return typeType 
+           RecType _ -> termWith trm' $ return typeType
+           ExtR (Vr _) (RecType _) -> termWith trm' $ return typeType
                                       -- ext t = t ** ...
-           _ -> checkError (text "invalid record type extension" <+> nest 2 (ppTerm Unqualified 0 trm))
+           _ -> checkError ("invalid record type extension" <+> nest 2 (ppTerm Unqualified 0 trm))
 
        RecType rr -> do
-         (r',ty,s') <- checks [
-            do (r',ty) <- inferLType gr g r
-               return (r',ty,s)
-           ,
-            do (s',ty) <- inferLType gr g s
-               return (s',ty,r)
-           ]
-
-         case ty of
-           RecType rr1 -> do
-                let (rr0,rr2) = recParts rr rr1
-                r2 <- justCheck g r' rr0
-                s2 <- justCheck g s' rr2
-                return $ (ExtR r2 s2, typ) 
-           _ -> checkError (text "record type expected in extension of" <+> ppTerm Unqualified 0 r $$
-                            text "but found" <+> ppTerm Unqualified 0 ty)
+
+         ll2 <- case s of
+           R ss -> return $ map fst ss
+           _ -> do
+             (s',typ2) <- inferLType gr g s
+             case typ2 of
+               RecType ss -> return $ map fst ss
+               _ ->  checkError ("cannot get labels from" $$ nest 2 (ppTerm Unqualified 0 typ2))
+         let ll1 = [l | (l,_) <- rr, notElem l ll2]
+
+---         over <- getOverload gr g Nothing r --- this would solve #66 but fail ParadigmsAra. AR 6/7/2020
+---         let r1 = maybe r fst over
+         let r1 = r ---
+
+         (r',_) <- checkLType gr g r1 (RecType [field | field@(l,_) <- rr, elem l ll1])
+         (s',_) <- checkLType gr g s  (RecType [field | field@(l,_) <- rr, elem l ll2])
+
+         let rec = R ([(l,(Nothing,P r' l)) | l <- ll1] ++ [(l,(Nothing,P s' l)) | l <- ll2])
+         return (rec, typ)
 
        ExtR ty ex -> do
          r' <- justCheck g r ty
          s' <- justCheck g s ex
          return $ (ExtR r' s', typ) --- is this all? it assumes the same division in trm and typ
 
-       _ -> checkError (text "record extension not meaningful for" <+> ppTerm Unqualified 0 typ)
+       _ -> checkError ("record extension not meaningful for" <+> ppTerm Unqualified 0 typ)
 
     FV vs -> do
       ttys <- mapM (flip (checkLType gr g) typ) vs
@@ -498,7 +549,7 @@ checkLType gr g trm typ0 = do
           (arg',val) <- checkLType gr g arg p
           checkEqLType gr g typ t trm
           return (S tab' arg', t)
-        _ -> checkError (text "table type expected for applied table instead of" <+> ppType ty')
+        _ -> checkError ("table type expected for applied table instead of" <+> ppType ty')
      , do
       (arg',ty) <- inferLType gr g arg
       ty'       <- computeLType gr g ty
@@ -507,7 +558,8 @@ checkLType gr g trm typ0 = do
       ]
     Let (x,(mty,def)) body -> case mty of
       Just ty -> do
-        (def',ty') <- checkLType gr g def ty
+        (ty0,_)    <- checkLType gr g ty typeType
+        (def',ty') <- checkLType gr g def ty0
         body' <- justCheck ((Explicit,x,ty'):g) body typ
         return (Let (x,(Just ty',def')) body', typ)
       _ -> do
@@ -523,10 +575,10 @@ checkLType gr g trm typ0 = do
       termWith trm' $ checkEqLType gr g typ ty' trm'
  where
    justCheck g ty te = checkLType gr g ty te >>= return . fst
-
-   recParts rr t = (RecType rr1,RecType rr2) where 
-     (rr1,rr2) = partition (flip elem (map fst t) . fst) rr 
-
+{-
+   recParts rr t = (RecType rr1,RecType rr2) where
+     (rr1,rr2) = partition (flip elem (map fst t) . fst) rr
+-}
    checkM rms (l,ty) = case lookup l rms of
      Just (Just ty0,t) -> do
        checkEqLType gr g ty ty0 t
@@ -535,12 +587,12 @@ checkLType gr g trm typ0 = do
      Just (_,t) -> do
        (t',ty') <- checkLType gr g t ty
        return (l,(Just ty',t'))
-     _ -> checkError $ 
-            if isLockLabel l 
+     _ -> checkError $
+            if isLockLabel l
               then let cat = drop 5 (showIdent (label2ident l))
-                   in ppTerm Unqualified 0 (R rms) <+> text "is not in the lincat of" <+> text cat <> 
-                      text "; try wrapping it with lin" <+> text cat
-              else text "cannot find value for label" <+> ppLabel l <+> text "in" <+> ppTerm Unqualified 0 (R rms)
+                   in ppTerm Unqualified 0 (R rms) <+> "is not in the lincat of" <+> cat <>
+                      "; try wrapping it with lin" <+> cat
+              else "cannot find value for label" <+> l <+> "in" <+> ppTerm Unqualified 0 (R rms)
 
    checkCase arg val (p,t) = do
      cont <- pattContext gr g arg p
@@ -553,7 +605,7 @@ pattContext env g typ p = case p of
   PP (q,c) ps | q /= cPredef -> do ---- why this /=? AR 6/1/2006
     t <- lookupResType env (q,c)
     let (cont,v) = typeFormCnc t
-    checkCond (text "wrong number of arguments for constructor in" <+> ppPatt Unqualified 0 p) 
+    checkCond ("wrong number of arguments for constructor in" <+> ppPatt Unqualified 0 p)
               (length cont == length ps)
     checkEqLType env g typ v (patt2term p)
     mapM (\((_,_,ty),p) -> pattContext env g ty p) (zip cont ps) >>= return . concat
@@ -564,7 +616,7 @@ pattContext env g typ p = case p of
         let pts = [(ty,tr) | (l,tr) <- r, Just ty <- [lookup l t]]
         ----- checkWarn $ prt p ++++ show pts ----- debug
         mapM (uncurry (pattContext env g)) pts >>= return . concat
-      _ -> checkError (text "record type expected for pattern instead of" <+> ppTerm Unqualified 0 typ')
+      _ -> checkError ("record type expected for pattern instead of" <+> ppTerm Unqualified 0 typ')
   PT t p' -> do
     checkEqLType env g typ t (patt2term p')
     pattContext env g typ p'
@@ -577,10 +629,10 @@ pattContext env g typ p = case p of
     g1 <- pattContext env g typ p'
     g2 <- pattContext env g typ q
     let pts = nub ([x | pt@(_,x,_) <- g1, notElem pt g2] ++ [x | pt@(_,x,_) <- g2, notElem pt g1])
-    checkCond 
-      (text "incompatible bindings of" <+>
-       fsep (map ppIdent pts) <+> 
-       text "in pattern alterantives" <+> ppPatt Unqualified 0 p) (null pts) 
+    checkCond
+      ("incompatible bindings of" <+>
+       fsep pts <+>
+       "in pattern alterantives" <+> ppPatt Unqualified 0 p) (null pts)
     return g1 -- must be g1 == g2
   PSeq p q -> do
     g1 <- pattContext env g typ p
@@ -590,11 +642,11 @@ pattContext env g typ p = case p of
   PNeg p' -> noBind typ p'
 
   _ -> return [] ---- check types!
- where 
+ where
    noBind typ p' = do
     co <- pattContext env g typ p'
     if not (null co)
-      then checkWarn (text "no variable bound inside pattern" <+> ppPatt Unqualified 0 p) 
+      then checkWarn ("no variable bound inside pattern" <+> ppPatt Unqualified 0 p)
            >> return []
       else return []
 
@@ -603,9 +655,31 @@ checkEqLType gr g t u trm = do
   (b,t',u',s) <- checkIfEqLType gr g t u trm
   case b of
     True  -> return t'
-    False -> checkError $ text s <+> text "type of" <+> ppTerm Unqualified 0 trm $$
-                          text "expected:" <+> ppType t $$
-                          text "inferred:" <+> ppType u
+    False ->
+      let inferredType = ppTerm Qualified 0 u
+          expectedType = ppTerm Qualified 0 t
+          term = ppTerm Unqualified 0 trm
+          funName = pp . head . words .render $ term
+          helpfulMsg =
+            case (arrows inferredType, arrows expectedType) of
+              (0,0) -> pp "" -- None of the types is a function
+              _ -> "\n   **" <+>
+                  if expectedType `isLessApplied` inferredType
+                    then "Maybe you gave too few arguments to" <+> funName
+                    else pp "Double-check that type signature and number of arguments match."
+      in checkError $ s <+> "type of" <+> term $$
+                            "expected:" <+> expectedType $$ -- ppqType t u $$
+                            "inferred:" <+> inferredType $$ -- ppqType u t
+                            helpfulMsg
+  where
+    -- count the number of arrows in the prettyprinted term
+    arrows :: Doc -> Int
+    arrows = length . filter (=="->") . words . render
+
+    -- If prettyprinted type t has fewer arrows then prettyprinted type u,
+    -- then t is "less applied", and we can print out more helpful error msg.
+    isLessApplied :: Doc -> Doc -> Bool
+    isLessApplied t u = arrows t < arrows u
 
 checkIfEqLType :: SourceGrammar -> Context -> Type -> Type -> Term -> Check (Bool,Type,Type,String)
 checkIfEqLType gr g t u trm = do
@@ -617,60 +691,62 @@ checkIfEqLType gr g t u trm = do
     --- better: use a flag to forgive? (AR 31/1/2006)
     _ -> case missingLock [] t' u' of
       Ok lo -> do
-        checkWarn $ text "missing lock field" <+> fsep (map ppLabel lo)
+        checkWarn $ "missing lock field" <+> fsep lo
         return (True,t',u',[])
       Bad s -> return (False,t',u',s)
 
   where
 
-   -- t is a subtype of u 
+   -- check that u is a subtype of t
    --- quick hack version of TC.eqVal
-   alpha g t u = case (t,u) of  
+   alpha g t u = case (t,u) of
 
      -- error (the empty type!) is subtype of any other type
      (_,u) | u == typeError -> True
 
      -- contravariance
-     (Prod _ x a b, Prod _ y c d) -> alpha g c a && alpha ((x,y):g) b d 
-                              
+     (Prod _ x a b, Prod _ y c d) -> alpha g c a && alpha ((x,y):g) b d
+
      -- record subtyping
-     (RecType rs, RecType ts) -> all (\ (l,a) -> 
-                                   any (\ (k,b) -> alpha g a b && l == k) ts) rs
+     (RecType rs, RecType ts) -> all (\ (l,a) ->
+                                   any (\ (k,b) -> l == k && alpha g a b) ts) rs
      (ExtR r s, ExtR r' s') -> alpha g r r' && alpha g s s'
      (ExtR r s, t) -> alpha g r t || alpha g s t
 
      -- the following say that Ints n is a subset of Int and of Ints m >= n
-     (t,u) | Just m <- isTypeInts t, Just n <- isTypeInts t -> m >= n
+     -- But why does it also allow Int as a subtype of Ints m? /TH 2014-04-04
+     (t,u) | Just m <- isTypeInts t, Just n <- isTypeInts u -> m >= n
            | Just _ <- isTypeInts t, u == typeInt           -> True ---- check size!
            | t == typeInt,           Just _ <- isTypeInts u -> True ---- why this ???? AR 11/12/2005
 
      ---- this should be made in Rename
-     (Q  (m,a), Q  (n,b)) | a == b -> elem m (allExtendsPlus gr n) 
+     (Q  (m,a), Q  (n,b)) | a == b -> elem m (allExtendsPlus gr n)
                                    || elem n (allExtendsPlus gr m)
                                    || m == n --- for Predef
-     (QC (m,a), QC (n,b)) | a == b -> elem m (allExtendsPlus gr n) 
+     (QC (m,a), QC (n,b)) | a == b -> elem m (allExtendsPlus gr n)
                                    || elem n (allExtendsPlus gr m)
-     (QC (m,a), Q  (n,b)) | a == b -> elem m (allExtendsPlus gr n) 
+     (QC (m,a), Q  (n,b)) | a == b -> elem m (allExtendsPlus gr n)
                                    || elem n (allExtendsPlus gr m)
-     (Q  (m,a), QC (n,b)) | a == b -> elem m (allExtendsPlus gr n) 
+     (Q  (m,a), QC (n,b)) | a == b -> elem m (allExtendsPlus gr n)
                                    || elem n (allExtendsPlus gr m)
 
-     (Table a b,  Table c d)  -> alpha g a c && alpha g b d
+     -- contravariance
+     (Table a b,  Table c d)  -> alpha g c a && alpha g b d
      (Vr x,       Vr y)       -> x == y || elem (x,y) g || elem (y,x) g
-     _                        -> t == u 
+     _                        -> t == u
      --- the following should be one-way coercions only. AR 4/1/2001
                                   || elem t sTypes && elem u sTypes
-                                  || (t == typeType && u == typePType) 
-                                  || (u == typeType && t == typePType) 
+                                  || (t == typeType && u == typePType)
+                                  || (u == typeType && t == typePType)
 
-   missingLock g t u = case (t,u) of  
-     (RecType rs, RecType ts) -> 
-       let 
-         ls = [l | (l,a) <- rs, 
+   missingLock g t u = case (t,u) of
+     (RecType rs, RecType ts) ->
+       let
+         ls = [l | (l,a) <- rs,
                    not (any (\ (k,b) -> alpha g a b && l == k) ts)]
          (locks,others) = partition isLockLabel ls
        in case others of
-         _:_ -> Bad $ render (text "missing record fields:" <+> fsep (punctuate comma (map ppLabel others)))
+         _:_ -> Bad $ render ("missing record fields:" <+> fsep (punctuate ',' (others)))
          _ -> return locks
      -- contravariance
      (Prod _ x a b, Prod _ y c d) -> do
@@ -696,7 +772,7 @@ termWith t ct = do
   return (t,ty)
 
 -- | compositional check\/infer of binary operations
-check2 :: (Term -> Check Term) -> (Term -> Term -> Term) -> 
+check2 :: (Term -> Check Term) -> (Term -> Term -> Term) ->
           Term -> Term -> Type -> Check (Term,Type)
 check2 chk con a b t = do
   a' <- chk a
@@ -708,14 +784,18 @@ ppType :: Type -> Doc
 ppType ty =
   case ty of
     RecType fs   -> case filter isLockLabel $ map fst fs of
-                      [lock] -> text (drop 5 (showIdent (label2ident lock)))
+                      [lock] -> pp (drop 5 (showIdent (label2ident lock)))
                       _      -> ppTerm Unqualified 0 ty
-    Prod _ x a b -> ppType a <+> text "->" <+> ppType b
+    Prod _ x a b -> ppType a <+> "->" <+> ppType b
     _            -> ppTerm Unqualified 0 ty
-
+{-
+ppqType :: Type -> Type -> Doc
+ppqType t u = case (ppType t, ppType u) of
+  (pt,pu) | render pt == render pu -> ppTerm Qualified 0 t
+  (pt,_) -> pt
+-}
 checkLookup :: Ident -> Context -> Check Type
 checkLookup x g =
   case [ty | (b,y,ty) <- g, x == y] of
-    []     -> checkError (text "unknown variable" <+> ppIdent x)
+    []     -> checkError ("unknown variable" <+> x)
     (ty:_) -> return ty
--}
diff --git a/src/compiler/GF/Compile/TypeCheck/RConcrete.hs b/src/compiler/GF/Compile/TypeCheck/RConcrete.hs
deleted file mode 100644
index aa13d5406..000000000
--- a/src/compiler/GF/Compile/TypeCheck/RConcrete.hs
+++ /dev/null
@@ -1,801 +0,0 @@
-{-# LANGUAGE PatternGuards #-}
-module GF.Compile.TypeCheck.RConcrete( checkLType, inferLType, computeLType, ppType ) where
-import Prelude hiding ((<>)) -- GHC 8.4.1 clash with Text.PrettyPrint
-
-import GF.Infra.CheckM
-import GF.Data.Operations
-
-import GF.Grammar
-import GF.Grammar.Lookup
-import GF.Grammar.Predef
-import GF.Grammar.PatternMatch
-import GF.Grammar.Lockfield (isLockLabel, lockRecType, unlockRecord)
-import GF.Compile.TypeCheck.Primitives
-
-import Data.List
-import Control.Monad
-import GF.Text.Pretty
-
-computeLType :: SourceGrammar -> Context -> Type -> Check Type
-computeLType gr g0 t = comp (reverse [(b,x, Vr x) | (b,x,_) <- g0] ++ g0) t
- where
-  comp g ty = case ty of
-    _ | Just _ <- isTypeInts ty -> return ty ---- shouldn't be needed
-      | isPredefConstant ty     -> return ty ---- shouldn't be needed
-
-    Q (m,ident) -> checkIn ("module" <+> m) $ do
-      ty' <- lookupResDef gr (m,ident)
-      if ty' == ty then return ty else comp g ty' --- is this necessary to test?
-
-    AdHocOverload ts -> do
-     over <- getOverload gr g (Just typeType) t
-     case over of
-       Just (tr,_) -> return tr
-       _ -> checkError ("unresolved overloading of constants" <+> ppTerm Qualified 0 t) 
-
-    Vr ident  -> checkLookup ident g -- never needed to compute!
-
-    App f a -> do
-      f' <- comp g f
-      a' <- comp g a
-      case f' of
-        Abs b x t -> comp ((b,x,a'):g) t
-        _ -> return $ App f' a'
-
-    Prod bt x a b -> do
-      a' <- comp g a
-      b' <- comp ((bt,x,Vr x) : g) b
-      return $ Prod bt x a' b'
-
-    Abs bt x b -> do
-      b' <- comp ((bt,x,Vr x):g) b
-      return $ Abs bt x b'
-
-    Let (x,(_,a)) b -> comp ((Explicit,x,a):g) b
-
-    ExtR r s -> do
-      r' <- comp g r
-      s' <- comp g s
-      case (r',s') of
-        (RecType rs, RecType ss) -> plusRecType r' s' >>= comp g
-        _ -> return $ ExtR r' s'
-
-    RecType fs -> do
-      let fs' = sortRec fs
-      liftM RecType $ mapPairsM (comp g) fs'
-
-    ELincat c t -> do
-      t' <- comp g t
-      lockRecType c t' ---- locking to be removed AR 20/6/2009
-
-    _ | ty == typeTok -> return typeStr
-    _ | isPredefConstant ty -> return ty
-
-    _ -> composOp (comp g) ty
-
--- the underlying algorithms
-
-inferLType :: SourceGrammar -> Context -> Term -> Check (Term, Type)
-inferLType gr g trm = case trm of
-
-   Q (m,ident) | isPredef m -> termWith trm $ case typPredefined ident of
-                                                Just ty -> return ty
-                                                Nothing -> checkError ("unknown in Predef:" <+> ident)
-
-   Q ident -> checks [
-     termWith trm $ lookupResType gr ident >>= computeLType gr g
-     ,
-     lookupResDef gr ident >>= inferLType gr g
-     ,
-     checkError ("cannot infer type of constant" <+> ppTerm Unqualified 0 trm)
-     ]
-
-   QC (m,ident) | isPredef m -> termWith trm $ case typPredefined ident of
-                                                 Just ty -> return ty
-                                                 Nothing -> checkError ("unknown in Predef:" <+> ident)
-
-   QC ident -> checks [
-       termWith trm $ lookupResType gr ident >>= computeLType gr g
-       ,
-       lookupResDef gr ident >>= inferLType gr g
-       ,
-       checkError ("cannot infer type of canonical constant" <+> ppTerm Unqualified 0 trm)
-       ]
-
-   Vr ident -> termWith trm $ checkLookup ident g
-
-   Typed e t -> do
-     t' <- computeLType gr g t
-     checkLType gr g e t'
-
-   AdHocOverload ts -> do
-     over <- getOverload gr g Nothing trm
-     case over of
-       Just trty -> return trty
-       _ -> checkError ("unresolved overloading of constants" <+> ppTerm Qualified 0 trm) 
-
-   App f a -> do
-     over <- getOverload gr g Nothing trm
-     case over of
-       Just trty -> return trty
-       _ -> do
-         (f',fty) <- inferLType gr g f
-         fty' <- computeLType gr g fty
-         case fty' of
-           Prod bt z arg val -> do 
-             a' <- justCheck g a arg
-             ty <- if isWildIdent z 
-                      then return val
-                      else substituteLType [(bt,z,a')] val
-             return (App f' a',ty)
-           _ ->
-             let term = ppTerm Unqualified 0 f
-                 funName = pp . head . words .render $ term
-              in checkError ("A function type is expected for" <+> term <+> "instead of type" <+> ppType fty $$
-                             "\n   ** Maybe you gave too many arguments to" <+> funName <+> "\n")
-
-   S f x -> do
-     (f', fty) <- inferLType gr g f
-     case fty of
-       Table arg val -> do
-         x'<- justCheck g x arg
-         return (S f' x', val)
-       _ -> checkError ("table lintype expected for the table in" $$ nest 2 (ppTerm Unqualified 0 trm))
-
-   P t i -> do
-     (t',ty) <- inferLType gr g t   --- ??
-     ty' <- computeLType gr g ty
-     let tr2 = P t' i
-     termWith tr2 $ case ty' of
-       RecType ts -> case lookup i ts of
-                       Nothing -> checkError ("unknown label" <+> i <+> "in" $$ nest 2 (ppTerm Unqualified 0 ty'))
-                       Just x  -> return x
-       _          -> checkError ("record type expected for:" <+> ppTerm Unqualified 0 t $$
-                                 " instead of the inferred:" <+> ppTerm Unqualified 0 ty')
-
-   R r -> do
-     let (ls,fs) = unzip r
-     fsts <- mapM inferM fs
-     let ts = [ty | (Just ty,_) <- fsts]
-     checkCond ("cannot infer type of record" $$ nest 2 (ppTerm Unqualified 0 trm)) (length ts == length fsts)
-     return $ (R (zip ls fsts), RecType (zip ls ts))
-
-   T (TTyped arg) pts -> do
-     (_,val) <- checks $ map (inferCase (Just arg)) pts
-     checkLType gr g trm (Table arg val)
-   T (TComp arg) pts -> do
-     (_,val) <- checks $ map (inferCase (Just arg)) pts
-     checkLType gr g trm (Table arg val)
-   T ti pts -> do  -- tries to guess: good in oper type inference
-     let pts' = [pt | pt@(p,_) <- pts, isConstPatt p]
-     case pts' of 
-       [] -> checkError ("cannot infer table type of" <+> ppTerm Unqualified 0 trm)
-----       PInt k : _ -> return $ Ints $ max [i | PInt i <- pts'] 
-       _  -> do 
-         (arg,val) <- checks $ map (inferCase Nothing) pts'
-         checkLType gr g trm (Table arg val)
-   V arg pts -> do
-     (_,val) <- checks $ map (inferLType gr g) pts
---   return (trm, Table arg val) -- old, caused issue 68
-     checkLType gr g trm (Table arg val)
-
-   K s  -> do
-     if elem ' ' s
-        then do
-          let ss = foldr C Empty (map K (words s))  
-          ----- removed irritating warning AR 24/5/2008
-          ----- checkWarn ("token \"" ++ s ++ 
-          -----              "\" converted to token list" ++ prt ss)
-          return (ss, typeStr)
-        else return (trm, typeStr)
-
-   EInt i -> return (trm, typeInt)
-
-   EFloat i -> return (trm, typeFloat)
-
-   Empty -> return (trm, typeStr)
-
-   C s1 s2 -> 
-     check2 (flip (justCheck g) typeStr) C s1 s2 typeStr
-
-   Glue s1 s2 -> 
-     check2 (flip (justCheck g) typeStr) Glue s1 s2 typeStr ---- typeTok
-
----- hack from Rename.identRenameTerm, to live with files with naming conflicts 18/6/2007
-   Strs (Cn c : ts) | c == cConflict -> do
-     checkWarn ("unresolved constant, could be any of" <+> hcat (map (ppTerm Unqualified 0) ts))
-     inferLType gr g (head ts)
-
-   Strs ts -> do
-     ts' <- mapM (\t -> justCheck g t typeStr) ts 
-     return (Strs ts', typeStrs)
-
-   Alts t aa -> do
-     t'  <- justCheck g t typeStr
-     aa' <- flip mapM aa (\ (c,v) -> do
-        c' <- justCheck g c typeStr 
-        v' <- checks $ map (justCheck g v) [typeStrs, EPattType typeStr]
-        return (c',v'))
-     return (Alts t' aa', typeStr)
-
-   RecType r -> do
-     let (ls,ts) = unzip r
-     ts' <- mapM (flip (justCheck g) typeType) ts 
-     return (RecType (zip ls ts'), typeType)
-
-   ExtR r s -> do
-   
----     over <- getOverload gr g Nothing r
----     let r1 = maybe r fst over
-     let r1 = r --- 
-
-     (r',rT) <- inferLType gr g r1
-     rT'     <- computeLType gr g rT
-     
-     (s',sT) <- inferLType gr g s
-     sT'     <- computeLType gr g sT
-
-     let trm' = ExtR r' s'
-     case (rT', sT') of
-       (RecType rs, RecType ss) -> do
-         let rt = RecType ([field | field@(l,_) <- rs, notElem l (map fst ss)] ++ ss) -- select types of later fields 
-         checkLType gr g trm' rt ---- return (trm', rt)
-       _ | rT' == typeType && sT' == typeType -> do
-         return (trm', typeType)
-       _ -> checkError ("records or record types expected in" <+> ppTerm Unqualified 0 trm)
-
-   Sort _     -> 
-     termWith trm $ return typeType
-
-   Prod bt x a b -> do
-     a' <- justCheck g a typeType
-     b' <- justCheck ((bt,x,a'):g) b typeType
-     return (Prod bt x a' b', typeType)
-
-   Table p t  -> do
-     p' <- justCheck g p typeType --- check p partype! 
-     t' <- justCheck g t typeType
-     return $ (Table p' t', typeType)
-
-   FV vs -> do
-     (_,ty) <- checks $ map (inferLType gr g) vs
----     checkIfComplexVariantType trm ty
-     checkLType gr g trm ty
-
-   EPattType ty -> do
-     ty' <- justCheck g ty typeType
-     return (EPattType ty',typeType)
-   EPatt p -> do
-     ty <- inferPatt p
-     return (trm, EPattType ty)
-
-   ELin c trm -> do
-     (trm',ty) <- inferLType gr g trm
-     ty' <- lockRecType c ty ---- lookup c; remove lock AR 20/6/2009
-     return $ (ELin c trm', ty') 
-
-   _ -> checkError ("cannot infer lintype of" <+> ppTerm Unqualified 0 trm)
-
- where
-   isPredef m = elem m [cPredef,cPredefAbs]
-
-   justCheck g ty te = checkLType gr g ty te >>= return . fst
-
-   -- for record fields, which may be typed
-   inferM (mty, t) = do
-     (t', ty') <- case mty of
-       Just ty -> checkLType gr g t ty
-       _ -> inferLType gr g t
-     return (Just ty',t')
-
-   inferCase mty (patt,term) = do
-     arg  <- maybe (inferPatt patt) return mty
-     cont <- pattContext gr g arg patt
-     (_,val) <- inferLType gr (reverse cont ++ g) term
-     return (arg,val)
-   isConstPatt p = case p of
-     PC _ ps -> True --- all isConstPatt ps
-     PP _ ps -> True --- all isConstPatt ps
-     PR ps -> all (isConstPatt . snd) ps
-     PT _ p -> isConstPatt p
-     PString _ -> True
-     PInt _ -> True
-     PFloat _ -> True
-     PChar -> True
-     PChars _ -> True
-     PSeq p q -> isConstPatt p && isConstPatt q
-     PAlt p q -> isConstPatt p && isConstPatt q
-     PRep p -> isConstPatt p
-     PNeg p -> isConstPatt p
-     PAs _ p -> isConstPatt p
-     _ -> False
-
-   inferPatt p = case p of
-     PP (q,c) ps | q /= cPredef -> liftM valTypeCnc (lookupResType gr (q,c))
-     PAs _ p  -> inferPatt p
-     PNeg p   -> inferPatt p
-     PAlt p q -> checks [inferPatt p, inferPatt q]
-     PSeq _ _ -> return $ typeStr
-     PRep _   -> return $ typeStr
-     PChar    -> return $ typeStr
-     PChars _ -> return $ typeStr
-     _ -> inferLType gr g (patt2term p) >>= return . snd
-
--- type inference: Nothing, type checking: Just t
--- the latter permits matching with value type
-getOverload :: SourceGrammar -> Context -> Maybe Type -> Term -> Check (Maybe (Term,Type))
-getOverload gr g mt ot = case appForm ot of
-     (f@(Q c), ts) -> case lookupOverload gr c of
-       Ok typs -> do
-         ttys <- mapM (inferLType gr g) ts
-         v <- matchOverload f typs ttys
-         return $ Just v
-       _ -> return Nothing
-     (AdHocOverload cs@(f:_), ts) -> do     --- the function name f is only used in error messages
-       let typs = concatMap collectOverloads cs
-       ttys <- mapM (inferLType gr g) ts
-       v <- matchOverload f typs ttys
-       return $ Just v
-     _ -> return Nothing
-     
- where
-   collectOverloads tr@(Q c) = case lookupOverload gr c of 
-     Ok typs -> typs
-     _ -> case lookupResType gr c of
-       Ok ty -> let (args,val) = typeFormCnc ty in [(map (\(b,x,t) -> t) args,(val,tr))]
-       _ -> []
-   collectOverloads _ = [] --- constructors QC
-
-   matchOverload f typs ttys = do
-     let (tts,tys) = unzip ttys
-     let vfs = lookupOverloadInstance tys typs
-     let matches = [vf | vf@((_,v,_),_) <- vfs, matchVal mt v]
-     let showTypes ty = hsep (map ppType ty)
-
-    
-     let (stys,styps) = (showTypes tys, [showTypes ty | (ty,_) <- typs])
-
-     -- to avoid strange error msg e.g. in case of unmatch record extension, show whole types if needed AR 28/1/2013
-     let (stysError,stypsError) = if elem (render stys) (map render styps)
-            then (hsep (map (ppTerm Unqualified 0) tys), [hsep (map (ppTerm Unqualified 0) ty) | (ty,_) <- typs])
-            else (stys,styps)
-
-     case ([vf | (vf,True) <- matches],[vf | (vf,False) <- matches]) of
-       ([(_,val,fun)],_) -> return (mkApp fun tts, val)
-       ([],[(pre,val,fun)]) -> do
-         checkWarn $  "ignoring lock fields in resolving" <+> ppTerm Unqualified 0 ot $$
-                      "for" $$
-                      nest 2 (showTypes tys) $$
-                      "using" $$
-                      nest 2 (showTypes pre)
-         return (mkApp fun tts, val)
-       ([],[]) -> do
-         checkError $ "no overload instance of" <+> ppTerm Qualified 0 f $$
-                      maybe empty (\x -> "with value type" <+> ppType x) mt $$
-                      "for argument list" $$
-                      nest 2 stysError $$
-                      "among alternatives" $$
-                      nest 2 (vcat stypsError) 
-
-
-       (vfs1,vfs2) -> case (noProds vfs1,noProds vfs2) of
-         ([(val,fun)],_) -> do
-           return (mkApp fun tts, val)
-         ([],[(val,fun)]) -> do
-           checkWarn ("ignoring lock fields in resolving" <+> ppTerm Unqualified 0 ot) 
-           return (mkApp fun tts, val)
-
------ unsafely exclude irritating warning AR 24/5/2008
------           checkWarn $ "overloading of" +++ prt f +++ 
------             "resolved by excluding partial applications:" ++++
------             unlines [prtType env ty | (ty,_) <- vfs', not (noProd ty)]
-
---- now forgiving ambiguity with a warning AR 1/2/2014
---  This gives ad hoc overloading the same behaviour as the choice of the first match in renaming did before. 
---  But it also gives a chance to ambiguous overloadings that were banned before. 
-         (nps1,nps2) -> do 
-              checkWarn $  "ambiguous overloading of" <+> ppTerm Unqualified 0 f <+>
-                  ----     "with argument types" <+> hsep (map (ppTerm Qualified 0) tys) $$ 
-                           "resolved by selecting the first of the alternatives" $$
-                           nest 2 (vcat [ppTerm Qualified 0 fun | (_,ty,fun) <- vfs1 ++ if null vfs1 then vfs2 else []])
-              case [(mkApp fun tts,val) | (val,fun) <- nps1 ++ nps2] of
-                 [] -> checkError $ "no alternatives left when resolving" <+> ppTerm Unqualified 0 f
-                 h:_ -> return h
-
-   matchVal mt v = elem mt [Nothing,Just v,Just (unlocked v)]
-
-   unlocked v = case v of
-     RecType fs -> RecType $ filter (not . isLockLabel . fst) (sortRec fs)
-     _ -> v
-   ---- TODO: accept subtypes
-   ---- TODO: use a trie
-   lookupOverloadInstance tys typs = 
-     [((pre,mkFunType rest val, t),isExact) | 
-       let lt = length tys,
-       (ty,(val,t)) <- typs, length ty >= lt,
-       let (pre,rest) = splitAt lt ty, 
-       let isExact = pre == tys,
-       isExact || map unlocked pre == map unlocked tys
-     ]
-
-   noProds vfs = [(v,f) | (_,v,f) <- vfs, noProd v]
-
-   noProd ty = case ty of
-     Prod _ _ _ _ -> False
-     _ -> True
-
-checkLType :: SourceGrammar -> Context -> Term -> Type -> Check (Term, Type)
-checkLType gr g trm typ0 = do
-  typ <- computeLType gr g typ0
-
-  case trm of
-
-    Abs bt x c -> do
-      case typ of
-        Prod bt' z a b -> do 
-          (c',b') <- if isWildIdent z
-                       then checkLType gr ((bt,x,a):g) c b
-                       else do b' <- checkIn (pp "abs") $ substituteLType [(bt',z,Vr x)] b
-                               checkLType gr ((bt,x,a):g) c b'
-          return $ (Abs bt x c', Prod bt' z a b')
-        _ -> checkError $ "function type expected instead of" <+> ppType typ $$
-                          "\n   ** Double-check that the type signature of the operation" $$
-                          "matches the number of arguments given to it.\n"
-
-    App f a -> do
-       over <- getOverload gr g (Just typ) trm
-       case over of
-         Just trty -> return trty
-         _ -> do
-          (trm',ty') <- inferLType gr g trm
-          termWith trm' $ checkEqLType gr g typ ty' trm'
-
-    AdHocOverload ts -> do
-      over <- getOverload gr g Nothing trm
-      case over of
-        Just trty -> return trty
-        _ -> checkError ("unresolved overloading of constants" <+> ppTerm Qualified 0 trm) 
-
-    Q _ -> do
-       over <- getOverload gr g (Just typ) trm
-       case over of
-         Just trty -> return trty
-         _ -> do
-          (trm',ty') <- inferLType gr g trm
-          termWith trm' $ checkEqLType gr g typ ty' trm'
-
-    T _ [] ->
-      checkError ("found empty table in type" <+> ppTerm Unqualified 0 typ)
-    T _ cs -> case typ of 
-      Table arg val -> do 
-        case allParamValues gr arg of
-          Ok vs -> do
-            let ps0 = map fst cs
-            ps <- testOvershadow ps0 vs
-            if null ps 
-              then return () 
-              else checkWarn ("patterns never reached:" $$
-                              nest 2 (vcat (map (ppPatt Unqualified 0) ps)))
-          _ -> return () -- happens with variable types
-        cs' <- mapM (checkCase arg val) cs
-        return (T (TTyped arg) cs', typ)
-      _ -> checkError $ "table type expected for table instead of" $$ nest 2 (ppType typ)
-    V arg0 vs ->
-      case typ of
-        Table arg1 val ->
-           do arg' <- checkEqLType gr g arg0 arg1 trm
-              vs1 <- allParamValues gr arg1
-              if length vs1 == length vs
-                 then return ()
-                 else checkError $ "wrong number of values in table" <+> ppTerm Unqualified 0 trm
-              vs' <- map fst `fmap` sequence [checkLType gr g v val|v<-vs]
-              return (V arg' vs',typ)
-
-    R r -> case typ of --- why needed? because inference may be too difficult
-       RecType rr -> do
-       --let (ls,_) = unzip rr        -- labels of expected type
-         fsts <- mapM (checkM r) rr   -- check that they are found in the record
-         return $ (R fsts, typ)       -- normalize record
-
-       _ -> checkError ("record type expected in type checking instead of" $$ nest 2 (ppTerm Unqualified 0 typ))
-
-    ExtR r s -> case typ of
-       _ | typ == typeType -> do
-         trm' <- computeLType gr g trm
-         case trm' of
-           RecType _ -> termWith trm' $ return typeType
-           ExtR (Vr _) (RecType _) -> termWith trm' $ return typeType 
-                                      -- ext t = t ** ...
-           _ -> checkError ("invalid record type extension" <+> nest 2 (ppTerm Unqualified 0 trm))
-
-       RecType rr -> do
-
-         ll2 <- case s of
-           R ss -> return $ map fst ss
-           _ -> do
-             (s',typ2) <- inferLType gr g s
-             case typ2 of
-               RecType ss -> return $ map fst ss
-               _ ->  checkError ("cannot get labels from" $$ nest 2 (ppTerm Unqualified 0 typ2))
-         let ll1 = [l | (l,_) <- rr, notElem l ll2]
-
----         over <- getOverload gr g Nothing r --- this would solve #66 but fail ParadigmsAra. AR 6/7/2020
----         let r1 = maybe r fst over
-         let r1 = r ---
-         
-         (r',_) <- checkLType gr g r1 (RecType [field | field@(l,_) <- rr, elem l ll1])
-         (s',_) <- checkLType gr g s  (RecType [field | field@(l,_) <- rr, elem l ll2])
-
-         let rec = R ([(l,(Nothing,P r' l)) | l <- ll1] ++ [(l,(Nothing,P s' l)) | l <- ll2])
-         return (rec, typ)
-
-       ExtR ty ex -> do
-         r' <- justCheck g r ty
-         s' <- justCheck g s ex
-         return $ (ExtR r' s', typ) --- is this all? it assumes the same division in trm and typ
-
-       _ -> checkError ("record extension not meaningful for" <+> ppTerm Unqualified 0 typ)
-
-    FV vs -> do
-      ttys <- mapM (flip (checkLType gr g) typ) vs
----      checkIfComplexVariantType trm typ
-      return (FV (map fst ttys), typ) --- typ' ?
-
-    S tab arg -> checks [ do
-      (tab',ty) <- inferLType gr g tab
-      ty'       <- computeLType gr g ty
-      case ty' of
-        Table p t -> do
-          (arg',val) <- checkLType gr g arg p
-          checkEqLType gr g typ t trm
-          return (S tab' arg', t)
-        _ -> checkError ("table type expected for applied table instead of" <+> ppType ty')
-     , do
-      (arg',ty) <- inferLType gr g arg
-      ty'       <- computeLType gr g ty
-      (tab',_)  <- checkLType gr g tab (Table ty' typ)
-      return (S tab' arg', typ)
-      ]
-    Let (x,(mty,def)) body -> case mty of
-      Just ty -> do
-        (ty0,_)    <- checkLType gr g ty typeType
-        (def',ty') <- checkLType gr g def ty0
-        body' <- justCheck ((Explicit,x,ty'):g) body typ
-        return (Let (x,(Just ty',def')) body', typ)
-      _ -> do
-        (def',ty) <- inferLType gr g def  -- tries to infer type of local constant
-        checkLType gr g (Let (x,(Just ty,def')) body) typ
-
-    ELin c tr -> do
-      tr1 <- unlockRecord c tr
-      checkLType gr g tr1 typ
-
-    _ -> do
-      (trm',ty') <- inferLType gr g trm
-      termWith trm' $ checkEqLType gr g typ ty' trm'
- where
-   justCheck g ty te = checkLType gr g ty te >>= return . fst
-{-
-   recParts rr t = (RecType rr1,RecType rr2) where 
-     (rr1,rr2) = partition (flip elem (map fst t) . fst) rr 
--}
-   checkM rms (l,ty) = case lookup l rms of
-     Just (Just ty0,t) -> do
-       checkEqLType gr g ty ty0 t
-       (t',ty') <- checkLType gr g t ty
-       return (l,(Just ty',t'))
-     Just (_,t) -> do
-       (t',ty') <- checkLType gr g t ty
-       return (l,(Just ty',t'))
-     _ -> checkError $ 
-            if isLockLabel l 
-              then let cat = drop 5 (showIdent (label2ident l))
-                   in ppTerm Unqualified 0 (R rms) <+> "is not in the lincat of" <+> cat <> 
-                      "; try wrapping it with lin" <+> cat
-              else "cannot find value for label" <+> l <+> "in" <+> ppTerm Unqualified 0 (R rms)
-
-   checkCase arg val (p,t) = do
-     cont <- pattContext gr g arg p
-     t' <- justCheck (reverse cont ++ g) t val
-     return (p,t')
-
-pattContext :: SourceGrammar -> Context -> Type -> Patt -> Check Context
-pattContext env g typ p = case p of
-  PV x -> return [(Explicit,x,typ)]
-  PP (q,c) ps | q /= cPredef -> do ---- why this /=? AR 6/1/2006
-    t <- lookupResType env (q,c)
-    let (cont,v) = typeFormCnc t
-    checkCond ("wrong number of arguments for constructor in" <+> ppPatt Unqualified 0 p) 
-              (length cont == length ps)
-    checkEqLType env g typ v (patt2term p)
-    mapM (\((_,_,ty),p) -> pattContext env g ty p) (zip cont ps) >>= return . concat
-  PR r -> do
-    typ' <- computeLType env g typ
-    case typ' of
-      RecType t -> do
-        let pts = [(ty,tr) | (l,tr) <- r, Just ty <- [lookup l t]]
-        ----- checkWarn $ prt p ++++ show pts ----- debug
-        mapM (uncurry (pattContext env g)) pts >>= return . concat
-      _ -> checkError ("record type expected for pattern instead of" <+> ppTerm Unqualified 0 typ')
-  PT t p' -> do
-    checkEqLType env g typ t (patt2term p')
-    pattContext env g typ p'
-
-  PAs x p -> do
-    g' <- pattContext env g typ p
-    return ((Explicit,x,typ):g')
-
-  PAlt p' q -> do
-    g1 <- pattContext env g typ p'
-    g2 <- pattContext env g typ q
-    let pts = nub ([x | pt@(_,x,_) <- g1, notElem pt g2] ++ [x | pt@(_,x,_) <- g2, notElem pt g1])
-    checkCond 
-      ("incompatible bindings of" <+>
-       fsep pts <+> 
-       "in pattern alterantives" <+> ppPatt Unqualified 0 p) (null pts) 
-    return g1 -- must be g1 == g2
-  PSeq p q -> do
-    g1 <- pattContext env g typ p
-    g2 <- pattContext env g typ q
-    return $ g1 ++ g2
-  PRep p' -> noBind typeStr p'
-  PNeg p' -> noBind typ p'
-
-  _ -> return [] ---- check types!
- where 
-   noBind typ p' = do
-    co <- pattContext env g typ p'
-    if not (null co)
-      then checkWarn ("no variable bound inside pattern" <+> ppPatt Unqualified 0 p) 
-           >> return []
-      else return []
-
-checkEqLType :: SourceGrammar -> Context -> Type -> Type -> Term -> Check Type
-checkEqLType gr g t u trm = do
-  (b,t',u',s) <- checkIfEqLType gr g t u trm
-  case b of
-    True  -> return t'
-    False ->
-      let inferredType = ppTerm Qualified 0 u
-          expectedType = ppTerm Qualified 0 t
-          term = ppTerm Unqualified 0 trm
-          funName = pp . head . words .render $ term
-          helpfulMsg =
-            case (arrows inferredType, arrows expectedType) of
-              (0,0) -> pp "" -- None of the types is a function
-              _ -> "\n   **" <+> 
-                  if expectedType `isLessApplied` inferredType
-                    then "Maybe you gave too few arguments to" <+> funName
-                    else pp "Double-check that type signature and number of arguments match."
-      in checkError $ s <+> "type of" <+> term $$
-                            "expected:" <+> expectedType $$ -- ppqType t u $$
-                            "inferred:" <+> inferredType $$ -- ppqType u t
-                            helpfulMsg
-  where
-    -- count the number of arrows in the prettyprinted term
-    arrows :: Doc -> Int
-    arrows = length . filter (=="->") . words . render
-
-    -- If prettyprinted type t has fewer arrows then prettyprinted type u,
-    -- then t is "less applied", and we can print out more helpful error msg.
-    isLessApplied :: Doc -> Doc -> Bool
-    isLessApplied t u = arrows t < arrows u
-
-checkIfEqLType :: SourceGrammar -> Context -> Type -> Type -> Term -> Check (Bool,Type,Type,String)
-checkIfEqLType gr g t u trm = do
-  t' <- computeLType gr g t
-  u' <- computeLType gr g u
-  case t' == u' || alpha [] t' u' of
-    True -> return (True,t',u',[])
-    -- forgive missing lock fields by only generating a warning.
-    --- better: use a flag to forgive? (AR 31/1/2006)
-    _ -> case missingLock [] t' u' of
-      Ok lo -> do
-        checkWarn $ "missing lock field" <+> fsep lo
-        return (True,t',u',[])
-      Bad s -> return (False,t',u',s)
-
-  where
-
-   -- check that u is a subtype of t
-   --- quick hack version of TC.eqVal
-   alpha g t u = case (t,u) of  
-
-     -- error (the empty type!) is subtype of any other type
-     (_,u) | u == typeError -> True
-
-     -- contravariance
-     (Prod _ x a b, Prod _ y c d) -> alpha g c a && alpha ((x,y):g) b d 
-                              
-     -- record subtyping
-     (RecType rs, RecType ts) -> all (\ (l,a) -> 
-                                   any (\ (k,b) -> l == k && alpha g a b) ts) rs
-     (ExtR r s, ExtR r' s') -> alpha g r r' && alpha g s s'
-     (ExtR r s, t) -> alpha g r t || alpha g s t
-
-     -- the following say that Ints n is a subset of Int and of Ints m >= n
-     -- But why does it also allow Int as a subtype of Ints m? /TH 2014-04-04
-     (t,u) | Just m <- isTypeInts t, Just n <- isTypeInts u -> m >= n
-           | Just _ <- isTypeInts t, u == typeInt           -> True ---- check size!
-           | t == typeInt,           Just _ <- isTypeInts u -> True ---- why this ???? AR 11/12/2005
-
-     ---- this should be made in Rename
-     (Q  (m,a), Q  (n,b)) | a == b -> elem m (allExtendsPlus gr n) 
-                                   || elem n (allExtendsPlus gr m)
-                                   || m == n --- for Predef
-     (QC (m,a), QC (n,b)) | a == b -> elem m (allExtendsPlus gr n) 
-                                   || elem n (allExtendsPlus gr m)
-     (QC (m,a), Q  (n,b)) | a == b -> elem m (allExtendsPlus gr n) 
-                                   || elem n (allExtendsPlus gr m)
-     (Q  (m,a), QC (n,b)) | a == b -> elem m (allExtendsPlus gr n) 
-                                   || elem n (allExtendsPlus gr m)
-
-     -- contravariance
-     (Table a b,  Table c d)  -> alpha g c a && alpha g b d
-     (Vr x,       Vr y)       -> x == y || elem (x,y) g || elem (y,x) g
-     _                        -> t == u 
-     --- the following should be one-way coercions only. AR 4/1/2001
-                                  || elem t sTypes && elem u sTypes
-                                  || (t == typeType && u == typePType) 
-                                  || (u == typeType && t == typePType) 
-
-   missingLock g t u = case (t,u) of  
-     (RecType rs, RecType ts) -> 
-       let 
-         ls = [l | (l,a) <- rs, 
-                   not (any (\ (k,b) -> alpha g a b && l == k) ts)]
-         (locks,others) = partition isLockLabel ls
-       in case others of
-         _:_ -> Bad $ render ("missing record fields:" <+> fsep (punctuate ',' (others)))
-         _ -> return locks
-     -- contravariance
-     (Prod _ x a b, Prod _ y c d) -> do
-        ls1 <- missingLock g c a
-        ls2 <- missingLock g b d
-        return $ ls1 ++ ls2
-
-     _ -> Bad ""
-
-   sTypes = [typeStr, typeTok, typeString]
-
--- auxiliaries
-
--- | light-weight substitution for dep. types
-substituteLType :: Context -> Type -> Check Type
-substituteLType g t = case t of
-  Vr x -> return $ maybe t id $ lookup x [(x,t) | (_,x,t) <- g]
-  _ -> composOp (substituteLType g) t
-
-termWith :: Term -> Check Type -> Check (Term, Type)
-termWith t ct = do
-  ty <- ct
-  return (t,ty)
-
--- | compositional check\/infer of binary operations
-check2 :: (Term -> Check Term) -> (Term -> Term -> Term) -> 
-          Term -> Term -> Type -> Check (Term,Type)
-check2 chk con a b t = do
-  a' <- chk a
-  b' <- chk b
-  return (con a' b', t)
-
--- printing a type with a lock field lock_C as C
-ppType :: Type -> Doc
-ppType ty =
-  case ty of
-    RecType fs   -> case filter isLockLabel $ map fst fs of
-                      [lock] -> pp (drop 5 (showIdent (label2ident lock)))
-                      _      -> ppTerm Unqualified 0 ty
-    Prod _ x a b -> ppType a <+> "->" <+> ppType b
-    _            -> ppTerm Unqualified 0 ty
-{-
-ppqType :: Type -> Type -> Doc
-ppqType t u = case (ppType t, ppType u) of
-  (pt,pu) | render pt == render pu -> ppTerm Qualified 0 t
-  (pt,_) -> pt
--}
-checkLookup :: Ident -> Context -> Check Type
-checkLookup x g =
-  case [ty | (b,y,ty) <- g, x == y] of
-    []     -> checkError ("unknown variable" <+> x)
-    (ty:_) -> return ty
-- 
cgit v1.2.3


From 5d7c687cb77ba10fd8a0ae70a605bb02f1ba59cf Mon Sep 17 00:00:00 2001
From: "John J. Camilleri" <john@digitalgrammars.com>
Date: Thu, 1 Jul 2021 14:32:39 +0200
Subject: Make imports in CheckGrammar a little more explicit

---
 src/compiler/GF/Compile/CheckGrammar.hs | 6 +++---
 1 file changed, 3 insertions(+), 3 deletions(-)

(limited to 'src')

diff --git a/src/compiler/GF/Compile/CheckGrammar.hs b/src/compiler/GF/Compile/CheckGrammar.hs
index a657fd020..71bce96c4 100644
--- a/src/compiler/GF/Compile/CheckGrammar.hs
+++ b/src/compiler/GF/Compile/CheckGrammar.hs
@@ -27,9 +27,9 @@ import GF.Infra.Ident
 import GF.Infra.Option
 
 import GF.Compile.TypeCheck.Abstract
-import GF.Compile.TypeCheck.Concrete
-import qualified GF.Compile.TypeCheck.ConcreteNew as CN
-import qualified GF.Compile.Compute.Concrete as CN
+import GF.Compile.TypeCheck.Concrete(computeLType,checkLType,inferLType,ppType)
+import qualified GF.Compile.TypeCheck.ConcreteNew as CN(checkLType,inferLType)
+import qualified GF.Compile.Compute.Concrete as CN(normalForm,resourceValues)
 
 import GF.Grammar
 import GF.Grammar.Lexer
-- 
cgit v1.2.3


From b090e9b0ff9c442396358090f0afa276e5531de5 Mon Sep 17 00:00:00 2001
From: "John J. Camilleri" <john@digitalgrammars.com>
Date: Thu, 1 Jul 2021 15:31:00 +0200
Subject: Add --haskell=pgf2 flag

---
 src/compiler/GF/Compile/PGFtoHaskell.hs | 120 +++++++++++++++++---------------
 src/compiler/GF/Infra/Option.hs         | 104 ++++++++++++++-------------
 2 files changed, 120 insertions(+), 104 deletions(-)

(limited to 'src')

diff --git a/src/compiler/GF/Compile/PGFtoHaskell.hs b/src/compiler/GF/Compile/PGFtoHaskell.hs
index 6356c9f6d..bc8e59f57 100644
--- a/src/compiler/GF/Compile/PGFtoHaskell.hs
+++ b/src/compiler/GF/Compile/PGFtoHaskell.hs
@@ -5,7 +5,7 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/06/17 12:39:07 $ 
+-- > CVS $Date: 2005/06/17 12:39:07 $
 -- > CVS $Author: bringert $
 -- > CVS $Revision: 1.8 $
 --
@@ -22,7 +22,7 @@ import PGF.Internal
 import GF.Data.Operations
 import GF.Infra.Option
 
-import Data.List --(isPrefixOf, find, intersperse)
+import Data.List(isPrefixOf,find,intercalate,intersperse,groupBy,sortBy)
 import qualified Data.Map as Map
 
 type Prefix = String -> String
@@ -34,11 +34,12 @@ grammar2haskell :: Options
                 -> PGF
                 -> String
 grammar2haskell opts name gr = foldr (++++) [] $
-  pragmas ++ haskPreamble gadt name derivingClause extraImports ++
+  pragmas ++ haskPreamble gadt name derivingClause (extraImports ++ pgfImports) ++
   [types, gfinstances gId lexical gr'] ++ compos
     where gr' = hSkeleton gr
           gadt = haskellOption opts HaskellGADT
           dataExt = haskellOption opts HaskellData
+          pgf2 = haskellOption opts HaskellPGF2
           lexical cat = haskellOption opts HaskellLexical && isLexicalCat opts cat
           gId | haskellOption opts HaskellNoPrefix = rmForbiddenChars
               | otherwise = ("G"++) . rmForbiddenChars
@@ -50,21 +51,23 @@ grammar2haskell opts name gr = foldr (++++) [] $
           derivingClause
                  | dataExt = "deriving (Show,Data)"
                  | otherwise = "deriving Show"
-          extraImports | gadt = ["import Control.Monad.Identity",
-                                 "import Data.Monoid"]
+          extraImports | gadt = ["import Control.Monad.Identity", "import Data.Monoid"]
                        | dataExt = ["import Data.Data"]
                        | otherwise = []
+          pgfImports | pgf2 = ["import PGF2 hiding (Tree)", "", "showCId :: CId -> String", "showCId = id"]
+                     | otherwise = ["import PGF hiding (Tree)"]
           types | gadt = datatypesGADT gId lexical gr'
                 | otherwise = datatypes gId derivingClause lexical gr'
           compos | gadt = prCompos gId lexical gr' ++ composClass
                  | otherwise = []
 
-haskPreamble gadt name derivingClause extraImports =
+haskPreamble :: Bool -> String -> String -> [String] -> [String]
+haskPreamble gadt name derivingClause imports =
  [
   "module " ++ name ++ " where",
   ""
- ] ++ extraImports ++ [
-  "import PGF hiding (Tree)",
+ ] ++ imports ++ [
+  "",
   "----------------------------------------------------",
   "-- automatic translation from GF to Haskell",
   "----------------------------------------------------",
@@ -85,10 +88,11 @@ haskPreamble gadt name derivingClause extraImports =
   ""
  ]
 
+predefInst :: Bool -> String -> String -> String -> String -> String -> String
 predefInst gadt derivingClause gtyp typ destr consr =
   (if gadt
     then []
-    else ("newtype" +++ gtyp +++ "=" +++ gtyp +++ typ +++ derivingClause ++ "\n\n")
+    else "newtype" +++ gtyp +++ "=" +++ gtyp +++ typ +++ derivingClause ++ "\n\n"
     )
   ++
   "instance Gf" +++ gtyp +++ "where" ++++
@@ -103,10 +107,10 @@ type OIdent = String
 type HSkeleton = [(OIdent, [(OIdent, [OIdent])])]
 
 datatypes :: Prefix -> DerivingClause -> (OIdent -> Bool) -> (String,HSkeleton) -> String
-datatypes gId derivingClause lexical = (foldr (+++++) "") . (filter (/="")) . (map (hDatatype gId derivingClause lexical)) . snd
+datatypes gId derivingClause lexical = foldr (+++++) "" . filter (/="") . map (hDatatype gId derivingClause lexical) . snd
 
 gfinstances :: Prefix -> (OIdent -> Bool) -> (String,HSkeleton) -> String
-gfinstances gId lexical (m,g) = (foldr (+++++) "") $ (filter (/="")) $ (map (gfInstance gId lexical m)) g
+gfinstances gId lexical (m,g) = foldr (+++++) "" $ filter (/="") $ map (gfInstance gId lexical m) g
 
 
 hDatatype  :: Prefix -> DerivingClause -> (OIdent -> Bool) -> (OIdent, [(OIdent, [OIdent])]) -> String
@@ -131,16 +135,17 @@ nonLexicalRules True rules = [r | r@(f,t) <- rules, not (null t)]
 lexicalConstructor :: OIdent -> String
 lexicalConstructor cat = "Lex" ++ cat
 
+predefTypeSkel :: HSkeleton
 predefTypeSkel = [(c,[]) | c <- ["String", "Int", "Float"]]
 
 -- GADT version of data types
 datatypesGADT :: Prefix -> (OIdent -> Bool) -> (String,HSkeleton) -> String
-datatypesGADT gId lexical (_,skel) = unlines $ 
+datatypesGADT gId lexical (_,skel) = unlines $
     concatMap (hCatTypeGADT gId) (skel ++ predefTypeSkel) ++
-    [ 
-      "", 
+    [
+      "",
       "data Tree :: * -> * where"
-    ] ++ 
+    ] ++
     concatMap (map ("  "++) . hDatatypeGADT gId lexical) skel ++
     [
       "  GString :: String -> Tree GString_",
@@ -164,23 +169,23 @@ hCatTypeGADT gId (cat,rules)
        "data"+++gId cat++"_"]
 
 hDatatypeGADT :: Prefix -> (OIdent -> Bool) -> (OIdent, [(OIdent, [OIdent])]) -> [String]
-hDatatypeGADT gId lexical (cat, rules) 
+hDatatypeGADT gId lexical (cat, rules)
     | isListCat (cat,rules) = [gId cat+++"::"+++"["++gId (elemCat cat)++"]" +++ "->" +++ t]
     | otherwise =
-        [ gId f +++ "::" +++ concatMap (\a -> gId a +++ "-> ") args ++ t 
+        [ gId f +++ "::" +++ concatMap (\a -> gId a +++ "-> ") args ++ t
           | (f,args) <- nonLexicalRules (lexical cat) rules ]
         ++ if lexical cat then [lexicalConstructor cat +++ ":: String ->"+++ t] else []
   where t = "Tree" +++ gId cat ++ "_"
 
 hEqGADT :: Prefix -> (OIdent -> Bool) -> (OIdent, [(OIdent, [OIdent])]) -> [String]
 hEqGADT gId lexical (cat, rules)
-  | isListCat (cat,rules) = let r = listr cat in ["(" ++ patt "x" r ++ "," ++ patt "y" r ++ ") -> " ++ listeqs] 
+  | isListCat (cat,rules) = let r = listr cat in ["(" ++ patt "x" r ++ "," ++ patt "y" r ++ ") -> " ++ listeqs]
   | otherwise = ["(" ++ patt "x" r ++ "," ++ patt "y" r ++ ") -> " ++ eqs r | r <- nonLexicalRules (lexical cat) rules]
           ++ if lexical cat then ["(" ++ lexicalConstructor cat +++ "x" ++ "," ++ lexicalConstructor cat +++ "y" ++ ") -> x == y"] else []
 
  where
    patt s (f,xs) = unwords (gId f : mkSVars s (length xs))
-   eqs (_,xs) = unwords ("and" : "[" : intersperse "," [x ++ " == " ++ y | 
+   eqs (_,xs) = unwords ("and" : "[" : intersperse "," [x ++ " == " ++ y |
      (x,y) <- zip (mkSVars "x" (length xs)) (mkSVars "y" (length xs)) ] ++ ["]"])
    listr c = (c,["foo"]) -- foo just for length = 1
    listeqs = "and [x == y | (x,y) <- zip x1 y1]"
@@ -189,25 +194,26 @@ prCompos :: Prefix -> (OIdent -> Bool) -> (String,HSkeleton) -> [String]
 prCompos gId lexical (_,catrules) =
     ["instance Compos Tree where",
      "  compos r a f t = case t of"]
-    ++ 
+    ++
     ["    " ++ prComposCons (gId f) xs | (c,rs) <- catrules, not (isListCat (c,rs)),
-                                         (f,xs) <- rs, not (null xs)] 
-    ++ 
+                                         (f,xs) <- rs, not (null xs)]
+    ++
     ["    " ++ prComposCons (gId c) ["x1"] | (c,rs) <- catrules, isListCat (c,rs)]
-    ++ 
+    ++
     ["    _ -> r t"]
   where
-    prComposCons f xs = let vs = mkVars (length xs) in 
+    prComposCons f xs = let vs = mkVars (length xs) in
                         f +++ unwords vs +++ "->" +++ rhs f (zip vs xs)
     rhs f vcs = "r" +++ f +++ unwords (map (prRec f) vcs)
-    prRec f (v,c) 
+    prRec f (v,c)
       | isList f  = "`a` foldr (a . a (r (:)) . f) (r [])" +++ v
       | otherwise = "`a`" +++ "f" +++ v
-    isList f = (gId "List") `isPrefixOf` f
+    isList f = gId "List" `isPrefixOf` f
 
 gfInstance :: Prefix -> (OIdent -> Bool) -> String -> (OIdent, [(OIdent, [OIdent])]) -> String
 gfInstance gId lexical m crs = hInstance gId lexical m crs ++++ fInstance gId lexical m crs
 
+hInstance :: (String -> String) -> (String -> Bool) -> String -> (String, [(OIdent, [OIdent])]) -> String
 ----hInstance m ("Cn",_) = "" --- seems to belong to an old applic. AR 18/5/2004
 hInstance gId _ m (cat,[]) = unlines [
   "instance Show" +++ gId cat,
@@ -216,15 +222,15 @@ hInstance gId _ m (cat,[]) = unlines [
   "  gf _ = undefined",
   "  fg _ = undefined"
   ]
-hInstance gId lexical m (cat,rules) 
+hInstance gId lexical m (cat,rules)
  | isListCat (cat,rules) =
   "instance Gf" +++ gId cat +++ "where" ++++
-     "  gf (" ++ gId cat +++ "[" ++ concat (intersperse "," baseVars) ++ "])" 
+     "  gf (" ++ gId cat +++ "[" ++ intercalate "," baseVars ++ "])"
            +++ "=" +++ mkRHS ("Base"++ec) baseVars ++++
-     "  gf (" ++ gId cat +++ "(x:xs)) = " 
-           ++ mkRHS ("Cons"++ec) ["x",prParenth (gId cat+++"xs")] 
+     "  gf (" ++ gId cat +++ "(x:xs)) = "
+           ++ mkRHS ("Cons"++ec) ["x",prParenth (gId cat+++"xs")]
 -- no show for GADTs
---     ++++ " gf (" ++ gId cat +++ "xs) = error (\"Bad " ++ cat ++ " value: \" ++ show xs)" 
+--     ++++ " gf (" ++ gId cat +++ "xs) = error (\"Bad " ++ cat ++ " value: \" ++ show xs)"
  | otherwise =
   "instance Gf" +++ gId cat +++ "where\n" ++
   unlines ([mkInst f xx | (f,xx) <- nonLexicalRules (lexical cat) rules]
@@ -233,19 +239,22 @@ hInstance gId lexical m (cat,rules)
    ec = elemCat cat
    baseVars = mkVars (baseSize (cat,rules))
    mkInst f xx = let xx' = mkVars (length xx) in "  gf " ++
-     (if length xx == 0 then gId f else prParenth (gId f +++ foldr1 (+++) xx')) +++
+     (if null xx then gId f else prParenth (gId f +++ foldr1 (+++) xx')) +++
      "=" +++ mkRHS f xx'
-   mkRHS f vars = "mkApp (mkCId \"" ++ f ++ "\")" +++ 
-		   "[" ++ prTList ", " ["gf" +++ x | x <- vars] ++ "]"
+   mkRHS f vars = "mkApp (mkCId \"" ++ f ++ "\")" +++
+       "[" ++ prTList ", " ["gf" +++ x | x <- vars] ++ "]"
 
+mkVars :: Int -> [String]
 mkVars = mkSVars "x"
+
+mkSVars :: String -> Int -> [String]
 mkSVars s n = [s ++ show i | i <- [1..n]]
 
 ----fInstance m ("Cn",_) = "" ---
 fInstance _ _ m (cat,[]) = ""
 fInstance gId lexical m (cat,rules) =
   "  fg t =" ++++
-  (if isList 
+  (if isList
     then "    " ++ gId cat ++ " (fgs t) where\n     fgs t = case unApp t of"
     else "    case unApp t of") ++++
   unlines [mkInst f xx | (f,xx) <- nonLexicalRules (lexical cat) rules] ++++
@@ -257,27 +266,28 @@ fInstance gId lexical m (cat,rules) =
      "      Just (i," ++
      "[" ++ prTList "," xx' ++ "])" +++
      "| i == mkCId \"" ++ f ++ "\" ->" +++ mkRHS f xx'
-       where xx' = ["x" ++ show i | (_,i) <- zip xx [1..]]
-	     mkRHS f vars 
-		 | isList =
-		     if "Base" `isPrefixOf` f 
-                       then "[" ++ prTList ", " [ "fg" +++ x | x <- vars ] ++ "]"
-		       else "fg" +++ (vars !! 0) +++ ":" +++ "fgs" +++ (vars !! 1)
-		 | otherwise = 
-		     gId f +++  
-		     prTList " " [prParenth ("fg" +++ x) | x <- vars]
+       where
+         xx' = ["x" ++ show i | (_,i) <- zip xx [1..]]
+         mkRHS f vars
+           | isList =
+               if "Base" `isPrefixOf` f
+                             then "[" ++ prTList ", " [ "fg" +++ x | x <- vars ] ++ "]"
+                 else "fg" +++ (vars !! 0) +++ ":" +++ "fgs" +++ (vars !! 1)
+           | otherwise =
+               gId f +++
+               prTList " " [prParenth ("fg" +++ x) | x <- vars]
 
 --type HSkeleton = [(OIdent, [(OIdent, [OIdent])])]
 hSkeleton :: PGF -> (String,HSkeleton)
-hSkeleton gr = 
-  (showCId (absname gr), 
-   let fs = 
-         [(showCId c, [(showCId f, map showCId cs) | (f, (cs,_)) <- fs]) | 
+hSkeleton gr =
+  (showCId (absname gr),
+   let fs =
+         [(showCId c, [(showCId f, map showCId cs) | (f, (cs,_)) <- fs]) |
                                         fs@((_, (_,c)):_) <- fns]
-   in fs ++ [(sc, []) | c <- cts, let sc = showCId c, notElem sc (["Int", "Float", "String"] ++ map fst fs)]
+   in fs ++ [(sc, []) | c <- cts, let sc = showCId c, sc `notElem` (["Int", "Float", "String"] ++ map fst fs)]
   )
  where
-   cts = Map.keys (cats (abstract gr)) 
+   cts = Map.keys (cats (abstract gr))
    fns = groupBy valtypg (sortBy valtyps (map jty (Map.assocs (funs (abstract gr)))))
    valtyps (_, (_,x)) (_, (_,y)) = compare x y
    valtypg (_, (_,x)) (_, (_,y)) = x == y
@@ -291,9 +301,10 @@ updateSkeleton cat skel rule =
 -}
 isListCat :: (OIdent, [(OIdent, [OIdent])]) -> Bool
 isListCat (cat,rules) = "List" `isPrefixOf` cat && length rules == 2
-		    && ("Base"++c) `elem` fs && ("Cons"++c) `elem` fs
-    where c = elemCat cat
-	  fs = map fst rules
+        && ("Base"++c) `elem` fs && ("Cons"++c) `elem` fs
+    where
+      c = elemCat cat
+      fs = map fst rules
 
 -- | Gets the element category of a list category.
 elemCat :: OIdent -> OIdent
@@ -310,7 +321,7 @@ baseSize (_,rules) = length bs
     where Just (_,bs) = find (("Base" `isPrefixOf`) . fst) rules
 
 composClass :: [String]
-composClass = 
+composClass =
     [
      "",
      "class Compos t where",
@@ -337,4 +348,3 @@ composClass =
      "",
      "newtype C b a = C { unC :: b }"
     ]
-
diff --git a/src/compiler/GF/Infra/Option.hs b/src/compiler/GF/Infra/Option.hs
index 6b7ff0cad..2a2ffd176 100644
--- a/src/compiler/GF/Infra/Option.hs
+++ b/src/compiler/GF/Infra/Option.hs
@@ -2,13 +2,13 @@ module GF.Infra.Option
     (
      -- ** Command line options
      -- *** Option types
-     Options, 
-     Flags(..), 
-     Mode(..), Phase(..), Verbosity(..), 
-     OutputFormat(..), 
+     Options,
+     Flags(..),
+     Mode(..), Phase(..), Verbosity(..),
+     OutputFormat(..),
      SISRFormat(..), Optimization(..), CFGTransform(..), HaskellOption(..),
      Dump(..), Pass(..), Recomp(..),
-     outputFormatsExpl, 
+     outputFormatsExpl,
      -- *** Option parsing
      parseOptions, parseModuleOptions, fixRelativeLibPaths,
      -- *** Option pretty-printing
@@ -47,7 +47,7 @@ import PGF.Internal(Literal(..))
 import qualified Control.Monad.Fail as Fail
 
 usageHeader :: String
-usageHeader = unlines 
+usageHeader = unlines
  ["Usage: gf [OPTIONS] [FILE [...]]",
   "",
   "How each FILE is handled depends on the file name suffix:",
@@ -90,10 +90,10 @@ data Phase = Preproc | Convert | Compile | Link
 data OutputFormat = FmtPGFPretty
                   | FmtCanonicalGF
                   | FmtCanonicalJson
-                  | FmtJavaScript 
+                  | FmtJavaScript
                   | FmtJSON
-                  | FmtPython 
-                  | FmtHaskell 
+                  | FmtPython
+                  | FmtHaskell
                   | FmtJava
                   | FmtProlog
                   | FmtBNF
@@ -102,37 +102,42 @@ data OutputFormat = FmtPGFPretty
                   | FmtNoLR
                   | FmtSRGS_XML
                   | FmtSRGS_XML_NonRec
-                  | FmtSRGS_ABNF 
+                  | FmtSRGS_ABNF
                   | FmtSRGS_ABNF_NonRec
-                  | FmtJSGF 
-                  | FmtGSL 
+                  | FmtJSGF
+                  | FmtGSL
                   | FmtVoiceXML
                   | FmtSLF
                   | FmtRegExp
                   | FmtFA
   deriving (Eq,Ord)
 
-data SISRFormat = 
+data SISRFormat =
     -- | SISR Working draft 1 April 2003
     --   <http://www.w3.org/TR/2003/WD-semantic-interpretation-20030401/>
-    SISR_WD20030401    
+    SISR_WD20030401
   | SISR_1_0
  deriving (Show,Eq,Ord)
 
 data Optimization = OptStem | OptCSE | OptExpand | OptParametrize
   deriving (Show,Eq,Ord)
 
-data CFGTransform = CFGNoLR 
+data CFGTransform = CFGNoLR
                   | CFGRegular
-                  | CFGTopDownFilter 
-                  | CFGBottomUpFilter 
+                  | CFGTopDownFilter
+                  | CFGBottomUpFilter
                   | CFGStartCatOnly
                   | CFGMergeIdentical
                   | CFGRemoveCycles
   deriving (Show,Eq,Ord)
 
-data HaskellOption = HaskellNoPrefix | HaskellGADT | HaskellLexical
-                   | HaskellConcrete | HaskellVariants | HaskellData
+data HaskellOption = HaskellNoPrefix
+                   | HaskellGADT
+                   | HaskellLexical
+                   | HaskellConcrete
+                   | HaskellVariants
+                   | HaskellData
+                   | HaskellPGF2
   deriving (Show,Eq,Ord)
 
 data Warning = WarnMissingLincat
@@ -196,7 +201,7 @@ instance Show Options where
 parseOptions :: ErrorMonad err =>
                 [String]                   -- ^ list of string arguments
              -> err (Options, [FilePath])
-parseOptions args 
+parseOptions args
   | not (null errs) = errors errs
   | otherwise       = do opts <- concatOptions `fmap` liftErr (sequence optss)
                          return (opts, files)
@@ -208,7 +213,7 @@ parseModuleOptions :: ErrorMonad err =>
                    -> err Options
 parseModuleOptions args = do
   (opts,nonopts) <- parseOptions args
-  if null nonopts 
+  if null nonopts
     then return opts
     else errors $ map ("Non-option among module options: " ++) nonopts
 
@@ -281,7 +286,7 @@ defaultFlags = Flags {
       optOptimizations   = Set.fromList [OptStem,OptCSE,OptExpand,OptParametrize],
       optOptimizePGF     = False,
       optSplitPGF        = False,
-      optCFGTransforms   = Set.fromList [CFGRemoveCycles, CFGBottomUpFilter, 
+      optCFGTransforms   = Set.fromList [CFGRemoveCycles, CFGBottomUpFilter,
                                          CFGTopDownFilter, CFGMergeIdentical],
       optLibraryPath     = [],
       optStartCat        = Nothing,
@@ -301,7 +306,7 @@ defaultFlags = Flags {
 -- | Option descriptions
 {-# NOINLINE optDescr #-}
 optDescr :: [OptDescr (Err Options)]
-optDescr = 
+optDescr =
     [
      Option ['?','h'] ["help"] (NoArg (mode ModeHelp)) "Show help message.",
      Option ['V'] ["version"] (NoArg (mode ModeVersion)) "Display GF version number.",
@@ -327,44 +332,44 @@ optDescr =
 --   Option ['t'] ["trace"] (NoArg (trace True)) "Trace computations",
 --   Option [] ["no-trace"] (NoArg (trace False)) "Don't trace computations",
      Option [] ["gfo-dir"] (ReqArg gfoDir "DIR") "Directory to put .gfo files in (default = '.').",
-     Option ['f'] ["output-format"] (ReqArg outFmt "FMT") 
+     Option ['f'] ["output-format"] (ReqArg outFmt "FMT")
         (unlines ["Output format. FMT can be one of:",
                   "Canonical GF grammar: canonical_gf, canonical_json, (and haskell with option --haskell=concrete)",
                   "Multiple concrete: pgf (default), json, js, pgf_pretty, prolog, python, ...", -- gar,
                   "Single concrete only: bnf, ebnf, fa, gsl, jsgf, regexp, slf, srgs_xml, srgs_abnf, vxml, ....", -- cf, lbnf,
                   "Abstract only: haskell, ..."]), -- prolog_abs,
-     Option [] ["sisr"] (ReqArg sisrFmt "FMT") 
+     Option [] ["sisr"] (ReqArg sisrFmt "FMT")
         (unlines ["Include SISR tags in generated speech recognition grammars.",
                   "FMT can be one of: old, 1.0"]),
-     Option [] ["haskell"] (ReqArg hsOption "OPTION") 
-            ("Turn on an optional feature when generating Haskell data types. OPTION = " 
+     Option [] ["haskell"] (ReqArg hsOption "OPTION")
+            ("Turn on an optional feature when generating Haskell data types. OPTION = "
              ++ concat (intersperse " | " (map fst haskellOptionNames))),
-     Option [] ["lexical"] (ReqArg lexicalCat "CAT[,CAT[...]]") 
+     Option [] ["lexical"] (ReqArg lexicalCat "CAT[,CAT[...]]")
             "Treat CAT as a lexical category.",
-     Option [] ["literal"] (ReqArg literalCat "CAT[,CAT[...]]") 
+     Option [] ["literal"] (ReqArg literalCat "CAT[,CAT[...]]")
             "Treat CAT as a literal category.",
-     Option ['D'] ["output-dir"] (ReqArg outDir "DIR") 
+     Option ['D'] ["output-dir"] (ReqArg outDir "DIR")
            "Save output files (other than .gfo files) in DIR.",
-     Option [] ["gf-lib-path"] (ReqArg gfLibPath "DIR") 
+     Option [] ["gf-lib-path"] (ReqArg gfLibPath "DIR")
            "Overrides the value of GF_LIB_PATH.",
-     Option [] ["src","force-recomp"] (NoArg (recomp AlwaysRecomp)) 
+     Option [] ["src","force-recomp"] (NoArg (recomp AlwaysRecomp))
                  "Always recompile from source.",
-     Option [] ["recomp-if-newer"] (NoArg (recomp RecompIfNewer)) 
+     Option [] ["recomp-if-newer"] (NoArg (recomp RecompIfNewer))
                  "(default) Recompile from source if the source is newer than the .gfo file.",
-     Option [] ["gfo","no-recomp"] (NoArg (recomp NeverRecomp)) 
+     Option [] ["gfo","no-recomp"] (NoArg (recomp NeverRecomp))
                  "Never recompile from source, if there is already .gfo file.",
      Option [] ["retain"] (NoArg (set $ \o -> o { optRetainResource = True })) "Retain opers.",
      Option [] ["probs"] (ReqArg probsFile "file.probs") "Read probabilities from file.",
-     Option ['n'] ["name"] (ReqArg name "NAME") 
+     Option ['n'] ["name"] (ReqArg name "NAME")
            (unlines ["Use NAME as the name of the output. This is used in the output file names, ",
                      "with suffixes depending on the formats, and, when relevant, ",
                      "internally in the output."]),
      Option ['i'] [] (ReqArg addLibDir "DIR") "Add DIR to the library search path.",
      Option [] ["path"] (ReqArg setLibPath "DIR:DIR:...") "Set the library search path.",
-     Option [] ["preproc"] (ReqArg preproc "CMD") 
+     Option [] ["preproc"] (ReqArg preproc "CMD")
                  (unlines ["Use CMD to preprocess input files.",
                            "Multiple preprocessors can be used by giving this option multiple times."]),
-     Option [] ["coding"] (ReqArg coding "ENCODING") 
+     Option [] ["coding"] (ReqArg coding "ENCODING")
                 ("Character encoding of the source grammar, ENCODING = utf8, latin1, cp1251, ..."),
      Option [] ["startcat"] (ReqArg startcat "CAT") "Grammar start category.",
      Option [] ["language"] (ReqArg language "LANG") "Set the speech language flag to LANG in the generated grammar.",
@@ -372,7 +377,7 @@ optDescr =
      Option [] ["unlexer"] (ReqArg unlexer "UNLEXER") "Use unlexer UNLEXER.",
      Option [] ["pmcfg"] (NoArg (pmcfg True)) "Generate PMCFG (default).",
      Option [] ["no-pmcfg"] (NoArg (pmcfg False)) "Don't generate PMCFG (useful for libraries).",
-     Option [] ["optimize"] (ReqArg optimize "OPT") 
+     Option [] ["optimize"] (ReqArg optimize "OPT")
                 "Select an optimization package. OPT = all | values | parametrize | none",
      Option [] ["optimize-pgf"] (NoArg (optimize_pgf True))
                 "Enable or disable global grammar optimization. This could significantly reduce the size of the final PGF file",
@@ -447,7 +452,7 @@ optDescr =
        optimize    x = case lookup x optimizationPackages of
                          Just p  -> set $ \o -> o { optOptimizations = p }
                          Nothing -> fail $ "Unknown optimization package: " ++ x
-                         
+
        optimize_pgf x = set $ \o -> o { optOptimizePGF = x }
        splitPGF x = set $ \o -> o { optSplitPGF = x }
 
@@ -471,7 +476,7 @@ outputFormats :: [(String,OutputFormat)]
 outputFormats = map fst outputFormatsExpl
 
 outputFormatsExpl :: [((String,OutputFormat),String)]
-outputFormatsExpl = 
+outputFormatsExpl =
     [(("pgf_pretty",   FmtPGFPretty),"human-readable pgf"),
      (("canonical_gf", FmtCanonicalGF),"Canonical GF source files"),
      (("canonical_json", FmtCanonicalJson),"Canonical JSON source files"),
@@ -504,11 +509,11 @@ instance Read OutputFormat where
     readsPrec = lookupReadsPrec outputFormats
 
 optimizationPackages :: [(String, Set Optimization)]
-optimizationPackages = 
+optimizationPackages =
     [("all",         Set.fromList [OptStem,OptCSE,OptExpand,OptParametrize]),
      ("values",      Set.fromList [OptStem,OptCSE,OptExpand]),
      ("noexpand",    Set.fromList [OptStem,OptCSE]),
-     
+
      -- deprecated
      ("all_subs",    Set.fromList [OptStem,OptCSE,OptExpand,OptParametrize]),
      ("parametrize", Set.fromList [OptStem,OptCSE,OptExpand,OptParametrize]),
@@ -516,7 +521,7 @@ optimizationPackages =
     ]
 
 cfgTransformNames :: [(String, CFGTransform)]
-cfgTransformNames = 
+cfgTransformNames =
     [("nolr",         CFGNoLR),
      ("regular",      CFGRegular),
      ("topdown",      CFGTopDownFilter),
@@ -532,7 +537,8 @@ haskellOptionNames =
      ("lexical",  HaskellLexical),
      ("concrete", HaskellConcrete),
      ("variants", HaskellVariants),
-     ("data",     HaskellData)]
+     ("data",     HaskellData),
+     ("pgf2",     HaskellPGF2)]
 
 -- | This is for bacward compatibility. Since GHC 6.12 we
 -- started using the native Unicode support in GHC but it
@@ -558,7 +564,7 @@ onOff f def = OptArg g "[on,off]"
                         _     -> fail $ "Expected [on,off], got: " ++ show x
 
 readOutputFormat :: Fail.MonadFail m => String -> m OutputFormat
-readOutputFormat s = 
+readOutputFormat s =
     maybe (fail $ "Unknown output format: " ++ show s) return $ lookup s outputFormats
 
 -- FIXME: this is a copy of the function in GF.Devel.UseIO.
@@ -570,7 +576,7 @@ splitInModuleSearchPath s = case break isPathSep s of
     isPathSep :: Char -> Bool
     isPathSep c = c == ':' || c == ';'
 
--- 
+--
 -- * Convenience functions for checking options
 --
 
@@ -592,7 +598,7 @@ isLiteralCat opts c = Set.member c (flag optLiteralCats opts)
 isLexicalCat :: Options -> String -> Bool
 isLexicalCat opts c = Set.member c (flag optLexicalCats opts)
 
--- 
+--
 -- * Convenience functions for setting options
 --
 
@@ -623,8 +629,8 @@ readMaybe s = case reads s of
 
 toEnumBounded :: (Bounded a, Enum a, Ord a) => Int -> Maybe a
 toEnumBounded i = let mi = minBound
-                      ma = maxBound `asTypeOf` mi                      
-                   in if i >= fromEnum mi && i <= fromEnum ma 
+                      ma = maxBound `asTypeOf` mi
+                   in if i >= fromEnum mi && i <= fromEnum ma
                         then Just (toEnum i `asTypeOf` mi)
                         else Nothing
 
-- 
cgit v1.2.3


From d53e1713c7860de8a5c256ffe0eed81d5388ae41 Mon Sep 17 00:00:00 2001
From: Meowyam <maryam@chilon.net>
Date: Fri, 2 Jul 2021 16:08:34 +0800
Subject: resolves GrammaticalFramework/gf-core/#97

---
 src/compiler/GF/Command/CommonCommands.hs | 5 ++++-
 1 file changed, 4 insertions(+), 1 deletion(-)

(limited to 'src')

diff --git a/src/compiler/GF/Command/CommonCommands.hs b/src/compiler/GF/Command/CommonCommands.hs
index 0b698e79c..578331e65 100644
--- a/src/compiler/GF/Command/CommonCommands.hs
+++ b/src/compiler/GF/Command/CommonCommands.hs
@@ -170,10 +170,13 @@ commonCommands = fmap (mapCommandExec liftSIO) $ Map.fromList [
        restrictedSystem $ syst ++ " <" ++ tmpi ++ " >" ++ tmpo
        fmap fromString $ restricted $ readFile tmpo,
        -}
-       fmap fromString . restricted . readShellProcess syst $ toString arg,
+       fmap (fromStrings . lines) . restricted . readShellProcess syst . unlines $ toStrings arg,
      flags = [
        ("command","the system command applied to the argument")
        ],
+     options = [
+       ("lines","preserve input lines, and return output as a list of lines")
+       ],
      examples = [
        mkEx "gt | l | ? wc  -- generate trees, linearize, and count words"
        ]
-- 
cgit v1.2.3


From e1a40640cd55b6047f2aa36bf3394017d8867fd6 Mon Sep 17 00:00:00 2001
From: 2jacobtan <jacob.tan.en@gmail.com>
Date: Tue, 6 Jul 2021 05:42:34 +0800
Subject: specify version bounds in pgf.cabal and pgf2.cabal

---
 src/runtime/haskell-bind/pgf2.cabal |  6 +++---
 src/runtime/haskell/pgf.cabal       | 18 +++++++++---------
 2 files changed, 12 insertions(+), 12 deletions(-)

(limited to 'src')

diff --git a/src/runtime/haskell-bind/pgf2.cabal b/src/runtime/haskell-bind/pgf2.cabal
index c8d5d8c6c..fcd854d72 100644
--- a/src/runtime/haskell-bind/pgf2.cabal
+++ b/src/runtime/haskell-bind/pgf2.cabal
@@ -23,9 +23,9 @@ library
     PGF2.Expr,
     PGF2.Type
   build-depends:
-    base >=4.3 && <5,
-    containers,
-    pretty
+    base >= 4.9.1 && <4.15,
+    containers >= 0.5.7 && < 0.7,
+    pretty >= 1.1.3 && < 1.2
   default-language: Haskell2010
   build-tools: hsc2hs
   extra-libraries: pgf gu
diff --git a/src/runtime/haskell/pgf.cabal b/src/runtime/haskell/pgf.cabal
index f829a6e35..9a59502c4 100644
--- a/src/runtime/haskell/pgf.cabal
+++ b/src/runtime/haskell/pgf.cabal
@@ -14,16 +14,16 @@ tested-with: GHC==7.6.3, GHC==7.8.3, GHC==7.10.3, GHC==8.0.2, GHC==8.4.4
 library
   default-language: Haskell2010
   build-depends:
-    array,
-    base >= 4.6 && <5,
-    bytestring,
-    containers,
+    base >= 4.9.1 && <4.15,
+    array >= 0.5.1 && < 0.6,
+    containers >= 0.5.7 && < 0.7,
+    bytestring >= 0.10.8 && < 0.11,
+    utf8-string >= 1.0.1.1 && < 1.1,
+    random >= 1.1 && < 1.3,
+    pretty >= 1.1.3 && < 1.2,
+    mtl >= 2.2.1 && < 2.3,
+    ghc-prim >= 0.5.0 && < 0.7
     -- exceptions,
-    ghc-prim,
-    mtl,
-    pretty,
-    random,
-    utf8-string
 
   other-modules:
     -- not really part of GF but I have changed the original binary library
-- 
cgit v1.2.3


From dff1193f7b7a9f186835de80ca96471034abf182 Mon Sep 17 00:00:00 2001
From: "John J. Camilleri" <john@digitalgrammars.com>
Date: Thu, 1 Jul 2021 15:31:00 +0200
Subject: Add --haskell=pgf2 flag

---
 src/compiler/GF/Compile/PGFtoHaskell.hs | 120 +++++++++++++++++---------------
 src/compiler/GF/Infra/Option.hs         | 104 ++++++++++++++-------------
 2 files changed, 120 insertions(+), 104 deletions(-)

(limited to 'src')

diff --git a/src/compiler/GF/Compile/PGFtoHaskell.hs b/src/compiler/GF/Compile/PGFtoHaskell.hs
index 6356c9f6d..bc8e59f57 100644
--- a/src/compiler/GF/Compile/PGFtoHaskell.hs
+++ b/src/compiler/GF/Compile/PGFtoHaskell.hs
@@ -5,7 +5,7 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/06/17 12:39:07 $ 
+-- > CVS $Date: 2005/06/17 12:39:07 $
 -- > CVS $Author: bringert $
 -- > CVS $Revision: 1.8 $
 --
@@ -22,7 +22,7 @@ import PGF.Internal
 import GF.Data.Operations
 import GF.Infra.Option
 
-import Data.List --(isPrefixOf, find, intersperse)
+import Data.List(isPrefixOf,find,intercalate,intersperse,groupBy,sortBy)
 import qualified Data.Map as Map
 
 type Prefix = String -> String
@@ -34,11 +34,12 @@ grammar2haskell :: Options
                 -> PGF
                 -> String
 grammar2haskell opts name gr = foldr (++++) [] $
-  pragmas ++ haskPreamble gadt name derivingClause extraImports ++
+  pragmas ++ haskPreamble gadt name derivingClause (extraImports ++ pgfImports) ++
   [types, gfinstances gId lexical gr'] ++ compos
     where gr' = hSkeleton gr
           gadt = haskellOption opts HaskellGADT
           dataExt = haskellOption opts HaskellData
+          pgf2 = haskellOption opts HaskellPGF2
           lexical cat = haskellOption opts HaskellLexical && isLexicalCat opts cat
           gId | haskellOption opts HaskellNoPrefix = rmForbiddenChars
               | otherwise = ("G"++) . rmForbiddenChars
@@ -50,21 +51,23 @@ grammar2haskell opts name gr = foldr (++++) [] $
           derivingClause
                  | dataExt = "deriving (Show,Data)"
                  | otherwise = "deriving Show"
-          extraImports | gadt = ["import Control.Monad.Identity",
-                                 "import Data.Monoid"]
+          extraImports | gadt = ["import Control.Monad.Identity", "import Data.Monoid"]
                        | dataExt = ["import Data.Data"]
                        | otherwise = []
+          pgfImports | pgf2 = ["import PGF2 hiding (Tree)", "", "showCId :: CId -> String", "showCId = id"]
+                     | otherwise = ["import PGF hiding (Tree)"]
           types | gadt = datatypesGADT gId lexical gr'
                 | otherwise = datatypes gId derivingClause lexical gr'
           compos | gadt = prCompos gId lexical gr' ++ composClass
                  | otherwise = []
 
-haskPreamble gadt name derivingClause extraImports =
+haskPreamble :: Bool -> String -> String -> [String] -> [String]
+haskPreamble gadt name derivingClause imports =
  [
   "module " ++ name ++ " where",
   ""
- ] ++ extraImports ++ [
-  "import PGF hiding (Tree)",
+ ] ++ imports ++ [
+  "",
   "----------------------------------------------------",
   "-- automatic translation from GF to Haskell",
   "----------------------------------------------------",
@@ -85,10 +88,11 @@ haskPreamble gadt name derivingClause extraImports =
   ""
  ]
 
+predefInst :: Bool -> String -> String -> String -> String -> String -> String
 predefInst gadt derivingClause gtyp typ destr consr =
   (if gadt
     then []
-    else ("newtype" +++ gtyp +++ "=" +++ gtyp +++ typ +++ derivingClause ++ "\n\n")
+    else "newtype" +++ gtyp +++ "=" +++ gtyp +++ typ +++ derivingClause ++ "\n\n"
     )
   ++
   "instance Gf" +++ gtyp +++ "where" ++++
@@ -103,10 +107,10 @@ type OIdent = String
 type HSkeleton = [(OIdent, [(OIdent, [OIdent])])]
 
 datatypes :: Prefix -> DerivingClause -> (OIdent -> Bool) -> (String,HSkeleton) -> String
-datatypes gId derivingClause lexical = (foldr (+++++) "") . (filter (/="")) . (map (hDatatype gId derivingClause lexical)) . snd
+datatypes gId derivingClause lexical = foldr (+++++) "" . filter (/="") . map (hDatatype gId derivingClause lexical) . snd
 
 gfinstances :: Prefix -> (OIdent -> Bool) -> (String,HSkeleton) -> String
-gfinstances gId lexical (m,g) = (foldr (+++++) "") $ (filter (/="")) $ (map (gfInstance gId lexical m)) g
+gfinstances gId lexical (m,g) = foldr (+++++) "" $ filter (/="") $ map (gfInstance gId lexical m) g
 
 
 hDatatype  :: Prefix -> DerivingClause -> (OIdent -> Bool) -> (OIdent, [(OIdent, [OIdent])]) -> String
@@ -131,16 +135,17 @@ nonLexicalRules True rules = [r | r@(f,t) <- rules, not (null t)]
 lexicalConstructor :: OIdent -> String
 lexicalConstructor cat = "Lex" ++ cat
 
+predefTypeSkel :: HSkeleton
 predefTypeSkel = [(c,[]) | c <- ["String", "Int", "Float"]]
 
 -- GADT version of data types
 datatypesGADT :: Prefix -> (OIdent -> Bool) -> (String,HSkeleton) -> String
-datatypesGADT gId lexical (_,skel) = unlines $ 
+datatypesGADT gId lexical (_,skel) = unlines $
     concatMap (hCatTypeGADT gId) (skel ++ predefTypeSkel) ++
-    [ 
-      "", 
+    [
+      "",
       "data Tree :: * -> * where"
-    ] ++ 
+    ] ++
     concatMap (map ("  "++) . hDatatypeGADT gId lexical) skel ++
     [
       "  GString :: String -> Tree GString_",
@@ -164,23 +169,23 @@ hCatTypeGADT gId (cat,rules)
        "data"+++gId cat++"_"]
 
 hDatatypeGADT :: Prefix -> (OIdent -> Bool) -> (OIdent, [(OIdent, [OIdent])]) -> [String]
-hDatatypeGADT gId lexical (cat, rules) 
+hDatatypeGADT gId lexical (cat, rules)
     | isListCat (cat,rules) = [gId cat+++"::"+++"["++gId (elemCat cat)++"]" +++ "->" +++ t]
     | otherwise =
-        [ gId f +++ "::" +++ concatMap (\a -> gId a +++ "-> ") args ++ t 
+        [ gId f +++ "::" +++ concatMap (\a -> gId a +++ "-> ") args ++ t
           | (f,args) <- nonLexicalRules (lexical cat) rules ]
         ++ if lexical cat then [lexicalConstructor cat +++ ":: String ->"+++ t] else []
   where t = "Tree" +++ gId cat ++ "_"
 
 hEqGADT :: Prefix -> (OIdent -> Bool) -> (OIdent, [(OIdent, [OIdent])]) -> [String]
 hEqGADT gId lexical (cat, rules)
-  | isListCat (cat,rules) = let r = listr cat in ["(" ++ patt "x" r ++ "," ++ patt "y" r ++ ") -> " ++ listeqs] 
+  | isListCat (cat,rules) = let r = listr cat in ["(" ++ patt "x" r ++ "," ++ patt "y" r ++ ") -> " ++ listeqs]
   | otherwise = ["(" ++ patt "x" r ++ "," ++ patt "y" r ++ ") -> " ++ eqs r | r <- nonLexicalRules (lexical cat) rules]
           ++ if lexical cat then ["(" ++ lexicalConstructor cat +++ "x" ++ "," ++ lexicalConstructor cat +++ "y" ++ ") -> x == y"] else []
 
  where
    patt s (f,xs) = unwords (gId f : mkSVars s (length xs))
-   eqs (_,xs) = unwords ("and" : "[" : intersperse "," [x ++ " == " ++ y | 
+   eqs (_,xs) = unwords ("and" : "[" : intersperse "," [x ++ " == " ++ y |
      (x,y) <- zip (mkSVars "x" (length xs)) (mkSVars "y" (length xs)) ] ++ ["]"])
    listr c = (c,["foo"]) -- foo just for length = 1
    listeqs = "and [x == y | (x,y) <- zip x1 y1]"
@@ -189,25 +194,26 @@ prCompos :: Prefix -> (OIdent -> Bool) -> (String,HSkeleton) -> [String]
 prCompos gId lexical (_,catrules) =
     ["instance Compos Tree where",
      "  compos r a f t = case t of"]
-    ++ 
+    ++
     ["    " ++ prComposCons (gId f) xs | (c,rs) <- catrules, not (isListCat (c,rs)),
-                                         (f,xs) <- rs, not (null xs)] 
-    ++ 
+                                         (f,xs) <- rs, not (null xs)]
+    ++
     ["    " ++ prComposCons (gId c) ["x1"] | (c,rs) <- catrules, isListCat (c,rs)]
-    ++ 
+    ++
     ["    _ -> r t"]
   where
-    prComposCons f xs = let vs = mkVars (length xs) in 
+    prComposCons f xs = let vs = mkVars (length xs) in
                         f +++ unwords vs +++ "->" +++ rhs f (zip vs xs)
     rhs f vcs = "r" +++ f +++ unwords (map (prRec f) vcs)
-    prRec f (v,c) 
+    prRec f (v,c)
       | isList f  = "`a` foldr (a . a (r (:)) . f) (r [])" +++ v
       | otherwise = "`a`" +++ "f" +++ v
-    isList f = (gId "List") `isPrefixOf` f
+    isList f = gId "List" `isPrefixOf` f
 
 gfInstance :: Prefix -> (OIdent -> Bool) -> String -> (OIdent, [(OIdent, [OIdent])]) -> String
 gfInstance gId lexical m crs = hInstance gId lexical m crs ++++ fInstance gId lexical m crs
 
+hInstance :: (String -> String) -> (String -> Bool) -> String -> (String, [(OIdent, [OIdent])]) -> String
 ----hInstance m ("Cn",_) = "" --- seems to belong to an old applic. AR 18/5/2004
 hInstance gId _ m (cat,[]) = unlines [
   "instance Show" +++ gId cat,
@@ -216,15 +222,15 @@ hInstance gId _ m (cat,[]) = unlines [
   "  gf _ = undefined",
   "  fg _ = undefined"
   ]
-hInstance gId lexical m (cat,rules) 
+hInstance gId lexical m (cat,rules)
  | isListCat (cat,rules) =
   "instance Gf" +++ gId cat +++ "where" ++++
-     "  gf (" ++ gId cat +++ "[" ++ concat (intersperse "," baseVars) ++ "])" 
+     "  gf (" ++ gId cat +++ "[" ++ intercalate "," baseVars ++ "])"
            +++ "=" +++ mkRHS ("Base"++ec) baseVars ++++
-     "  gf (" ++ gId cat +++ "(x:xs)) = " 
-           ++ mkRHS ("Cons"++ec) ["x",prParenth (gId cat+++"xs")] 
+     "  gf (" ++ gId cat +++ "(x:xs)) = "
+           ++ mkRHS ("Cons"++ec) ["x",prParenth (gId cat+++"xs")]
 -- no show for GADTs
---     ++++ " gf (" ++ gId cat +++ "xs) = error (\"Bad " ++ cat ++ " value: \" ++ show xs)" 
+--     ++++ " gf (" ++ gId cat +++ "xs) = error (\"Bad " ++ cat ++ " value: \" ++ show xs)"
  | otherwise =
   "instance Gf" +++ gId cat +++ "where\n" ++
   unlines ([mkInst f xx | (f,xx) <- nonLexicalRules (lexical cat) rules]
@@ -233,19 +239,22 @@ hInstance gId lexical m (cat,rules)
    ec = elemCat cat
    baseVars = mkVars (baseSize (cat,rules))
    mkInst f xx = let xx' = mkVars (length xx) in "  gf " ++
-     (if length xx == 0 then gId f else prParenth (gId f +++ foldr1 (+++) xx')) +++
+     (if null xx then gId f else prParenth (gId f +++ foldr1 (+++) xx')) +++
      "=" +++ mkRHS f xx'
-   mkRHS f vars = "mkApp (mkCId \"" ++ f ++ "\")" +++ 
-		   "[" ++ prTList ", " ["gf" +++ x | x <- vars] ++ "]"
+   mkRHS f vars = "mkApp (mkCId \"" ++ f ++ "\")" +++
+       "[" ++ prTList ", " ["gf" +++ x | x <- vars] ++ "]"
 
+mkVars :: Int -> [String]
 mkVars = mkSVars "x"
+
+mkSVars :: String -> Int -> [String]
 mkSVars s n = [s ++ show i | i <- [1..n]]
 
 ----fInstance m ("Cn",_) = "" ---
 fInstance _ _ m (cat,[]) = ""
 fInstance gId lexical m (cat,rules) =
   "  fg t =" ++++
-  (if isList 
+  (if isList
     then "    " ++ gId cat ++ " (fgs t) where\n     fgs t = case unApp t of"
     else "    case unApp t of") ++++
   unlines [mkInst f xx | (f,xx) <- nonLexicalRules (lexical cat) rules] ++++
@@ -257,27 +266,28 @@ fInstance gId lexical m (cat,rules) =
      "      Just (i," ++
      "[" ++ prTList "," xx' ++ "])" +++
      "| i == mkCId \"" ++ f ++ "\" ->" +++ mkRHS f xx'
-       where xx' = ["x" ++ show i | (_,i) <- zip xx [1..]]
-	     mkRHS f vars 
-		 | isList =
-		     if "Base" `isPrefixOf` f 
-                       then "[" ++ prTList ", " [ "fg" +++ x | x <- vars ] ++ "]"
-		       else "fg" +++ (vars !! 0) +++ ":" +++ "fgs" +++ (vars !! 1)
-		 | otherwise = 
-		     gId f +++  
-		     prTList " " [prParenth ("fg" +++ x) | x <- vars]
+       where
+         xx' = ["x" ++ show i | (_,i) <- zip xx [1..]]
+         mkRHS f vars
+           | isList =
+               if "Base" `isPrefixOf` f
+                             then "[" ++ prTList ", " [ "fg" +++ x | x <- vars ] ++ "]"
+                 else "fg" +++ (vars !! 0) +++ ":" +++ "fgs" +++ (vars !! 1)
+           | otherwise =
+               gId f +++
+               prTList " " [prParenth ("fg" +++ x) | x <- vars]
 
 --type HSkeleton = [(OIdent, [(OIdent, [OIdent])])]
 hSkeleton :: PGF -> (String,HSkeleton)
-hSkeleton gr = 
-  (showCId (absname gr), 
-   let fs = 
-         [(showCId c, [(showCId f, map showCId cs) | (f, (cs,_)) <- fs]) | 
+hSkeleton gr =
+  (showCId (absname gr),
+   let fs =
+         [(showCId c, [(showCId f, map showCId cs) | (f, (cs,_)) <- fs]) |
                                         fs@((_, (_,c)):_) <- fns]
-   in fs ++ [(sc, []) | c <- cts, let sc = showCId c, notElem sc (["Int", "Float", "String"] ++ map fst fs)]
+   in fs ++ [(sc, []) | c <- cts, let sc = showCId c, sc `notElem` (["Int", "Float", "String"] ++ map fst fs)]
   )
  where
-   cts = Map.keys (cats (abstract gr)) 
+   cts = Map.keys (cats (abstract gr))
    fns = groupBy valtypg (sortBy valtyps (map jty (Map.assocs (funs (abstract gr)))))
    valtyps (_, (_,x)) (_, (_,y)) = compare x y
    valtypg (_, (_,x)) (_, (_,y)) = x == y
@@ -291,9 +301,10 @@ updateSkeleton cat skel rule =
 -}
 isListCat :: (OIdent, [(OIdent, [OIdent])]) -> Bool
 isListCat (cat,rules) = "List" `isPrefixOf` cat && length rules == 2
-		    && ("Base"++c) `elem` fs && ("Cons"++c) `elem` fs
-    where c = elemCat cat
-	  fs = map fst rules
+        && ("Base"++c) `elem` fs && ("Cons"++c) `elem` fs
+    where
+      c = elemCat cat
+      fs = map fst rules
 
 -- | Gets the element category of a list category.
 elemCat :: OIdent -> OIdent
@@ -310,7 +321,7 @@ baseSize (_,rules) = length bs
     where Just (_,bs) = find (("Base" `isPrefixOf`) . fst) rules
 
 composClass :: [String]
-composClass = 
+composClass =
     [
      "",
      "class Compos t where",
@@ -337,4 +348,3 @@ composClass =
      "",
      "newtype C b a = C { unC :: b }"
     ]
-
diff --git a/src/compiler/GF/Infra/Option.hs b/src/compiler/GF/Infra/Option.hs
index 6b7ff0cad..2a2ffd176 100644
--- a/src/compiler/GF/Infra/Option.hs
+++ b/src/compiler/GF/Infra/Option.hs
@@ -2,13 +2,13 @@ module GF.Infra.Option
     (
      -- ** Command line options
      -- *** Option types
-     Options, 
-     Flags(..), 
-     Mode(..), Phase(..), Verbosity(..), 
-     OutputFormat(..), 
+     Options,
+     Flags(..),
+     Mode(..), Phase(..), Verbosity(..),
+     OutputFormat(..),
      SISRFormat(..), Optimization(..), CFGTransform(..), HaskellOption(..),
      Dump(..), Pass(..), Recomp(..),
-     outputFormatsExpl, 
+     outputFormatsExpl,
      -- *** Option parsing
      parseOptions, parseModuleOptions, fixRelativeLibPaths,
      -- *** Option pretty-printing
@@ -47,7 +47,7 @@ import PGF.Internal(Literal(..))
 import qualified Control.Monad.Fail as Fail
 
 usageHeader :: String
-usageHeader = unlines 
+usageHeader = unlines
  ["Usage: gf [OPTIONS] [FILE [...]]",
   "",
   "How each FILE is handled depends on the file name suffix:",
@@ -90,10 +90,10 @@ data Phase = Preproc | Convert | Compile | Link
 data OutputFormat = FmtPGFPretty
                   | FmtCanonicalGF
                   | FmtCanonicalJson
-                  | FmtJavaScript 
+                  | FmtJavaScript
                   | FmtJSON
-                  | FmtPython 
-                  | FmtHaskell 
+                  | FmtPython
+                  | FmtHaskell
                   | FmtJava
                   | FmtProlog
                   | FmtBNF
@@ -102,37 +102,42 @@ data OutputFormat = FmtPGFPretty
                   | FmtNoLR
                   | FmtSRGS_XML
                   | FmtSRGS_XML_NonRec
-                  | FmtSRGS_ABNF 
+                  | FmtSRGS_ABNF
                   | FmtSRGS_ABNF_NonRec
-                  | FmtJSGF 
-                  | FmtGSL 
+                  | FmtJSGF
+                  | FmtGSL
                   | FmtVoiceXML
                   | FmtSLF
                   | FmtRegExp
                   | FmtFA
   deriving (Eq,Ord)
 
-data SISRFormat = 
+data SISRFormat =
     -- | SISR Working draft 1 April 2003
     --   <http://www.w3.org/TR/2003/WD-semantic-interpretation-20030401/>
-    SISR_WD20030401    
+    SISR_WD20030401
   | SISR_1_0
  deriving (Show,Eq,Ord)
 
 data Optimization = OptStem | OptCSE | OptExpand | OptParametrize
   deriving (Show,Eq,Ord)
 
-data CFGTransform = CFGNoLR 
+data CFGTransform = CFGNoLR
                   | CFGRegular
-                  | CFGTopDownFilter 
-                  | CFGBottomUpFilter 
+                  | CFGTopDownFilter
+                  | CFGBottomUpFilter
                   | CFGStartCatOnly
                   | CFGMergeIdentical
                   | CFGRemoveCycles
   deriving (Show,Eq,Ord)
 
-data HaskellOption = HaskellNoPrefix | HaskellGADT | HaskellLexical
-                   | HaskellConcrete | HaskellVariants | HaskellData
+data HaskellOption = HaskellNoPrefix
+                   | HaskellGADT
+                   | HaskellLexical
+                   | HaskellConcrete
+                   | HaskellVariants
+                   | HaskellData
+                   | HaskellPGF2
   deriving (Show,Eq,Ord)
 
 data Warning = WarnMissingLincat
@@ -196,7 +201,7 @@ instance Show Options where
 parseOptions :: ErrorMonad err =>
                 [String]                   -- ^ list of string arguments
              -> err (Options, [FilePath])
-parseOptions args 
+parseOptions args
   | not (null errs) = errors errs
   | otherwise       = do opts <- concatOptions `fmap` liftErr (sequence optss)
                          return (opts, files)
@@ -208,7 +213,7 @@ parseModuleOptions :: ErrorMonad err =>
                    -> err Options
 parseModuleOptions args = do
   (opts,nonopts) <- parseOptions args
-  if null nonopts 
+  if null nonopts
     then return opts
     else errors $ map ("Non-option among module options: " ++) nonopts
 
@@ -281,7 +286,7 @@ defaultFlags = Flags {
       optOptimizations   = Set.fromList [OptStem,OptCSE,OptExpand,OptParametrize],
       optOptimizePGF     = False,
       optSplitPGF        = False,
-      optCFGTransforms   = Set.fromList [CFGRemoveCycles, CFGBottomUpFilter, 
+      optCFGTransforms   = Set.fromList [CFGRemoveCycles, CFGBottomUpFilter,
                                          CFGTopDownFilter, CFGMergeIdentical],
       optLibraryPath     = [],
       optStartCat        = Nothing,
@@ -301,7 +306,7 @@ defaultFlags = Flags {
 -- | Option descriptions
 {-# NOINLINE optDescr #-}
 optDescr :: [OptDescr (Err Options)]
-optDescr = 
+optDescr =
     [
      Option ['?','h'] ["help"] (NoArg (mode ModeHelp)) "Show help message.",
      Option ['V'] ["version"] (NoArg (mode ModeVersion)) "Display GF version number.",
@@ -327,44 +332,44 @@ optDescr =
 --   Option ['t'] ["trace"] (NoArg (trace True)) "Trace computations",
 --   Option [] ["no-trace"] (NoArg (trace False)) "Don't trace computations",
      Option [] ["gfo-dir"] (ReqArg gfoDir "DIR") "Directory to put .gfo files in (default = '.').",
-     Option ['f'] ["output-format"] (ReqArg outFmt "FMT") 
+     Option ['f'] ["output-format"] (ReqArg outFmt "FMT")
         (unlines ["Output format. FMT can be one of:",
                   "Canonical GF grammar: canonical_gf, canonical_json, (and haskell with option --haskell=concrete)",
                   "Multiple concrete: pgf (default), json, js, pgf_pretty, prolog, python, ...", -- gar,
                   "Single concrete only: bnf, ebnf, fa, gsl, jsgf, regexp, slf, srgs_xml, srgs_abnf, vxml, ....", -- cf, lbnf,
                   "Abstract only: haskell, ..."]), -- prolog_abs,
-     Option [] ["sisr"] (ReqArg sisrFmt "FMT") 
+     Option [] ["sisr"] (ReqArg sisrFmt "FMT")
         (unlines ["Include SISR tags in generated speech recognition grammars.",
                   "FMT can be one of: old, 1.0"]),
-     Option [] ["haskell"] (ReqArg hsOption "OPTION") 
-            ("Turn on an optional feature when generating Haskell data types. OPTION = " 
+     Option [] ["haskell"] (ReqArg hsOption "OPTION")
+            ("Turn on an optional feature when generating Haskell data types. OPTION = "
              ++ concat (intersperse " | " (map fst haskellOptionNames))),
-     Option [] ["lexical"] (ReqArg lexicalCat "CAT[,CAT[...]]") 
+     Option [] ["lexical"] (ReqArg lexicalCat "CAT[,CAT[...]]")
             "Treat CAT as a lexical category.",
-     Option [] ["literal"] (ReqArg literalCat "CAT[,CAT[...]]") 
+     Option [] ["literal"] (ReqArg literalCat "CAT[,CAT[...]]")
             "Treat CAT as a literal category.",
-     Option ['D'] ["output-dir"] (ReqArg outDir "DIR") 
+     Option ['D'] ["output-dir"] (ReqArg outDir "DIR")
            "Save output files (other than .gfo files) in DIR.",
-     Option [] ["gf-lib-path"] (ReqArg gfLibPath "DIR") 
+     Option [] ["gf-lib-path"] (ReqArg gfLibPath "DIR")
            "Overrides the value of GF_LIB_PATH.",
-     Option [] ["src","force-recomp"] (NoArg (recomp AlwaysRecomp)) 
+     Option [] ["src","force-recomp"] (NoArg (recomp AlwaysRecomp))
                  "Always recompile from source.",
-     Option [] ["recomp-if-newer"] (NoArg (recomp RecompIfNewer)) 
+     Option [] ["recomp-if-newer"] (NoArg (recomp RecompIfNewer))
                  "(default) Recompile from source if the source is newer than the .gfo file.",
-     Option [] ["gfo","no-recomp"] (NoArg (recomp NeverRecomp)) 
+     Option [] ["gfo","no-recomp"] (NoArg (recomp NeverRecomp))
                  "Never recompile from source, if there is already .gfo file.",
      Option [] ["retain"] (NoArg (set $ \o -> o { optRetainResource = True })) "Retain opers.",
      Option [] ["probs"] (ReqArg probsFile "file.probs") "Read probabilities from file.",
-     Option ['n'] ["name"] (ReqArg name "NAME") 
+     Option ['n'] ["name"] (ReqArg name "NAME")
            (unlines ["Use NAME as the name of the output. This is used in the output file names, ",
                      "with suffixes depending on the formats, and, when relevant, ",
                      "internally in the output."]),
      Option ['i'] [] (ReqArg addLibDir "DIR") "Add DIR to the library search path.",
      Option [] ["path"] (ReqArg setLibPath "DIR:DIR:...") "Set the library search path.",
-     Option [] ["preproc"] (ReqArg preproc "CMD") 
+     Option [] ["preproc"] (ReqArg preproc "CMD")
                  (unlines ["Use CMD to preprocess input files.",
                            "Multiple preprocessors can be used by giving this option multiple times."]),
-     Option [] ["coding"] (ReqArg coding "ENCODING") 
+     Option [] ["coding"] (ReqArg coding "ENCODING")
                 ("Character encoding of the source grammar, ENCODING = utf8, latin1, cp1251, ..."),
      Option [] ["startcat"] (ReqArg startcat "CAT") "Grammar start category.",
      Option [] ["language"] (ReqArg language "LANG") "Set the speech language flag to LANG in the generated grammar.",
@@ -372,7 +377,7 @@ optDescr =
      Option [] ["unlexer"] (ReqArg unlexer "UNLEXER") "Use unlexer UNLEXER.",
      Option [] ["pmcfg"] (NoArg (pmcfg True)) "Generate PMCFG (default).",
      Option [] ["no-pmcfg"] (NoArg (pmcfg False)) "Don't generate PMCFG (useful for libraries).",
-     Option [] ["optimize"] (ReqArg optimize "OPT") 
+     Option [] ["optimize"] (ReqArg optimize "OPT")
                 "Select an optimization package. OPT = all | values | parametrize | none",
      Option [] ["optimize-pgf"] (NoArg (optimize_pgf True))
                 "Enable or disable global grammar optimization. This could significantly reduce the size of the final PGF file",
@@ -447,7 +452,7 @@ optDescr =
        optimize    x = case lookup x optimizationPackages of
                          Just p  -> set $ \o -> o { optOptimizations = p }
                          Nothing -> fail $ "Unknown optimization package: " ++ x
-                         
+
        optimize_pgf x = set $ \o -> o { optOptimizePGF = x }
        splitPGF x = set $ \o -> o { optSplitPGF = x }
 
@@ -471,7 +476,7 @@ outputFormats :: [(String,OutputFormat)]
 outputFormats = map fst outputFormatsExpl
 
 outputFormatsExpl :: [((String,OutputFormat),String)]
-outputFormatsExpl = 
+outputFormatsExpl =
     [(("pgf_pretty",   FmtPGFPretty),"human-readable pgf"),
      (("canonical_gf", FmtCanonicalGF),"Canonical GF source files"),
      (("canonical_json", FmtCanonicalJson),"Canonical JSON source files"),
@@ -504,11 +509,11 @@ instance Read OutputFormat where
     readsPrec = lookupReadsPrec outputFormats
 
 optimizationPackages :: [(String, Set Optimization)]
-optimizationPackages = 
+optimizationPackages =
     [("all",         Set.fromList [OptStem,OptCSE,OptExpand,OptParametrize]),
      ("values",      Set.fromList [OptStem,OptCSE,OptExpand]),
      ("noexpand",    Set.fromList [OptStem,OptCSE]),
-     
+
      -- deprecated
      ("all_subs",    Set.fromList [OptStem,OptCSE,OptExpand,OptParametrize]),
      ("parametrize", Set.fromList [OptStem,OptCSE,OptExpand,OptParametrize]),
@@ -516,7 +521,7 @@ optimizationPackages =
     ]
 
 cfgTransformNames :: [(String, CFGTransform)]
-cfgTransformNames = 
+cfgTransformNames =
     [("nolr",         CFGNoLR),
      ("regular",      CFGRegular),
      ("topdown",      CFGTopDownFilter),
@@ -532,7 +537,8 @@ haskellOptionNames =
      ("lexical",  HaskellLexical),
      ("concrete", HaskellConcrete),
      ("variants", HaskellVariants),
-     ("data",     HaskellData)]
+     ("data",     HaskellData),
+     ("pgf2",     HaskellPGF2)]
 
 -- | This is for bacward compatibility. Since GHC 6.12 we
 -- started using the native Unicode support in GHC but it
@@ -558,7 +564,7 @@ onOff f def = OptArg g "[on,off]"
                         _     -> fail $ "Expected [on,off], got: " ++ show x
 
 readOutputFormat :: Fail.MonadFail m => String -> m OutputFormat
-readOutputFormat s = 
+readOutputFormat s =
     maybe (fail $ "Unknown output format: " ++ show s) return $ lookup s outputFormats
 
 -- FIXME: this is a copy of the function in GF.Devel.UseIO.
@@ -570,7 +576,7 @@ splitInModuleSearchPath s = case break isPathSep s of
     isPathSep :: Char -> Bool
     isPathSep c = c == ':' || c == ';'
 
--- 
+--
 -- * Convenience functions for checking options
 --
 
@@ -592,7 +598,7 @@ isLiteralCat opts c = Set.member c (flag optLiteralCats opts)
 isLexicalCat :: Options -> String -> Bool
 isLexicalCat opts c = Set.member c (flag optLexicalCats opts)
 
--- 
+--
 -- * Convenience functions for setting options
 --
 
@@ -623,8 +629,8 @@ readMaybe s = case reads s of
 
 toEnumBounded :: (Bounded a, Enum a, Ord a) => Int -> Maybe a
 toEnumBounded i = let mi = minBound
-                      ma = maxBound `asTypeOf` mi                      
-                   in if i >= fromEnum mi && i <= fromEnum ma 
+                      ma = maxBound `asTypeOf` mi
+                   in if i >= fromEnum mi && i <= fromEnum ma
                         then Just (toEnum i `asTypeOf` mi)
                         else Nothing
 
-- 
cgit v1.2.3


From 173ab96839212e042c38629d45bcd30cc6e111ca Mon Sep 17 00:00:00 2001
From: Inari Listenmaa <inari.listenmaa@gmail.com>
Date: Sat, 6 Jun 2020 11:35:05 +0200
Subject: Hotfix for https://github.com/GrammaticalFramework/gf-core/issues/56

---
 src/compiler/GF/Compile/Rename.hs | 22 +++++++++++++++++++++-
 1 file changed, 21 insertions(+), 1 deletion(-)

(limited to 'src')

diff --git a/src/compiler/GF/Compile/Rename.hs b/src/compiler/GF/Compile/Rename.hs
index aacf24c5b..c7ea56b45 100644
--- a/src/compiler/GF/Compile/Rename.hs
+++ b/src/compiler/GF/Compile/Rename.hs
@@ -39,6 +39,7 @@ import GF.Data.Operations
 
 import Control.Monad
 import Data.List (nub,(\\))
+import qualified Data.List as L
 import qualified Data.Map as Map
 import Data.Maybe(mapMaybe)
 import GF.Text.Pretty
@@ -105,7 +106,26 @@ renameIdentTerm' env@(act,imps) t0 =
                               ts@(t:_) -> do checkWarn ("atomic term" <+> ppTerm Qualified 0 t0 $$
                                                         "conflict" <+> hsep (punctuate ',' (map (ppTerm Qualified 0) ts)) $$
                                                         "given" <+> fsep (punctuate ',' (map fst qualifs)))
-                                             return t
+                                             return (bestTerm ts) -- Heuristic for resource grammar. Returns t for all others.
+       where
+        -- Hotfix for https://github.com/GrammaticalFramework/gf-core/issues/56
+        -- Real bug is probably somewhere deeper in recognising excluded functions. /IL 2020-06-06
+        notFromCommonModule :: Term -> Bool
+        notFromCommonModule term =
+          let t = render $ ppTerm Qualified 0 term :: String
+           in not $ any (\moduleName -> moduleName `L.isPrefixOf` t)
+                        ["CommonX", "ConstructX", "ExtendFunctor"
+                        ,"MarkHTMLX", "ParamX", "TenseX", "TextX"]
+
+        -- If one of the terms comes from the common modules,
+        -- we choose the other one, because that's defined in the grammar.
+        bestTerm :: [Term] -> Term
+        bestTerm [] = error "constant not found" -- not reached: bestTerm is only called for case ts@(t:_)
+        bestTerm ts@(t:_) =
+          let notCommon = [t | t <- ts, notFromCommonModule t]
+           in case notCommon of
+                []    -> t -- All terms are from common modules, return first of original list
+                (u:_) -> u -- ≥1 terms are not from common modules, return first of those
 
 info2status :: Maybe ModuleName -> Ident -> Info -> StatusInfo
 info2status mq c i = case i of
-- 
cgit v1.2.3


From dff215504a71235d0aeb6852e64ef682cc095668 Mon Sep 17 00:00:00 2001
From: Meowyam <maryam@chilon.net>
Date: Tue, 6 Jul 2021 15:00:17 +0800
Subject: resolves GrammaticalFramework/gf-core/#97, without l

---
 src/compiler/GF/Command/CommonCommands.hs | 4 +++-
 1 file changed, 3 insertions(+), 1 deletion(-)

(limited to 'src')

diff --git a/src/compiler/GF/Command/CommonCommands.hs b/src/compiler/GF/Command/CommonCommands.hs
index 578331e65..7ca2c0ee4 100644
--- a/src/compiler/GF/Command/CommonCommands.hs
+++ b/src/compiler/GF/Command/CommonCommands.hs
@@ -15,6 +15,7 @@ import GF.Command.Abstract --(isOpt,valStrOpts,prOpt)
 import GF.Text.Pretty
 import GF.Text.Transliterations
 import GF.Text.Lexing(stringOp,opInEnv)
+import Data.Char (isSpace)
 
 import qualified PGF as H(showCId,showExpr,toATree,toTrie,Trie(..))
 
@@ -170,7 +171,8 @@ commonCommands = fmap (mapCommandExec liftSIO) $ Map.fromList [
        restrictedSystem $ syst ++ " <" ++ tmpi ++ " >" ++ tmpo
        fmap fromString $ restricted $ readFile tmpo,
        -}
-       fmap (fromStrings . lines) . restricted . readShellProcess syst . unlines $ toStrings arg,
+       fmap (fromStrings . lines) . restricted . readShellProcess syst . unlines . map (dropWhile (=='\n')) $ toStrings $ arg,
+
      flags = [
        ("command","the system command applied to the argument")
        ],
-- 
cgit v1.2.3


From 1e3de38ac4e9d4eee8bb947fb16682490a1130c5 Mon Sep 17 00:00:00 2001
From: Meowyam <maryam@chilon.net>
Date: Tue, 6 Jul 2021 15:22:59 +0800
Subject: remove redundant options

---
 src/compiler/GF/Command/CommonCommands.hs | 3 ---
 1 file changed, 3 deletions(-)

(limited to 'src')

diff --git a/src/compiler/GF/Command/CommonCommands.hs b/src/compiler/GF/Command/CommonCommands.hs
index 7ca2c0ee4..c685fc525 100644
--- a/src/compiler/GF/Command/CommonCommands.hs
+++ b/src/compiler/GF/Command/CommonCommands.hs
@@ -176,9 +176,6 @@ commonCommands = fmap (mapCommandExec liftSIO) $ Map.fromList [
      flags = [
        ("command","the system command applied to the argument")
        ],
-     options = [
-       ("lines","preserve input lines, and return output as a list of lines")
-       ],
      examples = [
        mkEx "gt | l | ? wc  -- generate trees, linearize, and count words"
        ]
-- 
cgit v1.2.3


From 84b4b6fab93a2ef9367878a6055595f81552791d Mon Sep 17 00:00:00 2001
From: "John J. Camilleri" <john@digitalgrammars.com>
Date: Tue, 6 Jul 2021 14:11:30 +0200
Subject: Some more cabal file cleanup. Add stack files for pgf, pgf2.

---
 gf.cabal                                      |  9 ++++-----
 src/runtime/haskell-bind/pgf2.cabal           | 15 +++++++++------
 src/runtime/haskell-bind/stack-ghc7.10.3.yaml |  3 +++
 src/runtime/haskell-bind/stack-ghc8.0.2.yaml  |  1 +
 src/runtime/haskell-bind/stack-ghc8.10.4.yaml |  1 +
 src/runtime/haskell/pgf.cabal                 | 13 +++++++------
 src/runtime/haskell/stack-ghc7.10.3.yaml      |  3 +++
 src/runtime/haskell/stack-ghc8.0.2.yaml       |  1 +
 src/runtime/haskell/stack-ghc8.10.4.yaml      |  1 +
 9 files changed, 30 insertions(+), 17 deletions(-)
 create mode 100644 src/runtime/haskell-bind/stack-ghc7.10.3.yaml
 create mode 100644 src/runtime/haskell-bind/stack-ghc8.0.2.yaml
 create mode 100644 src/runtime/haskell-bind/stack-ghc8.10.4.yaml
 create mode 100644 src/runtime/haskell/stack-ghc7.10.3.yaml
 create mode 100644 src/runtime/haskell/stack-ghc8.0.2.yaml
 create mode 100644 src/runtime/haskell/stack-ghc8.10.4.yaml

(limited to 'src')

diff --git a/gf.cabal b/gf.cabal
index 0eba0ead3..b9c7d9631 100644
--- a/gf.cabal
+++ b/gf.cabal
@@ -8,10 +8,9 @@ license-file: LICENSE
 category: Natural Language Processing, Compiler
 synopsis: Grammatical Framework
 description: GF, Grammatical Framework, is a programming language for multilingual grammar applications
-homepage: http://www.grammaticalframework.org/
+homepage: https://www.grammaticalframework.org/
 bug-reports: https://github.com/GrammaticalFramework/gf-core/issues
-maintainer: Thomas Hallgren
-tested-with: GHC==8.0.2, GHC==8.10.4
+tested-with: GHC==7.10.3, GHC==8.0.2, GHC==8.10.4
 
 data-dir: src
 extra-source-files: WebSetup.hs
@@ -75,7 +74,7 @@ flag c-runtime
 library
   default-language:    Haskell2010
   build-depends:
-    -- | GHC 8.0.2 to GHC 8.10.4
+    -- GHC 8.0.2 to GHC 8.10.4
     base >= 4.9.1 && <4.15,
     array >= 0.5.1 && < 0.6,
     containers >= 0.5.7 && < 0.7,
@@ -84,9 +83,9 @@ library
     random >= 1.1 && < 1.3,
     pretty >= 1.1.3 && < 1.2,
     mtl >= 2.2.1 && < 2.3,
+    -- For compatability with GHC < 8
     exceptions >= 0.8.3 && < 0.11,
     fail >= 4.9.0 && < 4.10,
-    -- For compatability with ghc < 8
     -- We need transformers-compat >= 0.6.3, but that is only in newer snapshots where it is redundant.
     transformers-compat >= 0.5.1.4 && < 0.7,
     ghc-prim >= 0.5.0 && < 0.7
diff --git a/src/runtime/haskell-bind/pgf2.cabal b/src/runtime/haskell-bind/pgf2.cabal
index fcd854d72..eb1e3c708 100644
--- a/src/runtime/haskell-bind/pgf2.cabal
+++ b/src/runtime/haskell-bind/pgf2.cabal
@@ -1,18 +1,21 @@
 name: pgf2
 version: 1.3.0
+
+cabal-version: 1.22
+build-type: Simple
+license: LGPL-3
+license-file: LICENSE
+category: Natural Language Processing
 synopsis: Bindings to the C version of the PGF runtime
 description:
   GF, Grammatical Framework, is a programming language for multilingual grammar applications.
   GF grammars are compiled into Portable Grammar Format (PGF) which can be used with the PGF runtime, written in C.
   This package provides Haskell bindings to that runtime.
-homepage: https://www.grammaticalframework.org
-license: LGPL-3
-license-file: LICENSE
+homepage: https://www.grammaticalframework.org/
+bug-reports: https://github.com/GrammaticalFramework/gf-core/issues
 author: Krasimir Angelov
-category: Natural Language Processing
-build-type: Simple
 extra-source-files: CHANGELOG.md, README.md
-cabal-version: >=1.10
+tested-with: GHC==7.10.3, GHC==8.0.2, GHC==8.10.4
 
 library
   exposed-modules:
diff --git a/src/runtime/haskell-bind/stack-ghc7.10.3.yaml b/src/runtime/haskell-bind/stack-ghc7.10.3.yaml
new file mode 100644
index 000000000..c916b4bb0
--- /dev/null
+++ b/src/runtime/haskell-bind/stack-ghc7.10.3.yaml
@@ -0,0 +1,3 @@
+resolver: lts-6.35 # ghc 7.10.3
+
+allow-newer: true
diff --git a/src/runtime/haskell-bind/stack-ghc8.0.2.yaml b/src/runtime/haskell-bind/stack-ghc8.0.2.yaml
new file mode 100644
index 000000000..af08206d9
--- /dev/null
+++ b/src/runtime/haskell-bind/stack-ghc8.0.2.yaml
@@ -0,0 +1 @@
+resolver: lts-9.21 # ghc 8.0.2
diff --git a/src/runtime/haskell-bind/stack-ghc8.10.4.yaml b/src/runtime/haskell-bind/stack-ghc8.10.4.yaml
new file mode 100644
index 000000000..195e90993
--- /dev/null
+++ b/src/runtime/haskell-bind/stack-ghc8.10.4.yaml
@@ -0,0 +1 @@
+resolver: lts-18.0 # ghc 8.10.4
diff --git a/src/runtime/haskell/pgf.cabal b/src/runtime/haskell/pgf.cabal
index 9a59502c4..56c1ca04a 100644
--- a/src/runtime/haskell/pgf.cabal
+++ b/src/runtime/haskell/pgf.cabal
@@ -1,15 +1,15 @@
 name: pgf
-version: 3.10.1-git
+version: 3.11.0-git
 
-cabal-version: >= 1.20
+cabal-version: 1.22
 build-type: Simple
 license: OtherLicense
 category: Natural Language Processing
 synopsis: Grammatical Framework
 description: A library for interpreting the Portable Grammar Format (PGF)
-homepage: http://www.grammaticalframework.org/
+homepage: https://www.grammaticalframework.org/
 bug-reports: https://github.com/GrammaticalFramework/gf-core/issues
-tested-with: GHC==7.6.3, GHC==7.8.3, GHC==7.10.3, GHC==8.0.2, GHC==8.4.4
+tested-with: GHC==7.10.3, GHC==8.0.2, GHC==8.10.4
 
 library
   default-language: Haskell2010
@@ -22,8 +22,9 @@ library
     random >= 1.1 && < 1.3,
     pretty >= 1.1.3 && < 1.2,
     mtl >= 2.2.1 && < 2.3,
-    ghc-prim >= 0.5.0 && < 0.7
-    -- exceptions,
+    ghc-prim >= 0.5.0 && < 0.7,
+    -- For compatability with GHC < 8
+    fail >= 4.9.0 && < 4.10
 
   other-modules:
     -- not really part of GF but I have changed the original binary library
diff --git a/src/runtime/haskell/stack-ghc7.10.3.yaml b/src/runtime/haskell/stack-ghc7.10.3.yaml
new file mode 100644
index 000000000..c916b4bb0
--- /dev/null
+++ b/src/runtime/haskell/stack-ghc7.10.3.yaml
@@ -0,0 +1,3 @@
+resolver: lts-6.35 # ghc 7.10.3
+
+allow-newer: true
diff --git a/src/runtime/haskell/stack-ghc8.0.2.yaml b/src/runtime/haskell/stack-ghc8.0.2.yaml
new file mode 100644
index 000000000..af08206d9
--- /dev/null
+++ b/src/runtime/haskell/stack-ghc8.0.2.yaml
@@ -0,0 +1 @@
+resolver: lts-9.21 # ghc 8.0.2
diff --git a/src/runtime/haskell/stack-ghc8.10.4.yaml b/src/runtime/haskell/stack-ghc8.10.4.yaml
new file mode 100644
index 000000000..195e90993
--- /dev/null
+++ b/src/runtime/haskell/stack-ghc8.10.4.yaml
@@ -0,0 +1 @@
+resolver: lts-18.0 # ghc 8.10.4
-- 
cgit v1.2.3


From 0c3ca3d79acb34e0159cf6b51ba41ff570ad2af1 Mon Sep 17 00:00:00 2001
From: "John J. Camilleri" <john@digitalgrammars.com>
Date: Tue, 6 Jul 2021 14:43:21 +0200
Subject: Add note in PGF2 documentation about risk for integer overflow.

Closes #109
---
 src/runtime/haskell-bind/PGF2/Expr.hsc | 14 ++++++++------
 1 file changed, 8 insertions(+), 6 deletions(-)

(limited to 'src')

diff --git a/src/runtime/haskell-bind/PGF2/Expr.hsc b/src/runtime/haskell-bind/PGF2/Expr.hsc
index 85e55ab40..35ee628d1 100644
--- a/src/runtime/haskell-bind/PGF2/Expr.hsc
+++ b/src/runtime/haskell-bind/PGF2/Expr.hsc
@@ -19,7 +19,7 @@ wildCId = "_" :: CId
 type Cat = CId -- ^ Name of syntactic category
 type Fun = CId -- ^ Name of function
 
-data BindType = 
+data BindType =
     Explicit
   | Implicit
   deriving Show
@@ -38,7 +38,7 @@ instance Show Expr where
   show = showExpr []
 
 instance Eq Expr where
-  (Expr e1 e1_touch) == (Expr e2 e2_touch) = 
+  (Expr e1 e1_touch) == (Expr e2 e2_touch) =
     unsafePerformIO $ do
       res <- pgf_expr_eq e1 e2
       e1_touch >> e2_touch
@@ -113,9 +113,9 @@ unApp (Expr expr touch) =
       appl <- pgf_expr_unapply expr pl
       if appl == nullPtr
         then return Nothing
-        else do 
+        else do
            fun <- peekCString =<< (#peek PgfApplication, fun) appl
-           arity <- (#peek PgfApplication, n_args) appl :: IO CInt 
+           arity <- (#peek PgfApplication, n_args) appl :: IO CInt
            c_args <- peekArray (fromIntegral arity) (appl `plusPtr` (#offset PgfApplication, args))
            return $ Just (fun, [Expr c_arg touch | c_arg <- c_args])
 
@@ -140,7 +140,9 @@ unStr (Expr expr touch) =
               touch
               return (Just s)
 
--- | Constructs an expression from an integer literal
+-- | Constructs an expression from an integer literal.
+-- Note that the C runtime does not support long integers, and you may run into overflow issues with large values.
+-- See [here](https://github.com/GrammaticalFramework/gf-core/issues/109) for more details.
 mkInt :: Int -> Expr
 mkInt val =
   unsafePerformIO $ do
@@ -267,7 +269,7 @@ foreign import ccall "wrapper"
 -- in the expression in order reverse to the order
 -- of binding.
 showExpr :: [CId] -> Expr -> String
-showExpr scope e = 
+showExpr scope e =
   unsafePerformIO $
     withGuPool $ \tmpPl ->
       do (sb,out) <- newOut tmpPl
-- 
cgit v1.2.3


From ef422164154e093b1231c2ee905c0539c0c0a1b3 Mon Sep 17 00:00:00 2001
From: "John J. Camilleri" <john@digitalgrammars.com>
Date: Tue, 6 Jul 2021 15:35:03 +0200
Subject: Add import from command line invocation to command history

Closes #64
---
 src/compiler/GF/Interactive.hs  |  2 +-
 src/compiler/GF/Interactive2.hs | 11 ++++++-----
 src/compiler/GF/Main.hs         |  7 ++++---
 3 files changed, 11 insertions(+), 9 deletions(-)

(limited to 'src')

diff --git a/src/compiler/GF/Interactive.hs b/src/compiler/GF/Interactive.hs
index 9987b7c39..855ab22d1 100644
--- a/src/compiler/GF/Interactive.hs
+++ b/src/compiler/GF/Interactive.hs
@@ -38,7 +38,6 @@ import GF.Server(server)
 #endif
 
 import GF.Command.Messages(welcome)
-import GF.Infra.UseIO (Output)
 -- Provides an orphan instance of MonadFail for StateT in ghc versions < 8
 import Control.Monad.Trans.Instances ()
 
@@ -56,6 +55,7 @@ mainGFI opts files = do
 
 shell opts files = flip evalStateT (emptyGFEnv opts) $
                    do mapStateT runSIO $ importInEnv opts files
+                      modify $ \ gfenv0 -> gfenv0 {history = [unwords ("i":files)]}
                       loop
 
 #ifdef SERVER_MODE
diff --git a/src/compiler/GF/Interactive2.hs b/src/compiler/GF/Interactive2.hs
index 02e42e19e..6967309b9 100644
--- a/src/compiler/GF/Interactive2.hs
+++ b/src/compiler/GF/Interactive2.hs
@@ -58,6 +58,7 @@ mainGFI opts files = do
 
 shell opts files = flip evalStateT (emptyGFEnv opts) $
                    do mapStateT runSIO $ importInEnv opts files
+                      modify $ \ gfenv0 -> gfenv0 {history = [unwords ("i":files)]}
                       loop
 
 {-
@@ -101,7 +102,7 @@ timeIt act =
 
 -- | Optionally show how much CPU time was used to run an IO action
 optionallyShowCPUTime :: (Monad m,MonadSIO m) => Options -> m a -> m a
-optionallyShowCPUTime opts act 
+optionallyShowCPUTime opts act
   | not (verbAtLeast opts Normal) = act
   | otherwise = do (dt,r) <- timeIt act
                    liftSIO $ putStrLnFlush $ show (dt `div` 1000000000) ++ " msec"
@@ -358,7 +359,7 @@ wordCompletion gfenv (left,right) = do
     CmplIdent _ pref
       -> case mb_pgf of
            Just pgf -> ret (length pref)
-                           [Haskeline.simpleCompletion name 
+                           [Haskeline.simpleCompletion name
                             | name <- C.functions pgf,
                               isPrefixOf pref name]
            _ -> ret (length pref) []
@@ -369,7 +370,7 @@ wordCompletion gfenv (left,right) = do
     cmdEnv = commandenv gfenv
 {-
     optLang opts = valStrOpts "lang" (head $ Map.keys (concretes cmdEnv)) opts
-    optType opts = 
+    optType opts =
       let str = valStrOpts "cat" (H.showCId $ H.lookStartCat pgf) opts
       in case H.readType str of
            Just ty -> ty
@@ -416,7 +417,7 @@ wc_type = cmd_name
     option x y (c  :cs)
       | isIdent c       = option x y cs
       | otherwise       = cmd x cs
-      
+
     optValue x y ('"':cs) = str x y cs
     optValue x y cs       = cmd x cs
 
@@ -434,7 +435,7 @@ wc_type = cmd_name
       where
         x1 = take (length x - length y - d) x
         x2 = takeWhile (\c -> isIdent c || isSpace c || c == '-' || c == '=' || c == '"') x1
-        
+
         cmd = case [x | (x,cs) <- RP.readP_to_S pCommand x2, all isSpace cs] of
 	        [x] -> Just x
                 _   -> Nothing
diff --git a/src/compiler/GF/Main.hs b/src/compiler/GF/Main.hs
index 7cde1ce97..7d4500c7b 100644
--- a/src/compiler/GF/Main.hs
+++ b/src/compiler/GF/Main.hs
@@ -16,18 +16,19 @@ import Data.Version
 import System.Directory
 import System.Environment (getArgs)
 import System.Exit
-import GF.System.Console (setConsoleEncoding)
+-- import GF.System.Console (setConsoleEncoding)
 
 -- | Run the GF main program, taking arguments from the command line.
 -- (It calls 'setConsoleEncoding' and 'getOptions', then 'mainOpts'.)
 -- Run @gf --help@ for usage info.
 main :: IO ()
 main = do
-  --setConsoleEncoding
+  -- setConsoleEncoding
   uncurry mainOpts =<< getOptions
 
 -- | Get and parse GF command line arguments. Fix relative paths.
 -- Calls 'getArgs' and 'parseOptions'.
+getOptions :: IO (Options, [FilePath])
 getOptions = do
   args <- getArgs
   case parseOptions args of
@@ -43,7 +44,7 @@ getOptions = do
 -- the options it invokes 'mainGFC', 'mainGFI', 'mainRunGFI', 'mainServerGFI',
 -- or it just prints version/usage info.
 mainOpts :: Options -> [FilePath] -> IO ()
-mainOpts opts files = 
+mainOpts opts files =
     case flag optMode opts of
       ModeVersion     -> putStrLn $ "Grammatical Framework (GF) version " ++ showVersion version ++ "\n" ++ buildInfo
       ModeHelp        -> putStrLn helpMessage
-- 
cgit v1.2.3


From f2e52d6f2c2bc90febceebdea0268b40ea37476c Mon Sep 17 00:00:00 2001
From: "John J. Camilleri" <john@digitalgrammars.com>
Date: Wed, 7 Jul 2021 09:40:41 +0200
Subject: Replace tabs for whitespace in source code

---
 src/compiler/GF/Compile/CFGtoPGF.hs              |  12 +-
 src/compiler/GF/Compile/CheckGrammar.hs          |   4 +-
 src/compiler/GF/Compile/Rename.hs                |  26 +-
 src/compiler/GF/Compile/TypeCheck/Abstract.hs    |  16 +-
 src/compiler/GF/Compile/TypeCheck/Concrete.hs    |   1 -
 src/compiler/GF/Compile/TypeCheck/ConcreteNew.hs |  16 +-
 src/compiler/GF/Compile/TypeCheck/TC.hs          |  88 +--
 src/compiler/GF/Compile/Update.hs                |  66 +-
 src/compiler/GF/Data/BacktrackM.hs               |  26 +-
 src/compiler/GF/Data/Graph.hs                    |  20 +-
 src/compiler/GF/Data/Graphviz.hs                 |  28 +-
 src/compiler/GF/Data/Operations.hs               |  74 +--
 src/compiler/GF/Data/Relation.hs                 |  18 +-
 src/compiler/GF/Data/Utilities.hs                |  10 +-
 src/compiler/GF/Grammar/Canonical.hs             |  22 +-
 src/compiler/GF/Grammar/Lexer.x                  |   2 +-
 src/compiler/GF/Grammar/Lookup.hs                |  26 +-
 src/compiler/GF/Grammar/PatternMatch.hs          |  33 +-
 src/compiler/GF/Grammar/Printer.hs               | 729 +++++++++++------------
 src/compiler/GF/Grammar/Values.hs                |  19 +-
 src/compiler/GF/Infra/CheckM.hs                  |  12 +-
 src/compiler/GF/Interactive.hs                   |   2 +-
 src/compiler/GF/Speech/FiniteState.hs            | 110 ++--
 src/compiler/GF/Speech/GSL.hs                    |   6 +-
 src/compiler/GF/Speech/JSGF.hs                   |   7 +-
 src/compiler/GF/Speech/PGFToCFG.hs               |  16 +-
 src/compiler/GF/Speech/SRG.hs                    |  50 +-
 src/compiler/GF/Speech/SRGS_ABNF.hs              |  11 +-
 src/compiler/GF/Speech/SRGS_XML.hs               |  24 +-
 src/compiler/GF/Text/Transliterations.hs         | 132 ++--
 src/runtime/haskell-bind/pgf2.cabal              |   2 +-
 src/runtime/haskell/pgf.cabal                    |   2 +-
 32 files changed, 803 insertions(+), 807 deletions(-)

(limited to 'src')

diff --git a/src/compiler/GF/Compile/CFGtoPGF.hs b/src/compiler/GF/Compile/CFGtoPGF.hs
index f9ab8afcf..59448ce97 100644
--- a/src/compiler/GF/Compile/CFGtoPGF.hs
+++ b/src/compiler/GF/Compile/CFGtoPGF.hs
@@ -18,7 +18,7 @@ import Data.List
 --------------------------
 
 cf2pgf :: FilePath -> ParamCFG -> PGF
-cf2pgf fpath cf = 
+cf2pgf fpath cf =
  let pgf = PGF Map.empty aname (cf2abstr cf) (Map.singleton cname (cf2concr cf))
  in updateProductionIndices pgf
  where
@@ -33,7 +33,7 @@ cf2abstr cfg = Abstr aflags afuns acats
 
     acats  = Map.fromList [(cat, ([], [(0,mkRuleName rule) | rule <- rules], 0))
                             | (cat,rules) <- (Map.toList . Map.fromListWith (++))
-                                                [(cat2id cat, catRules cfg cat) | 
+                                                [(cat2id cat, catRules cfg cat) |
                                                      cat <- allCats' cfg]]
     afuns  = Map.fromList [(mkRuleName rule, (cftype [cat2id c | NonTerminal c <- ruleRhs rule] (cat2id (ruleLhs rule)), 0, Nothing, 0))
                             | rule <- allRules cfg]
@@ -52,7 +52,7 @@ cf2concr cfg = Concr Map.empty Map.empty
     cats  = allCats' cfg
     rules = allRules cfg
 
-    sequences0 = Set.fromList (listArray (0,0) [SymCat 0 0] : 
+    sequences0 = Set.fromList (listArray (0,0) [SymCat 0 0] :
                                map mkSequence rules)
     sequences  = listArray (0,Set.size sequences0-1) (Set.toList sequences0)
 
@@ -102,7 +102,7 @@ cf2concr cfg = Concr Map.empty Map.empty
 
     mkLinDefRef (cat,_) =
       (cat2fid cat 0,[0])
-      
+
     addProd prods (fid,prod) =
       case IntMap.lookup fid prods of
         Just set -> IntMap.insert fid (Set.insert prod set) prods
@@ -130,5 +130,5 @@ cf2concr cfg = Concr Map.empty Map.empty
 
 mkRuleName rule =
   case ruleName rule of
-	CFObj n _ -> n
-	_         -> wildCId
+    CFObj n _ -> n
+    _         -> wildCId
diff --git a/src/compiler/GF/Compile/CheckGrammar.hs b/src/compiler/GF/Compile/CheckGrammar.hs
index 71bce96c4..7f053f85c 100644
--- a/src/compiler/GF/Compile/CheckGrammar.hs
+++ b/src/compiler/GF/Compile/CheckGrammar.hs
@@ -175,7 +175,7 @@ checkInfo opts cwd sgr (m,mo) c info = checkInModule cwd mo NoLoc empty $ do
         checkTyp gr typ
       case md of
         Just eqs -> mapM_ (\(L loc eq) -> mkCheck loc "the definition of function" $
-	                                        checkDef gr (m,c) typ eq) eqs
+                                          checkDef gr (m,c) typ eq) eqs
         Nothing  -> return ()
       return (AbsFun (Just (L loc typ)) ma md moper)
 
@@ -316,7 +316,7 @@ linTypeOfType cnc m typ = do
    mkLinArg (i,(n,mc@(m,cat))) = do
      val  <- lookLin mc
      let vars = mkRecType varLabel $ replicate n typeStr
-	 symb = argIdent n cat i
+         symb = argIdent n cat i
      rec <- if n==0 then return val else
                        errIn (render ("extending" $$
                                       nest 2 vars $$
diff --git a/src/compiler/GF/Compile/Rename.hs b/src/compiler/GF/Compile/Rename.hs
index c7ea56b45..41b2cdc67 100644
--- a/src/compiler/GF/Compile/Rename.hs
+++ b/src/compiler/GF/Compile/Rename.hs
@@ -5,7 +5,7 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/05/30 18:39:44 $ 
+-- > CVS $Date: 2005/05/30 18:39:44 $
 -- > CVS $Author: aarne $
 -- > CVS $Revision: 1.19 $
 --
@@ -23,9 +23,9 @@
 -----------------------------------------------------------------------------
 
 module GF.Compile.Rename (
-	       renameSourceTerm,
-	       renameModule
-	      ) where
+     renameSourceTerm,
+     renameModule
+    ) where
 
 import GF.Infra.Ident
 import GF.Infra.CheckM
@@ -68,7 +68,7 @@ renameIdentTerm env = accumulateError (renameIdentTerm' env)
 
 -- Fails immediately on error, makes it possible to try other possibilities
 renameIdentTerm' :: Status -> Term -> Check Term
-renameIdentTerm' env@(act,imps) t0 = 
+renameIdentTerm' env@(act,imps) t0 =
   case t0 of
     Vr c -> ident predefAbs c
     Cn c -> ident (\_ s -> checkError s) c
@@ -85,8 +85,8 @@ renameIdentTerm' env@(act,imps) t0 =
     _ -> return t0
   where
     opens   = [st  | (OSimple _,st) <- imps]
-    qualifs = [(m, st) | (OQualif m _, st) <- imps] ++ 
-              [(m, st) | (OQualif _ m, st) <- imps] ++ 
+    qualifs = [(m, st) | (OQualif m _, st) <- imps] ++
+              [(m, st) | (OQualif _ m, st) <- imps] ++
               [(m, st) | (OSimple m, st) <- imps] -- qualif is always possible
 
     -- this facility is mainly for BWC with GF1: you need not import PredefAbs
@@ -94,7 +94,7 @@ renameIdentTerm' env@(act,imps) t0 =
       | isPredefCat c = return (Q (cPredefAbs,c))
       | otherwise     = checkError s
 
-    ident alt c = 
+    ident alt c =
       case Map.lookup c act of
         Just f -> return (f c)
         _      -> case mapMaybe (Map.lookup c) opens of
@@ -157,7 +157,7 @@ modInfo2status (o,mo) = (o,tree2status o (jments mo))
 self2status :: ModuleName -> ModuleInfo -> StatusMap
 self2status c m = Map.mapWithKey (info2status (Just c)) (jments m)
 
-  
+
 renameInfo :: FilePath -> Status -> Module -> Ident -> Info -> Check Info
 renameInfo cwd status (m,mi) i info =
   case info of
@@ -208,7 +208,7 @@ renameTerm env vars = ren vars where
     Abs b x t    -> liftM  (Abs b x) (ren (x:vs) t)
     Prod bt x a b -> liftM2 (Prod bt x) (ren vs a) (ren (x:vs) b)
     Typed a b  -> liftM2 Typed (ren vs a) (ren vs b)
-    Vr x      
+    Vr x
       | elem x vs -> return trm
       | otherwise -> renid trm
     Cn _   -> renid trm
@@ -219,7 +219,7 @@ renameTerm env vars = ren vars where
       i' <- case i of
         TTyped ty -> liftM TTyped $ ren vs ty -- the only annotation in source
         _ -> return i
-      liftM (T i') $ mapM (renCase vs) cs  
+      liftM (T i') $ mapM (renCase vs) cs
 
     Let (x,(m,a)) b -> do
       m' <- case m of
@@ -229,7 +229,7 @@ renameTerm env vars = ren vars where
       b' <- ren (x:vs) b
       return $ Let (x,(m',a')) b'
 
-    P t@(Vr r) l                                               -- Here we have $r.l$ and this is ambiguous it could be either 
+    P t@(Vr r) l                                               -- Here we have $r.l$ and this is ambiguous it could be either
                                                                -- record projection from variable or constant $r$ or qualified expression with module $r$
       | elem r vs -> return trm                                -- try var proj first ..
       | otherwise -> checks [ renid' (Q (MN r,label2ident l))      -- .. and qualified expression second.
@@ -331,7 +331,7 @@ renamePattern env patt =
 renameContext :: Status -> Context -> Check Context
 renameContext b = renc [] where
   renc vs cont = case cont of
-    (bt,x,t) : xts 
+    (bt,x,t) : xts
       | isWildIdent x -> do
           t'   <- ren vs t
           xts' <- renc vs xts
diff --git a/src/compiler/GF/Compile/TypeCheck/Abstract.hs b/src/compiler/GF/Compile/TypeCheck/Abstract.hs
index 196e1a646..c76660259 100644
--- a/src/compiler/GF/Compile/TypeCheck/Abstract.hs
+++ b/src/compiler/GF/Compile/TypeCheck/Abstract.hs
@@ -5,7 +5,7 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/09/15 16:22:02 $ 
+-- > CVS $Date: 2005/09/15 16:22:02 $
 -- > CVS $Author: aarne $
 -- > CVS $Revision: 1.16 $
 --
@@ -13,11 +13,11 @@
 -----------------------------------------------------------------------------
 
 module GF.Compile.TypeCheck.Abstract (-- * top-level type checking functions; TC should not be called directly.
-		  checkContext,
-		  checkTyp,
-		  checkDef,
-		  checkConstrs,
-		 ) where
+    checkContext,
+    checkTyp,
+    checkDef,
+    checkConstrs,
+   ) where
 
 import GF.Data.Operations
 
@@ -33,8 +33,8 @@ import GF.Text.Pretty
 --import Control.Monad (foldM, liftM, liftM2)
 
 -- | invariant way of creating TCEnv from context
-initTCEnv gamma = 
-  (length gamma,[(x,VGen i x) | ((x,_),i) <- zip gamma [0..]], gamma) 
+initTCEnv gamma =
+  (length gamma,[(x,VGen i x) | ((x,_),i) <- zip gamma [0..]], gamma)
 
 -- interface to TC type checker
 
diff --git a/src/compiler/GF/Compile/TypeCheck/Concrete.hs b/src/compiler/GF/Compile/TypeCheck/Concrete.hs
index 380970405..e9420290a 100644
--- a/src/compiler/GF/Compile/TypeCheck/Concrete.hs
+++ b/src/compiler/GF/Compile/TypeCheck/Concrete.hs
@@ -69,7 +69,6 @@ computeLType gr g0 t = comp (reverse [(b,x, Vr x) | (b,x,_) <- g0] ++ g0) t
       lockRecType c t' ---- locking to be removed AR 20/6/2009
 
     _ | ty == typeTok -> return typeStr
-    _ | isPredefConstant ty -> return ty
 
     _ -> composOp (comp g) ty
 
diff --git a/src/compiler/GF/Compile/TypeCheck/ConcreteNew.hs b/src/compiler/GF/Compile/TypeCheck/ConcreteNew.hs
index c32afa7a5..d85af5361 100644
--- a/src/compiler/GF/Compile/TypeCheck/ConcreteNew.hs
+++ b/src/compiler/GF/Compile/TypeCheck/ConcreteNew.hs
@@ -396,7 +396,7 @@ tcRecTypeFields ge scope ((l,ty):rs) mb_ty = do
   return ((l,ty):rs,mb_ty)
 
 -- | Invariant: if the third argument is (Just rho),
--- 	            then rho is in weak-prenex form
+--              then rho is in weak-prenex form
 instSigma :: GlobalEnv -> Scope -> Term -> Sigma -> Maybe Rho -> TcM (Term, Rho)
 instSigma ge scope t ty1 Nothing    = return (t,ty1)           -- INST1
 instSigma ge scope t ty1 (Just ty2) = do                       -- INST2
@@ -631,8 +631,8 @@ allBinders = [ identS [x]          | x <- ['a'..'z'] ] ++
 type Scope = [(Ident,Value)]
 
 type Sigma = Value
-type Rho   = Value	-- No top-level ForAll
-type Tau   = Value	-- No ForAlls anywhere
+type Rho   = Value -- No top-level ForAll
+type Tau   = Value -- No ForAlls anywhere
 
 data MetaValue
   = Unbound Scope Sigma
@@ -724,8 +724,8 @@ getMetaVars loc sc_tys = do
     go (Vr tv)    acc = acc
     go (App x y)  acc = go x (go y acc)
     go (Meta i)   acc
-	  | i `elem` acc  = acc
-	  | otherwise	  = i : acc
+      | i `elem` acc  = acc
+      | otherwise     = i : acc
     go (Q _)      acc = acc
     go (QC _)     acc = acc
     go (Sort _)   acc = acc
@@ -742,9 +742,9 @@ getFreeVars loc sc_tys = do
   return (foldr (go []) [] tys)
   where
     go bound (Vr tv)            acc
-	  | tv `elem` bound             = acc
-	  | tv `elem` acc               = acc
-	  | otherwise                   = tv : acc
+      | tv `elem` bound             = acc
+      | tv `elem` acc               = acc
+      | otherwise                   = tv : acc
     go bound (App x y)          acc = go bound x (go bound y acc)
     go bound (Meta _)           acc = acc
     go bound (Q _)              acc = acc
diff --git a/src/compiler/GF/Compile/TypeCheck/TC.hs b/src/compiler/GF/Compile/TypeCheck/TC.hs
index abcb24617..c0df83394 100644
--- a/src/compiler/GF/Compile/TypeCheck/TC.hs
+++ b/src/compiler/GF/Compile/TypeCheck/TC.hs
@@ -5,21 +5,22 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/10/02 20:50:19 $ 
+-- > CVS $Date: 2005/10/02 20:50:19 $
 -- > CVS $Author: aarne $
 -- > CVS $Revision: 1.11 $
 --
 -- Thierry Coquand's type checking algorithm that creates a trace
 -----------------------------------------------------------------------------
 
-module GF.Compile.TypeCheck.TC (AExp(..),
-	   Theory,
-	   checkExp,
-	   inferExp,
-	   checkBranch,
-	   eqVal,
-	   whnf
-	  ) where
+module GF.Compile.TypeCheck.TC (
+    AExp(..),
+    Theory,
+    checkExp,
+    inferExp,
+    checkBranch,
+    eqVal,
+    whnf
+  ) where
 
 import GF.Data.Operations
 import GF.Grammar
@@ -31,17 +32,17 @@ import Data.Maybe
 import GF.Text.Pretty
 
 data AExp =
-     AVr   Ident Val 
+     AVr   Ident Val
    | ACn   QIdent Val
-   | AType 
-   | AInt  Int 
+   | AType
+   | AInt  Int
    | AFloat Double
    | AStr  String
    | AMeta MetaId Val
    | ALet  (Ident,(Val,AExp)) AExp
-   | AApp  AExp AExp Val 
-   | AAbs  Ident Val AExp 
-   | AProd Ident AExp AExp 
+   | AApp  AExp AExp Val
+   | AAbs  Ident Val AExp
+   | AProd Ident AExp AExp
 -- -- | AEqs  [([Exp],AExp)] --- not used
    | ARecType [ALabelling]
    | AR    [AAssign]
@@ -50,7 +51,7 @@ data AExp =
    | AData Val
   deriving (Eq,Show)
 
-type ALabelling = (Label, AExp) 
+type ALabelling = (Label, AExp)
 type AAssign = (Label, (Val, AExp))
 
 type Theory = QIdent -> Err Val
@@ -71,7 +72,7 @@ whnf :: Val -> Err Val
 whnf v = ---- errIn ("whnf" +++ prt v) $ ---- debug
          case v of
   VApp u w -> do
-    u' <- whnf u 
+    u' <- whnf u
     w' <- whnf w
     app u' w'
   VClos env e -> eval env e
@@ -81,9 +82,9 @@ app :: Val -> Val -> Err Val
 app u v = case u of
   VClos env (Abs _ x e) -> eval ((x,v):env) e
   _ -> return $ VApp u v
-  
+
 eval :: Env -> Term -> Err Val
-eval env e = ---- errIn ("eval" +++ prt e +++ "in" +++ prEnv env) $ 
+eval env e = ---- errIn ("eval" +++ prt e +++ "in" +++ prEnv env) $
              case e of
   Vr x    -> lookupVar env x
   Q c   -> return $ VCn c
@@ -95,23 +96,23 @@ eval env e = ---- errIn ("eval" +++ prt e +++ "in" +++ prEnv env) $
   _ -> return $ VClos env e
 
 eqVal :: Int -> Val -> Val -> Err [(Val,Val)]
-eqVal k u1 u2 = ---- errIn (prt u1 +++ "<>" +++ prBracket (show k) +++ prt u2) $ 
+eqVal k u1 u2 = ---- errIn (prt u1 +++ "<>" +++ prBracket (show k) +++ prt u2) $
                 do
   w1 <- whnf u1
-  w2 <- whnf u2 
+  w2 <- whnf u2
   let v = VGen k
   case (w1,w2) of
     (VApp f1 a1, VApp f2 a2) -> liftM2 (++) (eqVal k f1 f2) (eqVal k a1 a2)
     (VClos env1 (Abs _ x1 e1), VClos env2 (Abs _ x2 e2)) ->
       eqVal (k+1) (VClos ((x1,v x1):env1) e1) (VClos ((x2,v x1):env2) e2)
     (VClos env1 (Prod _ x1 a1 e1), VClos env2 (Prod _ x2 a2 e2)) ->
-      liftM2 (++) 
+      liftM2 (++)
         (eqVal k     (VClos            env1  a1) (VClos            env2  a2))
         (eqVal (k+1) (VClos ((x1,v x1):env1) e1) (VClos ((x2,v x1):env2) e2))
     (VGen i _, VGen j _) -> return [(w1,w2) | i /= j]
-    (VCn (_, i), VCn (_,j)) -> return [(w1,w2) | i /= j] 
+    (VCn (_, i), VCn (_,j)) -> return [(w1,w2) | i /= j]
     --- thus ignore qualifications; valid because inheritance cannot
-    --- be qualified. Simplifies annotation. AR 17/3/2005 
+    --- be qualified. Simplifies annotation. AR 17/3/2005
     _ -> return [(w1,w2) | w1 /= w2]
 -- invariant: constraints are in whnf
 
@@ -127,10 +128,10 @@ checkExp th tenv@(k,rho,gamma) e ty = do
 
     Abs _ x t -> case typ of
       VClos env (Prod _ y a b) -> do
-	a' <- whnf $ VClos env a ---
-	(t',cs) <- checkExp th 
-                           (k+1,(x,v x):rho, (x,a'):gamma) t (VClos ((y,v x):env) b)
-	return (AAbs x a' t', cs)
+                           a' <- whnf $ VClos env a ---
+                           (t',cs) <- checkExp th
+                                          (k+1,(x,v x):rho, (x,a'):gamma) t (VClos ((y,v x):env) b)
+                           return (AAbs x a' t', cs)
       _ -> Bad (render ("function type expected for" <+> ppTerm Unqualified 0 e <+> "instead of" <+> ppValue Unqualified 0 typ))
 
     Let (x, (mb_typ, e1)) e2 -> do
@@ -150,7 +151,7 @@ checkExp th tenv@(k,rho,gamma) e ty = do
       (b',csb) <- checkType th (k+1, (x,v x):rho, (x,VClos rho a):gamma) b
       return (AProd x a' b', csa ++ csb)
 
-    R xs -> 
+    R xs ->
       case typ of
         VRecType ys -> do case [l | (l,_) <- ys, isNothing (lookup l xs)] of
                             [] -> return ()
@@ -174,7 +175,7 @@ checkInferExp th tenv@(k,_,_) e typ = do
   (e',w,cs1) <- inferExp th tenv e
   cs2 <- eqVal k w typ
   return (e',cs1 ++ cs2)
-      
+
 inferExp :: Theory -> TCEnv -> Term -> Err (AExp, Val, [(Val,Val)])
 inferExp th tenv@(k,rho,gamma) e = case e of
    Vr x -> mkAnnot (AVr x) $ noConstr $ lookupVar gamma x
@@ -200,13 +201,13 @@ inferExp th tenv@(k,rho,gamma) e = case e of
     (e2,val2,cs2) <- inferExp th (k,rho,(x,val1):gamma) e2
     return (ALet (x,(val1,e1)) e2, val2, cs1++cs2)
    App f t -> do
-    (f',w,csf) <- inferExp th tenv f 
+    (f',w,csf) <- inferExp th tenv f
     typ <- whnf w
     case typ of
       VClos env (Prod _ x a b) -> do
         (a',csa) <- checkExp th tenv t (VClos env a)
-	b' <- whnf $ VClos ((x,VClos rho t):env) b
-	return $ (AApp f' a' b', b', csf ++ csa)
+        b' <- whnf $ VClos ((x,VClos rho t):env) b
+        return $ (AApp f' a' b', b', csf ++ csa)
       _ -> Bad (render ("Prod expected for function" <+> ppTerm Unqualified 0 f <+> "instead of" <+> ppValue Unqualified 0 typ))
    _ -> Bad (render ("cannot infer type of expression" <+> ppTerm Unqualified 0 e))
 
@@ -232,9 +233,9 @@ checkAssign th tenv@(k,rho,gamma) typs (lbl,(Nothing,exp)) = do
                    return ((lbl,(val,aexp)),cs)
 
 checkBranch :: Theory -> TCEnv -> Equation -> Val -> Err (([Term],AExp),[(Val,Val)])
-checkBranch th tenv b@(ps,t) ty = errIn ("branch" +++ show b) $ 
-                                  chB tenv' ps' ty 
- where 
+checkBranch th tenv b@(ps,t) ty = errIn ("branch" +++ show b) $
+                                  chB tenv' ps' ty
+ where
 
   (ps',_,rho2,k') = ps2ts k ps
   tenv' = (k, rho2++rho, gamma) ---- k' ?
@@ -245,11 +246,11 @@ checkBranch th tenv b@(ps,t) ty = errIn ("branch" +++ show b) $
       typ <- whnf ty
       case typ of
         VClos env (Prod _ y a b) -> do
-	  a' <- whnf $ VClos env a
+          a' <- whnf $ VClos env a
           (p', sigma, binds, cs1) <- checkP tenv p y a'
           let tenv' = (length binds, sigma ++ rho, binds ++ gamma)
           ((ps',exp),cs2) <- chB tenv' ps2 (VClos ((y,p'):env) b)
-	  return ((p:ps',exp), cs1 ++ cs2) -- don't change the patt
+          return ((p:ps',exp), cs1 ++ cs2) -- don't change the patt
         _ -> Bad (render ("Product expected for definiens" <+> ppTerm Unqualified 0 t <+> "instead of" <+> ppValue Unqualified 0 typ))
     [] -> do
       (e,cs) <- checkExp th tenv t ty
@@ -259,15 +260,15 @@ checkBranch th tenv b@(ps,t) ty = errIn ("branch" +++ show b) $
      let sigma = [(x, VGen i x) | ((x,_),i) <- zip delta [k..]]
      return (VClos sigma t, sigma, delta, cs)
 
-  ps2ts k = foldr p2t ([],0,[],k) 
+  ps2ts k = foldr p2t ([],0,[],k)
   p2t p (ps,i,g,k) = case p of
-     PW      -> (Meta i : ps, i+1,g,k) 
+     PW      -> (Meta i : ps, i+1,g,k)
      PV x    -> (Vr x   : ps, i, upd x k g,k+1)
      PAs x p -> p2t p (ps,i,g,k)
      PString s -> (K s : ps, i, g, k)
      PInt n -> (EInt n : ps, i, g, k)
      PFloat n -> (EFloat n : ps, i, g, k)
-     PP c xs -> (mkApp (Q c) xss : ps, j, g',k') 
+     PP c xs -> (mkApp (Q c) xss : ps, j, g',k')
                     where (xss,j,g',k') = foldr p2t ([],i,g,k) xs
      PImplArg p -> p2t p (ps,i,g,k)
      PTilde t -> (t : ps, i, g, k)
@@ -307,8 +308,8 @@ checkPatt th tenv exp val = do
        case typ of
          VClos env (Prod _ x a b) -> do
            (a',_,csa) <- checkExpP tenv t (VClos env a)
-	   b' <- whnf $ VClos ((x,VClos rho t):env) b
-	   return $ (AApp f' a' b', b', csf ++ csa)
+           b' <- whnf $ VClos ((x,VClos rho t):env) b
+           return $ (AApp f' a' b', b', csf ++ csa)
          _ -> Bad (render ("Prod expected for function" <+> ppTerm Unqualified 0 f <+> "instead of" <+> ppValue Unqualified 0 typ))
      _ -> Bad (render ("cannot typecheck pattern" <+> ppTerm Unqualified 0 exp))
 
@@ -321,4 +322,3 @@ mkAnnot :: (Val -> AExp) -> Err (Val,[(Val,Val)]) -> Err (AExp,Val,[(Val,Val)])
 mkAnnot a ti = do
   (v,cs) <- ti
   return (a v, v, cs)
-
diff --git a/src/compiler/GF/Compile/Update.hs b/src/compiler/GF/Compile/Update.hs
index 4399405b8..7bbe1d8dc 100644
--- a/src/compiler/GF/Compile/Update.hs
+++ b/src/compiler/GF/Compile/Update.hs
@@ -5,7 +5,7 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/05/30 18:39:44 $ 
+-- > CVS $Date: 2005/05/30 18:39:44 $
 -- > CVS $Author: aarne $
 -- > CVS $Revision: 1.8 $
 --
@@ -34,14 +34,14 @@ buildAnyTree :: Fail.MonadFail m => ModuleName -> [(Ident,Info)] -> m (Map.Map I
 buildAnyTree m = go Map.empty
   where
     go map []         = return map
-    go map ((c,j):is) = do
+    go map ((c,j):is) =
       case Map.lookup c map of
         Just i  -> case unifyAnyInfo m i j of
-		     Ok k  -> go (Map.insert c k map) is
-		     Bad _ -> fail $ render ("conflicting information in module"<+>m $$
-		                             nest 4 (ppJudgement Qualified (c,i)) $$
-		                             "and" $+$
-		                             nest 4 (ppJudgement Qualified (c,j)))
+          Ok k  -> go (Map.insert c k map) is
+          Bad _ -> fail $ render ("conflicting information in module"<+>m $$
+                                  nest 4 (ppJudgement Qualified (c,i)) $$
+                                  "and" $+$
+                                  nest 4 (ppJudgement Qualified (c,j)))
         Nothing -> go (Map.insert c j map) is
 
 extendModule :: FilePath -> SourceGrammar -> SourceModule -> Check SourceModule
@@ -51,14 +51,14 @@ extendModule cwd gr (name,m)
   ---- Should be replaced by real control. AR 4/2/2005
   | mstatus m == MSIncomplete && isModCnc m = return (name,m)
   | otherwise                               = checkInModule cwd m NoLoc empty $ do
-                                                 m' <- foldM extOne m (mextend m) 
+                                                 m' <- foldM extOne m (mextend m)
                                                  return (name,m')
  where
    extOne mo (n,cond) = do
      m0 <- lookupModule gr n
 
      -- test that the module types match, and find out if the old is complete
-     unless (sameMType (mtype m) (mtype mo)) 
+     unless (sameMType (mtype m) (mtype mo))
             (checkError ("illegal extension type to module" <+> name))
 
      let isCompl = isCompleteModule m0
@@ -67,7 +67,7 @@ extendModule cwd gr (name,m)
      js1 <- extendMod gr isCompl ((n,m0), isInherited cond) name (jments mo)
 
      -- if incomplete, throw away extension information
-     return $ 
+     return $
           if isCompl
             then mo {jments = js1}
             else mo {mextend= filter ((/=n) . fst) (mextend mo)
@@ -75,7 +75,7 @@ extendModule cwd gr (name,m)
                     ,jments = js1
                     }
 
--- | rebuilding instance + interface, and "with" modules, prior to renaming. 
+-- | rebuilding instance + interface, and "with" modules, prior to renaming.
 -- AR 24/10/2003
 rebuildModule :: FilePath -> SourceGrammar -> SourceModule -> Check SourceModule
 rebuildModule cwd gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ msrc_ env_ js_)) =
@@ -88,8 +88,8 @@ rebuildModule cwd gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ msrc_ env_ js
 
     -- add the information given in interface into an instance module
     Nothing -> do
-      unless (null is || mstatus mi == MSIncomplete) 
-             (checkError ("module" <+> i <+> 
+      unless (null is || mstatus mi == MSIncomplete)
+             (checkError ("module" <+> i <+>
                           "has open interfaces and must therefore be declared incomplete"))
       case mt of
         MTInstance (i0,mincl) -> do
@@ -113,7 +113,7 @@ rebuildModule cwd gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ msrc_ env_ js
       let stat' = if all (flip elem infs) is
                     then MSComplete
                     else MSIncomplete
-      unless (stat' == MSComplete || stat == MSIncomplete) 
+      unless (stat' == MSComplete || stat == MSIncomplete)
              (checkError ("module" <+> i <+> "remains incomplete"))
       ModInfo mt0 _ fs me' _ ops0 _ fpath _ js <- lookupModule gr ext
       let ops1 = nub $
@@ -141,24 +141,24 @@ rebuildModule cwd gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ msrc_ env_ js
 extendMod :: Grammar ->
              Bool -> (Module,Ident -> Bool) -> ModuleName ->
              Map.Map Ident Info -> Check (Map.Map Ident Info)
-extendMod gr isCompl ((name,mi),cond) base new = foldM try new $ Map.toList (jments mi) 
+extendMod gr isCompl ((name,mi),cond) base new = foldM try new $ Map.toList (jments mi)
   where
     try new (c,i0)
       | not (cond c) = return new
       | otherwise    = case Map.lookup c new of
                          Just j -> case unifyAnyInfo name i j of
-		                     Ok k  -> return $ Map.insert c k new
-		                     Bad _ -> do (base,j) <- case j of 
-		                                               AnyInd _ m -> lookupOrigInfo gr (m,c)
-		                                               _          -> return (base,j)
-		                                 (name,i) <- case i of 
+                                     Ok k  -> return $ Map.insert c k new
+                                     Bad _ -> do (base,j) <- case j of
+                                                               AnyInd _ m -> lookupOrigInfo gr (m,c)
+                                                               _          -> return (base,j)
+                                                 (name,i) <- case i of
                                                                AnyInd _ m -> lookupOrigInfo gr (m,c)
                                                                _          -> return (name,i)
-		                                 checkError ("cannot unify the information" $$ 
-		                                             nest 4 (ppJudgement Qualified (c,i)) $$
-		                                             "in module" <+> name <+> "with" $$
-		                                             nest 4 (ppJudgement Qualified (c,j)) $$
-		                                             "in module" <+> base)
+                                                 checkError ("cannot unify the information" $$
+                                                             nest 4 (ppJudgement Qualified (c,i)) $$
+                                                             "in module" <+> name <+> "with" $$
+                                                             nest 4 (ppJudgement Qualified (c,j)) $$
+                                                             "in module" <+> base)
                          Nothing-> if isCompl
                                      then return $ Map.insert c (indirInfo name i) new
                                      else return $ Map.insert c i new
@@ -166,11 +166,11 @@ extendMod gr isCompl ((name,mi),cond) base new = foldM try new $ Map.toList (jme
         i = globalizeLoc (msrc mi) i0
 
     indirInfo :: ModuleName -> Info -> Info
-    indirInfo n info = AnyInd b n' where 
+    indirInfo n info = AnyInd b n' where
       (b,n') = case info of
         ResValue _ -> (True,n)
         ResParam _ _ -> (True,n)
-        AbsFun _ _ Nothing _ -> (True,n) 
+        AbsFun _ _ Nothing _ -> (True,n)
         AnyInd b k -> (b,k)
         _ -> (False,n) ---- canonical in Abs
 
@@ -194,24 +194,24 @@ globalizeLoc fpath i =
 
 unifyAnyInfo :: ModuleName -> Info -> Info -> Err Info
 unifyAnyInfo m i j = case (i,j) of
-  (AbsCat mc1, AbsCat mc2) -> 
+  (AbsCat mc1, AbsCat mc2) ->
     liftM AbsCat (unifyMaybeL mc1 mc2)
-  (AbsFun mt1 ma1 md1 moper1, AbsFun mt2 ma2 md2 moper2) -> 
+  (AbsFun mt1 ma1 md1 moper1, AbsFun mt2 ma2 md2 moper2) ->
     liftM4 AbsFun (unifyMaybeL mt1 mt2) (unifAbsArrity ma1 ma2) (unifAbsDefs md1 md2) (unifyMaybe moper1 moper2) -- adding defs
 
   (ResParam mt1 mv1, ResParam mt2 mv2) ->
     liftM2 ResParam (unifyMaybeL mt1 mt2) (unifyMaybe mv1 mv2)
-  (ResValue (L l1 t1), ResValue (L l2 t2)) 
+  (ResValue (L l1 t1), ResValue (L l2 t2))
       | t1==t2    -> return (ResValue (L l1 t1))
       | otherwise -> fail ""
   (_, ResOverload ms t) | elem m ms ->
     return $ ResOverload ms t
-  (ResOper mt1 m1, ResOper mt2 m2) -> 
+  (ResOper mt1 m1, ResOper mt2 m2) ->
     liftM2 ResOper (unifyMaybeL mt1 mt2) (unifyMaybeL m1 m2)
 
-  (CncCat mc1 md1 mr1 mp1 mpmcfg1, CncCat mc2 md2 mr2 mp2 mpmcfg2) -> 
+  (CncCat mc1 md1 mr1 mp1 mpmcfg1, CncCat mc2 md2 mr2 mp2 mpmcfg2) ->
     liftM5 CncCat (unifyMaybeL mc1 mc2) (unifyMaybeL md1 md2) (unifyMaybeL mr1 mr2) (unifyMaybeL mp1 mp2)  (unifyMaybe mpmcfg1 mpmcfg2)
-  (CncFun m mt1 md1 mpmcfg1, CncFun _ mt2 md2 mpmcfg2) -> 
+  (CncFun m mt1 md1 mpmcfg1, CncFun _ mt2 md2 mpmcfg2) ->
     liftM3 (CncFun m) (unifyMaybeL mt1 mt2) (unifyMaybeL md1 md2) (unifyMaybe mpmcfg1 mpmcfg2)
 
   (AnyInd b1 m1, AnyInd b2 m2) -> do
diff --git a/src/compiler/GF/Data/BacktrackM.hs b/src/compiler/GF/Data/BacktrackM.hs
index 14cbf90d2..970de5c06 100644
--- a/src/compiler/GF/Data/BacktrackM.hs
+++ b/src/compiler/GF/Data/BacktrackM.hs
@@ -16,18 +16,18 @@
 {-# LANGUAGE CPP #-}
 module GF.Data.BacktrackM (
                     -- * the backtracking state monad
-		    BacktrackM,
-		    -- * monad specific utilities
-		    member,
-		    cut,
-		    -- * running the monad
-		    foldBM,          runBM,
-		    foldSolutions,   solutions,
-		    foldFinalStates, finalStates,
-		    
-		    -- * reexport the 'MonadState' class
-		    module Control.Monad.State.Class,
-		  ) where
+                    BacktrackM,
+                    -- * monad specific utilities
+                    member,
+                    cut,
+                    -- * running the monad
+                    foldBM,          runBM,
+                    foldSolutions,   solutions,
+                    foldFinalStates, finalStates,
+
+                    -- * reexport the 'MonadState' class
+                    module Control.Monad.State.Class,
+                  ) where
 
 import Data.List
 import Control.Applicative
@@ -70,7 +70,7 @@ instance Applicative (BacktrackM s) where
 instance Monad (BacktrackM s) where
     return a   = BM (\c s b -> c a s b)
     BM m >>= k = BM (\c s b -> m (\a s b -> unBM (k a) c s b) s b)
-	where unBM (BM m) = m
+        where unBM (BM m) = m
 
 #if !(MIN_VERSION_base(4,13,0))
     fail = Fail.fail
diff --git a/src/compiler/GF/Data/Graph.hs b/src/compiler/GF/Data/Graph.hs
index 797325bbb..fd8ec9d99 100644
--- a/src/compiler/GF/Data/Graph.hs
+++ b/src/compiler/GF/Data/Graph.hs
@@ -5,7 +5,7 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/11/10 16:43:44 $ 
+-- > CVS $Date: 2005/11/10 16:43:44 $
 -- > CVS $Author: bringert $
 -- > CVS $Revision: 1.2 $
 --
@@ -34,7 +34,7 @@ import Data.Set (Set)
 import qualified Data.Set as Set
 
 data Graph n a b = Graph [n] ![Node n a] ![Edge n b]
-		 deriving (Eq,Show)
+    deriving (Eq,Show)
 
 type Node n a = (n,a)
 type Edge n b = (n,n,b)
@@ -63,7 +63,7 @@ emap f (Graph c ns es) = Graph c ns [(x,y,f l) | (x,y,l) <- es]
 
 -- | Add a node to the graph.
 newNode :: a               -- ^ Node label
-        -> Graph n a b 
+        -> Graph n a b
         -> (Graph n a b,n) -- ^ Node graph and name of new node
 newNode l (Graph (c:cs) ns es) = (Graph cs ((c,l):ns) es, c)
 
@@ -83,7 +83,7 @@ newEdges es g = foldl' (flip newEdge) g es
 -- lazy version:
 -- newEdges es' (Graph c ns es) = Graph c ns (es'++es)
 
-insertEdgeWith :: Eq n => 
+insertEdgeWith :: Eq n =>
                   (b -> b -> b) -> Edge n b -> Graph n a b -> Graph n a b
 insertEdgeWith f e@(x,y,l) (Graph c ns es) = Graph c ns (h es)
   where h [] = [e]
@@ -97,7 +97,7 @@ removeNode n = removeNodes (Set.singleton n)
 -- | Remove a set of nodes and all edges to and from those nodes.
 removeNodes :: Ord n => Set n -> Graph n a b -> Graph n a b
 removeNodes xs (Graph c ns es) = Graph c ns' es'
-  where 
+  where
   keepNode n = not (Set.member n xs)
   ns' = [ x | x@(n,_) <- ns, keepNode n ]
   es' = [ e | e@(f,t,_) <- es, keepNode f && keepNode t ]
@@ -105,7 +105,7 @@ removeNodes xs (Graph c ns es) = Graph c ns' es'
 -- | Get a map of node names to info about each node.
 nodeInfo :: Ord n => Graph n a b -> NodeInfo n a b
 nodeInfo g = Map.fromList [ (n, (x, fn inc n, fn out n)) | (n,x) <- nodes g ]
-  where 
+  where
   inc = groupEdgesBy edgeTo g
   out = groupEdgesBy edgeFrom g
   fn m n = fromMaybe [] (Map.lookup n m)
@@ -148,16 +148,16 @@ reverseGraph :: Graph n a b -> Graph n a b
 reverseGraph (Graph c ns es) = Graph c ns [ (t,f,l) | (f,t,l) <- es ]
 
 -- | Add the nodes from the second graph to the first graph.
---   The nodes in the second graph will be renamed using the name 
+--   The nodes in the second graph will be renamed using the name
 --   supply in the first graph.
 --   This function is more efficient when the second graph
 --   is smaller than the first.
-mergeGraphs :: Ord m => Graph n a b -> Graph m a b 
+mergeGraphs :: Ord m => Graph n a b -> Graph m a b
             -> (Graph n a b, m -> n) -- ^ The new graph and a function translating
                                       --  the old names of nodes in the second graph
                                       --  to names in the new graph.
 mergeGraphs (Graph c ns1 es1) g2 = (Graph c' (ns2++ns1) (es2++es1), newName)
-  where 
+  where
   (xs,c') = splitAt (length (nodes g2)) c
   newNames = Map.fromList (zip (map fst (nodes g2)) xs)
   newName n = fromJust $ Map.lookup n newNames
@@ -170,7 +170,7 @@ renameNodes :: (n -> m) -- ^ renaming function
             -> Graph n a b -> Graph m a b
 renameNodes newName c (Graph _ ns es) = Graph c ns' es'
     where ns' = map' (\ (n,x) -> (newName n,x)) ns
-	  es' = map' (\ (f,t,l) -> (newName f, newName t, l)) es
+          es' = map' (\ (f,t,l) -> (newName f, newName t, l)) es
 
 -- | A strict 'map'
 map' :: (a -> b) -> [a] -> [b]
diff --git a/src/compiler/GF/Data/Graphviz.hs b/src/compiler/GF/Data/Graphviz.hs
index 411f76898..fa47bac67 100644
--- a/src/compiler/GF/Data/Graphviz.hs
+++ b/src/compiler/GF/Data/Graphviz.hs
@@ -5,7 +5,7 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/09/15 18:10:44 $ 
+-- > CVS $Date: 2005/09/15 18:10:44 $
 -- > CVS $Author: bringert $
 -- > CVS $Revision: 1.2 $
 --
@@ -13,14 +13,14 @@
 -----------------------------------------------------------------------------
 
 module GF.Data.Graphviz (
-				  Graph(..), GraphType(..), 
-				  Node(..), Edge(..),
-				  Attr,
-                                  addSubGraphs,
-                                  setName,
-                                  setAttr,
-				  prGraphviz
-			) where
+                          Graph(..), GraphType(..),
+                          Node(..), Edge(..),
+                          Attr,
+                          addSubGraphs,
+                          setName,
+                          setAttr,
+                          prGraphviz
+                        ) where
 
 import Data.Char
 
@@ -70,14 +70,14 @@ prGraphviz g@(Graph t i _ _ _ _) =
     graphtype t ++ " " ++ maybe "" esc i ++ " {\n" ++ prGraph g ++ "}\n"
 
 prSubGraph :: Graph -> String
-prSubGraph g@(Graph _ i _ _ _ _) = 
+prSubGraph g@(Graph _ i _ _ _ _) =
     "subgraph" ++ " " ++ maybe "" esc i ++ " {\n" ++ prGraph g ++ "}"
 
 prGraph :: Graph -> String
-prGraph (Graph t id at ns es ss) = 
+prGraph (Graph t id at ns es ss) =
     unlines $ map (++";") (map prAttr at
-		           ++ map prNode ns 
-		           ++ map (prEdge t) es
+                           ++ map prNode ns
+                           ++ map (prEdge t) es
                            ++ map prSubGraph ss)
 
 graphtype :: GraphType -> String
@@ -96,7 +96,7 @@ edgeop Undirected = "--"
 
 prAttrList :: [Attr] -> String
 prAttrList [] = ""
-prAttrList at =	"[" ++ join "," (map prAttr at) ++ "]"
+prAttrList at = "[" ++ join "," (map prAttr at) ++ "]"
 
 prAttr :: Attr -> String
 prAttr (n,v) = esc n ++ " = " ++ esc v
diff --git a/src/compiler/GF/Data/Operations.hs b/src/compiler/GF/Data/Operations.hs
index 08fa15c3e..e9b95f8ab 100644
--- a/src/compiler/GF/Data/Operations.hs
+++ b/src/compiler/GF/Data/Operations.hs
@@ -5,7 +5,7 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/11/11 16:12:41 $ 
+-- > CVS $Date: 2005/11/11 16:12:41 $
 -- > CVS $Author: bringert $
 -- > CVS $Revision: 1.22 $
 --
@@ -15,34 +15,34 @@
 -----------------------------------------------------------------------------
 
 module GF.Data.Operations (
-		   -- ** The Error monad
-		   Err(..), err, maybeErr, testErr, fromErr, errIn, 
-		   lookupErr,
-
-		   -- ** Error monad class
-		   ErrorMonad(..), checks, --doUntil, allChecks, checkAgain,
-                   liftErr,
-		   
-		   -- ** Checking
-		   checkUnique, unifyMaybeBy, unifyMaybe,
-
-           -- ** Monadic operations on lists and pairs
-		   mapPairsM, pairM,
- 
-		   -- ** Printing
-		   indent, (+++), (++-), (++++), (+++-), (+++++),
-		   prUpper, prReplicate, prTList, prQuotedString, prParenth, prCurly, 
-		   prBracket, prArgList, prSemicList, prCurlyList, restoreEscapes,
-		   numberedParagraphs, prConjList, prIfEmpty, wrapLines,
-
-		   -- ** Topological sorting
-		   topoTest, topoTest2,
-
-		   -- ** Misc
-		   readIntArg,
-		   iterFix,  chunks,
-                
-		  ) where
+     -- ** The Error monad
+     Err(..), err, maybeErr, testErr, fromErr, errIn,
+     lookupErr,
+
+     -- ** Error monad class
+     ErrorMonad(..), checks, --doUntil, allChecks, checkAgain,
+                 liftErr,
+
+     -- ** Checking
+     checkUnique, unifyMaybeBy, unifyMaybe,
+
+         -- ** Monadic operations on lists and pairs
+     mapPairsM, pairM,
+
+     -- ** Printing
+     indent, (+++), (++-), (++++), (+++-), (+++++),
+     prUpper, prReplicate, prTList, prQuotedString, prParenth, prCurly,
+     prBracket, prArgList, prSemicList, prCurlyList, restoreEscapes,
+     numberedParagraphs, prConjList, prIfEmpty, wrapLines,
+
+     -- ** Topological sorting
+     topoTest, topoTest2,
+
+     -- ** Misc
+     readIntArg,
+     iterFix,  chunks,
+
+    ) where
 
 import Data.Char (isSpace, toUpper, isSpace, isDigit)
 import Data.List (nub, partition, (\\))
@@ -107,7 +107,7 @@ indent i s = replicate i ' ' ++ s
 (+++), (++-), (++++), (+++-), (+++++) :: String -> String -> String
 a +++ b   = a ++ " "    ++ b
 
-a ++- ""  = a 
+a ++- ""  = a
 a ++- b   = a +++ b
 
 a ++++ b  = a ++ "\n"   ++ b
@@ -145,20 +145,20 @@ prCurly   s = "{" ++ s ++ "}"
 prBracket s = "[" ++ s ++ "]"
 
 prArgList, prSemicList, prCurlyList :: [String] -> String
-prArgList   = prParenth . prTList "," 
+prArgList   = prParenth . prTList ","
 prSemicList = prTList " ; "
 prCurlyList = prCurly . prSemicList
 
 restoreEscapes :: String -> String
-restoreEscapes s = 
-  case s of 
+restoreEscapes s =
+  case s of
     []       -> []
     '"' : t  -> '\\' : '"'  : restoreEscapes t
     '\\': t  -> '\\' : '\\' : restoreEscapes t
     c   : t  -> c : restoreEscapes t
 
 numberedParagraphs :: [[String]] -> [String]
-numberedParagraphs t = case t of 
+numberedParagraphs t = case t of
   []   -> []
   p:[] -> p
   _    -> concat [(show n ++ ".") : s | (n,s) <- zip [1..] t]
@@ -204,12 +204,12 @@ topoTest2 g0 = maybe (Right cycles) Left (tsort g)
         ([],[]) -> Just []
         ([],_) -> Nothing
         (ns,rest) -> (leaves:) `fmap` tsort [(n,es \\ leaves) | (n,es)<-rest]
-	  where leaves = map fst ns
+            where leaves = map fst ns
 
 
 -- | Fix point iterator (for computing e.g. transitive closures or reachability)
 iterFix :: Eq a => ([a] -> [a]) -> [a] -> [a]
-iterFix more start = iter start start 
+iterFix more start = iter start start
   where
     iter old new = if (null new')
                       then old
@@ -241,7 +241,7 @@ liftErr e = err raise return e
 {-
 instance ErrorMonad (STM s) where
   raise msg = STM (\s -> raise msg)
-  handle (STM f) g = STM (\s -> (f s) 
+  handle (STM f) g = STM (\s -> (f s)
                                 `handle` (\e -> let STM g' = (g e) in
                                                     g' s))
 
diff --git a/src/compiler/GF/Data/Relation.hs b/src/compiler/GF/Data/Relation.hs
index 5a3e80e6f..62da769b5 100644
--- a/src/compiler/GF/Data/Relation.hs
+++ b/src/compiler/GF/Data/Relation.hs
@@ -5,7 +5,7 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/10/26 17:13:13 $ 
+-- > CVS $Date: 2005/10/26 17:13:13 $
 -- > CVS $Author: bringert $
 -- > CVS $Revision: 1.1 $
 --
@@ -83,7 +83,7 @@ transitiveClosure r = fix (Map.map growSet) r
   where growSet ys = foldl Set.union ys (map (allRelated r) $ Set.toList ys)
 
 reflexiveClosure_ :: Ord a => [a] -- ^ The set over which the relation is defined.
-		 -> Rel a -> Rel a
+                  -> Rel a -> Rel a
 reflexiveClosure_ u r = relates [(x,x) | x <- u] r
 
 -- | Uses 'domain'
@@ -104,7 +104,7 @@ reflexiveElements :: Ord a => Rel a -> Set a
 reflexiveElements r = Set.fromList [ x | (x,ys) <- Map.toList r, x `Set.member` ys ]
 
 -- | Keep the related pairs for which the predicate is true.
-filterRel :: Ord a => (a -> a -> Bool) -> Rel a -> Rel a 
+filterRel :: Ord a => (a -> a -> Bool) -> Rel a -> Rel a
 filterRel p = fst . purgeEmpty . Map.mapWithKey (Set.filter . p)
 
 -- | Remove keys that map to no elements.
@@ -112,16 +112,16 @@ purgeEmpty :: Ord a => Rel a -> (Rel a, Set a)
 purgeEmpty r = let (r',r'') = Map.partition (not . Set.null) r
                 in (r', Map.keysSet r'')
 
--- | Get the equivalence classes from an equivalence relation. 
+-- | Get the equivalence classes from an equivalence relation.
 equivalenceClasses :: Ord a => Rel a -> [Set a]
 equivalenceClasses r = equivalenceClasses_ (Map.keys r) r
  where equivalenceClasses_ [] _ = []
        equivalenceClasses_ (x:xs) r = ys:equivalenceClasses_ zs r
-	   where ys = allRelated r x
-                 zs = [x' | x' <- xs, not (x' `Set.member` ys)]
+          where ys = allRelated r x
+                zs = [x' | x' <- xs, not (x' `Set.member` ys)]
 
 isTransitive :: Ord a => Rel a -> Bool
-isTransitive r = and [z `Set.member` ys | (x,ys) <- Map.toList r, 
+isTransitive r = and [z `Set.member` ys | (x,ys) <- Map.toList r,
                       y <- Set.toList ys, z <- Set.toList (allRelated r y)]
 
 isReflexive :: Ord a => Rel a -> Bool
@@ -181,7 +181,7 @@ remove x r = let (mss,r') = Map.updateLookupWithKey (\_ _ -> Nothing) x r
                    Nothing      -> (r', Set.empty, Set.empty)
                    -- remove element from all incoming and outgoing sets
                    -- of other elements
-                   Just (is,os) -> 
+                   Just (is,os) ->
                        let r''  = foldr (\i -> Map.adjust (\ (is',os') -> (is', Set.delete x os')) i) r'  $ Set.toList is
                            r''' = foldr (\o -> Map.adjust (\ (is',os') -> (Set.delete x is', os')) o) r'' $ Set.toList os
                         in (r''', is, os)
@@ -190,4 +190,4 @@ incoming :: Ord a => a -> Rel' a -> Set a
 incoming x r = maybe Set.empty fst $ Map.lookup x r
 
 --outgoing :: Ord a => a -> Rel' a -> Set a
---outgoing x r = maybe Set.empty snd $ Map.lookup x r
\ No newline at end of file
+--outgoing x r = maybe Set.empty snd $ Map.lookup x r
diff --git a/src/compiler/GF/Data/Utilities.hs b/src/compiler/GF/Data/Utilities.hs
index 29ed329dc..913953b6e 100644
--- a/src/compiler/GF/Data/Utilities.hs
+++ b/src/compiler/GF/Data/Utilities.hs
@@ -4,7 +4,7 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/10/26 18:47:16 $ 
+-- > CVS $Date: 2005/10/26 18:47:16 $
 -- > CVS $Author: bringert $
 -- > CVS $Revision: 1.6 $
 --
@@ -33,7 +33,7 @@ longerThan    n = not . notLongerThan n
 lookupList :: Eq a => a -> [(a, b)] -> [b]
 lookupList a [] = []
 lookupList a (p:ps) | a == fst p = snd p : lookupList a ps
-		    | otherwise  =         lookupList a ps
+                    | otherwise  =         lookupList a ps
 
 split :: [a] -> ([a], [a])
 split (x : y : as) = (x:xs, y:ys)
@@ -48,8 +48,8 @@ splitBy p (a : as) = if p a then (a:xs, ys) else (xs, a:ys)
 foldMerge :: (a -> a -> a) -> a -> [a] -> a
 foldMerge merge zero = fm
     where fm [] = zero
-	  fm [a] = a
-	  fm abs = let (as, bs) = split abs in fm as `merge` fm bs
+          fm [a] = a
+          fm abs = let (as, bs) = split abs in fm as `merge` fm bs
 
 select :: [a] -> [(a, [a])]
 select [] = []
@@ -68,7 +68,7 @@ safeInit :: [a] -> [a]
 safeInit [] = []
 safeInit xs = init xs
 
--- | Sorts and then groups elements given an ordering of the 
+-- | Sorts and then groups elements given an ordering of the
 --   elements.
 sortGroupBy :: (a -> a -> Ordering) -> [a] -> [[a]]
 sortGroupBy f = groupBy (compareEq f) . sortBy f
diff --git a/src/compiler/GF/Grammar/Canonical.hs b/src/compiler/GF/Grammar/Canonical.hs
index 80e9f5e7b..e62424f6a 100644
--- a/src/compiler/GF/Grammar/Canonical.hs
+++ b/src/compiler/GF/Grammar/Canonical.hs
@@ -45,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)
 
@@ -60,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]
@@ -74,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
@@ -107,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)
 
 --------------------------------------------------------------------------------
@@ -250,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
@@ -265,7 +265,7 @@ instance PPA LinPattern where
       ParamPattern pv -> ppA pv
       RecordPattern r -> block r
       TuplePattern ps -> "<"<>punctuate "," ps<>">"
-      WildPattern     -> pp "_"                
+      WildPattern     -> pp "_"
 
 instance RhsSeparator LinPattern where rhsSep _ = pp "="
 
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/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
diff --git a/src/compiler/GF/Infra/CheckM.hs b/src/compiler/GF/Infra/CheckM.hs
index c0234999a..a5ff7148a 100644
--- a/src/compiler/GF/Infra/CheckM.hs
+++ b/src/compiler/GF/Infra/CheckM.hs
@@ -5,7 +5,7 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/04/21 16:22:33 $ 
+-- > CVS $Date: 2005/04/21 16:22:33 $
 -- > CVS $Author: bringert $
 -- > CVS $Revision: 1.5 $
 --
@@ -14,10 +14,10 @@
 
 module GF.Infra.CheckM
           (Check, CheckResult, Message, runCheck, runCheck',
-	   checkError, checkCond, checkWarn, checkWarnings, checkAccumError,
-	   checkIn, checkInModule, checkMap, checkMapRecover,
+           checkError, checkCond, checkWarn, checkWarnings, checkAccumError,
+           checkIn, checkInModule, checkMap, checkMapRecover,
            parallelCheck, accumulateError, commitCheck,
-	  ) where
+          ) where
 import Prelude hiding ((<>)) -- GHC 8.4.1 clash with Text.PrettyPrint
 
 import GF.Data.Operations
@@ -141,10 +141,10 @@ checkMapRecover f = fmap Map.fromList . parallelCheck . map f' . Map.toList
   where f' (k,v) = fmap ((,)k) (f k v)
 
 {-
-checkMapRecover f mp = do 
+checkMapRecover f mp = do
   let xs = map (\ (k,v) -> (k,runCheck (f k v))) (Map.toList mp)
   case [s | (_,Bad s) <- xs] of
-    ss@(_:_) -> checkError (text (unlines ss)) 
+    ss@(_:_) -> checkError (text (unlines ss))
     _   -> do
       let (kx,ss) = unzip [((k,x),s) | (k, Ok (x,s)) <- xs]
       if not (all null ss) then checkWarn (text (unlines ss)) else return ()
diff --git a/src/compiler/GF/Interactive.hs b/src/compiler/GF/Interactive.hs
index 855ab22d1..1ea62e4b3 100644
--- a/src/compiler/GF/Interactive.hs
+++ b/src/compiler/GF/Interactive.hs
@@ -433,7 +433,7 @@ wc_type = cmd_name
         x2 = takeWhile (\c -> isIdent c || isSpace c || c == '-' || c == '=' || c == '"') x1
 
         cmd = case [x | (x,cs) <- RP.readP_to_S pCommand x2, all isSpace cs] of
-	        [x] -> Just x
+                [x] -> Just x
                 _   -> Nothing
 
     isIdent c = c == '_' || c == '\'' || isAlphaNum c
diff --git a/src/compiler/GF/Speech/FiniteState.hs b/src/compiler/GF/Speech/FiniteState.hs
index cb5247755..95acd35c5 100644
--- a/src/compiler/GF/Speech/FiniteState.hs
+++ b/src/compiler/GF/Speech/FiniteState.hs
@@ -5,37 +5,37 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/11/10 16:43:44 $ 
+-- > CVS $Date: 2005/11/10 16:43:44 $
 -- > CVS $Author: bringert $
 -- > CVS $Revision: 1.16 $
 --
 -- A simple finite state network module.
 -----------------------------------------------------------------------------
 module GF.Speech.FiniteState (FA(..), State, NFA, DFA,
-			      startState, finalStates,
-			      states, transitions,
+                              startState, finalStates,
+                              states, transitions,
                               isInternal,
-			      newFA, newFA_,
-			      addFinalState,
-			      newState, newStates,
+                              newFA, newFA_,
+                              addFinalState,
+                              newState, newStates,
                               newTransition, newTransitions,
                               insertTransitionWith, insertTransitionsWith,
-			      mapStates, mapTransitions,
+                              mapStates, mapTransitions,
                               modifyTransitions,
-                              nonLoopTransitionsTo, nonLoopTransitionsFrom, 
+                              nonLoopTransitionsTo, nonLoopTransitionsFrom,
                               loops,
                               removeState,
                               oneFinalState,
                               insertNFA,
                               onGraph,
-			      moveLabelsToNodes, removeTrivialEmptyNodes,
+                              moveLabelsToNodes, removeTrivialEmptyNodes,
                               minimize,
                               dfa2nfa,
                               unusedNames, renameStates,
-			      prFAGraphviz, faToGraphviz) where
+                              prFAGraphviz, faToGraphviz) where
 
 import Data.List
-import Data.Maybe 
+import Data.Maybe
 --import Data.Map (Map)
 import qualified Data.Map as Map
 import Data.Set (Set)
@@ -98,13 +98,13 @@ newTransition f t l = onGraph (newEdge (f,t,l))
 newTransitions :: [(n, n, b)] -> FA n a b -> FA n a b
 newTransitions es = onGraph (newEdges es)
 
-insertTransitionWith :: Eq n => 
+insertTransitionWith :: Eq n =>
                         (b -> b -> b) -> (n, n, b) -> FA n a b -> FA n a b
 insertTransitionWith f t = onGraph (insertEdgeWith f t)
 
-insertTransitionsWith :: Eq n => 
+insertTransitionsWith :: Eq n =>
                          (b -> b -> b) -> [(n, n, b)] -> FA n a b -> FA n a b
-insertTransitionsWith f ts fa = 
+insertTransitionsWith f ts fa =
     foldl' (flip (insertTransitionWith f)) fa ts
 
 mapStates :: (a -> c) -> FA n a b -> FA n c b
@@ -128,11 +128,11 @@ unusedNames (FA (Graph names _ _) _ _) = names
 -- | Gets all incoming transitions to a given state, excluding
 -- transtions from the state itself.
 nonLoopTransitionsTo :: Eq n => n -> FA n a b -> [(n,b)]
-nonLoopTransitionsTo s fa = 
+nonLoopTransitionsTo s fa =
     [(f,l) | (f,t,l) <- transitions fa, t == s && f /= s]
 
 nonLoopTransitionsFrom :: Eq n => n -> FA n a b -> [(n,b)]
-nonLoopTransitionsFrom s fa = 
+nonLoopTransitionsFrom s fa =
     [(t,l) | (f,t,l) <- transitions fa, f == s && t /= s]
 
 loops :: Eq n => n -> FA n a b -> [b]
@@ -145,7 +145,7 @@ renameStates :: Ord x => [y] -- ^ Infinite supply of new names
 renameStates supply (FA g s fs) = FA (renameNodes newName rest g) s' fs'
     where (ns,rest) = splitAt (length (nodes g)) supply
           newNodes = Map.fromList (zip (map fst (nodes g)) ns)
-	  newName n = Map.findWithDefault (error "FiniteState.newName") n newNodes
+          newName n = Map.findWithDefault (error "FiniteState.newName") n newNodes
           s' = newName s
           fs' = map newName fs
 
@@ -154,9 +154,9 @@ insertNFA :: NFA a -- ^ NFA to insert into
           -> (State, State) -- ^ States to insert between
           -> NFA a -- ^ NFA to insert.
           -> NFA a
-insertNFA (FA g1 s1 fs1) (f,t) (FA g2 s2 fs2) 
+insertNFA (FA g1 s1 fs1) (f,t) (FA g2 s2 fs2)
     = FA (newEdges es g') s1 fs1
-    where 
+    where
     es = (f,ren s2,Nothing):[(ren f2,t,Nothing) | f2 <- fs2]
     (g',ren) = mergeGraphs g1 g2
 
@@ -182,9 +182,9 @@ oneFinalState nl el fa =
 moveLabelsToNodes :: (Ord n,Eq a) => FA n () (Maybe a) -> FA n (Maybe a) ()
 moveLabelsToNodes = onGraph f
   where f g@(Graph c _ _) = Graph c' ns (concat ess)
-	    where is = [ ((n,l),inc) | (n, (l,inc,_)) <- Map.toList (nodeInfo g)]
-		  (c',is') = mapAccumL fixIncoming c is
-		  (ns,ess) = unzip (concat is')
+         where is = [ ((n,l),inc) | (n, (l,inc,_)) <- Map.toList (nodeInfo g)]
+               (c',is') = mapAccumL fixIncoming c is
+               (ns,ess) = unzip (concat is')
 
 
 -- | Remove empty nodes which are not start or final, and have
@@ -196,12 +196,12 @@ removeTrivialEmptyNodes = pruneUnusable . skipSimpleEmptyNodes
 --   This is not done if the pointed-to node is a final node.
 skipSimpleEmptyNodes :: (Eq a, Ord n) => FA n (Maybe a) () -> FA n (Maybe a) ()
 skipSimpleEmptyNodes fa = onGraph og fa
-  where 
+  where
   og g@(Graph c ns es) = if es' == es then g else og (Graph c ns es')
     where
     es' = concatMap changeEdge es
     info = nodeInfo g
-    changeEdge e@(f,t,()) 
+    changeEdge e@(f,t,())
       | isNothing (getNodeLabel info t)
        -- && (i * o <= i + o)
         && not (isFinal fa t)
@@ -223,28 +223,28 @@ pruneUnusable fa = onGraph f fa
  where
  f g = if Set.null rns then g else f (removeNodes rns g)
   where info = nodeInfo g
-        rns = Set.fromList [ n | (n,_) <- nodes g, 
+        rns = Set.fromList [ n | (n,_) <- nodes g,
                              isInternal fa n,
-                             inDegree info n == 0 
+                             inDegree info n == 0
                              || outDegree info n == 0]
 
-fixIncoming :: (Ord n, Eq a) => [n] 
+fixIncoming :: (Ord n, Eq a) => [n]
             -> (Node n (),[Edge n (Maybe a)]) -- ^ A node and its incoming edges
             -> ([n],[(Node n (Maybe a),[Edge n ()])]) -- ^ Replacement nodes with their
                                                       -- incoming edges.
 fixIncoming cs c@((n,()),es) = (cs'', ((n,Nothing),es'):newContexts)
   where ls = nub $ map edgeLabel es
-	(cs',cs'') = splitAt (length ls) cs
-	newNodes = zip cs' ls
-	es' = [ (x,n,()) | x <- map fst newNodes ]
-	-- separate cyclic and non-cyclic edges
-	(cyc,ncyc) = partition (\ (f,_,_) -> f == n) es
-	          -- keep all incoming non-cyclic edges with the right label
-	to (x,l) = [ (f,x,()) | (f,_,l') <- ncyc, l == l']
-	          -- for each cyclic edge with the right label, 
-	          -- add an edge from each of the new nodes (including this one)
-		    ++ [ (y,x,()) | (f,_,l') <- cyc, l == l', (y,_) <- newNodes]
-	newContexts = [ (v, to v) | v <- newNodes ]
+        (cs',cs'') = splitAt (length ls) cs
+        newNodes = zip cs' ls
+        es' = [ (x,n,()) | x <- map fst newNodes ]
+        -- separate cyclic and non-cyclic edges
+        (cyc,ncyc) = partition (\ (f,_,_) -> f == n) es
+                  -- keep all incoming non-cyclic edges with the right label
+        to (x,l) = [ (f,x,()) | (f,_,l') <- ncyc, l == l']
+                  -- for each cyclic edge with the right label,
+                  -- add an edge from each of the new nodes (including this one)
+                  ++ [ (y,x,()) | (f,_,l') <- cyc, l == l', (y,_) <- newNodes]
+        newContexts = [ (v, to v) | v <- newNodes ]
 
 --alphabet :: Eq b => Graph n a (Maybe b) -> [b]
 --alphabet = nub . catMaybes . map edgeLabel . edges
@@ -254,19 +254,19 @@ determinize (FA g s f) = let (ns,es) = h (Set.singleton start) Set.empty Set.emp
                              (ns',es') = (Set.toList ns, Set.toList es)
                              final = filter isDFAFinal ns'
                              fa = FA (Graph undefined [(n,()) | n <- ns'] es') start final
- 		          in renameStates [0..] fa
+                         in renameStates [0..] fa
   where info = nodeInfo g
 --        reach = nodesReachable out
-	start = closure info $ Set.singleton s
+        start = closure info $ Set.singleton s
         isDFAFinal n = not (Set.null (Set.fromList f `Set.intersection` n))
-	h currentStates oldStates es
-	    | Set.null currentStates = (oldStates,es)
-	    | otherwise = ((h $! uniqueNewStates) $! allOldStates) $! es'
-	    where 
-	    allOldStates = oldStates `Set.union` currentStates
+        h currentStates oldStates es
+            | Set.null currentStates = (oldStates,es)
+            | otherwise = ((h $! uniqueNewStates) $! allOldStates) $! es'
+            where
+            allOldStates = oldStates `Set.union` currentStates
             (newStates,es') = new (Set.toList currentStates) Set.empty es
-	    uniqueNewStates = newStates Set.\\ allOldStates
-        -- Get the sets of states reachable from the given states 
+            uniqueNewStates = newStates Set.\\ allOldStates
+        -- Get the sets of states reachable from the given states
         -- by consuming one symbol, and the associated edges.
         new [] rs es = (rs,es)
         new (n:ns) rs es = new ns rs' es'
@@ -281,7 +281,7 @@ closure info x = closure_ x x
   where closure_ acc check | Set.null check = acc
                            | otherwise = closure_ acc' check'
             where
-            reach = Set.fromList [y | x <- Set.toList check, 
+            reach = Set.fromList [y | x <- Set.toList check,
                                       (_,y,Nothing) <- getOutgoing info x]
             acc' = acc `Set.union` reach
             check' = reach Set.\\ acc
@@ -296,8 +296,8 @@ reachable1 info ns = Map.fromListWith (++) [(c, [y]) | n <- Set.toList ns, (_,y,
 reverseNFA :: NFA a -> NFA a
 reverseNFA (FA g s fs) = FA g''' s' [s]
     where g' = reverseGraph g
-	  (g'',s') = newNode () g'
-	  g''' = newEdges [(s',f,Nothing) | f <- fs] g''
+          (g'',s') = newNode () g'
+          g''' = newEdges [(s',f,Nothing) | f <- fs] g''
 
 dfa2nfa :: DFA a -> NFA a
 dfa2nfa = mapTransitions Just
@@ -313,13 +313,13 @@ prFAGraphviz  = Dot.prGraphviz . faToGraphviz
 --prFAGraphviz_  = Dot.prGraphviz . faToGraphviz . mapStates show . mapTransitions show
 
 faToGraphviz :: (Eq n,Show n) => FA n String String -> Dot.Graph
-faToGraphviz (FA (Graph _ ns es) s f) 
+faToGraphviz (FA (Graph _ ns es) s f)
     = Dot.Graph Dot.Directed Nothing [] (map mkNode ns) (map mkEdge es) []
    where mkNode (n,l) = Dot.Node (show n) attrs
-	     where attrs = [("label",l)]
-			   ++ if n == s then [("shape","box")] else []
-			   ++ if n `elem` f then [("style","bold")] else []
-	 mkEdge (x,y,l) = Dot.Edge (show x) (show y) [("label",l)]
+          where attrs = [("label",l)]
+                 ++ if n == s then [("shape","box")] else []
+                 ++ if n `elem` f then [("style","bold")] else []
+         mkEdge (x,y,l) = Dot.Edge (show x) (show y) [("label",l)]
 
 --
 -- * Utilities
diff --git a/src/compiler/GF/Speech/GSL.hs b/src/compiler/GF/Speech/GSL.hs
index a898a4bb5..ceaf86ae0 100644
--- a/src/compiler/GF/Speech/GSL.hs
+++ b/src/compiler/GF/Speech/GSL.hs
@@ -26,14 +26,14 @@ width = 75
 
 gslPrinter :: Options -> PGF -> CId -> String
 gslPrinter opts pgf cnc = renderStyle st $ prGSL $ makeNonLeftRecursiveSRG opts pgf cnc
-  where st = style { lineLength = width } 
+  where st = style { lineLength = width }
 
 prGSL :: SRG -> Doc
 prGSL srg = header $++$ mainCat $++$ foldr ($++$) empty (map prRule (srgRules srg))
     where
     header = ";GSL2.0" $$
-	     comment ("Nuance speech recognition grammar for " ++ srgName srg) $$
-             comment ("Generated by GF") 
+             comment ("Nuance speech recognition grammar for " ++ srgName srg) $$
+             comment ("Generated by GF")
     mainCat = ".MAIN" <+> prCat (srgStartCat srg)
     prRule (SRGRule cat rhs) = prCat cat <+> union (map prAlt rhs)
     -- FIXME: use the probability
diff --git a/src/compiler/GF/Speech/JSGF.hs b/src/compiler/GF/Speech/JSGF.hs
index 15f5ff69d..b12fb0ace 100644
--- a/src/compiler/GF/Speech/JSGF.hs
+++ b/src/compiler/GF/Speech/JSGF.hs
@@ -31,7 +31,7 @@ width :: Int
 width = 75
 
 jsgfPrinter :: Options
-	    -> PGF 
+            -> PGF
             -> CId -> String
 jsgfPrinter opts pgf cnc = renderStyle st $ prJSGF sisr $ makeNonLeftRecursiveSRG opts pgf cnc
   where st = style { lineLength = width }
@@ -44,7 +44,7 @@ prJSGF sisr srg
     header = "#JSGF" <+> "V1.0" <+> "UTF-8" <+> lang <> ';' $$
              comment ("JSGF speech recognition grammar for " ++ srgName srg) $$
              comment "Generated by GF" $$
-	     ("grammar " ++ srgName srg ++ ";") 
+             ("grammar " ++ srgName srg ++ ";")
     lang = maybe empty pp (srgLanguage srg)
     mainCat = rule True "MAIN" [prCat (srgStartCat srg)]
     prRule (SRGRule cat rhs) = rule (isExternalCat srg cat) cat (map prAlt rhs)
@@ -62,7 +62,7 @@ prItem :: Maybe SISRFormat -> CFTerm -> SRGItem -> Doc
 prItem sisr t = f 0
   where
     f _ (REUnion [])  = pp "<VOID>"
-    f p (REUnion xs) 
+    f p (REUnion xs)
         | not (null es) = brackets (f 0 (REUnion nes))
         | otherwise = (if p >= 1 then parens else id) (alts (map (f 1) xs))
       where (es,nes) = partition isEpsilon xs
@@ -110,4 +110,3 @@ prepunctuate p (x:xs) = x : map (p <>) xs
 
 ($++$) :: Doc -> Doc -> Doc
 x $++$ y = x $$ emptyLine $$ y
-
diff --git a/src/compiler/GF/Speech/PGFToCFG.hs b/src/compiler/GF/Speech/PGFToCFG.hs
index a8ecec27d..fdd8a6c84 100644
--- a/src/compiler/GF/Speech/PGFToCFG.hs
+++ b/src/compiler/GF/Speech/PGFToCFG.hs
@@ -28,7 +28,7 @@ toBNF f pgf cnc = prCFG $ f $ pgfToCFG pgf cnc
 
 type Profile = [Int]
 
-pgfToCFG :: PGF 
+pgfToCFG :: PGF
           -> CId   -- ^ Concrete syntax name
           -> CFG
 pgfToCFG pgf lang = mkCFG (showCId (lookStartCat pgf)) extCats (startRules ++ concatMap ruleToCFRule rules)
@@ -40,8 +40,8 @@ pgfToCFG pgf lang = mkCFG (showCId (lookStartCat pgf)) extCats (startRules ++ co
                          , prod <- Set.toList set]
 
     fcatCats :: Map FId Cat
-    fcatCats = Map.fromList [(fc, showCId c ++ "_" ++ show i) 
-                                 | (c,CncCat s e lbls) <- Map.toList (cnccats cnc), 
+    fcatCats = Map.fromList [(fc, showCId c ++ "_" ++ show i)
+                                 | (c,CncCat s e lbls) <- Map.toList (cnccats cnc),
                                    (fc,i) <- zip (range (s,e)) [1..]]
 
     fcatCat :: FId -> Cat
@@ -58,7 +58,7 @@ pgfToCFG pgf lang = mkCFG (showCId (lookStartCat pgf)) extCats (startRules ++ co
     topdownRules cat = f cat []
       where
         f cat rules = maybe rules (Set.foldr g rules) (IntMap.lookup cat (productions cnc))
-	 
+
         g (PApply funid args) rules = (cncfuns cnc ! funid,args) : rules
         g (PCoerce cat)       rules = f cat rules
 
@@ -67,13 +67,13 @@ pgfToCFG pgf lang = mkCFG (showCId (lookStartCat pgf)) extCats (startRules ++ co
     extCats = Set.fromList $ map ruleLhs startRules
 
     startRules :: [CFRule]
-    startRules = [Rule (showCId c) [NonTerminal (fcatToCat fc r)] (CFRes 0) 
-                      | (c,CncCat s e lbls) <- Map.toList (cnccats cnc), 
+    startRules = [Rule (showCId c) [NonTerminal (fcatToCat fc r)] (CFRes 0)
+                      | (c,CncCat s e lbls) <- Map.toList (cnccats cnc),
                         fc <- range (s,e), not (isPredefFId fc),
                         r <- [0..catLinArity fc-1]]
 
     ruleToCFRule :: (FId,Production) -> [CFRule]
-    ruleToCFRule (c,PApply funid args) = 
+    ruleToCFRule (c,PApply funid args) =
         [Rule (fcatToCat c l) (mkRhs row) (profilesToTerm [fixProfile row n | n <- [0..length args-1]])
            | (l,seqid) <- Array.assocs rhs
            , let row = sequences cnc ! seqid
@@ -106,7 +106,7 @@ pgfToCFG pgf lang = mkCFG (showCId (lookStartCat pgf)) extCats (startRules ++ co
         fixProfile row i = [k | (k,j) <- nts, j == i]
             where
               nts = zip [0..] [j | nt <- Array.elems row, j <- getPos nt]
-              
+
               getPos (SymCat j _) = [j]
               getPos (SymLit j _) = [j]
               getPos _            = []
diff --git a/src/compiler/GF/Speech/SRG.hs b/src/compiler/GF/Speech/SRG.hs
index 9d51e52e9..b761c45cd 100644
--- a/src/compiler/GF/Speech/SRG.hs
+++ b/src/compiler/GF/Speech/SRG.hs
@@ -2,8 +2,8 @@
 -- |
 -- Module      : SRG
 --
--- Representation of, conversion to, and utilities for 
--- printing of a general Speech Recognition Grammar. 
+-- Representation of, conversion to, and utilities for
+-- printing of a general Speech Recognition Grammar.
 --
 -- FIXME: remove \/ warn \/ fail if there are int \/ string literal
 -- categories in the grammar
@@ -40,20 +40,20 @@ import qualified Data.Set as Set
 --import Debug.Trace
 
 data SRG = SRG { srgName :: String    -- ^ grammar name
-		 , srgStartCat :: Cat     -- ^ start category name
-                 , srgExternalCats :: Set Cat
-                 , srgLanguage :: Maybe String -- ^ The language for which the grammar 
-                                                   --   is intended, e.g. en-UK
-	         , srgRules :: [SRGRule] 
-	       }
-	 deriving (Eq,Show)
+               , srgStartCat :: Cat     -- ^ start category name
+               , srgExternalCats :: Set Cat
+               , srgLanguage :: Maybe String -- ^ The language for which the grammar
+                                             --   is intended, e.g. en-UK
+               , srgRules :: [SRGRule]
+               }
+        deriving (Eq,Show)
 
 data SRGRule = SRGRule Cat [SRGAlt]
-	     deriving (Eq,Show)
+        deriving (Eq,Show)
 
 -- | maybe a probability, a rule name and an EBNF right-hand side
 data SRGAlt = SRGAlt (Maybe Double) CFTerm SRGItem
-	      deriving (Eq,Show)
+        deriving (Eq,Show)
 
 type SRGItem = RE SRGSymbol
 
@@ -65,7 +65,7 @@ type SRGNT = (Cat, Int)
 ebnfPrinter :: Options -> PGF -> CId -> String
 ebnfPrinter opts pgf cnc = prSRG opts $ makeSRG opts pgf cnc
 
--- | Create a compact filtered non-left-recursive SRG. 
+-- | Create a compact filtered non-left-recursive SRG.
 makeNonLeftRecursiveSRG :: Options -> PGF -> CId -> SRG
 makeNonLeftRecursiveSRG opts = makeSRG opts'
     where
@@ -76,11 +76,11 @@ makeSRG opts = mkSRG cfgToSRG preprocess
     where
       cfgToSRG cfg = [cfRulesToSRGRule rs | (_,rs) <- allRulesGrouped cfg]
       preprocess =   maybeTransform opts CFGMergeIdentical mergeIdentical
-                   . maybeTransform opts CFGNoLR removeLeftRecursion 
+                   . maybeTransform opts CFGNoLR removeLeftRecursion
                    . maybeTransform opts CFGRegular makeRegular
                    . maybeTransform opts CFGTopDownFilter topDownFilter
                    . maybeTransform opts CFGBottomUpFilter bottomUpFilter
-                   . maybeTransform opts CFGRemoveCycles removeCycles 
+                   . maybeTransform opts CFGRemoveCycles removeCycles
                    . maybeTransform opts CFGStartCatOnly purgeExternalCats
 
 setDefaultCFGTransform :: Options -> CFGTransform -> Bool -> Options
@@ -95,7 +95,7 @@ stats g = "Categories: " ++ show (countCats g)
           ++ ", External categories: " ++ show (Set.size (cfgExternalCats g))
           ++ ", Rules: " ++ show (countRules g)
 -}
-makeNonRecursiveSRG :: Options 
+makeNonRecursiveSRG :: Options
                     -> PGF
                     -> CId -- ^ Concrete syntax name.
                     -> SRG
@@ -111,26 +111,26 @@ makeNonRecursiveSRG opts = mkSRG cfgToSRG id
 mkSRG :: (CFG -> [SRGRule]) -> (CFG -> CFG) -> PGF -> CId -> SRG
 mkSRG mkRules preprocess pgf cnc =
     SRG { srgName = showCId cnc,
-	  srgStartCat = cfgStartCat cfg,
+          srgStartCat = cfgStartCat cfg,
           srgExternalCats = cfgExternalCats cfg,
           srgLanguage = languageCode pgf cnc,
-	  srgRules = mkRules cfg }
+          srgRules = mkRules cfg }
     where cfg = renameCats (showCId cnc) $ preprocess $ pgfToCFG pgf cnc
 
--- | Renames all external cats C to C_cat, and all internal cats C_X (where X is any string), 
+-- | Renames all external cats C to C_cat, and all internal cats C_X (where X is any string),
 --   to C_N where N is an integer.
 renameCats :: String -> CFG -> CFG
 renameCats prefix cfg = mapCFGCats renameCat cfg
   where renameCat c | isExternal c = c ++ "_cat"
                     | otherwise = Map.findWithDefault (badCat c) c names
-        isExternal c = c `Set.member` cfgExternalCats cfg        
+        isExternal c = c `Set.member` cfgExternalCats cfg
         catsByPrefix = buildMultiMap [(takeWhile (/='_') cat, cat) | cat <- allCats' cfg, not (isExternal cat)]
         names = Map.fromList [(c,pref++"_"++show i) | (pref,cs) <- catsByPrefix, (c,i) <- zip cs [1..]]
         badCat c = error ("GF.Speech.SRG.renameCats: " ++ c ++ "\n" ++ prCFG cfg)
 
 cfRulesToSRGRule :: [CFRule] -> SRGRule
 cfRulesToSRGRule rs@(r:_) = SRGRule (ruleLhs r) rhs
-    where 
+    where
       alts = [((n,Nothing),mkSRGSymbols 0 ss) | Rule c ss n <- rs]
       rhs = [SRGAlt p n (srgItem sss) | ((n,p),sss) <- buildMultiMap alts ]
 
@@ -153,7 +153,7 @@ srgItem = unionRE . map mergeItems . sortGroupBy (compareBy filterCats)
 -- non-optimizing version:
 --srgItem = unionRE . map seqRE
 
--- | Merges a list of right-hand sides which all have the same 
+-- | Merges a list of right-hand sides which all have the same
 -- sequence of non-terminals.
 mergeItems :: [[SRGSymbol]] -> SRGItem
 mergeItems = minimizeRE . ungroupTokens . minimizeRE . unionRE . map seqRE . map groupTokens
@@ -174,16 +174,16 @@ ungroupTokens = joinRE . mapRE (symbol (RESymbol . NonTerminal) (REConcat . map
 
 prSRG :: Options -> SRG -> String
 prSRG opts srg = prProductions $ map prRule $ ext ++ int
-    where 
+    where
       sisr = flag optSISR opts
       (ext,int) = partition (isExternalCat srg . srgLHSCat) (srgRules srg)
       prRule (SRGRule c alts) = (c,unwords (intersperse "|" (concatMap prAlt alts)))
-      prAlt (SRGAlt _ t rhs) = 
-          -- FIXME: hack: we high-jack the --sisr flag to add 
+      prAlt (SRGAlt _ t rhs) =
+          -- FIXME: hack: we high-jack the --sisr flag to add
           -- a simple lambda calculus format for semantic interpretation
           -- Maybe the --sisr flag should be renamed.
           case sisr of
-            Just _  -> 
+            Just _  ->
                 -- copy tags to each part of a top-level union,
                 -- to get simpler output
                 case rhs of
diff --git a/src/compiler/GF/Speech/SRGS_ABNF.hs b/src/compiler/GF/Speech/SRGS_ABNF.hs
index dc5c7bbd3..3db8fe7c2 100644
--- a/src/compiler/GF/Speech/SRGS_ABNF.hs
+++ b/src/compiler/GF/Speech/SRGS_ABNF.hs
@@ -5,7 +5,7 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/11/01 20:09:04 $ 
+-- > CVS $Date: 2005/11/01 20:09:04 $
 -- > CVS $Author: bringert $
 -- > CVS $Revision: 1.16 $
 --
@@ -38,7 +38,7 @@ width :: Int
 width = 75
 
 srgsAbnfPrinter :: Options
-	        -> PGF -> CId -> String
+                -> PGF -> CId -> String
 srgsAbnfPrinter opts pgf cnc = showDoc $ prABNF sisr $ makeNonLeftRecursiveSRG opts pgf cnc
     where sisr = flag optSISR opts
 
@@ -72,7 +72,7 @@ prItem :: Maybe SISRFormat -> CFTerm -> SRGItem -> Doc
 prItem sisr t = f 0
   where
     f _ (REUnion [])  = pp "$VOID"
-    f p (REUnion xs) 
+    f p (REUnion xs)
         | not (null es) = brackets (f 0 (REUnion nes))
         | otherwise = (if p >= 1 then parens else id) (alts (map (f 1) xs))
       where (es,nes) = partition isEpsilon xs
@@ -84,13 +84,13 @@ prItem sisr t = f 0
 
 prSymbol :: Maybe SISRFormat -> CFTerm -> SRGSymbol -> Doc
 prSymbol sisr cn (NonTerminal n@(c,_)) = prCat c <+> tag sisr (catSISR cn n)
-prSymbol _ cn (Terminal t) 
+prSymbol _ cn (Terminal t)
     | all isPunct t = empty  -- removes punctuation
     | otherwise = pp t -- FIXME: quote if there is whitespace or odd chars
 
 tag :: Maybe SISRFormat -> (SISRFormat -> SISRTag) -> Doc
 tag Nothing _ = empty
-tag (Just fmt) t = 
+tag (Just fmt) t =
     case t fmt of
       [] -> empty
       -- grr, silly SRGS ABNF does not have an escaping mechanism
@@ -125,4 +125,3 @@ prepunctuate p (x:xs) = x : map (p <>) xs
 
 ($++$) :: Doc -> Doc -> Doc
 x $++$ y = x $$ emptyLine $$ y
-
diff --git a/src/compiler/GF/Speech/SRGS_XML.hs b/src/compiler/GF/Speech/SRGS_XML.hs
index 397bfb739..17d8eec5c 100644
--- a/src/compiler/GF/Speech/SRGS_XML.hs
+++ b/src/compiler/GF/Speech/SRGS_XML.hs
@@ -34,13 +34,13 @@ prSrgsXml :: Maybe SISRFormat -> SRG -> String
 prSrgsXml sisr srg = showXMLDoc (optimizeSRGS xmlGr)
     where
     xmlGr = grammar sisr (srgStartCat srg) (srgLanguage srg) $
-              [meta "description" 
+              [meta "description"
                  ("SRGS XML speech recognition grammar for " ++ srgName srg ++ "."),
                meta "generator" "Grammatical Framework"]
-	    ++ map ruleToXML (srgRules srg)
+               ++ map ruleToXML (srgRules srg)
     ruleToXML (SRGRule cat alts) = Tag "rule" ([("id",cat)]++pub) (prRhs alts)
         where pub = if isExternalCat srg cat then [("scope","public")] else []
-    prRhs rhss = [oneOf (map (mkProd sisr) rhss)] 
+    prRhs rhss = [oneOf (map (mkProd sisr) rhss)]
 
 mkProd :: Maybe SISRFormat -> SRGAlt -> XML
 mkProd sisr (SRGAlt mp n rhs) = Tag "item" [] (ti ++ [x] ++ tf)
@@ -50,9 +50,9 @@ mkProd sisr (SRGAlt mp n rhs) = Tag "item" [] (ti ++ [x] ++ tf)
 
 mkItem :: Maybe SISRFormat -> CFTerm -> SRGItem -> XML
 mkItem sisr cn = f
-  where 
+  where
     f (REUnion [])  = ETag "ruleref" [("special","VOID")]
-    f (REUnion xs) 
+    f (REUnion xs)
         | not (null es) = Tag "item" [("repeat","0-1")] [f (REUnion nes)]
         | otherwise = oneOf (map f xs)
       where (es,nes) = partition isEpsilon xs
@@ -62,7 +62,7 @@ mkItem sisr cn = f
     f (RESymbol s)  = symItem sisr cn s
 
 symItem :: Maybe SISRFormat -> CFTerm -> Symbol SRGNT Token -> XML
-symItem sisr cn (NonTerminal n@(c,_)) = 
+symItem sisr cn (NonTerminal n@(c,_)) =
     Tag "item" [] $ [ETag "ruleref" [("uri","#" ++ c)]] ++ tag sisr (catSISR cn n)
 symItem _ _ (Terminal t) = Tag "item" [] [Data (showToken t)]
 
@@ -81,12 +81,12 @@ oneOf = Tag "one-of" []
 grammar :: Maybe SISRFormat
         -> String  -- ^ root
         -> Maybe String -- ^language
-	-> [XML] -> XML
-grammar sisr root ml = 
+        -> [XML] -> XML
+grammar sisr root ml =
     Tag "grammar" $ [("xmlns","http://www.w3.org/2001/06/grammar"),
-		     ("version","1.0"),
-		     ("mode","voice"),
-		     ("root",root)]
+                     ("version","1.0"),
+                     ("mode","voice"),
+                     ("root",root)]
                  ++ (if isJust sisr then [("tag-format","semantics/1.0")] else [])
                  ++ maybe [] (\l -> [("xml:lang", l)]) ml
 
@@ -94,7 +94,7 @@ meta :: String -> String -> XML
 meta n c = ETag "meta" [("name",n),("content",c)]
 
 optimizeSRGS :: XML -> XML
-optimizeSRGS = bottomUpXML f 
+optimizeSRGS = bottomUpXML f
   where f (Tag "item" [] [x@(Tag "item" _ _)]) = x
         f (Tag "item" [] [x@(Tag "one-of" _ _)]) = x
         f (Tag "item" as [Tag "item" [] xs]) = Tag "item" as xs
diff --git a/src/compiler/GF/Text/Transliterations.hs b/src/compiler/GF/Text/Transliterations.hs
index 9b1b6e151..8dbc02823 100644
--- a/src/compiler/GF/Text/Transliterations.hs
+++ b/src/compiler/GF/Text/Transliterations.hs
@@ -17,7 +17,7 @@ import qualified Data.Map as Map
 -- to add a new one: define the Unicode range and the corresponding ASCII strings,
 -- which may be one or more characters long
 
--- conventions to be followed: 
+-- conventions to be followed:
 --   each character is either [letter] or [letter+nonletters]
 --   when using a sparse range of unicodes, mark missing codes as "-" in transliterations
 --   characters can be invisible: ignored in translation to unicode
@@ -33,7 +33,7 @@ transliterateWithFile name src isFrom =
   (if isFrom then appTransFromUnicode else appTransToUnicode) (getTransliterationFile name src)
 
 transliteration :: String -> Maybe Transliteration
-transliteration s = Map.lookup s allTransliterations 
+transliteration s = Map.lookup s allTransliterations
 
 allTransliterations = Map.fromList [
   ("amharic",transAmharic),
@@ -67,25 +67,25 @@ data Transliteration = Trans {
   }
 
 appTransToUnicode :: Transliteration -> String -> String
-appTransToUnicode trans = 
+appTransToUnicode trans =
   concat .
   map (\c -> maybe c (return . toEnum) $
              Map.lookup c (trans_to_unicode trans)
-      ) . 
-  filter (flip notElem (invisible_chars trans)) . 
+      ) .
+  filter (flip notElem (invisible_chars trans)) .
   unchar
 
 appTransFromUnicode :: Transliteration -> String -> String
-appTransFromUnicode trans = 
+appTransFromUnicode trans =
   concat .
-  map (\c -> maybe [toEnum c] id $ 
+  map (\c -> maybe [toEnum c] id $
              Map.lookup c (trans_from_unicode trans)
-      ) . 
+      ) .
   map fromEnum
 
 
 mkTransliteration :: String -> [String] -> [Int] -> Transliteration
-mkTransliteration name ts us = 
+mkTransliteration name ts us =
  Trans (Map.fromList (tzip ts us)) (Map.fromList (uzip us ts)) [] name
   where
     tzip ts us = [(t,u) | (t,u) <- zip ts us, t /= "-"]
@@ -102,7 +102,7 @@ getTransliterationFile name = uncurry (mkTransliteration name) . codes
 
 unchar :: String -> [String]
 unchar s = case s of
-  c:d:cs 
+  c:d:cs
    | isAlpha d -> [c]    : unchar (d:cs)
    | isSpace d -> [c]:[d]: unchar cs
    | otherwise -> let (ds,cs2) = break (\x -> isAlpha x || isSpace x) cs in
@@ -122,8 +122,8 @@ transThai = mkTransliteration "Thai" allTrans allCodes where
   allCodes = [0x0e00 .. 0x0e7f]
 
 transDevanagari :: Transliteration
-transDevanagari = 
-  (mkTransliteration "Devanagari" 
+transDevanagari =
+  (mkTransliteration "Devanagari"
     allTransUrduHindi allCodes){invisible_chars = ["a"]} where
       allCodes = [0x0900 .. 0x095f] ++ [0x0966 .. 0x096f]
 
@@ -136,13 +136,13 @@ allTransUrduHindi = words $
     "-  -  -  -  -  -  -  -  q  x  g.  z  R R'  f  -  " ++
     "N0 N1 N2 N3 N4 N5 N6 N7 N8 N9 "
 
-
+
 transUrdu :: Transliteration
-transUrdu = 
+transUrdu =
   (mkTransliteration "Urdu" allTrans allCodes) where
-    allCodes = [0x0622 .. 0x062f] ++ [0x0630 .. 0x063a] ++ [0x0641,0x0642] ++ [0x06A9] ++ [0x0644 .. 0x0648] ++ 
+    allCodes = [0x0622 .. 0x062f] ++ [0x0630 .. 0x063a] ++ [0x0641,0x0642] ++ [0x06A9] ++ [0x0644 .. 0x0648] ++
                [0x0654,0x0658,0x0679,0x067e,0x0686,0x0688,0x0691,0x0698,0x06af,0x06c1,0x06c3,0x06cc,0x06ba,0x06be,0x06d2] ++
-			   [0x06f0 .. 0x06f9] ++ [0x061f,0x06D4]
+               [0x06f0 .. 0x06f9] ++ [0x061f,0x06D4]
     allTrans = words $
       "A - w^ - y^ a b - t C j H K d " ++  -- 0622 - 062f
       "Z r z s X S Z- t- z- e G "   ++  -- 0630 - 063a
@@ -151,22 +151,22 @@ transUrdu =
       "N0 N1 N2 N3 N4 N5 N6 N7 N8 N9 " ++ "? ."
 
 transSindhi :: Transliteration
-transSindhi = 
+transSindhi =
   (mkTransliteration "Sindhi" allTrans allCodes) where
     allCodes = [0x062e] ++ [0x0627 .. 0x062f] ++ [0x0630 .. 0x063a] ++ [0x0641 .. 0x0648] ++
                [0x067a,0x067b,0x067d,0x067e,0x067f] ++ [0x0680 .. 0x068f] ++
                [0x0699,0x0918,0x06a6,0x061d,0x06a9,0x06af,0x06b3,0x06bb,0x06be,0x06f6,0x064a,0x06b1, 0x06aa, 0x06fd, 0x06fe] ++
-			   [0x06f0 .. 0x06f9] ++ [0x061f,0x06D4]
+               [0x06f0 .. 0x06f9] ++ [0x061f,0x06D4]
     allTrans = words $
       "K a b - t C j H - d " ++  -- 0626 - 062f
       "Z r z s X S Z- t- z- e G "   ++  -- 0630 - 063a
       "f q - L m n - W "    ++  -- 0641 - 0648
       "T! B T p T' " ++  -- 067a,067b,067d,067e,067f
       "B' - - Y' J' - c c' - - d! - d' D - D' " ++  -- 0680 - 068f
-      "R - F' - k' g G' t' h' e' y c! k A M " ++  -- 0699, 0918, 06a6, 061d, 06a9,06af,06b3,06bb,06be,06f6,06cc,06b1 
+      "R - F' - k' g G' t' h' e' y c! k A M " ++  -- 0699, 0918, 06a6, 061d, 06a9,06af,06b3,06bb,06be,06f6,06cc,06b1
       "N0 N1 N2 N3 N4 N5 N6 N7 N8 N9 " ++ "? ."
 
-    
+
 
 transArabic :: Transliteration
 transArabic = mkTransliteration "Arabic" allTrans allCodes where
@@ -175,8 +175,8 @@ transArabic = mkTransliteration "Arabic" allTrans allCodes where
     "W  r  z  s  C S  D  T  Z  c  G "                 ++  -- 0630 - 063a
     "   f  q  k  l  m  n  h  w  y. y a. u. i. a  u "  ++  -- 0641 - 064f
     "i  v2 o  a: V+ V- i: a+ "                        ++  -- 0650 - 0657
-    "A*  q?"                                              -- 0671 (used by AED) 
-  allCodes = [0x0621..0x062f] ++ [0x0630..0x063a] ++ 
+    "A*  q?"                                              -- 0671 (used by AED)
+  allCodes = [0x0621..0x062f] ++ [0x0630..0x063a] ++
              [0x0641..0x064f] ++ [0x0650..0x0657] ++ [0x0671,0x061f]
 
 
@@ -193,16 +193,16 @@ transPersian = (mkTransliteration "Persian/Farsi" allTrans allCodes)
     "   V  A: A? w? A- y? A  b  t. t  t-  j  H  K  d " ++  -- 0621 - 062f
     "W  r  z  s  C  S  D  T  Z  c  G "                 ++  -- 0630 - 063a
     "   f  q  -  l  m  n  h  v  -  y. a. u. i. a  u "   ++  -- 0640 - 064f
-    "i  v2 o  a: V+ V- i: a+ " ++                          -- 0650 - 0657 
+    "i  v2 o  a: V+ V- i: a+ " ++                          -- 0650 - 0657
     "p  c^ J  k  g  y q? Z0"
-  allCodes = [0x0621..0x062f] ++ [0x0630..0x063a] ++ 
-             [0x0641..0x064f] ++ [0x0650..0x0657] ++ 
+  allCodes = [0x0621..0x062f] ++ [0x0630..0x063a] ++
+             [0x0641..0x064f] ++ [0x0650..0x0657] ++
              [0x067e,0x0686,0x0698,0x06a9,0x06af,0x06cc,0x061f,0x200c]
 
 transNepali :: Transliteration
 transNepali = mkTransliteration "Nepali" allTrans allCodes where
   allTrans = words $
-    "z+  z= " ++ 
+    "z+  z= " ++
     "-  V  M  h: -  H  A  i: I: f  F  Z  -  -  -  e: " ++
     "E: -  -  O  W  k  K  g  G  n: C  c  j  J  Y  q  " ++
     "Q  x  X  N  t  T  d  D  n  -  p  P  b  B  m  y  " ++
@@ -241,7 +241,7 @@ transGreek = mkTransliteration "modern Greek" allTrans allCodes where
     "i= A  B  G  D  E  Z  H  V  I  K  L  M  N  X  O  " ++
     "P  R  -  S  T  Y  F  C  Q  W  I- Y- a' e' h' i' " ++
     "y= a  b  g  d  e  z  h  v  i  k  l  m  n  x  o  " ++
-    "p  r  s* s  t  y  f  c  q  w  i- y- o' y' w' -  "    
+    "p  r  s* s  t  y  f  c  q  w  i- y- o' y' w' -  "
   allCodes = [0x0380 .. 0x03cf]
 
 transAncientGreek :: Transliteration
@@ -261,32 +261,32 @@ transAncientGreek = mkTransliteration "ancient Greek" allTrans allCodes where
    "y)  y(  y)` y(` y)' y(' y)~ y(~ -   Y(  -   Y(` -   Y(' -   Y(~ " ++
    "w)  w(  w)` w(` w)' w(' w)~ w(~ W)  W(  W)` W(` W)' W(' W)~ W(~ " ++
    "a`  a'  e`  e'  h`  h'  i`  i'  o`  o'  y`  y'  w`  w'  -   -   " ++
-   "a|) a|( a|)` a|(` a|)' a|(' a|)~ a|(~ - - - - - - - - " ++ -- 1f80-  
-   "h|) h|( h|)` h|(` h|)' h|(' h|)~ h|(~ - - - - - - - - " ++ -- 1f90-  
-   "w|) w|( w|)` w|(` w|)' w|(' w|)~ w|(~ - - - - - - - - " ++ -- 1fa0-  
+   "a|) a|( a|)` a|(` a|)' a|(' a|)~ a|(~ - - - - - - - - " ++ -- 1f80-
+   "h|) h|( h|)` h|(` h|)' h|(' h|)~ h|(~ - - - - - - - - " ++ -- 1f90-
+   "w|) w|( w|)` w|(` w|)' w|(' w|)~ w|(~ - - - - - - - - " ++ -- 1fa0-
    "a.  a_  a|` a|  a|'  -  a~ a|~ - - - - - - - - " ++ -- 1fb0-
    "-  -  h|` h|  h|'  -  h~ h|~ - - - - - - - - " ++ -- 1fc0-
    "i. i_ i=` i=' -    -  i~ i=~ - - - - - - - - " ++ -- 1fd0-
-   "y. y_ y=` y=' r)   r( y~ y=~ - - - - - - - - " ++ -- 1fe0-   
+   "y. y_ y=` y=' r)   r( y~ y=~ - - - - - - - - " ++ -- 1fe0-
    "-  -  w|` w|  w|'  -  w~ w|~ - - - - - - - - " ++ -- 1ff0-
    -- HL, Private Use Area Code Points (New Athena Unicode, Cardo, ALPHABETUM, Antioch)
    -- see: http://apagreekkeys.org/technicalDetails.html
    --      GreekKeys Support by Donald Mastronarde
-   "- - - - - - - - - e. o. R) Y) Y)` Y)' Y)~ "    ++ -- e1a0-e1af  
+   "- - - - - - - - - e. o. R) Y) Y)` Y)' Y)~ "    ++ -- e1a0-e1af
    "e~ e)~ e(~ e_ e_' e_` e_) e_( e_)` e_(` e_)' e_(' E)~ E(~ E_ E. " ++ -- e1b0-e1bf
    "o~ o)~ o(~ o_ o_' o_` o_) o_( o_)` o_(` o_)' o_(' O)~ O(~ O_ O. " ++ -- e1c0-e1cf
-   "a_` - a_~ a_)` a_(` a_)~ a_(~ - a.` a.) a.)` a.(' a.(` - - - "    ++ -- eaf0-eaff  
-   "a_' - - - a_) a_( - a_)' - a_(' a.' a.( a.)' - - - "              ++ -- eb00-eb0f  
+   "a_` - a_~ a_)` a_(` a_)~ a_(~ - a.` a.) a.)` a.(' a.(` - - - "    ++ -- eaf0-eaff
+   "a_' - - - a_) a_( - a_)' - a_(' a.' a.( a.)' - - - "              ++ -- eb00-eb0f
    "e_)~ e_(~ - - - - - e_~ - - - - - - - - "                         ++ -- eb20-eb2f
-   "- - - - - - i_~ - i_` i_' - - i_) i_)' i_( i_(' "                 ++ -- eb30-eb3f   
+   "- - - - - - i_~ - i_` i_' - - i_) i_)' i_( i_(' "                 ++ -- eb30-eb3f
    "i.' i.) i.)' i.( i.` i.)` - i.(' i.(` - - - - - - - "             ++ -- eb40-eb4f
    "- - - - i_)` i_(` - i_)~ i_(~ - o_~ o_)~ o_(~ - - - "             ++ -- eb50-eb5f
    "y_` " ++ -- eb6f
    "y_~ y_)` - - - y_(` - y_)~ y_(~ - y_' - - y_) y_( y_)' "  ++         -- eb70-eb7f
    "y_(' y.' y.( y.` y.) y.)' - - y.)` y.(' y.(` - - - - - "             -- eb80-eb8f
- allCodes =  -- [0x00B0 .. 0x00Bf] 
-             [0x0380 .. 0x03cf] ++ [0x1f00 .. 0x1fff] 
-          ++ [0xe1a0 .. 0xe1af] 
+ allCodes =  -- [0x00B0 .. 0x00Bf]
+             [0x0380 .. 0x03cf] ++ [0x1f00 .. 0x1fff]
+          ++ [0xe1a0 .. 0xe1af]
           ++ [0xe1b0 .. 0xe1bf]
           ++ [0xe1c0 .. 0xe1cf]
           ++ [0xeaf0 .. 0xeaff]
@@ -297,36 +297,34 @@ transAncientGreek = mkTransliteration "ancient Greek" allTrans allCodes where
           ++ [0xeb50 .. 0xeb5f] ++ [0xeb6f]
           ++ [0xeb70 .. 0xeb7f]
           ++ [0xeb80 .. 0xeb8f]
- 
-transAmharic :: Transliteration
+
+transAmharic :: Transliteration
 transAmharic = mkTransliteration "Amharic" allTrans allCodes where
- 
-allTrans = words $
-    
-  	" h.  h-  h'  h(  h)  h  h?  h*  l.  l-  l'  l(  l)  l  l?  l*  "++
-	" H.  H-  H'  H(  H)  H  H?  H*  m.  m-  m'  m(  m)  m  m?  m*  "++
-	" s.  s-  s'  s(  s)  s  s?  s*  r.  r-  r'  r(  r)  r  r?  r* "++
-	" -   -   -   -   -  -   -  -   x.  x-  x'  x(  x)  x  x?   x* "++
-	" q.  q-  q'  q(  q)  q  q?  q*  -   -   -   -   -   -  -   - "++
-	" -   -   -   -   -   -  -   -   -   -   -   -   -   -  -   - "++
-	" b.  b-  b'  b(  b)  b  b?  b*  v.  v-  v'  v(  v)  v  v?  v* "++
-	" t.  t-  t'  t(  t)  t  t?  t*  c.  c-  c'  c(  c)  c  c?  c* "++
-	" X.  X-  X'  X(  X)  X  X?  -   -   -   -   X*  -   -  -   - "++
-	" n.  n-  n'  n(  n)  n  n?  n*  N.  N-  N'  N(  N)  N  N?  N* "++
-	" a   u   i   A   E   e  o   e*  k.  k-  k'  k(  k)  k  k?  - "++
-	" -   -   -   k*  -   -  -   -   -   -   -   -   -   -  -   - "++
-	" -   -   -   -   -   -  -   -   w.  w-  w'  w(  w)  w  w?  w* "++
-	" -   -   -   -   -   -  -   -   z.  z-  z'  z(  z)  z  z?  z* "++
-	" Z.  Z-  Z'  Z(  Z)  Z  Z?  Z*  y.  y-  y'  y(  y)  y  y?  y* "++
-	" d.  d-  d'  d(  d)  d  d?  d*  -   -   -   -   -   -  -   - "++
-	" j.  j-  j'  j(  j)  j  j?  j*  g.  g-  g'  g(  g)  g  g?  - "++
-	" -   -   -   g*  -   -  -   -   -   -   -   -   -   -  -   - "++
-	" T.  T-  T'  T(  T)  T  T?  T*  C.  C-  C'  C(  C)  C  C?  C* "++
-	" P.  P-  P'  P(  P)  P  P?  P*  S.  S-  S'  S(  S)  S  S?  S* "++
-	" -   -   -   -   -   -  -   -   f.  f-  f'  f(  f)  f  f?  f*"++
-	" p.  p-  p'  p(  p)  p  p?  p*" 	
-allCodes = [0x1200..0x1357]
- 
+  allTrans = words $
+    " h.  h-  h'  h(  h)  h  h?  h*  l.  l-  l'  l(  l)  l  l?  l*  "++
+    " H.  H-  H'  H(  H)  H  H?  H*  m.  m-  m'  m(  m)  m  m?  m*  "++
+    " s.  s-  s'  s(  s)  s  s?  s*  r.  r-  r'  r(  r)  r  r?  r* "++
+    " -   -   -   -   -  -   -  -   x.  x-  x'  x(  x)  x  x?   x* "++
+    " q.  q-  q'  q(  q)  q  q?  q*  -   -   -   -   -   -  -   - "++
+    " -   -   -   -   -   -  -   -   -   -   -   -   -   -  -   - "++
+    " b.  b-  b'  b(  b)  b  b?  b*  v.  v-  v'  v(  v)  v  v?  v* "++
+    " t.  t-  t'  t(  t)  t  t?  t*  c.  c-  c'  c(  c)  c  c?  c* "++
+    " X.  X-  X'  X(  X)  X  X?  -   -   -   -   X*  -   -  -   - "++
+    " n.  n-  n'  n(  n)  n  n?  n*  N.  N-  N'  N(  N)  N  N?  N* "++
+    " a   u   i   A   E   e  o   e*  k.  k-  k'  k(  k)  k  k?  - "++
+    " -   -   -   k*  -   -  -   -   -   -   -   -   -   -  -   - "++
+    " -   -   -   -   -   -  -   -   w.  w-  w'  w(  w)  w  w?  w* "++
+    " -   -   -   -   -   -  -   -   z.  z-  z'  z(  z)  z  z?  z* "++
+    " Z.  Z-  Z'  Z(  Z)  Z  Z?  Z*  y.  y-  y'  y(  y)  y  y?  y* "++
+    " d.  d-  d'  d(  d)  d  d?  d*  -   -   -   -   -   -  -   - "++
+    " j.  j-  j'  j(  j)  j  j?  j*  g.  g-  g'  g(  g)  g  g?  - "++
+    " -   -   -   g*  -   -  -   -   -   -   -   -   -   -  -   - "++
+    " T.  T-  T'  T(  T)  T  T?  T*  C.  C-  C'  C(  C)  C  C?  C* "++
+    " P.  P-  P'  P(  P)  P  P?  P*  S.  S-  S'  S(  S)  S  S?  S* "++
+    " -   -   -   -   -   -  -   -   f.  f-  f'  f(  f)  f  f?  f*"++
+    " p.  p-  p'  p(  p)  p  p?  p*"
+  allCodes = [0x1200..0x1357]
+
 -- by Prasad 31/5/2013
 transSanskrit :: Transliteration
 transSanskrit = (mkTransliteration "Sanskrit" allTrans allCodes) {invisible_chars = ["a"]} where
diff --git a/src/runtime/haskell-bind/pgf2.cabal b/src/runtime/haskell-bind/pgf2.cabal
index eb1e3c708..1d5f61991 100644
--- a/src/runtime/haskell-bind/pgf2.cabal
+++ b/src/runtime/haskell-bind/pgf2.cabal
@@ -26,7 +26,7 @@ library
     PGF2.Expr,
     PGF2.Type
   build-depends:
-    base >= 4.9.1 && <4.15,
+    base >= 4.9.1 && < 4.15,
     containers >= 0.5.7 && < 0.7,
     pretty >= 1.1.3 && < 1.2
   default-language: Haskell2010
diff --git a/src/runtime/haskell/pgf.cabal b/src/runtime/haskell/pgf.cabal
index 56c1ca04a..ab54be441 100644
--- a/src/runtime/haskell/pgf.cabal
+++ b/src/runtime/haskell/pgf.cabal
@@ -14,7 +14,7 @@ tested-with: GHC==7.10.3, GHC==8.0.2, GHC==8.10.4
 library
   default-language: Haskell2010
   build-depends:
-    base >= 4.9.1 && <4.15,
+    base >= 4.9.1 && < 4.15,
     array >= 0.5.1 && < 0.6,
     containers >= 0.5.7 && < 0.7,
     bytestring >= 0.10.8 && < 0.11,
-- 
cgit v1.2.3


From 0954b4cbab2564c4d35043a87fddc9aee26b4166 Mon Sep 17 00:00:00 2001
From: "John J. Camilleri" <john@digitalgrammars.com>
Date: Wed, 7 Jul 2021 13:04:09 +0200
Subject: More cabal file cleanup. Remove some more tabs from Haskell source.

---
 gf.cabal                            | 45 ++++++++++++++++++++-----------------
 src/compiler/GF/Interactive2.hs     |  2 +-
 src/compiler/SimpleEditor/Syntax.hs |  8 +++----
 src/runtime/haskell/pgf.cabal       | 18 ++++++++-------
 src/server/URLEncoding.hs           | 18 +++++++--------
 src/server/transfer/Fold.hs         |  8 +++----
 6 files changed, 52 insertions(+), 47 deletions(-)

(limited to 'src')

diff --git a/gf.cabal b/gf.cabal
index e5cd46e32..711acaeb2 100644
--- a/gf.cabal
+++ b/gf.cabal
@@ -41,11 +41,11 @@ data-files:
 
 custom-setup
   setup-depends:
-    base,
-    Cabal >=1.22.0.0,
+    base >= 4.9.1 && < 4.15,
+    Cabal >= 1.22.0.0,
     directory >= 1.3.0 && < 1.4,
     filepath >= 1.4.1 && < 1.5,
-    process >=1.0.1.1
+    process >= 1.0.1.1 && < 1.7
 
 source-repository head
   type: git
@@ -75,20 +75,23 @@ library
   default-language: Haskell2010
   build-depends:
     -- GHC 8.0.2 to GHC 8.10.4
-    base >= 4.9.1 && < 4.15,
     array >= 0.5.1 && < 0.6,
-    containers >= 0.5.7 && < 0.7,
+    base >= 4.9.1 && < 4.15,
     bytestring >= 0.10.8 && < 0.11,
-    utf8-string >= 1.0.1.1 && < 1.1,
-    random >= 1.1 && < 1.3,
-    pretty >= 1.1.3 && < 1.2,
-    mtl >= 2.2.1 && < 2.3,
-    -- For compatability with GHC < 8
+    containers >= 0.5.7 && < 0.7,
     exceptions >= 0.8.3 && < 0.11,
-    fail >= 4.9.0 && < 4.10,
+    ghc-prim >= 0.5.0 && < 0.7,
+    mtl >= 2.2.1 && < 2.3,
+    pretty >= 1.1.3 && < 1.2,
+    random >= 1.1 && < 1.3,
+    utf8-string >= 1.0.1.1 && < 1.1,
     -- We need transformers-compat >= 0.6.3, but that is only in newer snapshots where it is redundant.
-    transformers-compat >= 0.5.1.4 && < 0.7,
-    ghc-prim >= 0.5.0 && < 0.7
+    transformers-compat >= 0.5.1.4 && < 0.7
+
+  if impl(ghc<8.0)
+    build-depends:
+      fail >= 4.9.0 && < 4.10
+
   hs-source-dirs: src/runtime/haskell
 
   other-modules:
@@ -152,13 +155,13 @@ library
 ---- GF compiler as a library:
 
   build-depends:
-    filepath >= 1.4.1 && < 1.5,
     directory >= 1.3.0 && < 1.4,
-    time >= 1.6.0 && < 1.10,
-    process >= 1.4.3 && < 1.7,
+    filepath >= 1.4.1 && < 1.5,
     haskeline >= 0.7.3 && < 0.9,
+    json >= 0.9.1 && < 0.11,
     parallel >= 3.2.1.1 && < 3.3,
-    json >= 0.9.1 && < 0.11
+    process >= 1.4.3 && < 1.7,
+    time >= 1.6.0 && < 1.10
 
   hs-source-dirs: src/compiler
   exposed-modules:
@@ -292,9 +295,9 @@ library
 
   if flag(server)
     build-depends:
+      cgi >= 3001.3.0.2 && < 3001.6,
       httpd-shed >= 0.4.0 && < 0.5,
-      network>=2.3 && <2.7,
-      cgi >= 3001.3.0.2 && < 3001.6
+      network>=2.3 && <2.7
     if flag(network-uri)
       build-depends:
         network-uri >= 2.6.1.0 && < 2.7,
@@ -346,8 +349,8 @@ library
       Win32 >= 2.3.1.1 && < 2.7
   else
     build-depends:
-      unix >= 2.7.2 && < 2.8,
-      terminfo >=0.4.0 && < 0.5
+      terminfo >=0.4.0 && < 0.5,
+      unix >= 2.7.2 && < 2.8
 
   if impl(ghc>=8.2)
     ghc-options: -fhide-source-paths
diff --git a/src/compiler/GF/Interactive2.hs b/src/compiler/GF/Interactive2.hs
index 6967309b9..d429b4530 100644
--- a/src/compiler/GF/Interactive2.hs
+++ b/src/compiler/GF/Interactive2.hs
@@ -437,7 +437,7 @@ wc_type = cmd_name
         x2 = takeWhile (\c -> isIdent c || isSpace c || c == '-' || c == '=' || c == '"') x1
 
         cmd = case [x | (x,cs) <- RP.readP_to_S pCommand x2, all isSpace cs] of
-	        [x] -> Just x
+                [x] -> Just x
                 _   -> Nothing
 
     isIdent c = c == '_' || c == '\'' || isAlphaNum c
diff --git a/src/compiler/SimpleEditor/Syntax.hs b/src/compiler/SimpleEditor/Syntax.hs
index 4a5eb6da8..8280ed461 100644
--- a/src/compiler/SimpleEditor/Syntax.hs
+++ b/src/compiler/SimpleEditor/Syntax.hs
@@ -23,10 +23,10 @@ data Fun      = Fun      { fname:: FunId, ftype:: Type }
 
 data Concrete = Concrete { langcode:: Id,
                            opens:: [ModId],
-		           params:: [Param],
-		           lincats:: [Lincat],
-		           opers:: [Oper],
-		           lins:: [Lin] }
+                           params:: [Param],
+                           lincats:: [Lincat],
+                           opers:: [Oper],
+                           lins:: [Lin] }
                 deriving Show
 
 data Param  = Param  {pname:: Id, prhs:: String}              deriving Show
diff --git a/src/runtime/haskell/pgf.cabal b/src/runtime/haskell/pgf.cabal
index ab54be441..41e67f6ae 100644
--- a/src/runtime/haskell/pgf.cabal
+++ b/src/runtime/haskell/pgf.cabal
@@ -14,17 +14,19 @@ tested-with: GHC==7.10.3, GHC==8.0.2, GHC==8.10.4
 library
   default-language: Haskell2010
   build-depends:
-    base >= 4.9.1 && < 4.15,
     array >= 0.5.1 && < 0.6,
-    containers >= 0.5.7 && < 0.7,
+    base >= 4.9.1 && < 4.15,
     bytestring >= 0.10.8 && < 0.11,
-    utf8-string >= 1.0.1.1 && < 1.1,
-    random >= 1.1 && < 1.3,
-    pretty >= 1.1.3 && < 1.2,
-    mtl >= 2.2.1 && < 2.3,
+    containers >= 0.5.7 && < 0.7,
     ghc-prim >= 0.5.0 && < 0.7,
-    -- For compatability with GHC < 8
-    fail >= 4.9.0 && < 4.10
+    mtl >= 2.2.1 && < 2.3,
+    pretty >= 1.1.3 && < 1.2,
+    random >= 1.1 && < 1.3,
+    utf8-string >= 1.0.1.1 && < 1.1
+
+  if impl(ghc<8.0)
+    build-depends:
+      fail >= 4.9.0 && < 4.10
 
   other-modules:
     -- not really part of GF but I have changed the original binary library
diff --git a/src/server/URLEncoding.hs b/src/server/URLEncoding.hs
index 881ca21cd..1a8f579b2 100644
--- a/src/server/URLEncoding.hs
+++ b/src/server/URLEncoding.hs
@@ -6,9 +6,9 @@ import Data.Char (chr,digitToInt,isHexDigit)
 -- | Decode hexadecimal escapes
 urlDecodeUnicode :: String -> String
 urlDecodeUnicode [] = ""
-urlDecodeUnicode ('%':'u':x1:x2:x3:x4:s) 
+urlDecodeUnicode ('%':'u':x1:x2:x3:x4:s)
     | all isHexDigit [x1,x2,x3,x4] =
-    chr (    digitToInt x1 `shiftL` 12 
+    chr (    digitToInt x1 `shiftL` 12
          .|. digitToInt x2 `shiftL` 8
          .|. digitToInt x3 `shiftL` 4
          .|. digitToInt x4) : urlDecodeUnicode s
@@ -45,8 +45,8 @@ fromhex2 d1 d2 = 16*digitToInt d1+digitToInt d2
 -- Repeatedly extract (and transform) values until a predicate hold.  Return the list of values.
 unfoldr :: (a -> (b, a)) -> (a -> Bool) -> a -> [b]
 unfoldr f p x | p x       = []
-	      | otherwise = y:unfoldr f p x'
-			      where (y, x') = f x
+              | otherwise = y:unfoldr f p x'
+                              where (y, x') = f x
 
 chopList :: ([a] -> (b, [a])) -> [a] -> [b]
 chopList f l = unfoldr f null l
@@ -54,8 +54,8 @@ chopList f l = unfoldr f null l
 breakAt :: (Eq a) => a -> [a] -> ([a], [a])
 breakAt _ [] = ([], [])
 breakAt x (x':xs) =
-	if x == x' then
-	    ([], xs)
-	else
-	    let (ys, zs) = breakAt x xs
-	    in  (x':ys, zs)
+    if x == x' then
+        ([], xs)
+    else
+        let (ys, zs) = breakAt x xs
+        in  (x':ys, zs)
diff --git a/src/server/transfer/Fold.hs b/src/server/transfer/Fold.hs
index 61f0d4b34..165e762fb 100644
--- a/src/server/transfer/Fold.hs
+++ b/src/server/transfer/Fold.hs
@@ -13,14 +13,14 @@ fold t =
   case unApp t of
     Just (i,[x])  ->
         case M.lookup i foldable of
-	        Just j -> appFold j x
-	        _      -> mkApp i [fold x]
+          Just j -> appFold j x
+          _      -> mkApp i [fold x]
     Just (i,xs)   -> mkApp i $ map fold xs
     _             -> t
 
 appFold :: CId -> Tree -> Tree
-appFold j t = 
+appFold j t =
   case unApp t of
     Just (i,[t,ts]) | isPre i "Cons"  -> mkApp j [fold t, appFold j ts]
     Just (i,[t,s])  | isPre i "Base"  -> mkApp j [fold t, fold s]
-  where isPre i s = take 4 (show i) == s
\ No newline at end of file
+  where isPre i s = take 4 (show i) == s
-- 
cgit v1.2.3


From cdbe73eb475cf44e1a45b2abacb12756e394016a Mon Sep 17 00:00:00 2001
From: "John J. Camilleri" <john@digitalgrammars.com>
Date: Thu, 8 Jul 2021 12:10:41 +0200
Subject: Remove two missing-methods warnings

---
 src/compiler/GF/Compile/Compute/Predef.hs | 4 ++++
 src/runtime/haskell/PGF/Binary.hs         | 3 ++-
 2 files changed, 6 insertions(+), 1 deletion(-)

(limited to 'src')

diff --git a/src/compiler/GF/Compile/Compute/Predef.hs b/src/compiler/GF/Compile/Compute/Predef.hs
index 609a17798..b9e23d424 100644
--- a/src/compiler/GF/Compile/Compute/Predef.hs
+++ b/src/compiler/GF/Compile/Compute/Predef.hs
@@ -27,6 +27,10 @@ instance Predef Int where
 
 instance Predef Bool where
   toValue = boolV
+  fromValue v = case v of
+    VCApp (cPredef,cPTrue) [] -> return True
+    VCApp (cPredef,cPFalse) [] -> return False
+    _ -> verror "Bool" v
 
 instance Predef String where
   toValue = string
diff --git a/src/runtime/haskell/PGF/Binary.hs b/src/runtime/haskell/PGF/Binary.hs
index e0e50f4be..a78472ea9 100644
--- a/src/runtime/haskell/PGF/Binary.hs
+++ b/src/runtime/haskell/PGF/Binary.hs
@@ -28,7 +28,7 @@ instance Binary PGF where
            let v = (major,minor)
            if major==pgfMajorVersion && minor<=pgfMinorVersion
              then getPGF'
-             else if v==Old.version 
+             else if v==Old.version
                   then Old.getPGF'
                   else fail $ "Unsupported PGF version "++show (major,minor)
 
@@ -185,6 +185,7 @@ instance Binary Instr where
   put (PUSH_ACCUM (LFlt d)) = putWord8 78 >> put d
   put (POP_ACCUM          ) = putWord8 80
   put (ADD                ) = putWord8 84
+  get = fail "Missing implementation for ‘get’ in the instance declaration for ‘Binary Instr’"
 
 instance Binary Type where
   put (DTyp hypos cat exps) = put (hypos,cat,exps)
-- 
cgit v1.2.3


From a1fd3ea142f215d7a030b8a95d32ba0c55dd61fb Mon Sep 17 00:00:00 2001
From: "John J. Camilleri" <john@digitalgrammars.com>
Date: Thu, 8 Jul 2021 13:56:58 +0200
Subject: Fix bug introduced in cdbe73eb475cf44e1a45b2abacb12756e394016a

Apparently I don't understand how pattern-matching works in Haskell
---
 src/compiler/GF/Compile/Compute/Predef.hs | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

(limited to 'src')

diff --git a/src/compiler/GF/Compile/Compute/Predef.hs b/src/compiler/GF/Compile/Compute/Predef.hs
index b9e23d424..58b9b3447 100644
--- a/src/compiler/GF/Compile/Compute/Predef.hs
+++ b/src/compiler/GF/Compile/Compute/Predef.hs
@@ -28,8 +28,8 @@ instance Predef Int where
 instance Predef Bool where
   toValue = boolV
   fromValue v = case v of
-    VCApp (cPredef,cPTrue) [] -> return True
-    VCApp (cPredef,cPFalse) [] -> return False
+    VCApp (mn,i) [] | mn == cPredef && i == cPTrue -> return True
+    VCApp (mn,i) [] | mn == cPredef && i == cPFalse -> return False
     _ -> verror "Bool" v
 
 instance Predef String where
-- 
cgit v1.2.3


From bd270b05ff92b15c15d5dfebd52576d0e15d0b04 Mon Sep 17 00:00:00 2001
From: Andreas Källberg <anka.213@gmail.com>
Date: Sun, 29 Nov 2020 14:51:55 +0100
Subject: Remove the `Either Int` from value2term

This prevents HUGE space leak and makes compiling a PGF a LOT faster

For example, an application grammar moved from taking over 50GB
of ram and taking 5 minutes (most of which is spent on garbage colelction)
to taking 1.2 seconds and using 42mb of memory

The price we pay is that the "variable #n is out of scope" error is now
lazy and will happen when we try to evaluate the term instead of
happening when the function returns and allowing the caller to chose how
to handle the error.
I don't think this should matter in practice, since it's very rare;
at least Inari has never encountered it.
---
 src/compiler/GF/Compile/Compute/Concrete.hs | 66 +++++++++++++++--------------
 1 file changed, 34 insertions(+), 32 deletions(-)

(limited to 'src')

diff --git a/src/compiler/GF/Compile/Compute/Concrete.hs b/src/compiler/GF/Compile/Compute/Concrete.hs
index 4b54c8c84..a346de882 100644
--- a/src/compiler/GF/Compile/Compute/Concrete.hs
+++ b/src/compiler/GF/Compile/Compute/Concrete.hs
@@ -493,57 +493,59 @@ vtrace loc arg res = trace (render (hang (pv arg) 4 ("->"<+>pv res))) res
     pf (_,v) = ppV v
     pa (_,v) = ppV v
     ppV v = case value2term' True loc [] v of
-              Left i  -> "variable #" <> pp i <+> "is out of scope"
-              Right t -> ppTerm Unqualified 10 t
+              -- Left i  -> "variable #" <> pp i <+> "is out of scope"
+              t -> ppTerm Unqualified 10 t
 
 -- | Convert a value back to a term
 value2term :: GLocation -> [Ident] -> Value -> Either Int Term
-value2term = value2term' False
+value2term loc xs v0 = Right $ value2term' False loc xs v0
+
+value2term' :: Bool -> p -> [Ident] -> Value -> Term
 value2term' stop loc xs v0 =
   case v0 of
-    VApp pre vs    -> liftM (foldl App (Q (cPredef,predefName pre))) (mapM v2t vs)
-    VCApp f vs     -> liftM  (foldl App (QC f))   (mapM v2t vs)
-    VGen j vs      -> liftM2 (foldl App) (var j)  (mapM v2t vs)
-    VMeta j env vs -> liftM  (foldl App (Meta j)) (mapM v2t vs)
-    VProd bt v x f -> liftM2 (Prod bt x) (v2t v) (v2t' x f)
-    VAbs  bt   x f -> liftM  (Abs  bt x)         (v2t' x f)
-    VInt n         -> return (EInt n)
-    VFloat f       -> return (EFloat f)
-    VString s      -> return (if null s then Empty else K s)
-    VSort s        -> return (Sort s)
-    VImplArg v     -> liftM  ImplArg (v2t v)
-    VTblType p res -> liftM2 Table (v2t p) (v2t res)
-    VRecType rs    -> liftM  RecType (mapM (\(l,v) -> fmap ((,) l) (v2t v)) rs)
-    VRec as        -> liftM  R       (mapM (\(l,v) -> v2t v >>= \t -> return (l,(Nothing,t))) as)
-    VV t _ vs      -> liftM  (V t)   (mapM v2t vs)
-    VT wild v cs   -> v2t v >>= \t -> liftM (T ((if wild then TWild else TTyped) t)) (mapM nfcase cs)
-    VFV vs         -> liftM  FV (mapM v2t vs)
-    VC v1 v2       -> liftM2 C (v2t v1) (v2t v2)
-    VS v1 v2       -> liftM2 S (v2t v1) (v2t v2)
-    VP v l         -> v2t v >>= \t -> return (P t l)
-    VPatt p        -> return (EPatt p)
-    VPattType v    -> v2t v >>= return . EPattType
-    VAlts v vvs    -> liftM2 Alts (v2t v) (mapM (\(x,y) -> liftM2 (,) (v2t x) (v2t y)) vvs)
-    VStrs vs       -> liftM  Strs (mapM v2t vs)
+    VApp pre vs    -> applyMany (Q (cPredef,predefName pre)) vs
+    VCApp f vs     -> applyMany (QC f)                       vs
+    VGen j vs      -> applyMany (var j)                      vs
+    VMeta j env vs -> applyMany (Meta j)                     vs
+    VProd bt v x f -> Prod bt x (v2t v)  (v2t' x f)
+    VAbs  bt   x f -> Abs  bt x          (v2t' x f)
+    VInt n         -> EInt n
+    VFloat f       -> EFloat f
+    VString s      -> if null s then Empty else K s
+    VSort s        -> Sort s
+    VImplArg v     -> ImplArg (v2t v)
+    VTblType p res -> Table (v2t p) (v2t res)
+    VRecType rs    -> RecType [(l, v2t v) | (l,v) <- rs]
+    VRec as        -> R       [(l, (Nothing, v2t v)) | (l,v) <- as]
+    VV t _ vs      -> V t     (map v2t vs)
+    VT wild v cs   -> T ((if wild then TWild else TTyped) (v2t v)) (map nfcase cs)
+    VFV vs         -> FV (map v2t vs)
+    VC v1 v2       -> C (v2t v1) (v2t v2)
+    VS v1 v2       -> S (v2t v1) (v2t v2)
+    VP v l         -> P (v2t v) l
+    VPatt p        -> EPatt p
+    VPattType v    -> EPattType $ v2t v
+    VAlts v vvs    -> Alts (v2t v) [(v2t x, v2t y) | (x,y) <- vvs]
+    VStrs vs       -> Strs (map v2t vs)
 --  VGlue v1 v2    -> Glue (v2t v1) (v2t v2)
 --  VExtR v1 v2    -> ExtR (v2t v1) (v2t v2)
-    VError err     -> return (Error err)
-
+    VError err     -> Error err
   where
+    applyMany f vs = foldl App f (map v2t vs)
     v2t = v2txs xs
     v2txs = value2term' stop loc
     v2t' x f = v2txs (x:xs) (bind f (gen xs))
 
     var j
-      | j<length xs = Right (Vr (reverse xs !! j))
-      | otherwise   = Left  j
+      | j<length xs = Vr (reverse xs !! j)
+      | otherwise   = error ("variable #"++show j++" is out of scope")
 
 
     pushs xs e = foldr push e xs
     push x (env,xs) = ((x,gen xs):env,x:xs)
     gen xs = VGen (length xs) []
 
-    nfcase (p,f) = liftM ((,) p) (v2txs xs' (bind f env'))
+    nfcase (p,f) = (,) p (v2txs xs' (bind f env'))
       where (env',xs') = pushs (pattVars p) ([],xs)
 
     bind (Bind f) x = if stop
-- 
cgit v1.2.3


From b3881570c78cfc4596b64b9ef03463f6b74f1b19 Mon Sep 17 00:00:00 2001
From: Andreas Källberg <anka.213@gmail.com>
Date: Sun, 29 Nov 2020 15:03:08 +0100
Subject: Remove last traces of the Either in value2term

---
 src/compiler/GF/Compile/Compute/Concrete.hs      | 21 +++++++++++----------
 src/compiler/GF/Compile/TypeCheck/ConcreteNew.hs | 10 +++++-----
 2 files changed, 16 insertions(+), 15 deletions(-)

(limited to 'src')

diff --git a/src/compiler/GF/Compile/Compute/Concrete.hs b/src/compiler/GF/Compile/Compute/Concrete.hs
index a346de882..dd2180937 100644
--- a/src/compiler/GF/Compile/Compute/Concrete.hs
+++ b/src/compiler/GF/Compile/Compute/Concrete.hs
@@ -30,11 +30,12 @@ import Debug.Trace(trace)
 normalForm :: GlobalEnv -> L Ident -> Term -> Term
 normalForm (GE gr rv opts _) loc = err (bugloc loc) id . nfx (GE gr rv opts loc)
 
+nfx :: GlobalEnv -> Term -> Err Term
 nfx env@(GE _ _ _ loc) t = do
   v <- eval env [] t
   case value2term loc [] v of
-    Left i  -> fail ("variable #"++show i++" is out of scope")
-    Right t -> return t
+    -- Left i  -> fail ("variable #"++show i++" is out of scope")
+    t -> return t
 
 eval :: GlobalEnv -> Env -> Term -> Err Value
 eval (GE gr rvs opts loc) env t = ($ (map snd env)) # value cenv t
@@ -289,8 +290,8 @@ glue env (v1,v2) = glu v1 v2
                        then VC v1 (VC (VApp BIND []) v2)
                        else let loc  = gloc env
                                 vt v = case value2term loc (local env) v of
-                                         Left i  -> Error ('#':show i)
-                                         Right t -> t
+                                        --  Left i  -> Error ('#':show i)
+                                        t -> t
                                 originalMsg = render $ ppL loc (hang "unsupported token gluing" 4
                                                                (Glue (vt v1) (vt v2)))
                                 term = render $ pp  $ Glue (vt v1) (vt v2)
@@ -356,8 +357,8 @@ select env vv =
 
 match loc cs v =
   case value2term loc [] v of
-    Left i  -> bad ("variable #"++show i++" is out of scope")
-    Right t -> err bad return (matchPattern cs t)
+    -- Left i  -> bad ("variable #"++show i++" is out of scope")
+    t -> err bad return (matchPattern cs t)
   where
     bad = fail . ("In pattern matching: "++)
 
@@ -384,8 +385,8 @@ valueTable env i cs =
 
     convertv cs' vty =
       case value2term (gloc env) [] vty of
-        Left i    -> fail ("variable #"++show i++" is out of scope")
-        Right pty -> convert' cs' =<< paramValues'' env pty
+        -- Left i    -> fail ("variable #"++show i++" is out of scope")
+        pty -> convert' cs' =<< paramValues'' env pty
 
     convert cs' ty = convert' cs' =<< paramValues' env ty
 
@@ -497,8 +498,8 @@ vtrace loc arg res = trace (render (hang (pv arg) 4 ("->"<+>pv res))) res
               t -> ppTerm Unqualified 10 t
 
 -- | Convert a value back to a term
-value2term :: GLocation -> [Ident] -> Value -> Either Int Term
-value2term loc xs v0 = Right $ value2term' False loc xs v0
+value2term :: GLocation -> [Ident] -> Value -> Term
+value2term = value2term' False
 
 value2term' :: Bool -> p -> [Ident] -> Value -> Term
 value2term' stop loc xs v0 =
diff --git a/src/compiler/GF/Compile/TypeCheck/ConcreteNew.hs b/src/compiler/GF/Compile/TypeCheck/ConcreteNew.hs
index d85af5361..628f7ea4c 100644
--- a/src/compiler/GF/Compile/TypeCheck/ConcreteNew.hs
+++ b/src/compiler/GF/Compile/TypeCheck/ConcreteNew.hs
@@ -568,9 +568,9 @@ unifyVar ge scope i env vs ty2 = do            -- Check whether i is bound
     Bound ty1       -> do v <- liftErr (eval ge env ty1)
                           unify ge scope (vapply (geLoc ge) v vs) ty2
     Unbound scope' _ -> case value2term (geLoc ge) (scopeVars scope') ty2 of
-                          Left i     -> let (v,_) = reverse scope !! i
-                                        in tcError ("Variable" <+> pp v <+> "has escaped")
-                          Right ty2' -> do ms2 <- getMetaVars (geLoc ge) [(scope,ty2)]
+                          -- Left i     -> let (v,_) = reverse scope !! i
+                          --               in tcError ("Variable" <+> pp v <+> "has escaped")
+                                ty2' -> do ms2 <- getMetaVars (geLoc ge) [(scope,ty2)]
                                            if i `elem` ms2
                                              then tcError ("Occurs check for" <+> ppMeta i <+> "in:" $$
                                                            nest 2 (ppTerm Unqualified 0 ty2'))
@@ -766,8 +766,8 @@ zonkTerm t = composOp zonkTerm t
 
 tc_value2term loc xs v =
   case value2term loc xs v of
-    Left i  -> tcError ("Variable #" <+> pp i <+> "has escaped")
-    Right t -> return t
+    -- Left i  -> tcError ("Variable #" <+> pp i <+> "has escaped")
+    t -> return t
 
 
 
-- 
cgit v1.2.3


From 7faf8c9dad5a88c38f7fa3633f8a1b286ac570c3 Mon Sep 17 00:00:00 2001
From: Andreas Källberg <anka.213@gmail.com>
Date: Mon, 12 Jul 2021 16:38:29 +0800
Subject: Clean up redundant case expressions

---
 src/compiler/GF/Compile/Compute/Concrete.hs      | 21 ++++++++++-----------
 src/compiler/GF/Compile/TypeCheck/ConcreteNew.hs |  4 ++--
 2 files changed, 12 insertions(+), 13 deletions(-)

(limited to 'src')

diff --git a/src/compiler/GF/Compile/Compute/Concrete.hs b/src/compiler/GF/Compile/Compute/Concrete.hs
index dd2180937..47e2f5cde 100644
--- a/src/compiler/GF/Compile/Compute/Concrete.hs
+++ b/src/compiler/GF/Compile/Compute/Concrete.hs
@@ -33,9 +33,9 @@ normalForm (GE gr rv opts _) loc = err (bugloc loc) id . nfx (GE gr rv opts loc)
 nfx :: GlobalEnv -> Term -> Err Term
 nfx env@(GE _ _ _ loc) t = do
   v <- eval env [] t
-  case value2term loc [] v of
+  return (value2term loc [] v)
+    -- Old value2term error message:
     -- Left i  -> fail ("variable #"++show i++" is out of scope")
-    t -> return t
 
 eval :: GlobalEnv -> Env -> Term -> Err Value
 eval (GE gr rvs opts loc) env t = ($ (map snd env)) # value cenv t
@@ -289,9 +289,9 @@ glue env (v1,v2) = glu v1 v2
           (v1,v2) -> if flag optPlusAsBind (opts env)
                        then VC v1 (VC (VApp BIND []) v2)
                        else let loc  = gloc env
-                                vt v = case value2term loc (local env) v of
+                                vt v = value2term loc (local env) v
+                                        -- Old value2term error message:
                                         --  Left i  -> Error ('#':show i)
-                                        t -> t
                                 originalMsg = render $ ppL loc (hang "unsupported token gluing" 4
                                                                (Glue (vt v1) (vt v2)))
                                 term = render $ pp  $ Glue (vt v1) (vt v2)
@@ -356,9 +356,9 @@ select env vv =
       (v1,v2) -> ok2 VS v1 v2
 
 match loc cs v =
-  case value2term loc [] v of
+  err bad return (matchPattern cs (value2term loc [] v))
+    -- Old value2term error message:
     -- Left i  -> bad ("variable #"++show i++" is out of scope")
-    t -> err bad return (matchPattern cs t)
   where
     bad = fail . ("In pattern matching: "++)
 
@@ -384,9 +384,8 @@ valueTable env i cs =
     wild = case i of TWild _ -> True; _ -> False
 
     convertv cs' vty =
-      case value2term (gloc env) [] vty of
-        -- Left i    -> fail ("variable #"++show i++" is out of scope")
-        pty -> convert' cs' =<< paramValues'' env pty
+      convert' cs' =<< paramValues'' env (value2term (gloc env) [] vty)
+        -- Old value2term error message: Left i    -> fail ("variable #"++show i++" is out of scope")
 
     convert cs' ty = convert' cs' =<< paramValues' env ty
 
@@ -493,9 +492,9 @@ vtrace loc arg res = trace (render (hang (pv arg) 4 ("->"<+>pv res))) res
     pf (_,VString n) = pp n
     pf (_,v) = ppV v
     pa (_,v) = ppV v
-    ppV v = case value2term' True loc [] v of
+    ppV v = ppTerm Unqualified 10 (value2term' True loc [] v)
+              -- Old value2term error message:
               -- Left i  -> "variable #" <> pp i <+> "is out of scope"
-              t -> ppTerm Unqualified 10 t
 
 -- | Convert a value back to a term
 value2term :: GLocation -> [Ident] -> Value -> Term
diff --git a/src/compiler/GF/Compile/TypeCheck/ConcreteNew.hs b/src/compiler/GF/Compile/TypeCheck/ConcreteNew.hs
index 628f7ea4c..ed3a20ce0 100644
--- a/src/compiler/GF/Compile/TypeCheck/ConcreteNew.hs
+++ b/src/compiler/GF/Compile/TypeCheck/ConcreteNew.hs
@@ -765,9 +765,9 @@ zonkTerm (Meta i) = do
 zonkTerm t = composOp zonkTerm t
 
 tc_value2term loc xs v =
-  case value2term loc xs v of
+  return $ value2term loc xs v
+    -- Old value2term error message:
     -- Left i  -> tcError ("Variable #" <+> pp i <+> "has escaped")
-    t -> return t
 
 
 
-- 
cgit v1.2.3


From 743f5e55d486633ec7b148ea9a30ba7e59892e6d Mon Sep 17 00:00:00 2001
From: Meowyam <maryam@chilon.net>
Date: Wed, 14 Jul 2021 16:28:14 +0800
Subject: add missing install.sh file for c runtime

---
 src/runtime/c/install.sh | 3 +++
 1 file changed, 3 insertions(+)
 create mode 100755 src/runtime/c/install.sh

(limited to 'src')

diff --git a/src/runtime/c/install.sh b/src/runtime/c/install.sh
new file mode 100755
index 000000000..78483719d
--- /dev/null
+++ b/src/runtime/c/install.sh
@@ -0,0 +1,3 @@
+bash setup.sh configure
+bash setup.sh build
+bash setup.sh install
-- 
cgit v1.2.3


From 45bc5595c03059ff2c83d9079f5e17d92267c5c9 Mon Sep 17 00:00:00 2001
From: Inari Listenmaa <inari.listenmaa@gmail.com>
Date: Thu, 15 Jul 2021 09:54:15 +0800
Subject: Update C runtime install instructions

---
 src/runtime/c/INSTALL | 7 +++++--
 1 file changed, 5 insertions(+), 2 deletions(-)

(limited to 'src')

diff --git a/src/runtime/c/INSTALL b/src/runtime/c/INSTALL
index 6bbaefdce..c45c18fa9 100644
--- a/src/runtime/c/INSTALL
+++ b/src/runtime/c/INSTALL
@@ -14,6 +14,9 @@ For Linux users
 
 You will need the packages: autoconf, automake, libtool, make
 
+- On Ubuntu: $ apt-get install autotools-dev
+- On Fedora: $ dnf install autoconf automake libtool
+
 The compilation steps are:
 
 $ autoreconf -i
@@ -28,7 +31,7 @@ For Mac OSX users
 The following is what I did to make it work on MacOSX 10.8:
 
 - Install XCode and XCode command line tools
-- Install Homebrew: http://mxcl.github.com/homebrew/
+- Install Homebrew: https://brew.sh
 
 $ brew install automake autoconf libtool
 $ glibtoolize
@@ -49,7 +52,7 @@ For Windows users
   After the installation, don't forget to fix the fstab file. See here:
      http://www.mingw.org/wiki/Getting_Started
 
-- From the MSYS shell (c:/MinGW/msys/1.0/msys.bat) go to the directory 
+- From the MSYS shell (c:/MinGW/msys/1.0/msys.bat) go to the directory
   which contains the INSTALL file and do:
 
   $ autoreconf -i
-- 
cgit v1.2.3