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

7 files changed, 303 insertions, 135 deletions

diff --git a/src/compiler/GF.hs b/src/compiler/GF.hs
index 8938a053e..a99970a57 100644
--- a/src/compiler/GF.hs
+++ b/src/compiler/GF.hs
@@ -19,7 +19,9 @@ module GF(
            module GF.Grammar.Printer,
            module GF.Infra.Ident,
            -- ** Binary serialisation
-           module GF.Grammar.Binary
+           module GF.Grammar.Binary,
+           -- * Canonical GF
+           module GF.Compile.GrammarToCanonical
   ) where
 import GF.Main
 import GF.Compiler
@@ -36,3 +38,5 @@ import GF.Grammar.Macros
 import GF.Grammar.Printer
 import GF.Infra.Ident
 import GF.Grammar.Binary
+
+import GF.Compile.GrammarToCanonical
diff --git a/src/compiler/GF/Compile/ConcreteToHaskell.hs b/src/compiler/GF/Compile/ConcreteToHaskell.hs
index 51ed5242e..d74fcdacd 100644
--- a/src/compiler/GF/Compile/ConcreteToHaskell.hs
+++ b/src/compiler/GF/Compile/ConcreteToHaskell.hs
@@ -11,7 +11,7 @@ import GF.Infra.Ident(Ident,identS,identW,prefixIdent)
 import GF.Infra.Option
 import GF.Haskell as H
 import GF.Grammar.Canonical as C
-import GF.Compile.ConcreteToCanonical
+import GF.Compile.GrammarToCanonical
 import Debug.Trace(trace)
 
 -- | Generate Haskell code for the all concrete syntaxes associated with
@@ -142,8 +142,8 @@ concrete2haskell opts
         rhs = lets (zipWith letlin args absctx)
                    (convert vs (coerce env lincat rhs0))
           where
-            vs = [(VarValueId x,a)|(VarId x,a)<-zip xs args]
-            env= [(VarValueId x,lc)|(VarId x,lc)<-zip xs (map arglincat absctx)]
+            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)))
@@ -173,15 +173,20 @@ concrete2haskell opts
             VariantValue [] -> empty
             VariantValue ts@(_:_) -> variants ts
             VarValue x -> maybe (Var (gId x)) (pure . Var) $ lookup x vs
-            IntConstant n -> pure (lit n)
-            StrConstant s -> pure (token s)
             PreValue vs t' -> pure (alts t' vs)
             ParamConstant (Param c vs) -> aps (Var (pId c)) (map ppT vs)
             ErrorValue s -> ap (Const "error") (Const (show s)) -- !!
+            LiteralValue l -> ppL l
             _ -> error ("convert "++show t)
 
+        ppL l =
+          case l of
+            FloatConstant x -> pure (lit x)
+            IntConstant n -> pure (lit n)
+            StrConstant s -> pure (token s)
+
         pId p@(ParamId s) =
-          if "to_R_" `isPrefixOf` s then toIdent p else gId p -- !! a hack
+          if "to_R_" `isPrefixOf` unqual s then toIdent p else gId p -- !! a hack
           
         table cs =
             if all (null.patVars) ps
@@ -189,8 +194,8 @@ concrete2haskell opts
             else LambdaCase (map ppCase cs)
           where
             (ds,ts') = dedup ts
-            (ps,ts) = unzip [(p,t)|TableRowValue p t<-cs]
-        ppCase (TableRowValue p t) = (ppP p,ppTv (patVars p++vs) t)
+            (ps,ts) = unzip [(p,t)|TableRow p t<-cs]
+        ppCase (TableRow p t) = (ppP p,ppTv (patVars p++vs) t)
 {-
         ppPredef n =
           case predef n of
@@ -304,8 +309,8 @@ instance Records LinValue where
       Selection v1 v2 -> records (v1,v2)
       _ -> S.empty
 
-instance Records TableRowValue where
-  records (TableRowValue _ v) = records v
+instance Records rhs => Records (TableRow rhs) where
+  records (TableRow _ v) = records v
 
 
 -- | Record subtyping is converted into explicit coercions in Haskell
@@ -313,7 +318,7 @@ coerce env ty t =
   case (ty,t) of 
     (_,VariantValue ts) -> VariantValue (map (coerce env ty) ts)
     (TableType ti tv,TableValue _ cs) ->
-      TableValue ti [TableRowValue p (coerce env tv t)|TableRowValue p t<-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]]
@@ -329,7 +334,7 @@ coerce env ty t =
     _ -> t
   where
     app f ts = ParamConstant (Param f ts) -- !! a hack
-    to_rcon = ParamId . to_rcon' . labels
+    to_rcon = ParamId . Unqual . to_rcon' . labels
 
 patVars p = []
 
@@ -395,11 +400,16 @@ linfunName c = prefixIdent "lin" (toIdent c)
 
 class ToIdent i where toIdent :: i -> Ident
 
-instance ToIdent ParamId where toIdent (ParamId s) = identS s
+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 s) = identS s
+instance ToIdent VarValueId where toIdent (VarValueId q) = qIdentS q
+
+qIdentS = identS . unqual
+
+unqual (Qual (ModId m) n) = m++"_"++n
+unqual (Unqual n) = n
 
 instance ToIdent VarId where
   toIdent Anonymous = identW
diff --git a/src/compiler/GF/Compile/ConcreteToCanonical.hs b/src/compiler/GF/Compile/GrammarToCanonical.hs
index 34c7bee73..32a4e301b 100644
--- a/src/compiler/GF/Compile/ConcreteToCanonical.hs
+++ b/src/compiler/GF/Compile/GrammarToCanonical.hs
@@ -1,6 +1,6 @@
 -- | Translate grammars to Canonical form
 -- (a common intermediate representation to simplify export to other formats)
-module GF.Compile.ConcreteToCanonical(grammar2canonical,abstract2canonical,concretes2canonical) where
+module GF.Compile.GrammarToCanonical(grammar2canonical,abstract2canonical,concretes2canonical) where
 import Data.List(nub,partition)
 import qualified Data.Map as M
 import qualified Data.Set as S
@@ -55,7 +55,7 @@ abstract2canonical absname gr =
 -- | Generate Canonical code for the all concrete syntaxes associated with
 -- the named abstract syntax in given the grammar.
 concretes2canonical opts absname gr =
-  [(cncname,concrete2canonical opts gr cenv absname cnc cncmod)
+  [(cncname,concrete2canonical gr cenv absname cnc cncmod)
      | let cenv = resourceValues opts gr,
        cnc<-allConcretes gr absname,
        let cncname = "canonical/"++render cnc ++ ".gf" :: FilePath
@@ -63,9 +63,7 @@ concretes2canonical opts absname gr =
   ]
 
 -- | Generate Canonical GF for the given concrete module.
--- The only options that make a difference are
--- @-haskell=noprefix@ and @-haskell=variants@.
-concrete2canonical opts gr cenv absname cnc modinfo =
+concrete2canonical gr cenv absname cnc modinfo =
   Concrete (modId cnc) (modId absname) (convFlags gr cnc)
       (neededParamTypes S.empty (params defs))
       [lincat|(_,Left lincat)<-defs]
@@ -153,7 +151,7 @@ convert' gr vs = ppT
       case t of
 --      Abs b x t -> ...
 --      V ty ts -> VTableValue (convType ty) (map ppT ts)
-        V ty ts -> TableValue (convType ty) [TableRowValue (ppP p) (ppT t)|(p,t)<-zip ps ts]
+        V ty ts -> TableValue (convType ty) [TableRow (ppP p) (ppT t)|(p,t)<-zip ps ts]
           where
             Ok pts = allParamValues gr ty
             Ok ps = mapM term2patt pts
@@ -167,16 +165,16 @@ convert' gr vs = ppT
         Cn x -> VarValue (gId x) -- hmm
         Con c -> ParamConstant (Param (gId c) [])
         Sort k -> VarValue (gId k)
-        EInt n -> IntConstant n
-        Q (m,n) -> if m==cPredef then ppPredef n else VarValue (gId (qual m n))
-        QC (m,n) -> ParamConstant (Param (gId (qual m n)) [])
-        K s -> StrConstant s
-        Empty -> StrConstant ""
+        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)) [])
+        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
 
-    ppCase (p,t) = TableRowValue (ppP p) (ppTv (patVars p++vs) t)
+    ppCase (p,t) = TableRow (ppP p) (ppTv (patVars p++vs) t)
 
     ppPredef n =
       case predef n of
@@ -185,14 +183,14 @@ convert' gr vs = ppT
         Ok SOFT_SPACE -> p "SOFT_SPACE"
         Ok CAPIT      -> p "CAPIT"
         Ok ALL_CAPIT  -> p "ALL_CAPIT"
-        _ -> VarValue (gId n)
+        _ -> VarValue (gQId cPredef n) -- hmm
       where
        p = PredefValue . PredefId
       
     ppP p =
       case p of
         PC c ps -> ParamPattern (Param (gId c) (map ppP ps))
-        PP (m,c) ps -> ParamPattern (Param (gId (qual 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
@@ -220,6 +218,7 @@ convert' gr vs = ppT
 
         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
 
     fields = map field . filter (not.isLockLabel.fst)
@@ -235,8 +234,8 @@ convert' gr vs = ppT
 
 concatValue v1 v2 =
   case (v1,v2) of
-    (StrConstant "",_) -> v2
-    (_,StrConstant "") -> v1
+    (LiteralValue (StrConstant ""),_) -> v2
+    (_,LiteralValue (StrConstant "")) -> v1
     _ -> ConcatValue v1 v2
 
 projection r l = maybe (Projection r l) id (proj r l)
@@ -251,19 +250,19 @@ proj r l =
 selection t v =
   case t of
     TableValue tt r ->
-        case nub [rv|TableRowValue _ rv<-keep] of
+        case nub [rv|TableRow _ rv<-keep] of
           [rv] -> rv
           _ -> Selection (TableValue tt r') v
       where
         r' = if null discard
              then r
-             else keep++[TableRowValue WildPattern impossible]
+             else keep++[TableRow WildPattern impossible]
         (keep,discard) = partition (mightMatchRow v) r
     _ -> Selection t v
 
 impossible = ErrorValue "impossible"
 
-mightMatchRow v (TableRowValue p _) =
+mightMatchRow v (TableRow p _) =
   case p of
     WildPattern -> True
     _ -> mightMatch v p
@@ -300,8 +299,8 @@ 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 (gId (qual m n)))
-        Q (m,n) -> ParamType (ParamTypeId (gId (qual m n)))
+        QC (m,n) -> ParamType (ParamTypeId ((gQId m n)))
+        Q (m,n) -> ParamType (ParamTypeId ((gQId m n)))
         _ -> error $ "Missing case in convType for: "++show t
 
     convFields = map convField . filter (not.isLockLabel.fst)
@@ -327,25 +326,21 @@ paramType gr q@(_,n) =
          ((S.singleton (m,n),argTypes ps),
           [ParamDef name (map (param m) ps)]
          )
-       where name = gId (qual m n)
+       where name = (gQId m n)
       Ok (m,ResOper  _ (Just (L _ t)))
         | m==cPredef && n==cInts ->
            ((S.empty,S.empty),[]) {-
            ((S.singleton (m,n),S.empty),
-            [Type (ConAp (gId (qual m n)) [identS "n"]) (TId (identS "Int"))])-}
+            [Type (ConAp ((gQId m n)) [identS "n"]) (TId (identS "Int"))])-}
         | otherwise ->
            ((S.singleton (m,n),paramTypes gr t),
-            [ParamAliasDef (gId (qual m n)) (convType t)])
+            [ParamAliasDef ((gQId m n)) (convType t)])
       _ -> ((S.empty,S.empty),[])
   where
-    param m (n,ctx) = Param (gId (qual 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]
 
-qual :: ModuleName -> Ident -> Ident
-qual m = prefixIdent (render m++"_")
-
-
 lblId = LabelId . render -- hmm
 modId (MN m) = ModId (showIdent m)
 
@@ -356,8 +351,16 @@ instance FromIdent VarId where
 
 instance FromIdent C.FunId where gId = C.FunId . showIdent
 instance FromIdent CatId where gId = CatId . showIdent
-instance FromIdent ParamId where gId = ParamId . showIdent
-instance FromIdent VarValueId where gId = VarValueId . showIdent
+instance FromIdent ParamId where gId = ParamId . unqual
+instance FromIdent VarValueId where gId = VarValueId . unqual
+
+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)
 
 convFlags gr mn =
   Flags [(n,convLit v) |
diff --git a/src/compiler/GF/Compiler.hs b/src/compiler/GF/Compiler.hs
index efb1ae70f..4003285b8 100644
--- a/src/compiler/GF/Compiler.hs
+++ b/src/compiler/GF/Compiler.hs
@@ -7,7 +7,7 @@ import GF.Compile as S(batchCompile,link,srcAbsName)
 import GF.CompileInParallel as P(parallelBatchCompile)
 import GF.Compile.Export
 import GF.Compile.ConcreteToHaskell(concretes2haskell)
-import GF.Compile.ConcreteToCanonical--(concretes2canonical)
+import GF.Compile.GrammarToCanonical--(concretes2canonical)
 import GF.Compile.CFGtoPGF
 import GF.Compile.GetGrammar
 import GF.Grammar.BNFC
diff --git a/src/compiler/GF/Grammar/Canonical.hs b/src/compiler/GF/Grammar/Canonical.hs
index 0da72d634..ed4f3fc9e 100644
--- a/src/compiler/GF/Grammar/Canonical.hs
+++ b/src/compiler/GF/Grammar/Canonical.hs
@@ -1,7 +1,13 @@
--- | Abstract syntax for canonical GF grammars, i.e. what's left after
+-- |
+-- Module    :  GF.Grammar.Canonical
+-- Stability :  provisional
+--
+-- Abstract syntax for canonical GF grammars, i.e. what's left after
 -- high-level constructions such as functors and opers have been eliminated
 -- by partial evaluation. This is intended as a common intermediate
 -- representation to simplify export to other formats.
+
+{-# LANGUAGE DeriveTraversable #-}
 module GF.Grammar.Canonical where
 import Prelude hiding ((<>))
 import GF.Text.Pretty
@@ -51,13 +57,11 @@ newtype ParamType = ParamTypeId ParamId deriving (Eq,Ord,Show)
 
 -- | Linearization value, RHS of @lin@
 data LinValue = ConcatValue LinValue LinValue
+              | LiteralValue LinLiteral
               | ErrorValue String
-              | FloatConstant Float 
-              | IntConstant Int 
               | ParamConstant ParamValue 
               | PredefValue PredefId
               | RecordValue [RecordRowValue]
-              | StrConstant String 
               | TableValue LinType [TableRowValue]
 ---           | VTableValue LinType [LinValue]
               | TupleValue [LinValue]
@@ -66,10 +70,17 @@ data LinValue = ConcatValue LinValue LinValue
               | PreValue [([String], LinValue)] LinValue
               | Projection LinValue LabelId
               | Selection LinValue LinValue
-               deriving (Eq,Ord,Show)
+              | CommentedValue String LinValue
+              deriving (Eq,Ord,Show)
+
+data LinLiteral = FloatConstant Float 
+                | IntConstant Int 
+                | StrConstant String 
+                deriving (Eq,Ord,Show)
 
 data LinPattern = ParamPattern ParamPattern
                 | RecordPattern [RecordRow LinPattern]
+                | TuplePattern [LinPattern]
                 | WildPattern
                 deriving (Eq,Ord,Show)
 
@@ -77,37 +88,47 @@ type ParamValue = Param LinValue
 type ParamPattern = Param LinPattern
 type ParamValueDef = Param ParamId
 
-data Param arg = Param ParamId [arg] deriving (Eq,Ord,Show)
+data Param arg = Param ParamId [arg]
+                 deriving (Eq,Ord,Show,Functor,Foldable,Traversable)
 
-type RecordRowType = RecordRow LinType
+type RecordRowType  = RecordRow LinType
 type RecordRowValue = RecordRow LinValue
+type TableRowValue  = TableRow LinValue
 
-data RecordRow rhs  = RecordRow LabelId rhs  deriving (Eq,Ord,Show)
-data TableRowValue  = TableRowValue LinPattern LinValue  deriving (Eq,Ord,Show)
+data RecordRow rhs = RecordRow LabelId    rhs
+                     deriving (Eq,Ord,Show,Functor,Foldable,Traversable)
+data TableRow  rhs = TableRow  LinPattern rhs
+                     deriving (Eq,Ord,Show,Functor,Foldable,Traversable)
 
 -- *** Identifiers in Concrete Syntax
 
-newtype PredefId = PredefId String    deriving (Eq,Ord,Show)
-newtype LabelId  = LabelId String     deriving (Eq,Ord,Show)
-data VarValueId  = VarValueId String  deriving (Eq,Ord,Show)
+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 
-newtype ParamId = ParamId String  deriving (Eq,Ord,Show)
+newtype ParamId = ParamId QualId  deriving (Eq,Ord,Show)
 
 --------------------------------------------------------------------------------
 -- ** Used in both Abstract and Concrete Syntax
 
-newtype ModId = ModId String  deriving (Eq,Show)
+newtype ModId = ModId Id  deriving (Eq,Ord,Show)
 
-newtype CatId = CatId String  deriving (Eq,Ord,Show)
-newtype FunId = FunId String  deriving (Eq,Show)
+newtype CatId = CatId Id  deriving (Eq,Ord,Show)
+newtype FunId = FunId Id  deriving (Eq,Show)
 
-data VarId = Anonymous | VarId String  deriving Show
+data VarId = Anonymous | VarId Id  deriving Show
 
 newtype Flags = Flags [(FlagName,FlagValue)] deriving Show
-type FlagName = String
+type FlagName = Id
 data FlagValue = Str String | Int Int | Flt Double deriving Show
 
+
+-- *** Identifiers
+
+type Id = String
+data QualId = Qual ModId Id | Unqual Id  deriving (Eq,Ord,Show)
+
 --------------------------------------------------------------------------------
 -- ** Pretty printing
 
@@ -199,12 +220,12 @@ instance Pretty LinValue where
             Projection lv l -> ppA lv<>"."<>l
             Selection tv pv -> ppA tv<>"!"<>ppA pv
             VariantValue vs -> "variants"<+>block vs
+            CommentedValue s v -> "{-" <+> s <+> "-}" $$ v
             _ -> ppA lv
 
 instance PPA LinValue where
   ppA lv = case lv of
-             FloatConstant f -> pp f
-             IntConstant n -> pp n
+             LiteralValue l -> ppA l
              ParamConstant pv -> ppA pv
              PredefValue p -> ppA p
              RecordValue [] -> pp "<>"
@@ -214,13 +235,20 @@ instance PPA LinValue where
                where
                  alt (ss,lv) = hang (hcat (punctuate "|" (map doubleQuotes ss)))
                                     2 ("=>"<+>lv)
-             StrConstant s -> doubleQuotes s -- hmm
              TableValue _ tvs -> "table"<+>block tvs
 --           VTableValue t ts -> "table"<+>t<+>brackets (semiSep ts)
              TupleValue lvs -> "<"<>punctuate "," lvs<>">"
              VarValue v -> pp v
              _ -> parens lv
 
+instance Pretty LinLiteral where pp = ppA
+
+instance PPA LinLiteral where
+  ppA l = case l of
+            FloatConstant f -> pp f
+            IntConstant n -> pp n
+            StrConstant s -> doubleQuotes s -- hmm
+  
 instance RhsSeparator LinValue where rhsSep _ = pp "="
 
 instance Pretty LinPattern where
@@ -233,6 +261,7 @@ instance PPA LinPattern where
   ppA p =
     case p of
       RecordPattern r -> block r
+      TuplePattern ps -> "<"<>punctuate "," ps<>">"
       WildPattern     -> pp "_"                
       _ -> parens p
 
@@ -241,8 +270,8 @@ instance RhsSeparator LinPattern where rhsSep _ = pp "="
 instance RhsSeparator rhs => Pretty (RecordRow rhs) where
   pp (RecordRow l v) = hang (l<+>rhsSep v) 2 v
 
-instance Pretty TableRowValue where
-  pp (TableRowValue l v) = hang (l<+>"=>") 2 v
+instance Pretty rhs => Pretty (TableRow rhs) where
+  pp (TableRow l v) = hang (l<+>"=>") 2 v
 
 --------------------------------------------------------------------------------
 instance Pretty ModId where pp (ModId s) = pp s
@@ -250,11 +279,17 @@ instance Pretty CatId where pp (CatId s) = pp s
 instance Pretty FunId where pp (FunId s) = pp s
 instance Pretty LabelId where pp (LabelId s) = pp s
 instance Pretty PredefId where pp = ppA
-instance PPA    PredefId where ppA (PredefId s) = pp s
+instance PPA    PredefId where ppA (PredefId s) = "Predef."<>s
 instance Pretty ParamId where pp = ppA
 instance PPA    ParamId where ppA (ParamId s) = pp s
 instance Pretty VarValueId where pp (VarValueId s) = pp s
 
+instance Pretty QualId where pp = ppA
+
+instance PPA QualId where
+  ppA (Qual m n) = m<>"_"<>n -- hmm
+  ppA (Unqual n) = pp n
+
 instance Pretty Flags where
   pp (Flags []) = empty
   pp (Flags flags) = "flags" <+> vcat (map ppFlag flags)
diff --git a/src/compiler/GF/Grammar/CanonicalJSON.hs b/src/compiler/GF/Grammar/CanonicalJSON.hs
index d791e0d9b..8b3464674 100644
--- a/src/compiler/GF/Grammar/CanonicalJSON.hs
+++ b/src/compiler/GF/Grammar/CanonicalJSON.hs
@@ -3,7 +3,8 @@ module GF.Grammar.CanonicalJSON (
   ) where
 
 import Text.JSON
-import qualified Control.Monad       as CM    (mapM, msum)
+import Control.Applicative ((<|>))
+import Data.Ratio (denominator, numerator)
 import GF.Grammar.Canonical
 
 
@@ -20,6 +21,8 @@ encodeJSON fpath g = writeFile fpath (encode g)
 instance JSON Grammar where
   showJSON (Grammar abs cncs) = makeObj [("abstract", showJSON abs), ("concretes", showJSON cncs)]
 
+  readJSON o = Grammar <$> o!"abstract" <*> o!"concretes"
+
 
 --------------------------------------------------------------------------------
 -- ** Abstract Syntax
@@ -31,30 +34,46 @@ instance JSON Abstract where
                ("cats", showJSON cats),
                ("funs", showJSON funs)]
 
+  readJSON o = Abstract
+    <$> o!"abs"
+    <*>(o!"flags" <|> return (Flags []))
+    <*> o!"cats"
+    <*> o!"funs"
+
 instance JSON CatDef where
   -- non-dependent categories are encoded as simple strings:
   showJSON (CatDef c []) = showJSON c
   showJSON (CatDef c cs) = makeObj [("cat", showJSON c), ("args", showJSON cs)]
 
+  readJSON o = CatDef <$> readJSON o <*> return []
+    <|>        CatDef <$> o!"cat" <*> o!"args"
+
 instance JSON FunDef where
   showJSON (FunDef f ty) = makeObj [("fun", showJSON f), ("type", showJSON ty)]
-{-
-instance FromJSON FunDef where
-  parseJSON = withObject "FunDef" $ \o -> FunDef <$> o .: "fun" <*> o .: "type"
--}
+
+  readJSON o = FunDef <$> o!"fun" <*> o!"type"
 
 instance JSON Type where
-  showJSON (Type bs ty) = makeObj [("args", showJSON bs), ("result", showJSON ty)]
+  showJSON (Type bs ty) = makeObj [(".args", showJSON bs), (".result", showJSON ty)]
+
+  readJSON o = Type <$> o!".args" <*> o!".result"
 
 instance JSON TypeApp where
   -- non-dependent categories are encoded as simple strings:
   showJSON (TypeApp c [])   = showJSON c
-  showJSON (TypeApp c args) = makeObj [("cat", showJSON c), ("args", showJSON args)]
+  showJSON (TypeApp c args) = makeObj [(".cat", showJSON c), (".args", showJSON args)]
+
+  readJSON o = TypeApp <$> readJSON o <*> return []
+    <|>        TypeApp <$> o!".cat" <*> o!".args"
 
 instance JSON TypeBinding where
   -- non-dependent categories are encoded as simple strings:
   showJSON (TypeBinding Anonymous (Type [] (TypeApp c []))) = showJSON c
-  showJSON (TypeBinding x ty) = makeObj [("var", showJSON x), ("type", showJSON ty)]
+  showJSON (TypeBinding x ty) = makeObj [(".var", showJSON x), (".type", showJSON ty)]
+
+  readJSON o = do c <- readJSON o
+                  return (TypeBinding Anonymous (Type [] (TypeApp c [])))
+           <|> TypeBinding <$> o!".var" <*> o!".type"
 
 
 --------------------------------------------------------------------------------
@@ -69,101 +88,173 @@ instance JSON Concrete where
                ("lincats", showJSON lincats),
                ("lins", showJSON lins)]
 
+  readJSON o = Concrete
+    <$> o!"cnc"
+    <*> o!"abs"
+    <*>(o!"flags" <|> return (Flags []))
+    <*> o!"params"
+    <*> o!"lincats"
+    <*> o!"lins"
+
 instance JSON ParamDef where
   showJSON (ParamDef      p pvs) = makeObj [("param", showJSON p), ("values", showJSON pvs)]
   showJSON (ParamAliasDef p t)   = makeObj [("param", showJSON p), ("alias", showJSON t)]
 
+  readJSON o = ParamDef      <$> o!"param" <*> o!"values"
+    <|>        ParamAliasDef <$> o!"param" <*> o!"alias"
+
 instance JSON LincatDef where
   showJSON (LincatDef c lt) = makeObj [("cat", showJSON c), ("lintype", showJSON lt)]
 
+  readJSON o = LincatDef <$> o!"cat" <*> o!"lintype"
+
 instance JSON LinDef where
   showJSON (LinDef f xs lv) = makeObj [("fun", showJSON f), ("args", showJSON xs), ("lin", showJSON lv)]
 
+  readJSON o = LinDef <$> o!"fun" <*> o!"args" <*> o!"lin"
+
 instance JSON LinType where
-  showJSON lt = case lt of
-    -- the basic types (Str, Float, Int) are encoded as strings:
-    StrType         -> showJSON "Str"
-    FloatType       -> showJSON "Float"
-    IntType         -> showJSON "Int"
-    -- parameters are also encoded as strings:
-    ParamType pt    -> showJSON pt
-    -- tables/tuples are encoded as JSON objects:
-    TableType pt lt -> makeObj [("tblarg", showJSON pt), ("tblval", showJSON lt)]
-    TupleType lts   -> makeObj [("tuple",  showJSON lts)]
-    -- records are encoded as records:
-    RecordType rows -> showJSON rows
+  -- the basic types (Str, Float, Int) are encoded as strings:
+  showJSON (StrType)         = showJSON "Str"
+  showJSON (FloatType)       = showJSON "Float"
+  showJSON (IntType)         = showJSON "Int"
+  -- parameters are also encoded as strings:
+  showJSON (ParamType pt)    = showJSON pt
+  -- tables/tuples are encoded as JSON objects:
+  showJSON (TableType pt lt) = makeObj [(".tblarg", showJSON pt), (".tblval", showJSON lt)]
+  showJSON (TupleType lts)   = makeObj [(".tuple",  showJSON lts)]
+  -- records are encoded as records:
+  showJSON (RecordType rows) = showJSON rows
+
+  readJSON o = do "Str"   <- readJSON o; return StrType
+    <|>        do "Float" <- readJSON o; return FloatType
+    <|>        do "Int"   <- readJSON o; return IntType
+    <|>        do  ptype  <- readJSON o; return (ParamType ptype)
+    <|>        TableType  <$> o!".tblarg" <*> o!".tblval"
+    <|>        TupleType  <$> o!".tuple"
+    <|>        RecordType <$> readJSON o
 
 instance JSON LinValue where
-  showJSON lv = case lv of
-    -- basic values (Str, Float, Int) are encoded as JSON strings/numbers:
-    StrConstant    s  -> showJSON s
-    FloatConstant  f  -> showJSON f
-    IntConstant    n  -> showJSON n
-    -- concatenation is encoded as a JSON array:
-    ConcatValue  v v' -> showJSON [showJSON v, showJSON v']
-    -- most values are encoded as JSON objects:
-    ParamConstant  pv -> makeObj [("param",    showJSON pv)]
-    PredefValue    p  -> makeObj [("predef",   showJSON p)]
-    TableValue  t tvs -> makeObj [("tblarg",   showJSON t), ("tblrows", showJSON tvs)]
-    TupleValue    lvs -> makeObj [("tuple",    showJSON lvs)]
-    VarValue       v  -> makeObj [("var",      showJSON v)]
-    ErrorValue     s  -> makeObj [("error",    showJSON s)]
-    Projection  lv l  -> makeObj [("project",  showJSON lv), ("label", showJSON l)]
-    Selection   tv pv -> makeObj [("select",   showJSON tv), ("key", showJSON pv)]
-    VariantValue   vs -> makeObj [("variants", showJSON vs)]
-    PreValue alts def -> makeObj [("pre", showJSON alts), ("default", showJSON def)]
-    -- records are encoded directly as JSON records:
-    RecordValue  rows -> showJSON rows
+  showJSON (LiteralValue  l ) = showJSON l
+  -- most values are encoded as JSON objects:
+  showJSON (ParamConstant pv) = makeObj [(".param",    showJSON pv)]
+  showJSON (PredefValue   p ) = makeObj [(".predef",   showJSON p)]
+  showJSON (TableValue t tvs) = makeObj [(".tblarg",   showJSON t), (".tblrows", showJSON tvs)]
+  showJSON (TupleValue   lvs) = makeObj [(".tuple",    showJSON lvs)]
+  showJSON (VarValue      v ) = makeObj [(".var",      showJSON v)]
+  showJSON (ErrorValue    s ) = makeObj [(".error",    showJSON s)]
+  showJSON (Projection lv l ) = makeObj [(".project",  showJSON lv), (".label", showJSON l)]
+  showJSON (Selection  tv pv) = makeObj [(".select",   showJSON tv), (".key", showJSON pv)]
+  showJSON (VariantValue  vs) = makeObj [(".variants", showJSON vs)]
+  showJSON (PreValue pre def) = makeObj [(".pre",      showJSON pre),(".default", showJSON def)]
+  -- records are encoded directly as JSON records:
+  showJSON (RecordValue rows) = showJSON rows
+  -- concatenation is encoded as a JSON array:
+  showJSON v@(ConcatValue _ _) = showJSON (flatten v [])
+    where flatten (ConcatValue v v') = flatten v . flatten v'
+          flatten  v                 = (v :)
+
+  readJSON o = LiteralValue  <$> readJSON o
+    <|>        ParamConstant <$> o!".param"
+    <|>        PredefValue   <$> o!".predef"
+    <|>        TableValue    <$> o!".tblarg"  <*> o!".tblrows"
+    <|>        TupleValue    <$> o!".tuple"
+    <|>        VarValue      <$> o!".var"
+    <|>        ErrorValue    <$> o!".error"
+    <|>        Projection    <$> o!".project" <*> o!".label"
+    <|>        Selection     <$> o!".select"  <*> o!".key"
+    <|>        VariantValue  <$> o!".variants"
+    <|>        PreValue      <$> o!".pre"     <*> o!".default"
+    <|>        RecordValue   <$> readJSON o
+    <|>        do vs <- readJSON o :: Result [LinValue]
+                  return (foldr1 ConcatValue vs)
+
+instance JSON LinLiteral where
+  -- basic values (Str, Float, Int) are encoded as JSON strings/numbers:
+  showJSON (StrConstant   s) = showJSON s
+  showJSON (FloatConstant f) = showJSON f
+  showJSON (IntConstant   n) = showJSON n
+
+  readJSON = readBasicJSON StrConstant IntConstant FloatConstant
 
 instance JSON LinPattern where
-  showJSON linpat = case linpat of
-    -- wildcards and patterns without arguments are encoded as strings:
-    WildPattern -> showJSON "_"
-    ParamPattern (Param p []) -> showJSON p
-    -- complex patterns are encoded as JSON objects:
-    ParamPattern pv -> showJSON pv
-    -- and records as records:
-    RecordPattern r -> showJSON r
+  -- wildcards and patterns without arguments are encoded as strings:
+  showJSON (WildPattern) = showJSON "_"
+  showJSON (ParamPattern (Param p [])) = showJSON p
+  -- complex patterns are encoded as JSON objects:
+  showJSON (ParamPattern pv) = showJSON pv
+  -- and records as records:
+  showJSON (RecordPattern r) = showJSON r
+
+  readJSON o = do "_" <- readJSON o; return WildPattern
+    <|>        do  p  <- readJSON o; return (ParamPattern (Param p []))
+    <|>        ParamPattern  <$> readJSON o
+    <|>        RecordPattern <$> readJSON o
 
 instance JSON arg => JSON (Param arg) where
   -- parameters without arguments are encoded as strings:
   showJSON (Param p [])   = showJSON p
-  showJSON (Param p args) = makeObj [("paramid", showJSON p), ("args", showJSON args)]
+  showJSON (Param p args) = makeObj [(".paramid", showJSON p), (".args", showJSON args)]
+
+  readJSON o = Param <$> readJSON o <*> return []
+    <|>        Param <$> o!".paramid" <*> o!".args"
 
 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 = makeObj [toJSONRecordRow row]
+  showJSON  row  = showJSONs [row]
+  showJSONs rows = makeObj (map toRow rows)
+    where toRow (RecordRow (LabelId lbl) val) = (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)
 
-toJSONRecordRow :: JSON a => RecordRow a -> (String,JSValue)
-toJSONRecordRow (RecordRow (LabelId lbl) val) = (lbl, showJSON val)
+instance JSON rhs => JSON (TableRow rhs) where
+  showJSON (TableRow l v) = makeObj [(".pattern", showJSON l), (".value", showJSON v)]
 
-instance JSON TableRowValue where
-  showJSON (TableRowValue l v) = makeObj [("pattern", showJSON l), ("value", showJSON l)]
+  readJSON o = TableRow <$> o!".pattern" <*> o!".value"
 
 
 -- *** Identifiers in Concrete Syntax
 
-instance JSON PredefId   where showJSON (PredefId    s) = showJSON s
-instance JSON LabelId    where showJSON (LabelId     s) = showJSON s
-instance JSON VarValueId where showJSON (VarValueId  s) = showJSON s
-instance JSON ParamId    where showJSON (ParamId     s) = showJSON s
-instance JSON ParamType  where showJSON (ParamTypeId s) = showJSON s
+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
-instance JSON CatId where showJSON (CatId s) = showJSON s
-instance JSON FunId where showJSON (FunId s) = showJSON s
+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:
   showJSON Anonymous = showJSON "_"
   showJSON (VarId x) = showJSON x
 
+  readJSON o = do "_" <- readJSON o; return Anonymous
+    <|>        VarId <$> readJSON o
+
+instance JSON QualId where
+  showJSON (Qual (ModId m) n) = showJSON (m++"."++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
+
 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 [(f, showJSON v) | (f, v) <- fs]
+
+  readJSON obj = Flags <$> mapM fromRow (assocsJSObject obj)
+    where fromRow (lbl, jsvalue) = do value <- readJSON jsvalue
+                                      return (lbl, value)
 
 instance JSON FlagValue where
   -- flag values are encoded as basic JSON types:
@@ -171,3 +262,28 @@ instance JSON FlagValue where
   showJSON (Int i) = showJSON i
   showJSON (Flt f) = showJSON f
 
+  readJSON = readBasicJSON Str Int Flt
+
+
+--------------------------------------------------------------------------------
+-- ** Convenience functions
+
+(!) :: JSON a => JSValue -> String -> Result a
+obj ! key = maybe (fail $ "CanonicalJSON.(!): Could not find key: " ++ show key)
+            readJSON
+            (lookup key (assocsJSObject obj))
+
+assocsJSObject :: JSValue -> [(String, JSValue)]
+assocsJSObject (JSObject o) = fromJSObject o
+assocsJSObject (JSArray  _) = fail $ "CanonicalJSON.assocsJSObject: Expected a JSON object, found an Array"
+assocsJSObject  jsvalue     = fail $ "CanonicalJSON.assocsJSObject: Expected a JSON object, found " ++ show jsvalue
+
+
+readBasicJSON :: (JSON int, Integral int, JSON flt, RealFloat flt) =>
+                 (String -> v) -> (int -> v) -> (flt -> v) -> JSValue -> Result v
+readBasicJSON str int flt o
+  =   str        <$> readJSON o
+  <|> int_or_flt <$> readJSON o
+  where int_or_flt f | f == fromIntegral n = int n
+                     | otherwise           = flt f
+          where n = round f
diff --git a/src/compiler/GF/Infra/Option.hs b/src/compiler/GF/Infra/Option.hs
index b99e2dbe9..7e1c22b9d 100644
--- a/src/compiler/GF/Infra/Option.hs
+++ b/src/compiler/GF/Infra/Option.hs
@@ -327,7 +327,7 @@ optDescr =
      Option [] ["gfo-dir"] (ReqArg gfoDir "DIR") "Directory to put .gfo files in (default = '.').",
      Option ['f'] ["output-format"] (ReqArg outFmt "FMT") 
         (unlines ["Output format. FMT can be one of:",
-                  "Canonical GF grammar: canonical_gf, canonical_json, canonical_yaml, (and haskell with option --haskell=concrete)",
+                  "Canonical GF grammar: canonical_gf, canonical_json, (and haskell with option --haskell=concrete)",
                   "Multiple concrete: pgf (default), 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,