Added French for new API. Started alpha conv. Fixed bugs.

9 files changed, 61 insertions, 14 deletions

diff --git a/src/GF/CF/Profile.hs b/src/GF/CF/Profile.hs
index 1b821d53a..edd35a18d 100644
--- a/src/GF/CF/Profile.hs
+++ b/src/GF/CF/Profile.hs
@@ -21,7 +21,7 @@ import List (nub)
 
 postParse :: CFTree -> Err Exp
 postParse tree = do
-  iterm <- errIn "postprocessing initial parse tree" $ tree2term tree
+  iterm <- errIn ("postprocessing parse tree" +++ prCFTree tree) $ tree2term tree
   return $ term2trm  iterm
 
 -- an intermediate data structure
@@ -93,4 +93,4 @@ term2trm (ITerm (fun, binds) terms) =
  where
    mkAbsR c e = foldr EAbs e c
    mkAppAtom a = mkApp (EAtom a)
-   mkApp = foldl EApp
\ No newline at end of file
+   mkApp = foldl EApp
diff --git a/src/GF/Compile/ShellState.hs b/src/GF/Compile/ShellState.hs
index 138630c3a..27d88f6fb 100644
--- a/src/GF/Compile/ShellState.hs
+++ b/src/GF/Compile/ShellState.hs
@@ -295,10 +295,14 @@ stateAbstract = abstractOf . stateGrammarST
 maybeStateAbstract (ShSt (ma,_,_)) = ma
 hasStateAbstract = maybe False (const True) . maybeStateAbstract
 abstractOfState = maybe emptyAbstractST id . maybeStateAbstract
+-}
 
 stateIsWord sg = isKnownWord (stateMorpho sg)
 
 
+
+{-
+
 -- getting info on a language
 existLang :: ShellState -> Language -> Bool
 existLang st lang = elem lang (allLanguages st)
diff --git a/src/GF/Shell/Commands.hs b/src/GF/Shell/Commands.hs
index b5bd28e3c..c7b27c3ca 100644
--- a/src/GF/Shell/Commands.hs
+++ b/src/GF/Shell/Commands.hs
@@ -268,7 +268,7 @@ execECommand env c = case c of
   _                  -> changeMsg ["command not yet implemented"]
  where
    sgr  = firstStateGrammar env 
-   agrs = [sgr] ---- allActiveGrammars env
+   agrs = allStateGrammars env ---- allActiveGrammars env
    cgr  = canCEnv env
    gr   = grammarCEnv env
    der  = maybe True not $ caseYesNo (globalOptions env) noDepTypes
diff --git a/src/GF/UseGrammar/Custom.hs b/src/GF/UseGrammar/Custom.hs
index 64cb29680..c117c0335 100644
--- a/src/GF/UseGrammar/Custom.hs
+++ b/src/GF/UseGrammar/Custom.hs
@@ -241,8 +241,8 @@ customTokenizer =
   ,(strCI "code",      const $ lexHaskell)
   ,(strCI "text",      const $ lexText)
   ,(strCI "unglue",    \gr -> map tS . decomposeWords (stateMorpho gr))
-----  ,(strCI "codelit",   lexHaskellLiteral . stateIsWord)
-----  ,(strCI "textlit",   lexTextLiteral . stateIsWord)
+  ,(strCI "codelit",   lexHaskellLiteral . stateIsWord)
+  ,(strCI "textlit",   lexTextLiteral . stateIsWord)
   ,(strCI "codeC",     const $ lexC2M)
   ,(strCI "codeCHigh", const $ lexC2M' True)
 -- add your own tokenizers here
diff --git a/src/GF/UseGrammar/Linear.hs b/src/GF/UseGrammar/Linear.hs
index e60f8da79..0bd053803 100644
--- a/src/GF/UseGrammar/Linear.hs
+++ b/src/GF/UseGrammar/Linear.hs
@@ -42,13 +42,17 @@ linearizeToRecord gr mk m = lin [] where
     xs' <- mapM (\ (i,x) -> lin (i:ts) x) $ zip [0..] xs
 
     r <- case at of
-      A.AtC f -> look f >>= comp xs'
+      A.AtC f -> lookf c t f >>= comp xs'
       A.AtL s -> return $ recS $ tK $ prt at
       A.AtI i -> return $ recS $ tK $ prt at
-      A.AtV x -> lookCat c >>= comp [tK (prt at)]
-      A.AtM m -> lookCat c >>= comp [tK (prt at)] 
+      A.AtV x -> lookCat c >>= comp [tK (prt_ at)]
+      A.AtM m -> lookCat c >>= comp [tK (prt_ at)] 
 
-    return $ fmk $ mkBinds binds r
+    r' <- case r of     -- to see stg in case the result is variants {}
+      FV [] -> lookCat c >>= comp [tK (prt_ t)]
+      _ -> return r
+
+    return $ fmk $ mkBinds binds r'
 
   look = lookupLin gr . redirectIdent m . rtQIdent
   comp = ccompute gr
@@ -60,6 +64,11 @@ linearizeToRecord gr mk m = lin [] where
   lookCat = return . errVal defLindef . look 
          ---- should always be given in the module
 
+  -- to show missing linearization as term
+  lookf c t f = case look f of
+    Ok h -> return h
+    _ -> lookCat c >>= comp [tK (prt_ t)]
+
 
 -- thus the special case:
 
diff --git a/src/GF/UseGrammar/Parsing.hs b/src/GF/UseGrammar/Parsing.hs
index b5b587c91..48b6ffac6 100644
--- a/src/GF/UseGrammar/Parsing.hs
+++ b/src/GF/UseGrammar/Parsing.hs
@@ -64,9 +64,10 @@ tokens2trms opts sg cn parser as = do
     _ | null ts0 -> checkWarn "No success in cf parsing" >> return []
     _ | raw      -> do
       ts1 <- return (map cf2trm0 ts0) ----- should not need annot
-      mapM (checkErr . (annotate gr) . trExp) ts1 ---- complicated
+      mapM (checkErr . (annotate gr) . trExp) ts1 ---- complicated; often fails
     _ -> do
-      (ts1,_) <- checkErr $ mapErr postParse ts0
+      (ts1,ss) <- checkErr $ mapErr postParse ts0
+      if null ts1 then raise ss else return ()
       ts2 <- mapM (checkErr . (annotate gr) . trExp) ts1 ---- 
       if forgive then return ts2 else do
         let tsss = [(t, allLinsOfTree gr cn t) | t <- ts2]
@@ -75,7 +76,7 @@ tokens2trms opts sg cn parser as = do
         if null ps 
            then raise $ "Failure in morphology." ++
                   if verb 
-                     then "\nPossible corrections: " +++++ 
+                     then "\nPossible corrections: " +++++
                           unlines (nub (map sstr (concatMap snd tsss)))
                      else ""
            else return ps
diff --git a/src/GF/UseGrammar/Tokenize.hs b/src/GF/UseGrammar/Tokenize.hs
index ac28276f5..b264075ba 100644
--- a/src/GF/UseGrammar/Tokenize.hs
+++ b/src/GF/UseGrammar/Tokenize.hs
@@ -129,6 +129,9 @@ unknown2string isKnown = map mkOne where
   mkOne t@(TC s) = if isKnown s then t else mkTL s
   mkOne t        = t
 
-lexTextLiteral    isKnown = unknown2string isKnown . lexText
+lexTextLiteral    isKnown = unknown2string (eitherUpper isKnown) . lexText
 lexHaskellLiteral isKnown = unknown2string isKnown . lexHaskell
 
+eitherUpper isKnown w@(c:cs) = isKnown (toLower c : cs) || isKnown (toUpper c : cs)
+eitherUpper isKnown w = isKnown w
+
diff --git a/src/Today.hs b/src/Today.hs
index 921d7fd2e..3647e0a63 100644
--- a/src/Today.hs
+++ b/src/Today.hs
@@ -1 +1 @@
-module Today where today = "Tue Nov 25 17:48:12 CET 2003"
+module Today where today = "Thu Dec  4 13:52:32 CET 2003"
diff --git a/src/tools/AlphaConvGF.hs b/src/tools/AlphaConvGF.hs
new file mode 100644
index 000000000..707ad8721
--- /dev/null
+++ b/src/tools/AlphaConvGF.hs
@@ -0,0 +1,30 @@
+module Main where
+
+import LexGF
+import Alex
+import System
+
+main :: IO ()
+main = do
+  file1:file2:_ <- getArgs
+  s  <- readFile file1
+  ts <- tokens s
+  if file1==file2 then print (length ts) else return () -- make sure file1 is in mem
+  writeFile file2 []                       -- create file2 or remove its old contents
+  alphaConv file2 ts (Pn 1 1 1)
+
+alphaConv :: FilePath -> [Token] -> Posn -> IO ()
+alphaConv file (t:ts) p0 = case t of
+  PT p (TV s) -> changeId file p0 p s ts
+  _ -> putToken file p0 t >>= alphaConv file ts
+alphaConv _ _ = putStrLn "Ready."
+
+putToken :: FilePath -> Posn -> Token -> IO Posn
+putToken file (Pn _ l0 c0) t@(PT (Pn a l c) _) = do
+  let s  = prToken t 
+      ns = l - l0
+      ls = length s
+  replicate ns $ appendFile file '\n'
+  replicate (if ns == 0 then c - c0 else c-1) $ putChar ' '
+  putStr s 
+  return $ Pn (a + ls) l (c + ls) ts