added command ps -stringop, with stringop being (un)lexer defined in Lexing

3 files changed, 89 insertions, 0 deletions

diff --git a/src-3.0/GF/Command/Abstract.hs b/src-3.0/GF/Command/Abstract.hs
index 1f72688a0..31858a1f9 100644
--- a/src-3.0/GF/Command/Abstract.hs
+++ b/src-3.0/GF/Command/Abstract.hs
@@ -46,3 +46,8 @@ valOpts flag def opts = case lookup flag flags of
 
 isOpt :: String -> [Option] -> Bool
 isOpt o opts = elem o [x | OOpt x <- opts]
+
+prOpt :: Option -> String
+prOpt (OOpt i) = i ----
+
+
diff --git a/src-3.0/GF/Command/Commands.hs b/src-3.0/GF/Command/Commands.hs
index 2a15be1c9..231f6db77 100644
--- a/src-3.0/GF/Command/Commands.hs
+++ b/src-3.0/GF/Command/Commands.hs
@@ -20,6 +20,7 @@ import GF.Infra.UseIO
 import GF.Data.ErrM ----
 import PGF.ExprSyntax (readExp)
 import GF.Command.Abstract
+import GF.Text.Lexing
 
 import Data.Maybe
 import qualified Data.Map as Map
@@ -196,6 +197,13 @@ allCommands pgf = Map.fromList [
                    "example:\n"++
                    "  ph | wf foo.hist  -- save the history into a file"
      }),
+  ("ps", emptyCommandInfo {
+     longname = "put_string",
+     synopsis = "return a string, possibly processed with a function",
+     exec = \opts -> 
+       return . fromString . maybe id id (stringOp (concatMap prOpt opts)) . toString,
+     flags = ["cat","lang"]
+     }),
   ("q",  emptyCommandInfo {
      longname = "quit",
      synopsis = "exit GF interpreter"
diff --git a/src-3.0/GF/Text/Lexing.hs b/src-3.0/GF/Text/Lexing.hs
new file mode 100644
index 000000000..20dd7bd5e
--- /dev/null
+++ b/src-3.0/GF/Text/Lexing.hs
@@ -0,0 +1,76 @@
+module GF.Text.Lexing (stringOp) where
+
+import Data.Char
+
+-- lexers and unlexers - they work on space-separated word strings
+
+stringOp :: String -> Maybe (String -> String)
+stringOp name = case name of
+  "lextext"    -> Just $ appLexer lexText
+  "lexcode"    -> Just $ appLexer lexText
+  "lexmixed"   -> Just $ appLexer lexMixed
+  "unlextext"  -> Just $ appUnlexer unlexText
+  "unlexcode"  -> Just $ appUnlexer unlexCode
+  "unlexmixed" -> Just $ appUnlexer unlexMixed
+  _ -> Nothing
+
+appLexer :: (String -> [String]) -> String -> String
+appLexer f = unwords . filter (not . null) . f
+
+appUnlexer :: ([String] -> String) -> String -> String
+appUnlexer f = f . words
+
+lexText :: String -> [String]
+lexText s = case s of
+  c:cs | isPunct c -> [c] : lexText cs
+  c:cs | isSpace c ->       lexText cs
+  _:_ -> let (w,cs) = break (\x -> isSpace x || isPunct x) s in w : lexText cs
+  _ -> [s]
+
+-- | Haskell lexer, usable for much code
+lexCode :: String -> [String]
+lexCode ss = case lex ss of
+  [(w@(_:_),ws)] -> w : lexCode ws
+  _ -> []
+
+-- | LaTeX style lexer, with "math" environment using Code between $...$
+lexMixed :: String -> [String]
+lexMixed = concat . alternate False where
+  alternate env s = case s of
+    _:_ -> case break (=='$') s of
+      (t,[])  -> lex env t : []
+      (t,c:m) -> lex env t : [[c]] : alternate (not env) m
+    _ -> []
+  lex env = if env then lexCode else lexText
+
+unlexText :: [String] -> String
+unlexText s = case s of
+  w:[] -> w
+  w:[c]:[] | isPunct c -> w ++ [c]
+  w:[c]:cs | isPunct c -> w ++ [c] ++ " " ++ unlexText cs
+  w:ws -> w ++ " " ++ unlexText ws
+  _ -> []
+
+unlexCode :: [String] -> String
+unlexCode s = case s of
+  w:[] -> w
+  [c]:cs | isParen c -> [c] ++ unlexCode cs
+  w:cs@([c]:_) | isClosing c -> w ++ unlexCode cs
+  w:ws -> w ++ " " ++ unlexCode ws
+  _ -> []
+
+
+unlexMixed :: [String] -> String
+unlexMixed = concat . alternate False where
+  alternate env s = case s of
+    _:_ -> case break (=="$") s of
+      (t,[])  -> unlex env t : []
+      (t,c:m) -> unlex env t : sep env c : alternate (not env) m
+    _ -> []
+  unlex env = if env then unlexCode else unlexText
+  sep env c = if env then c ++ " " else " " ++ c
+
+isPunct = flip elem ".?!,:;"
+isParen = flip elem "()[]{}"
+isClosing = flip elem ")]}"
+