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