improved gfe; sloc stats

1 files changed, 23 insertions, 11 deletions

diff --git a/src/GF/Compile/MkConcrete.hs b/src/GF/Compile/MkConcrete.hs
index be3d6f5b4..f586435a9 100644
--- a/src/GF/Compile/MkConcrete.hs
+++ b/src/GF/Compile/MkConcrete.hs
@@ -50,32 +50,44 @@ mkConcrete file = do
   let parser cat = errVal ([],"No parse") . 
                    optParseArgErrMsg (options [newMParser, firstCat cat, beVerbose]) gr
   let morpho = isKnownWord gr
-  writeFile (suffixFile "gf" (justModuleName file)) $ unlines $ 
-    map (mkCnc parser morpho) cont
+  let out = suffixFile "gf" $ justModuleName file
+  mapM_ (mkCnc out parser morpho) cont
 
 getResPath :: [String] -> String
 getResPath s = case head (dropWhile (all isSpace) s) of
   '-':'-':'#':path -> reverse (takeWhile (not . (=='=')) (reverse path))
   _ -> error "first line must be --# -resource=<PATH>" 
 
-mkCnc :: (String -> String -> ([Tree],String)) -> (String -> Bool) -> String -> String
-mkCnc parser morpho line = case words line of
-  "lin" : rest -> mkLinRule rest
-  _ -> line
+mkCnc :: FilePath -> (String -> String -> ([Tree],String)) -> (String -> Bool) -> 
+         String -> IO ()
+mkCnc out parser morpho line = do
+  let (res,msg) = mkCncLine parser morpho line
+  appendFile out res
+  appendFile out "\n"
+  ifNull (return ()) putStrLnFlush msg
+
+mkCncLine :: (String -> String -> ([Tree],String)) -> (String -> Bool) -> 
+             String -> (String,String)
+mkCncLine parser morpho line = case words line of
+  "lin"  : rest | elem "in" rest -> mkLinRule "lin" rest
+  "oper" : rest | elem "in" rest -> mkLinRule "oper" rest
+  _ -> (line,[])
  where
-   mkLinRule s = 
+   mkLinRule key s = 
     let
        (pre,str)  = span (/= "in") s
        ([cat],rest) = splitAt 1 $ tail str
        lin        = init (tail (unwords (init rest))) -- unquote
-       def 
+       def
         | last pre /= "=" = line  -- ordinary lin rule
         | otherwise  = case parser cat lin of 
-           ([t],_)  -> "lin " ++ unwords pre +++ prt_ (tree2exp t) +++ ";" 
-           (t:_,_)  -> "lin " ++ unwords pre +++ prt_ (tree2exp t) +++ "{- AMBIGUOUS -} ;"
+           ([t],_)  -> ind ++ key +++ unwords pre +++ prt_ (tree2exp t) +++ ";" 
+           (t:_,_)  -> ind ++ key +++ unwords pre +++ prt_ (tree2exp t) +++ ";" 
+                        +++ "-- AMBIGUOUS"
            ([],msg) -> "{-" ++ line ++++ morph lin ++++ "-}" 
     in
-     def
+     (def,def)
    morph s = case [w | w <- words s, not (morpho w)] of
      [] -> ""
      ws -> "unknown words: " ++ unwords ws
+   ind = takeWhile isSpace line