PGFService.hs bug fix: pattern match failure in doParse

doParse was missing a branch for PGF.ParseIncomplete.
Also introduced the operator .= to simply the code that builds JSON objects.

src/compiler/GFServer.hs

@@ -303,11 +303,11 @@ serveStaticFile path =
 
 serveStaticFile' path =
   do let ext = takeExtension path
-         (t,rdFile,encode) = contentTypeFromExt ext
+         (t,rdFile) = contentTypeFromExt ext
      if ext `elem` [".cgi",".fcgi",".sh",".php"]
        then return $ resp400 $ "Unsupported file type: "++ext
        else do b <- doesFileExist path
-               if b then fmap (ok200' (ct t) . encode) $ rdFile path
+               if b then fmap (ok200' (ct t)) $ rdFile path
                     else return (resp404 path)
 
 -- * Logging
@@ -349,8 +349,9 @@ contentTypeFromExt ext =
     ".jpg" -> bin "image/jpg"
     _ -> bin "application/octet-stream"
   where
-     text subtype = ("text/"++subtype++"; charset=UTF-8",readFile,encodeString)
+     text subtype = ("text/"++subtype++"; charset=UTF-8",
-     bin t = (t,readBinaryFile,id)
+                     fmap encodeString . readFile)
+     bin t = (t,readBinaryFile)
 
 -- * IO utilities
 updateFile path new =

src/server/PGFService.hs

@@ -155,49 +155,49 @@ doExternal (Just cmd) input =
 doTranslate :: PGF -> String -> Maybe PGF.Type -> Maybe PGF.Language -> Maybe PGF.Language -> JSValue
 doTranslate pgf input mcat mfrom mto =
   showJSON
-     [toJSObject (("from", showJSON from) :
+     [makeObj ("from".=from : "brackets".=bs : jsonTranslateOutput po)
-                  ("brackets", showJSON bs) :
+          | (from,po,bs) <- parse' pgf input mcat mfrom]
-                  jsonParseOutput po)
-           | (from,po,bs) <- parse' pgf input mcat mfrom]
   where
-    jsonParseOutput (PGF.ParseOk trees)  = [("translations",showJSON 
+    jsonTranslateOutput output =
-                                               [toJSObject [("tree",          showJSON tree),
+      case output of
-                                                            ("linearizations",showJSON 
+        PGF.ParseOk trees ->
-                                                               [toJSObject [("to", showJSON to),
+            ["translations".=
-                                                                            ("text",showJSON output)]
+              [makeObj ["tree".=tree,
-                                                                  | (to,output) <- linearizeAndBind pgf mto tree]
+                        "linearizations".=
-                                                            )]
+                            [makeObj ["to".=to, "text".=output]
-                                                   | tree <- trees])]
+                               | (to,output) <- linearizeAndBind pgf mto tree]] 
-    jsonParseOutput (PGF.ParseIncomplete)= []
+                | tree <- trees]]
-    jsonParseOutput (PGF.ParseFailed _)  = []
+        PGF.ParseIncomplete -> ["incomplete".=True]
-    jsonParseOutput (PGF.TypeError errs) = [("typeErrors",showJSON [toJSObject [("fid", showJSON fid)
+        PGF.ParseFailed n   -> ["parseFailed".=n]
-                                                                               ,("msg", showJSON (show (PGF.ppTcError err)))
+        PGF.TypeError errs -> jsonTypeErrors errs
-                                                                               ] | (fid,err) <- errs])]
+
+jsonTypeErrors errs = 
+    ["typeErrors".= [makeObj ["fid".=fid, "msg".=show (PGF.ppTcError err)]
+                       | (fid,err) <- errs]]
 
 -- used in phrasebook
 doTranslateGroup :: PGF -> String -> Maybe PGF.Type -> Maybe PGF.Language -> Maybe PGF.Language -> JSValue
 doTranslateGroup pgf input mcat mfrom mto =
   showJSON
-     [toJSObject [("from",          showJSON (langOnly (PGF.showLanguage from))),
+    [makeObj ["from".=langOnly (PGF.showLanguage from),
-                  ("to",            showJSON (langOnly (PGF.showLanguage to))),
+              "to".=langOnly (PGF.showLanguage to),
-                  ("linearizations",showJSON 
+              "linearizations".=
-                      [toJSObject (("text", doText (doBind alt)) : disamb lg from ts) | 
+                 [toJSObject (("text", doText (doBind alt)) : disamb lg from ts)
-                                             (ts,alt) <- output, let lg = length output])
+                    | (ts,alt) <- output, let lg = length output]
-                 ]
+              ]
-        | 
+       | 
-          (from,po,bs) <- parse' pgf input mcat mfrom,
+         (from,po,bs) <- parse' pgf input mcat mfrom,
-          (to,output)  <- groupResults [(t, linearize' pgf mto t) | t <- case po of {PGF.ParseOk ts -> ts; _ -> []}]
+         (to,output)  <- groupResults [(t, linearize' pgf mto t) | t <- case po of {PGF.ParseOk ts -> ts; _ -> []}]
           ]
   where
    groupResults = Map.toList . foldr more Map.empty . start . collect
      where
        collect tls = [(t,(l,s)) | (t,ls) <- tls, (l,s) <- ls, notDisamb l]
        start ls = [(l,[([t],s)]) | (t,(l,s)) <- ls]
-       more (l,s) = 
+       more (l,s) = Map.insertWith (\ [([t],x)] xs -> insertAlt t x xs) l s
-         Map.insertWith (\ [([t],x)] xs -> insertAlt t x xs) l s
 
    insertAlt t x xs = case xs of
-     (ts,y):xs2 -> if x==y then (t:ts,y):xs2        -- if string is there add only tree
+     (ts,y):xs2 -> if x==y then (t:ts,y):xs2 -- if string is there add only tree
                    else (ts,y) : insertAlt t x xs2
      _ -> [([t],x)]
 
@@ -234,79 +234,77 @@ doTranslateGroup pgf input mcat mfrom mto =
    notDisamb = (/="Disamb") . take 6 . PGF.showLanguage
 
 doParse :: PGF -> String -> Maybe PGF.Type -> Maybe PGF.Language -> JSValue
-doParse pgf input mcat mfrom = showJSON $ map toJSObject
+doParse pgf input mcat mfrom = showJSON $ map makeObj
-     [("from", showJSON from) :
+     ["from".=from : "brackets".=bs : jsonParseOutput po
-      ("brackets", showJSON bs) :
+        | (from,po,bs) <- parse' pgf input mcat mfrom]
-      jsonParseOutput po
-         | (from,po,bs) <- parse' pgf input mcat mfrom]
   where
-    jsonParseOutput (PGF.ParseOk trees)  = [("trees",showJSON trees)]
+    jsonParseOutput output =
-    jsonParseOutput (PGF.ParseFailed _)  = []
+      case output of
-    jsonParseOutput (PGF.TypeError errs) = [("typeErrors",showJSON [toJSObject [("fid", showJSON fid)
+        PGF.ParseOk trees   -> ["trees".=trees]
-                                                                               ,("msg", showJSON (show (PGF.ppTcError err)))
+        PGF.TypeError errs  -> jsonTypeErrors errs
-                                                                               ] | (fid,err) <- errs])]
+        PGF.ParseIncomplete -> ["incomlete".=True]
+        PGF.ParseFailed n   -> ["parseFailed".=n]
 
 doComplete :: PGF -> String -> Maybe PGF.Type -> Maybe PGF.Language -> Maybe Int -> JSValue
-doComplete pgf input mcat mfrom mlimit = showJSON $ map toJSObject
+doComplete pgf input mcat mfrom mlimit = showJSON
-  [[("from",        showJSON from),
+    [makeObj ["from".=from, "brackets".=bs, "completions".=cs, "text".=s]
-    ("brackets",    showJSON bs),
+       | from <- froms, let (bs,s,cs) = complete' pgf from cat mlimit input]
-    ("completions", showJSON cs),
-    ("text",        showJSON s)]
-          | from <- froms, let (bs,s,cs) = complete' pgf from cat mlimit input]
   where
     froms = maybe (PGF.languages pgf) (:[]) mfrom
     cat = fromMaybe (PGF.startCat pgf) mcat
 
 doLinearize :: PGF -> PGF.Tree -> Maybe PGF.Language -> JSValue
-doLinearize pgf tree mto = showJSON $
+doLinearize pgf tree mto = showJSON
-    [toJSObject [("to", PGF.showLanguage to),("text",text)]
+    [makeObj ["to".=PGF.showLanguage to, "text".=text]
       | (to,text) <- linearize' pgf mto tree]
 
 doLinearizes :: PGF -> PGF.Tree -> Maybe PGF.Language -> JSValue
-doLinearizes pgf tree mto = showJSON $ 
+doLinearizes pgf tree mto = showJSON
-    [toJSObject [("to", showJSON $ PGF.showLanguage to),
+    [makeObj ["to".=PGF.showLanguage to, "texts".=texts]
-                 ("texts",showJSON texts)]
+       | (to,texts) <- linearizes' pgf mto tree]
-      | (to,texts) <- linearizes' pgf mto tree]
 
 doRandom :: PGF -> Maybe PGF.Type -> Maybe Int -> Maybe Int -> Maybe PGF.Language -> IO JSValue
 doRandom pgf mcat mdepth mlimit mto =
   do g <- newStdGen
      let trees = PGF.generateRandomDepth g pgf cat (Just depth)
-     return $ showJSON $
+     return $ showJSON
-          [toJSObject [("tree", showJSON (PGF.showExpr [] tree)),
+          [makeObj ["tree".=PGF.showExpr [] tree,
-                       ("linearizations", showJSON [toJSObject [("to", PGF.showLanguage to),("text",text)] 
+                    "linearizations".=
-                                                          | (to,text) <- linearize' pgf mto tree])]
+                       [makeObj ["to".=PGF.showLanguage to, "text".=text] 
-                 | tree <- limit trees]
+                          | (to,text) <- linearize' pgf mto tree]]
+             | tree <- limit trees]
   where cat = fromMaybe (PGF.startCat pgf) mcat
         limit = take (fromMaybe 1 mlimit)
         depth = fromMaybe 4 mdepth
 
 doGenerate :: PGF -> Maybe PGF.Type -> Maybe Int -> Maybe Int -> Maybe PGF.Language -> JSValue
 doGenerate pgf mcat mdepth mlimit mto = 
-  let trees = PGF.generateAllDepth pgf cat (Just depth)
+    showJSON [makeObj ["tree".=PGF.showExpr [] tree,
-  in showJSON $
+                       "linearizations".=
-          [toJSObject [("tree", showJSON (PGF.showExpr [] tree)),
+                          [makeObj ["to".=PGF.showLanguage to, "text".=text]
-                       ("linearizations", showJSON [toJSObject [("to", PGF.showLanguage to),("text",text)] 
+                             | (to,text) <- linearize' pgf mto tree]]
-                                                          | (to,text) <- linearize' pgf mto tree])]
+                | tree <- limit trees]
-                 | tree <- limit trees]
+  where
-  where cat = fromMaybe (PGF.startCat pgf) mcat
+    trees = PGF.generateAllDepth pgf cat (Just depth)
-        limit = take (fromMaybe 1 mlimit)
+    cat = fromMaybe (PGF.startCat pgf) mcat
-        depth = fromMaybe 4 mdepth
+    limit = take (fromMaybe 1 mlimit)
+    depth = fromMaybe 4 mdepth
 
 doGrammar :: PGF -> Maybe (Accept Language) -> JSValue
-doGrammar pgf macc = showJSON $ toJSObject
+doGrammar pgf macc = showJSON $ makeObj
-             [("name", showJSON (PGF.abstractName pgf)),
+             ["name".=PGF.abstractName pgf,
-              ("userLanguage", showJSON (selectLanguage pgf macc)),
+              "userLanguage".=selectLanguage pgf macc,
-              ("startcat",showJSON (PGF.showType [] (PGF.startCat pgf))),
+              "startcat".=PGF.showType [] (PGF.startCat pgf),
-              ("categories", showJSON categories),
+              "categories".=categories,
-              ("functions", showJSON functions),
+              "functions".=functions,
-              ("languages", showJSON languages)]
+              "languages".=languages]
-  where languages = map toJSObject
+  where
-                    [[("name", showJSON l), 
+    languages =
-                      ("languageCode", showJSON $ fromMaybe "" (PGF.languageCode pgf l))]
+       [makeObj ["name".= l, 
-                     | l <- PGF.languages pgf]
+                  "languageCode".= fromMaybe "" (PGF.languageCode pgf l)]
-        categories = [PGF.showCId cat | cat <- PGF.categories pgf]
+          | l <- PGF.languages pgf]
-        functions  = [PGF.showCId fun | fun <- PGF.functions pgf]
+    categories = [PGF.showCId cat | cat <- PGF.categories pgf]
+    functions  = [PGF.showCId fun | fun <- PGF.functions pgf]
 
 doGraphvizAbstrTree pgf tree = do
   pipeIt2graphviz $  PGF.graphvizAbstractTree pgf (True,True) tree
@@ -433,13 +431,9 @@ instance JSON PGF.Expr where
 
 instance JSON PGF.BracketedString where
     readJSON x = return (PGF.Leaf "")
-    showJSON (PGF.Bracket cat fid index _ bs)
+    showJSON (PGF.Bracket cat fid index _ bs) =
-                          = showJSON $ toJSObject [("cat",      showJSON cat)
+        makeObj ["cat".=cat, "fid".=fid, "index".=index, "children".=bs]
-                                                  ,("fid",      showJSON fid)
+    showJSON (PGF.Leaf s) = makeObj ["token".=s]
-                                                  ,("index",    showJSON index)
-                                                  ,("children", showJSON bs)
-                                                  ]
-    showJSON (PGF.Leaf s) = showJSON $ toJSObject [("token", s)]
 
 -- * PGF utilities
 
@@ -516,5 +510,7 @@ langCodeLanguage pgf code = listToMaybe [l | l <- PGF.languages pgf, PGF.languag
 
 -- * General utilities
 
+f .= v = (f,showJSON v)
+
 --cleanFilePath :: FilePath -> FilePath
 --cleanFilePath = takeFileName