[project @ 2001-03-07 15:49:24 by sewardj]
authorsewardj <unknown>
Wed, 7 Mar 2001 15:49:24 +0000 (15:49 +0000)
committersewardj <unknown>
Wed, 7 Mar 2001 15:49:24 +0000 (15:49 +0000)
Driver and infrastructure files (.T's) for the new test framework.

36 files changed:
testsuite/config/msrc/cam-02-unx.T [new file with mode: 0644]
testsuite/config/simple-idioms/should-compile.T [new file with mode: 0644]
testsuite/config/simple-idioms/should-not-compile.T [new file with mode: 0644]
testsuite/config/simple-idioms/should-run.T [new file with mode: 0644]
testsuite/config/std-macros.T [new file with mode: 0644]
testsuite/driver/CmdLexer.hs [new file with mode: 0644]
testsuite/driver/CmdParser.hs [new file with mode: 0644]
testsuite/driver/CmdSemantics.hs [new file with mode: 0644]
testsuite/driver/CmdSyntax.hs [new file with mode: 0644]
testsuite/driver/Main.hs [new file with mode: 0644]
testsuite/driver/RunOneTest.hs [new file with mode: 0644]
testsuite/driver/basicRxLib/AbsTreeDefs.hs [new file with mode: 0644]
testsuite/driver/basicRxLib/Assertions.hs [new file with mode: 0644]
testsuite/driver/basicRxLib/AugTreeDefs.hs [new file with mode: 0644]
testsuite/driver/basicRxLib/AugmentTree.hs [new file with mode: 0644]
testsuite/driver/basicRxLib/BagRE.hs [new file with mode: 0644]
testsuite/driver/basicRxLib/CompileREP.hs [new file with mode: 0644]
testsuite/driver/basicRxLib/CompileREPB.hs [new file with mode: 0644]
testsuite/driver/basicRxLib/CompileRES.hs [new file with mode: 0644]
testsuite/driver/basicRxLib/ConstructorMonad.hs [new file with mode: 0644]
testsuite/driver/basicRxLib/ExecRE.hs [new file with mode: 0644]
testsuite/driver/basicRxLib/FiniteMap.hs [new file with mode: 0644]
testsuite/driver/basicRxLib/Global.hs [new file with mode: 0644]
testsuite/driver/basicRxLib/HandleInterval.hs [new file with mode: 0644]
testsuite/driver/basicRxLib/HandleSubexp.hs [new file with mode: 0644]
testsuite/driver/basicRxLib/IsPrefix.hs [new file with mode: 0644]
testsuite/driver/basicRxLib/MakeNFA.hs [new file with mode: 0644]
testsuite/driver/basicRxLib/MakeNFANode.hs [new file with mode: 0644]
testsuite/driver/basicRxLib/Matchers.hs [new file with mode: 0644]
testsuite/driver/basicRxLib/NFADefs.hs [new file with mode: 0644]
testsuite/driver/basicRxLib/OrdList.hs [new file with mode: 0644]
testsuite/driver/basicRxLib/ParsePolyRegexp.hs [new file with mode: 0644]
testsuite/driver/basicRxLib/ParsePolyRegexpBasic.hs [new file with mode: 0644]
testsuite/driver/basicRxLib/ParseStringRegexp.hs [new file with mode: 0644]
testsuite/driver/basicRxLib/Parsers.hs [new file with mode: 0644]
testsuite/driver/basicRxLib/Regexp.hs [new file with mode: 0644]

diff --git a/testsuite/config/msrc/cam-02-unx.T b/testsuite/config/msrc/cam-02-unx.T
new file mode 100644 (file)
index 0000000..01614a3
--- /dev/null
@@ -0,0 +1,2 @@
+
+$platform = "i386-unknown-linux"
diff --git a/testsuite/config/simple-idioms/should-compile.T b/testsuite/config/simple-idioms/should-compile.T
new file mode 100644 (file)
index 0000000..d646d72
--- /dev/null
@@ -0,0 +1,9 @@
+
+include ($confdir ++ "/../std-macros.T")
+expect pass
+
+pretest_cleanup()
+$res = simple_compile_Main()
+pass when contents("comp.stdout") == ""
+
+fail when otherwise
diff --git a/testsuite/config/simple-idioms/should-not-compile.T b/testsuite/config/simple-idioms/should-not-compile.T
new file mode 100644 (file)
index 0000000..f095962
--- /dev/null
@@ -0,0 +1,14 @@
+
+include ($confdir ++ "/../std-macros.T")
+expect pass
+
+pretest_cleanup()
+$res = simple_compile_Main()
+
+pass when 
+   $tool contains "ghc"
+   && contents("comp.stdout") contains "Could not deduce"
+
+-- put a pass clause here for NHC
+
+fail when otherwise
diff --git a/testsuite/config/simple-idioms/should-run.T b/testsuite/config/simple-idioms/should-run.T
new file mode 100644 (file)
index 0000000..7d0b05a
--- /dev/null
@@ -0,0 +1,12 @@
+
+include ($confdir ++ "/../std-macros.T")
+expect pass
+
+pretest_cleanup()
+
+simple_build_Main()
+$res = simple_run_main_no_stdin()
+
+pass when contents("run.stdout") == "True\n"
+
+fail when otherwise
\ No newline at end of file
diff --git a/testsuite/config/std-macros.T b/testsuite/config/std-macros.T
new file mode 100644 (file)
index 0000000..75fd618
--- /dev/null
@@ -0,0 +1,115 @@
+
+include ($confdir ++ "/" ++ $conffile)
+
+def qualify ( $_filename )
+{
+   return $testdir ++ "/" ++ $_filename
+}
+
+def rm_or_fail ( $_files )
+{
+   $cmd = "rm -f " ++ $_files
+   $res = run $cmd
+   if $res /= "0" then framefail ("rm_or_fail: can't rm: " ++ $_files) fi
+}
+
+def rm_nofail ( $_files )
+{
+   $cmd = "rm -f " ++ $_files
+   $res = run $cmd
+}
+
+def pretest_cleanup()
+{
+   rm_nofail(qualify("comp.stderr"))
+   rm_nofail(qualify("comp.stdout"))
+   rm_nofail(qualify("run.stderr"))
+   rm_nofail(qualify("run.stdout"))
+   -- not interested in the return code
+}
+
+-- Guess flags suitable for the compiler.
+def guess_compiler_flags()
+{
+   if   $tool contains "ghc"
+   then 
+        return "-no-recomp"
+   else 
+   if   $tool contains "nhc"
+   then 
+        return "-an-nhc-specific-flag"
+   else
+   if   $tool contains "hbc"
+   then
+        return ""
+   else
+        framefail ("Can't guess what kind of Haskell compiler " ++ 
+                   "you're testing: $tool = " ++ $tool)
+   fi
+   fi
+   fi
+}
+
+-- Compile Main.hs into main; comp errors -> comp.stdout.
+-- Used for run tests, so framefail if compilation fails.
+def simple_build_Main() 
+{
+   $flags = guess_compiler_flags()
+   rm_or_fail(qualify("comp.stdout"))
+   rm_or_fail(qualify("Main.hi"))
+   rm_or_fail(qualify("Main.o"))
+   rm_or_fail(qualify("main"))
+   $cmd = $tool ++ " " ++ $flags 
+          ++ " -o " ++ qualify("main") ++ " " 
+          ++ qualify("Main.hs") 
+          ++ " &> " ++ qualify("comp.stdout")
+   $res = run $cmd
+   if $res /= "0" then framefail "simple_build_Main: failed" fi
+}
+
+
+-- Just try to compile Main.hs to Main.o; no attempt at linking.
+-- Is used for compile-only tests, so don't framefail if compilation
+-- fails.
+def simple_compile_Main() 
+{
+   $flags = guess_compiler_flags()
+   rm_or_fail(qualify("comp.stdout"))
+   rm_or_fail(qualify("Main.hi"))
+   rm_or_fail(qualify("Main.o"))
+   $cmd = $tool ++ " " ++ $flags 
+          ++ " -c " ++ qualify("Main.hs") 
+          ++ " &> " ++ qualify("comp.stdout")
+   $res = run $cmd
+   return $res
+}
+
+-- Run main > run.stdout 2> run.stderr 
+-- Returns the exit code of the run.
+def simple_run_main_no_stdin ( )
+{
+   rm_or_fail(qualify("run.stdout"))
+   rm_or_fail(qualify("run.stderr"))
+   $cmd = qualify("main") 
+          ++ " > " ++ qualify("run.stdout")
+          ++ " 2> " ++ qualify("run.stderr")
+   $res = run $cmd
+   return $res
+}
+
+
+-- Run main < run.stdin > run.stdout 2> run.stderr 
+-- Returns the exit code of the run.
+def simple_run_main ( )
+{
+   rm_or_fail(qualify("run.stdout"))
+   rm_or_fail(qualify("run.stderr"))
+   $cmd = qualify("main") 
+          ++ " < " ++ qualify("run.stdin")
+          ++ " > " ++ qualify("run.stdout")
+          ++ " 2> " ++ qualify("run.stderr")
+   $res = run $cmd
+   return $res
+}
+
+
diff --git a/testsuite/driver/CmdLexer.hs b/testsuite/driver/CmdLexer.hs
new file mode 100644 (file)
index 0000000..87ade40
--- /dev/null
@@ -0,0 +1,157 @@
+
+module CmdLexer ( Lexeme(..), Token(..), tokenise,
+                  getLex, HasLineNo(..), HasTokNo(..), isVarChar ) 
+where
+
+
+import Char            ( isAlpha, isDigit, isSpace )
+
+
+---------------------------------------------------------------------
+-- nano-lexer
+data Lexeme
+   = LString   String          -- "string"
+   | LText     String          -- some_lump_of_text
+   | LVar      String          -- $varname
+   | L_When                    -- when
+   | L_Expect                  -- expect
+   | L_And                     -- &&
+   | L_Or                      -- ||
+   | L_Append                  -- ++
+   | L_Framefail               -- framefail
+   | L_Pass                    -- pass
+   | L_Fail                    -- fail
+   | L_Unknown                 -- unknown
+   | L_Skip                    -- skip
+   | L_Contains                        -- contains
+   | L_Lacks                   -- lacks
+   | L_Return                  -- return
+   | L_Eq                      -- ==
+   | L_NEq                     -- /=
+   | L_Assign                  -- =
+   | L_Otherwise               -- otherwise
+   | L_Open                    -- (
+   | L_Close                   -- )
+   | L_LBrace                  -- {
+   | L_RBrace                  -- }
+   | L_Comma                   -- ,
+   | L_Include                 -- include
+   | L_If                      -- if
+   | L_Then                    -- then
+   | L_Else                    -- else
+   | L_Fi                      -- fi
+   | L_Def                     -- def
+   | L_Print                   -- print
+   | L_Run                     -- run
+   | L_HasValue                        -- hasvalue
+   | L_Contents                        -- contents
+     deriving (Eq, Show)
+
+data Token
+   = Tok Int Int Lexeme -- token #, line #, Lex
+     deriving Show
+
+getLex   (Tok tno lno lexeme) = lexeme
+
+class HasLineNo a where
+   getLineNo :: a -> Int
+instance HasLineNo Token where
+   getLineNo (Tok tno lno lex) = lno
+instance HasLineNo a => HasLineNo [a] where
+   getLineNo []     = 999999   -- EOF presumably
+   getLineNo (t:ts) = getLineNo t
+
+class HasTokNo a where
+   getTokNo :: a -> Int
+instance HasTokNo Token where
+   getTokNo (Tok tno lno lex) = tno
+instance HasTokNo a => HasTokNo [a] where
+   getTokNo []     = 999999    -- EOF presumably
+   getTokNo (t:ts) = getTokNo t
+
+bomb = 0 :: Int
+
+tokenise :: Int -> String -> [Token]
+tokenise n toks
+  = let un_numbered = tokenise_wrk n toks
+        f tok_no (Tok _ lno lex) = Tok tok_no lno lex
+    in  zipWith f [1..] un_numbered
+
+-- do the biz, but don't insert token #s
+tokenise_wrk :: Int -> String -> [Token]
+tokenise_wrk n [] = []
+
+tokenise_wrk n ('&':'&':cs) = (Tok bomb n L_And) : tokenise_wrk n cs
+tokenise_wrk n ('|':'|':cs) = (Tok bomb n L_Or) : tokenise_wrk n cs
+tokenise_wrk n ('+':'+':cs) = (Tok bomb n L_Append) : tokenise_wrk n cs
+tokenise_wrk n ('=':'=':cs) = (Tok bomb n L_Eq) : tokenise_wrk n cs
+tokenise_wrk n ('/':'=':cs) = (Tok bomb n L_NEq) : tokenise_wrk n cs
+
+tokenise_wrk n (c:cs)
+   | take 2 (c:cs) == "--"
+   = tokenise_wrk n (dropWhile (/= '\n') (c:cs))
+   | c == '\n'
+   = tokenise_wrk (n+1) cs
+   | isSpace c 
+   = tokenise_wrk n cs
+   | c == '$' 
+   = let (vs, rest) = takeDrop isVarChar cs
+     in  (Tok bomb n (LVar vs)) : tokenise_wrk n rest
+   | c == '"'  -- "
+   = let str  = takeLitChars cs
+         rest = drop (length str) cs
+     in (Tok bomb n (LString (escIfy str))) : tokenise_wrk n (drop 1 rest)
+   | c == '('
+   = (Tok bomb n L_Open) : tokenise_wrk n cs
+   | c == ')'
+   = (Tok bomb n L_Close) : tokenise_wrk n cs
+   | c == '{'
+   = (Tok bomb n L_LBrace) : tokenise_wrk n cs
+   | c == '}'
+   = (Tok bomb n L_RBrace) : tokenise_wrk n cs
+   | c == ','
+   = (Tok bomb n L_Comma) : tokenise_wrk n cs
+   | c == '='
+   = (Tok bomb n L_Assign) : tokenise_wrk n cs
+   | otherwise
+   = let (str,rest) = takeDrop (`notElem` "(), \n\t") (c:cs)
+         kw x = (Tok bomb n x) : tokenise_wrk n rest
+     in  case str of
+            "framefail"    -> kw L_Framefail
+            "contents"     -> kw L_Contents
+            "def"          -> kw L_Def
+            "run"          -> kw L_Run
+            "if"           -> kw L_If
+            "then"         -> kw L_Then
+            "else"         -> kw L_Else
+            "fi"           -> kw L_Fi
+            "print"        -> kw L_Print
+            "when"         -> kw L_When
+            "expect"       -> kw L_Expect
+            "pass"         -> kw L_Pass
+            "fail"         -> kw L_Fail
+            "unknown"      -> kw L_Unknown
+            "skip"         -> kw L_Skip
+            "contains"     -> kw L_Contains
+            "lacks"        -> kw L_Lacks
+            "return"       -> kw L_Return
+            "otherwise"    -> kw L_Otherwise
+            "include"      -> kw L_Include
+            other          -> kw (LText other)
+
+takeDrop :: (Char -> Bool) -> String -> (String, String)
+takeDrop p cs = let taken = takeWhile p cs
+                in  (taken, drop (length taken) cs)
+
+isVarChar c = isAlpha c || isDigit c || c `elem` "_-"
+
+escIfy [] = []
+escIfy ('\\':'\\':cs) = '\\':escIfy cs
+escIfy ('\\':'n':cs)  = '\n':escIfy cs
+escIfy ('\\':'"':cs)  = '"':escIfy cs
+escIfy (c:cs) = c : escIfy cs
+
+takeLitChars [] = []
+takeLitChars ('\\':'"':cs) = '\\':'"':takeLitChars cs
+takeLitChars ('"':cs) = []     -- "
+takeLitChars (c:cs) = c : takeLitChars cs
diff --git a/testsuite/driver/CmdParser.hs b/testsuite/driver/CmdParser.hs
new file mode 100644 (file)
index 0000000..018ee08
--- /dev/null
@@ -0,0 +1,245 @@
+
+module CmdParser ( Parser, parseStringWith,
+                   pExpr, pStmt, pFile ) 
+where
+
+import CmdSyntax
+import CmdLexer
+
+import Char            ( isAlpha, isDigit, isSpace )
+import Directory       ( doesFileExist )
+
+import IOExts(trace)
+
+---------------------------------------------------------------------
+-- Parse a string with an arbitrary parser.
+
+parseStringWith :: String -> String -> Parser a -> Either String a
+parseStringWith err_src string p
+   = let tokens = tokenise 1 string
+         presult
+            = case p tokens of
+                 POk bads res [] -> Right res
+                 POk bads res uu -> Left (further bads uu)
+                 PFail bads      -> Left bads
+     in  case presult of
+            Right res  -> Right res
+            Left  bads -> Left (err_src ++ ":" ++ show (getLineNo bads) 
+                                ++ ": parse error on: "
+                                ++ if   null bads 
+                                   then "EOF" 
+                                   else show (getLex (head bads))
+                               )
+
+
+---------------------------------------------------------------------
+-- parsers
+pFile 
+   = pStar pTopDef
+
+pTopDef
+   = pAlts [
+        pApply TStmt pStmt,
+        p3 (\s w expr -> TSkip expr) (pKW L_Skip) (pKW L_When) pExpr,
+        p3 (\res w expr -> TResult res expr) pResult (pKW L_When) pExpr,
+        p2 (\e res -> TExpect res) (pKW L_Expect) pResult,
+        p2 (\i expr -> TInclude expr) (pKW L_Include) pExpr,
+        p4 (\d mnm formals stmts -> TMacroDef mnm (MacroDef formals stmts))
+           (pKW L_Def) pText pFormals (pInBraces (pStar pStmt))
+     ]
+     where
+        pFormals
+           = pInParens (pZeroOrMoreWithSep (pKW L_Comma) pFormalVar)
+
+pStmt 
+   = pAlts [
+        p3 (\var eq expr -> SAssign var expr) pVar (pKW L_Assign) pExpr,
+        p2 (\p expr -> SPrint expr) (pKW L_Print) pExpr,
+        p5 (\_ c _ t e -> SCond c t e)
+           (pKW L_If) pExpr (pKW L_Then) pStmts (pMaybeElse pStmts),
+        p2 (\mnm args -> SMacro mnm args) pText pMacroArgs,
+        p4 (\var eq run expr -> SRun var expr)
+           pVar (pKW L_Assign) (pKW L_Run) pExpr,
+        p2 (\ret expr -> SReturn expr) (pKW L_Return) pExpr,
+        p2 (\ret expr -> SFFail expr) (pKW L_Framefail) pExpr
+     ]
+     where
+        pStmts
+           = pStar pStmt
+
+pExpr
+   = pExpr9
+pExpr9
+   = pApply (foldr1 (EOp OpOr)) (pOneOrMoreWithSep (pKW L_Or) pExpr8)
+pExpr8
+   = pApply (foldr1 (EOp OpAnd)) (pOneOrMoreWithSep (pKW L_And) pExpr7)
+
+pExpr7
+   = pAlts [ p3 (\e0 op e6 -> EOp op e0 e6) pExpr0 pOp pExpr7,
+             pExpr0 ]
+     where
+        pOp = pAlts [pConstKW L_Eq OpEq,
+                     pConstKW L_NEq OpNEq,
+                     pConstKW L_Contains OpContains,
+                     pConstKW L_Lacks OpLacks,
+                     pConstKW L_Append OpAppend]
+
+pExpr0
+   = pAlts [
+        pApply EVar pVar,
+        pApply EString pString,
+        p2 (\c expr -> EContents expr) (pKW L_Contents) (pInParens pExpr),
+        p2 (\mnm args -> EMacro mnm args) pText pMacroArgs,
+        p5 (\_ c _ t e -> ECond c t e)
+           (pKW L_If) pExpr (pKW L_Then) pExpr (pMaybeElse pExpr),
+        pConstKW L_Otherwise EOtherwise,
+        p2 (\c expr -> EHasValue expr) (pKW L_HasValue) pExpr,
+        p2 (\ff expr -> EFFail expr) (pKW L_Framefail) pExpr,
+        pInParens pExpr
+     ]
+
+----------------------------
+
+pMacroArgs
+   = pInParens (pZeroOrMoreWithSep (pKW L_Comma) pExpr)
+
+pMaybeElse :: Parser a -> Parser (Maybe a)
+pMaybeElse p
+   = pAlts [ p3 (\_ e _ -> Just e) (pKW L_Else) p (pKW L_Fi),
+             pConstKW L_Fi Nothing ]
+
+pResult
+   = pAlts [pConstKW L_Pass Pass,
+            pConstKW L_Fail Fail,
+            pConstKW L_Unknown Unknown
+           ]
+
+pString
+   = pSatMap f where f (LString str) = Just str ; f _ = Nothing
+pVar
+   = pSatMap f where f (LVar var) = Just var ; f _ = Nothing
+pText
+   = pSatMap f where f (LText txt) = Just txt; f _ = Nothing
+pTextOrString
+   = pAlts [pString, pText]
+pInParens p
+   = p3 (\l x r -> x) (pKW L_Open) p (pKW L_Close)
+pInBraces p
+   = p3 (\l x r -> x) (pKW L_LBrace) p (pKW L_RBrace)
+
+pFormalVar
+   = pSatMap f where f (LVar var) 
+                        | take 1 var == "_" = Just var
+                        | otherwise = Nothing
+                     f _ = Nothing
+
+---------------------------------------------------------------------
+-- parser generics
+data PResult a
+   = PFail [Token] -- failure; [Token] is furthest failure
+   | POk   [Token] -- succeed; 1st [Token] is furthest failure
+                 a -- whatever
+           [Token] -- unused
+     deriving Show
+
+type Parser a = [Token] -> PResult a
+
+pEmpty :: a -> Parser a
+pEmpty x ts = POk ts x ts
+
+--pSat :: (Token -> Bool) -> Parser Token
+--pSat p []     = PFail (getLineNo [])
+--pSat p (t:ts) = if p t then POk t ts else PFail (getLineNo t)
+
+pApply :: (a -> b) -> Parser a -> Parser b
+pApply f p ts
+   = case p ts of
+        PFail bad      -> PFail bad
+        POk   bad x uu -> POk   bad (f x) uu
+
+pKW :: Lexeme -> Parser ()
+pKW lexeme (t:ts) | lexeme == getLex t  = POk (t:ts) () ts
+pKW lexeme ts                           = PFail ts
+
+pConstKW :: Lexeme -> a -> Parser a
+pConstKW lexeme x = pApply (const x) (pKW lexeme)
+
+
+pSatMap :: (Lexeme -> Maybe a) -> Parser a
+pSatMap fn (t:ts) 
+   = case fn (getLex t) of Just x  -> POk (t:ts) x ts
+                           Nothing -> PFail (t:ts)
+pSatMap fn []
+   = PFail []
+
+p2 :: (a -> b -> c) 
+      -> Parser a -> Parser b -> Parser c
+p2 f a1 a2 ts1
+   = case a1 ts1 of { PFail b1 -> PFail b1; POk ba1 x1 uu1 ->
+     case a2 uu1 of { PFail b2 -> PFail b2; POk ba2 x2 uu2 ->
+     POk (further ba1 ba2) (f x1 x2) uu2
+     }}
+
+p3 :: (a -> b -> c -> d) 
+      -> Parser a -> Parser b -> Parser c -> Parser d
+p3 f a1 a2 a3 ts1
+   = case a1 ts1 of { PFail b1 -> PFail b1 ; POk ba1 x1 uu1 ->
+     case a2 uu1 of { PFail b2 -> PFail b2 ; POk ba2 x2 uu2 ->
+     case a3 uu2 of { PFail b3 -> PFail b3 ; POk ba3 x3 uu3 ->
+     POk (further3 ba1 ba2 ba3) (f x1 x2 x3) uu3
+     }}}
+
+p4 :: (a -> b -> c -> d -> e) 
+      -> Parser a -> Parser b -> Parser c -> Parser d -> Parser e
+p4 f a1 a2 a3 a4 ts1
+   = case a1 ts1 of { PFail b1 -> PFail b1 ; POk ba1 x1 uu1 ->
+     case a2 uu1 of { PFail b2 -> PFail b2 ; POk ba2 x2 uu2 ->
+     case a3 uu2 of { PFail b3 -> PFail b3 ; POk ba3 x3 uu3 ->
+     case a4 uu3 of { PFail b4 -> PFail b4 ; POk ba4 x4 uu4 ->
+     POk (further4 ba1 ba2 ba3 ba4) (f x1 x2 x3 x4) uu4
+     }}}}
+
+p5 :: (a -> b -> c -> d -> e -> f) 
+      -> Parser a -> Parser b -> Parser c 
+      -> Parser d -> Parser e -> Parser f
+p5 f a1 a2 a3 a4 a5
+   = p2 ( \ (r1,r2,r3) (r4,r5) -> f r1 r2 r3 r4 r5 )
+        (p3 ( \x1 x2 x3 -> (x1,x2,x3) ) a1 a2 a3)
+        (p2 ( \x4 x5    -> (x4,x5)    ) a4 a5)
+
+pStar :: Parser a -> Parser [a]
+pStar p ts
+   = case p ts of
+        PFail bad -> POk bad [] ts
+        POk   bad x uu1 
+           -> case pStar p uu1 of
+                 POk bad2 xs uu2 -> POk (further bad bad2) (x:xs) uu2
+                 PFail bad       -> panic "pStar failed"
+
+pPlus :: Parser a -> Parser [a]
+pPlus p = p2 (:) p (pStar p)
+
+pOneOrMoreWithSep psep p
+   = p2 (:) p (pStar (p2 (\x y -> y) psep p))
+pZeroOrMoreWithSep psep p
+   = pAlts [pOneOrMoreWithSep psep p, pEmpty [] ]
+
+
+pAlts :: [Parser a] -> Parser a
+pAlts ps ts 
+   = loop ts ps
+     where
+        loop best_err_toks [] = PFail best_err_toks
+        loop best_err_toks (p:ps)
+           = case p ts of
+                POk bad x uu  -> POk (further bad best_err_toks) x uu
+                PFail other_err_toks 
+                   -> loop (further best_err_toks other_err_toks) ps
+
+further :: [Token] -> [Token] -> [Token]
+further bads1 bads2
+   = if getTokNo bads1 > getTokNo bads2 then bads1 else bads2
+further3 bads1 bads2 bads3
+   = further bads1 (further bads2 bads3)
+further4 bads1 bads2 bads3 bads4
+   = further (further bads4 bads1) (further bads2 bads3)
diff --git a/testsuite/driver/CmdSemantics.hs b/testsuite/driver/CmdSemantics.hs
new file mode 100644 (file)
index 0000000..52a3a92
--- /dev/null
@@ -0,0 +1,400 @@
+
+module CmdSemantics ( doEval )
+where
+
+import CmdSyntax
+import CmdLexer                ( isVarChar )
+import CmdParser       ( Parser, pExpr, pStmt, pFile, parseStringWith )
+import Monad           ( when )
+import Directory       ( doesFileExist )
+import System          ( ExitCode(..) )
+
+import IOExts(trace)
+---------------------------------------------------------------------
+-- Hook into Meurig Sage's regexp library
+
+import Regexp          ( MatcherFlag(..), searchS, legalRegexp, matchedAny )
+
+myMatchRegexp :: String -> String -> Maybe Bool
+myMatchRegexp rx str
+   -- | trace (show (rx, str)) True
+   = let result = searchS rx [Multi_Line] str
+     in  if   not (legalRegexp result)
+         then Nothing
+         else Just (matchedAny result)
+
+---------------------------------------------------------------------
+-- A simple monad to propagate failure inside the evaluator.
+
+type IOE a = IO (Either String a)
+
+returnE :: a -> IOE a
+returnE x = return (Right x)
+
+failE :: String -> IOE a
+failE str = return (Left str)
+
+thenE_ :: IOE a -> IOE b -> IOE b
+thenE_ x y
+   = do xv <- x
+        case xv of
+           Left  xerr -> return (Left xerr)
+           Right xok  -> y
+
+thenE :: IOE a -> (a -> IOE b) -> IOE b
+thenE x y
+   = do xv <- x
+        case xv of
+           Left  xerr -> return (Left xerr)
+           Right xok  -> y xok
+
+mapE :: (a -> IOE b) -> [a] -> IOE [b]
+mapE f [] = returnE []
+mapE f (x:xs) = f x        `thenE` \ x_done ->
+                mapE f xs `thenE` \ xs_done ->
+                returnE (x_done:xs_done)
+
+ioToE io 
+   = do r <- io
+        return (Right r)
+
+bind x f = f x
+
+
+---------------------------------------------------------------------
+-- environment management stuff
+
+data EvalEnv 
+   = EvalEnv {
+        vars :: [(Var, String)],       -- var binds
+        macs :: [(MacroName, MacroDef)],
+        dir  :: FilePath               -- 'cos evalCond might need
+                                       -- to read files in test dir
+     }
+
+addVarBindToEnv :: EvalEnv -> Var -> String -> IOE EvalEnv
+addVarBindToEnv env_in v s
+   | v `elem` ["tool", "testdir", "confdir", "conffile"]
+   = failE (readOnlyVar v)
+   | otherwise
+   = returnE (env_in { vars = (v,s):vars env_in })
+
+addMacroBindToEnv :: EvalEnv -> MacroName -> MacroDef -> EvalEnv
+addMacroBindToEnv env_in mnm mdef
+   = env_in { macs = (mnm,mdef):macs env_in }
+
+lookupVar :: EvalEnv -> Var -> IOE String
+lookupVar p v 
+   = case lookup v (vars p) of
+        Just xx -> returnE xx
+        Nothing -> failE (missingVar v)
+
+lookupMacro :: EvalEnv -> MacroName -> IOE MacroDef
+lookupMacro p mnm
+   = case lookup mnm (macs p) of
+        Just mdef -> returnE mdef
+        Nothing   -> failE (missingMacro mnm)
+
+initEvalEnv test_dir init_var_binds
+   = EvalEnv { vars = init_var_binds, macs = [], dir = test_dir }
+
+
+---------------------------------------------------------------------
+-- Top-level stuff.
+
+data TopRes
+   = TopRes EvalEnv            -- accumulated so far
+            (Maybe Result)     -- expected
+            (Maybe Result)     -- actual
+            [TopDef]           -- topdefs from include clauses?
+
+doTopDef :: EvalEnv -> TopDef -> IOE TopRes
+doTopDef p (TStmt stmt)
+   = doStmt p stmt                     `thenE` \ (p_new, _) ->
+     returnE (TopRes p_new Nothing Nothing [])
+doTopDef p (TSkip expr)
+   = evalExprToBool p expr             `thenE` \ do_skip ->
+     (if do_skip then Just Skipped else Nothing)
+                                       `bind`  \ maybe_skipped ->
+     returnE (TopRes p Nothing maybe_skipped [])
+doTopDef p (TResult res when_expr)
+   = evalExprToBool p when_expr                `thenE` \ expr_bool ->
+     (if expr_bool then Just res else Nothing)
+                                       `bind` \ maybe_result ->
+     returnE (TopRes p Nothing maybe_result [])
+doTopDef p (TExpect res)
+   = returnE (TopRes p (Just res) Nothing [])
+doTopDef p (TInclude expr)
+   = evalExpr p expr                   `thenE` \ filename ->
+     readFileE p filename              `thenE` \ contents ->
+     case parseStringWith ("file `" ++ filename ++ "'")
+                          contents pFile of
+             Left errmsg -> failE errmsg
+             Right more_topdefs 
+                -> returnE (TopRes p Nothing Nothing more_topdefs)
+doTopDef p (TMacroDef mnm mdef)
+   = addMacroBindToEnv p mnm mdef      `bind`  \ p_new ->
+     returnE (TopRes p_new Nothing Nothing [])
+
+-- Process top defs until either 
+-- * One expected and one actual result are available
+-- * We run out of topdefs
+-- With the additional complication that we should stop as
+-- soon as a `skip' actual result appears, regardless of 
+-- whether we have an actual result.
+
+doTopDefs :: EvalEnv -> [TopDef] -> ([Result], [Result]) 
+          -> IOE (Result, Result)
+
+doTopDefs p tds (_, (Skipped:_))
+   = returnE (Skipped, Skipped)
+doTopDefs p tds (e:exs, a:acts)
+   = returnE (e, a)
+doTopDefs p [] (exs, acts)
+   | null exs
+   = failE "No `expect' clauses found"
+   | null acts
+   = failE "Evaluation completed, but no actual result determined"
+doTopDefs p (td:tds) (exs, acts)
+   = doTopDef p td                     `thenE` \ td_result ->
+     case td_result of
+        TopRes p_new maybe_exp maybe_act new_tds
+           -> doTopDefs p_new (new_tds ++ tds)
+                              (exs  ++ listify maybe_exp,
+                               acts ++ listify maybe_act)
+              where listify (Just x) = [x]
+                    listify Nothing  = []
+
+
+-- Run the whole show, given some initial topdefs
+doEval :: FilePath -> [(Var,String)] -> [TopDef] 
+       -> IO (Maybe (Result, Result))
+doEval test_dir init_var_binds tds
+   = do outcome <- doTopDefs (initEvalEnv test_dir init_var_binds) tds ([],[])
+        case outcome of
+           Left err       -> do officialMsg err
+                                return Nothing
+           Right res_pair -> return (Just res_pair)
+
+---------------------------------------------------------------------
+-- The expression evaluator.
+
+fromBool b
+   = if b then "True" else "False"
+
+cantOpen f 
+   = "Can't open file `" ++ f ++ "'"
+regExpErr rx
+   = "Invalid regexp `" ++ rx ++ "'"
+missingVar v
+   = "No binding for variable `$" ++ v ++ "'"
+missingMacro mnm
+   = "No binding for macro `" ++ mnm ++ "'"
+notABool str
+   = "String `" ++ str ++ "' is neither `True' nor `False'"
+arityErr mnm n_formals n_actuals
+   = "Macro `" ++ mnm ++ "' expects " ++ show n_formals 
+     ++ " args, but was given " ++ show n_actuals
+macroArg mnm arg
+   = "No binding for formal param `$" ++ arg 
+     ++ "' whilst expanding macro `" ++ mnm ++ "'"
+readOnlyVar v
+   = "Assigments to variable `$" ++ v ++ "' are not allowed"
+hasValue mnm
+   = "Macro `" ++ mnm ++ "' used in context not expecting a value"
+noValue mnm
+   = "Macro `" ++ mnm ++ "' used in context expecting a value"
+
+evalOpExpr :: Op -> String -> String -> IOE String
+
+evalOpExpr OpAppend s1 s2 = returnE (s1 ++ s2)
+evalOpExpr OpEq     s1 s2 = returnE (fromBool (s1 == s2))
+evalOpExpr OpNEq    s1 s2 = returnE (fromBool (s1 /= s2))
+evalOpExpr OpContains s rx 
+   = case myMatchRegexp rx s of
+        Nothing -> failE (regExpErr rx)
+        Just bb -> returnE (fromBool bb)
+evalOpExpr OpLacks s rx 
+   = case myMatchRegexp rx s of
+        Nothing -> failE (regExpErr rx)
+        Just bb -> returnE (fromBool (not bb))
+
+
+doStmt :: EvalEnv -> Stmt -> IOE (EvalEnv, Maybe String)
+
+doStmt p (SAssign v expr)
+   = evalExpr p expr                   `thenE` \ str ->
+     addVarBindToEnv p v str           `thenE` \ p_new ->
+     returnE (p_new, Nothing)
+doStmt p (SPrint expr)
+   = evalExpr p expr                   `thenE` \ str ->
+     ioToE (putStr str)                        `thenE_`
+     returnE (p, Nothing)
+doStmt p (SCond c t maybe_f)
+   = evalExprToBool p c                        `thenE` \ c_bool ->
+     if   c_bool
+     then doStmts p t
+     else case maybe_f of
+             Nothing -> returnE (p, Nothing)
+             Just f  -> doStmts p f
+doStmt p (SMacro mnm args)
+   = evalMacroUse p mnm args           `thenE` \ (p_new, maybe_res) ->
+     case maybe_res of
+        Nothing -> returnE (p_new, Nothing)
+        Just vv -> failE (hasValue mnm)
+doStmt p (SRun var expr)
+   = evalExpr p expr                   `thenE` \ cmd_to_run ->
+     systemE cmd_to_run                        `thenE` \ exit_code ->
+     addVarBindToEnv p var 
+                     (show exit_code)  `thenE` \ p_new ->
+     returnE (p_new, Nothing)
+doStmt p (SReturn expr)
+   = evalExpr p expr                   `thenE` \ res ->
+     returnE (p, Just res)
+doStmt p (SFFail expr)
+   = evalExpr p expr                   `thenE` \ res ->
+     failE ("user-frame-fail: " ++ res)
+
+
+doStmts p []
+   = returnE (p, Nothing)
+doStmts p (s:ss)
+   = doStmt p s `thenE` \ (p_s, maybe_ret) -> 
+     case maybe_ret of
+        Just xx -> returnE (p_s, maybe_ret)
+        Nothing -> doStmts p_s ss
+
+
+evalExpr :: EvalEnv -> Expr -> IOE String
+evalExpr p (EOp op e1 e2)
+   | op `elem` [OpEq, OpNEq, OpAppend, OpContains, OpLacks]
+   = evalExpr p e1                     `thenE` \ e1s ->
+     evalExpr p e2                     `thenE` \ e2s ->
+     evalOpExpr op e1s e2s
+evalExpr p (EOp OpOr e1 e2)
+   = evalExprToBool p e1               `thenE` \ b1 ->
+     if b1 then returnE (fromBool True)
+           else evalExprToBool p e2    `thenE` \ b2 ->
+                returnE (fromBool b2)
+evalExpr p (EOp OpAnd e1 e2)
+   = evalExprToBool p e1               `thenE` \ b1 ->
+     if not b1 then returnE (fromBool False)
+               else evalExprToBool p e2        `thenE` \ b2 ->
+                    returnE (fromBool b2)
+evalExpr p (EString str)
+   = returnE str
+evalExpr p (EContents expr)
+   = evalExpr p expr                   `thenE` \ filename ->
+     readFileE p filename
+evalExpr p (EHasValue expr)
+   = evalExpr p expr                   `thenE` \ str ->
+     returnE (fromBool (not (null str)))
+evalExpr p EOtherwise
+   = returnE (fromBool True)
+evalExpr p (ECond c t maybe_f)
+   = evalExprToBool p c                        `thenE` \ c_bool ->
+     if   c_bool
+     then evalExpr p t
+     else case maybe_f of
+             Nothing -> returnE ""
+             Just f  -> evalExpr p f
+evalExpr p (EVar v)
+   = lookupVar p v
+evalExpr p (EMacro mnm args)
+   = evalMacroUse p mnm args           `thenE` \ (p_new, maybe_res) ->
+     case maybe_res of
+        Nothing -> failE (noValue mnm)
+        Just vv -> returnE vv
+evalExpr p (EFFail expr)
+   = evalExpr p expr                   `thenE` \ res ->
+     failE ("user-frame-fail: " ++ res)
+
+
+evalMacroUse :: EvalEnv -> MacroName -> [Expr] 
+             -> IOE (EvalEnv, Maybe String)
+evalMacroUse p mnm args
+   = lookupMacro p mnm                         `thenE` \ macro ->
+     case macro of { MacroDef formals stmts ->
+     if   length formals /= length args
+     then failE (arityErr mnm (length formals) (length args))
+     else 
+     mapE (evalExpr p) args            `thenE` \ arg_ress ->
+     zip formals arg_ress              `bind`  \ subst_env ->
+     map (substStmt subst_env) stmts   `bind`  \ stmts2 ->
+     doStmts p stmts2                  `thenE` \ pair ->
+     returnE pair
+     }
+
+substStmt :: [(Var,String)] -> Stmt -> Stmt
+substStmt env stmt
+   = case stmt of
+        SAssign v e -> SAssign v (se e)
+        SPrint e    -> SPrint (se e)
+        SCond c ts Nothing -> SCond (se c) (map ss ts) Nothing
+        SCond c ts (Just fs) -> SCond (se c) (map ss ts) (Just (map ss fs))
+        SRun v e -> SRun v (se e)
+        SReturn e -> SReturn (se e)
+        SMacro mnm es -> SMacro mnm (map se es)
+        SFFail e -> SFFail (se e)
+     where
+        se = substExpr env
+        ss = substStmt env
+
+substExpr env expr
+   = case expr of
+        EOp op a1 a2 -> EOp op (se a1) (se a2)
+        EVar v -> case lookup v env of
+                     Just str -> EString str
+                     Nothing -> EVar v
+        EString str -> EString str
+        EContents e -> EContents (se e)
+        EMacro mnm es -> EMacro mnm (map se es)
+        ECond c t Nothing  -> ECond (se c) (se t) Nothing
+        ECond c t (Just f) -> ECond (se c) (se t) (Just (se f))
+        EOtherwise -> EOtherwise
+        EHasValue e -> EHasValue (se e)
+        EFFail e -> EFFail (se e)
+     where
+        se = substExpr env
+        ss = substStmt env
+
+
+-------------------------
+
+-- If filename doesn't contain any slashes, stick $testdir/ on
+-- the front of it.
+readFileE :: EvalEnv -> String -> IOE String
+readFileE p filename0
+   = qualify filename0                         `thenE` \ filename ->
+     ioToE (doesFileExist filename)    `thenE` \ exists ->
+     if   not exists 
+     then failE (cantOpen filename)
+     else ioToE (readFile filename)    `thenE` \ contents ->
+     returnE contents
+     where
+        qualify fn 
+           | '/' `elem` fn 
+           = returnE fn
+           | otherwise 
+           = lookupVar p "testdir"     `thenE` \ testdir ->
+             returnE (testdir ++ "/" ++ fn)
+
+
+
+systemE :: String -> IOE Int
+systemE str
+   = ioToE (my_system str)             `thenE` \ ret_code ->
+     case ret_code of
+        ExitSuccess   -> returnE 0
+        ExitFailure m -> returnE m
+
+---------------------------
+
+evalExprToBool :: EvalEnv -> Expr -> IOE Bool
+evalExprToBool p e
+   = evalExpr p e                      `thenE` \ e_eval ->
+     case e_eval of
+        "True"  -> returnE True
+        "False" -> returnE False
+        other   -> failE (notABool other)
+
diff --git a/testsuite/driver/CmdSyntax.hs b/testsuite/driver/CmdSyntax.hs
new file mode 100644 (file)
index 0000000..1a9c8f7
--- /dev/null
@@ -0,0 +1,87 @@
+
+module CmdSyntax ( Var, MacroName, MacroDef(..),
+                   TopDef(..), Stmt(..), Expr(..),
+                   Op(..), Result(..),
+                   panic, officialMsg, my_system
+--                   isExpect, isWhen, isSkipWhen, isCompileOnly, 
+--                   isAssign 
+                 )
+where
+
+import IO              ( stdout, hPutStrLn )
+import System          ( system )
+
+---------------------------------------------------------------------
+-- misc
+panic str
+   = error ("\nruntests: the `impossible' happened:\n\t" ++ str ++ "\n")
+
+officialMsg str
+   = hPutStrLn stdout ("runtests: " ++ str)
+
+my_system s
+   = do putStrLn s
+        exit_code <- system s
+        --putStrLn (show exit_code)
+        return exit_code
+
+---------------------------------------------------------------------
+-- command abs syntax
+
+------------------
+type Var       = String
+type MacroName = String
+data MacroDef  = MacroDef [Var] [Stmt]
+                 deriving Show
+
+------------------
+
+data Expr
+   = EOp        Op Expr Expr
+   | EVar       Var
+   | EString    String
+   | EContents  Expr
+   | EMacro     MacroName [Expr]
+   | ECond      Expr Expr (Maybe Expr)
+   | EOtherwise
+   | EHasValue  Expr
+   | EFFail      Expr
+     deriving Show
+
+data Stmt
+   = SAssign    Var Expr
+   | SPrint     Expr
+   | SCond      Expr [Stmt] (Maybe [Stmt])
+   | SRun       Var Expr
+   | SReturn    Expr
+   | SMacro     MacroName [Expr]
+   | SFFail      Expr
+     deriving Show
+
+data TopDef
+   = TStmt      Stmt
+   | TSkip      Expr
+   | TResult    Result Expr
+   | TExpect    Result
+   | TInclude   Expr
+   | TMacroDef  MacroName MacroDef
+     deriving Show
+
+data Op
+   = OpAnd | OpOr | OpAppend | OpEq | OpNEq | OpContains | OpLacks
+     deriving (Eq, Show)
+{-
+isExpect (Expect _)     = True ; isExpect other = False
+isWhen   (When _ _)     = True ; isWhen other = False
+isSkipWhen (SkipWhen _) = True ; isSkipWhen other = False
+isCompileOnly CompileOnly = True ; isCompileOnly other = False
+isAssign (Assign _ _) = True; isAssign other = False
+-}
+
+data Result
+   = Pass              -- test passed
+   | Fail              -- test failed
+   | Unknown           -- test might have run, but outcome undetermined
+   | Skipped           -- skip-when clause indicated this test to be skipped
+     deriving (Eq, Show)
+
diff --git a/testsuite/driver/Main.hs b/testsuite/driver/Main.hs
new file mode 100644 (file)
index 0000000..d208cca
--- /dev/null
@@ -0,0 +1,209 @@
+
+module Main where
+
+import RunOneTest      ( run_one_test )
+import CmdSyntax       ( Var, Result(..), Expr(..), officialMsg, panic )
+import Directory
+import System
+import List
+
+findTests :: FilePath        -- name of root dir of tests
+          -> IO [FilePath]   -- name of all dirs containing "testconfig.T"
+
+findTests root_in
+   = snarf ((reverse . dropWhile (== '/') . reverse) root_in)
+           "."
+     where
+        snarf root dir
+           = do --putStr "snarf: "
+                --print (root,dir)
+                let this_dir = root ++ "/" ++ dir
+
+                dir_contents_raw <- getDirectoryContents this_dir
+                let dir_contents = filter (`notElem` [".", ".."]) 
+                                          dir_contents_raw
+
+                let tag_subdir f = do b <- doesDirectoryExist 
+                                              (this_dir ++ "/" ++ f)
+                                      return (b, f)
+
+                tagged_contents <- mapM tag_subdir dir_contents
+                --print tagged_contents
+                let include_this_dir
+                       = (not.null) [ () | (False, f) <- tagged_contents, 
+                                                         f == "testconfig.T"]
+                let subdir_names
+                       = [ f | (True, f) <- tagged_contents ]
+                subdir_testss
+                   <- mapM (\d -> snarf root (dir++"/"++d)) subdir_names
+                let subdir_tests 
+                       = (if include_this_dir then [scrub (root++"/"++dir)] 
+                                              else [])
+                         ++ concat subdir_testss
+                return subdir_tests
+
+        -- (eg)   "tests/./test1/run.stderr"  -->  "tests/test1/run.stderr"
+        scrub :: String -> String
+        scrub []               = []
+        scrub ('/':'.':'/':cs) = '/':scrub cs
+        scrub (c:cs)           = c : scrub cs
+
+
+run_multiple_tests :: [(Var,String)]           -- default var binds
+                   -> [FilePath]               -- paths to test dirs
+                   -> IO [(FilePath, 
+                           Maybe (Result, Result))]
+run_multiple_tests base_varenv dirs_containing_tests
+   = mapM f dirs_containing_tests
+     where f a_dir = do res <- run_one_test a_dir base_varenv
+                        return (a_dir, res)
+
+
+usage
+   = "usage:\n" ++
+     "runtests --tool=<compiler-to-test>\n" ++         -- "
+     "         --config=<path_to_config_file>\n" ++    -- "
+     "         path_to_root_of_tests_directory"
+
+
+main
+   = getArgs >>= main_really
+imain arg_str
+   = main_really (words arg_str)
+test
+   = imain "--tool=ghc --config=../config/cam-02-unx ../tests/"
+
+main_really arg_ws0
+   = do { let (arg_ws1, maybe_tool) = fish arg_ws0 "--tool="
+        ; let (arg_ws2, maybe_conf) = fish arg_ws1 "--config="
+        ; if (length arg_ws2 /= 1 || isNothing maybe_tool 
+                                  || isNothing maybe_conf) 
+           then do officialMsg usage
+                   exitWith (ExitFailure 1)
+           else 
+
+     do { let tool = unJust maybe_tool
+              conf = unJust maybe_conf
+              (confdir, conffile) = splitPathname conf
+              root_dir = head arg_ws2
+              base_varenv = [("tool", tool), ("confdir", confdir), 
+                             ("conffile", conffile)]
+
+        ; conf_ok <- doesFileExist conf
+        ; if    not conf_ok
+           then do officialMsg ("Config file `" ++ conf ++ "' doesn't exist.")
+                   exitWith (ExitFailure 1)
+           else 
+
+     do { all_tests <- findTests root_dir
+        ; putStr "\n"
+        ; officialMsg ("Found " ++ show (length all_tests) ++ " tests:")
+        ; putStrLn (unlines all_tests)
+        ; all_results <- run_multiple_tests base_varenv all_tests
+        ; putStr "\n"
+        ; officialMsg ("All done.")
+        -- ; putStr ("\n" ++ ((unlines . map show) all_results))
+        ; putStr ("\n" ++ executive_summary all_results)
+        ; putStr "\n"
+        -- ; exitWith ExitSuccess
+     }}}
+     where
+        splitPathname full
+           | '/' `notElem` full = (".", full)
+           | otherwise
+           = let full_r = reverse full
+                 f_r    = takeWhile (/= '/') full_r
+                 p_r    = drop (1 + length f_r) full_r
+             in  if null p_r then (".", reverse f_r)
+                             else (reverse p_r, reverse f_r)
+
+-- Summarise overall outcome
+executive_summary :: [(FilePath, Maybe (Result, Result))] -> String
+executive_summary outcomes
+   = let n_cands    = length outcomes
+         meta_fails = filter is_meta_fail outcomes
+         outcomes_ok = filter (not.is_meta_fail) outcomes
+         skipped    = filter is_skip       outcomes_ok
+
+         p_p = filter (got ((== Pass), (== Pass))) outcomes_ok
+         p_f = filter (got ((== Pass), (== Fail))) outcomes_ok
+         f_p = filter (got ((== Fail), (== Pass))) outcomes_ok
+         f_f = filter (got ((== Fail), (== Fail))) outcomes_ok
+
+         exp_u = filter (got ((== Unknown), const True)) outcomes_ok
+         act_u = filter (got (const True, (== Unknown))) outcomes_ok
+         u_u   = filter (got ((== Unknown), (== Unknown))) outcomes_ok
+
+         unexpected_u
+            = filter (`notElem` u_u) (exp_u ++ act_u)
+
+         unexpected = nub (p_f ++ f_p ++ unexpected_u)
+
+         summary
+            = unlines [ "OVERALL SUMMARY:"
+                      , ""
+                      , "   " ++ show n_cands 
+                              ++ " total test candidates, of which:"
+                      , "   " ++ show (length meta_fails) 
+                              ++ " framework failures,"
+                      , "   " ++ show (length skipped) ++ " were skipped,"
+                      , ""
+                      , "   " ++ show (length p_p) ++ " expected passes,"
+                      , "   " ++ show (length f_f) ++ " expected failures,"
+                      , "   " ++ show (length f_p) ++ " unexpected passes,"
+                      , "   " ++ show (length p_f) ++ " unexpected failures,"
+                      , ""
+                      , "   " ++ show (length exp_u) ++ " specified as unknown,"
+                      , "   " ++ show (length act_u) ++ " actual unknowns,"
+                      , "   " ++ show (length u_u) ++ " expected unknowns."
+                      ]
+
+         unexpected_summary
+            | null unexpected 
+            = ""
+            | otherwise
+            = "\nThe following tests had unexpected outcomes:\n"
+              ++ unlines (map ppTest unexpected)
+
+         metafail_summary
+            | null meta_fails
+            = ""
+            | otherwise
+            = "\nThe following tests had framework failures:\n"
+              ++ unlines (map (("   "++).fst) meta_fails)
+
+         ppTest (dir, Just (exp,act))
+             = "   exp:" ++ show exp ++ ", act:" ++ show act ++ "    " ++ dir
+
+         is_meta_fail (_, Nothing) = True
+         is_meta_fail other        = False
+
+         got (f1,f2) (_, Just (r1,r2)) = f1 r1 && f2 r2
+         got (f1,f2) other             = False
+
+         is_skip (_, Just (Skipped, Skipped)) = True
+         is_skip (_, Just (r1, r2))
+            | r1 == Skipped || r2 == Skipped 
+            = panic "is_skip"
+         is_skip other = False
+
+         is_exp_unk (_, Just (Unknown, Unknown)) = True
+         is_exp_unk other                        = False
+     in
+         summary ++ unexpected_summary ++ metafail_summary
+
+-- Helper for cmd line args
+fish :: [String] -> String -> ([String], Maybe String)
+fish strs prefix
+   = let n_prefix  = length prefix
+         pfx_eq    = (== prefix).(take n_prefix)
+         matched   = filter pfx_eq strs
+         unmatched = filter (not.pfx_eq) strs
+     in  case matched of
+            [m] -> (unmatched, Just (drop n_prefix m))
+            _   -> (strs,      Nothing)
+
+isNothing Nothing  = True
+isNothing (Just _) = False
+
+unJust (Just x) = x
diff --git a/testsuite/driver/RunOneTest.hs b/testsuite/driver/RunOneTest.hs
new file mode 100644 (file)
index 0000000..ebf87aa
--- /dev/null
@@ -0,0 +1,48 @@
+
+module RunOneTest ( run_one_test )
+where
+
+import CmdSyntax
+import CmdSemantics
+import Directory
+import Monad   ( when )
+import System  ( ExitCode(..) )
+
+-- This function should always return, no matter how disastrously
+-- things go.  If things go badly wrong, ie the test dir does not
+-- exist, or the config files have syntax errs, or whatever, it should
+-- print suitable error messages and return MetaFail.  Then its caller
+-- (which is responsible for running multiple tests) can decide whether
+-- to abort the entire run, or keep going, as it pleases.
+
+-- returns: 
+---   Nothing if there is a meta-failure -- for whatever
+--       reason, the test could not be conducted.  This indicates
+--       a failure of the test framework; this should never happen.
+--    Just (expected_result, actual_result) -- fst is the result
+--       which the testconfig.T file says should happen, the second
+--       is what actually happened.
+
+run_one_test :: FilePath       -- test dir
+             -> [(Var, String)]        -- default var bindings
+               -- containing at least $tool, $confdir, $conffile
+             -> IO (Maybe (Result, Result))
+run_one_test test_dir p_default
+   = do { putStr "\n"
+        ; officialMsg ("====== " ++ test_dir ++ " ======")
+        ; dir_exists <- doesDirectoryExist test_dir
+        ; if    not dir_exists 
+           then do officialMsg ("test directory `" ++ test_dir ++ 
+                                "' doesn't exist.")
+                   return Nothing
+           else 
+
+     do { let p_init = p_default ++ [("testdir", test_dir)]
+        ; let tds = [mkInclude (EVar "confdir") (EVar "conffile"),
+                     mkInclude (EVar "testdir") (EString "testconfig.T")]
+        -- ; print (show tds, show p_init)
+        ; doEval test_dir p_init tds
+     }}
+     where
+        mkInclude dir file 
+           = TInclude (EOp OpAppend dir (EOp OpAppend (EString "/") file))
\ No newline at end of file
diff --git a/testsuite/driver/basicRxLib/AbsTreeDefs.hs b/testsuite/driver/basicRxLib/AbsTreeDefs.hs
new file mode 100644 (file)
index 0000000..4ddb3d2
--- /dev/null
@@ -0,0 +1,338 @@
+module AbsTreeDefs
+   (AbsTree(..),Regexp,
+    mkEl,mkBackref,mkEnd,justPrefix,
+    mkSub,mkOpt,mkStar,mkPlus,mkMin,mkExact,mkMinMax,mkNg,
+    mkCon,mkAlt,
+    mkMinDef,mkMinMaxDef,
+    addEnd,
+    isElem,isBref,isEnd,
+    isSub,isStar,isPlus,isOpt,isMin,isMinmax,isNg,isInterval,isRepeatable,
+    isCon,isAlt,
+    isLeaf,isUn,isBin,child,left,right,updateChild,updateLeft,updateRight,
+    getMin,getMinMax,getPrefix,
+    getElem,getBref,getSEName,
+    getExtraRE,updateExtraRE,
+    foldPostT,foldPreT
+    )
+
+
+where
+
+import FiniteMap
+import Matchers
+
+data AbsTree a b = ABS (Regexp a b,b) -- regexp with some extra info at each node
+
+data Regexp a b = 
+          -- These have no children
+               EL (MatcherImpl a)              -- An element matcher
+                 Bool                  -- is this a prefix matcher
+             | BACKREF String          -- Match the nth subexp, for given n
+                       ([a]->MatcherImpl a)-- The matcher function to use
+
+             | END                     -- End of the Regexp
+
+          -- These are have 1 child
+             | SUB  String              -- the name to reference the subexp
+                    (AbsTree a b)       -- Root of a subexpression
+             | STAR (AbsTree a b)       -- Match 0 or more
+             | PLUS (AbsTree a b)       -- Match 1 or more
+             | OPT  (AbsTree a b)       -- Match 0 or 1
+             | MIN Int           -- Match at least n times, for given n
+                  (AbsTree a b)
+                  
+             | MINMAX Int Int    -- Match between n and m times, for given n,m
+                     (AbsTree a b)
+                     
+             | NGMIN Int           -- Match at least n times, non-greedily
+                    (AbsTree a b)
+                    
+             | NGMINMAX Int Int        -- Match between n and m times, non-greedily
+                       (AbsTree a b) 
+                       
+          -- These have two children
+             | CON (AbsTree a b)       -- Match concatenation of two subregexps
+                  (AbsTree a b)
+                  
+             | ALT (AbsTree a b)       -- Match first or second subregexp
+                  (AbsTree a b)
+                  
+          
+-- Build a regexp tree      
+-- mk functions are wrappers to build the abstract syntax tree for a node.
+
+junk = error "Not defined yet"
+
+-- leaf nodes
+mkEl f = ABS (EL f False,junk)
+mkBackref x f = ABS (BACKREF x f,junk)
+mkEnd = ABS (END,junk)
+justPrefix (ABS (EL f _,stuff))= ABS (EL f True,stuff) 
+
+-- nodes with one child
+mkSub s n = ABS (SUB s n,junk)
+mkOpt n = ABS (OPT n,junk)
+mkStar n = ABS (STAR n, junk)
+mkPlus n = ABS (PLUS n,junk)
+
+mkMin 0 n = ABS (STAR n,junk)
+mkMin 1 n = ABS (PLUS n,junk)
+mkMin x n | isElem n = 
+            let bef = (mkEl . foldl1 regseq . map getElem .take (x-1)) (repeat n) 
+            in  mkCon bef (mkPlus n)
+          | otherwise = ABS (MIN x n,junk)
+-- JRS: redundant clause: mkMin x n = ABS (MIN x n,junk)
+
+-- make a min node that is not to be optimised into a plus or star
+mkMinDef x n other = ABS (MIN x n,other)
+
+mkExact x n | isElem n =
+                (mkEl . foldl1 regseq . map getElem . take x) (repeat n) 
+mkExact 1 n = n
+mkExact x n = ABS (MINMAX x x n,junk)
+
+mkMinMax 0 1 n = ABS (OPT n,junk) 
+mkMinMax x y n | x <= 1 = ABS (MINMAX x y n,junk)
+mkMinMax x y n | isElem n = 
+              let bef = (mkEl . foldl1 regseq . map getElem.take (x-1)) (repeat n)
+              in  mkCon bef (ABS (MINMAX 1 (y-x+1) n,junk))
+mkMinMax x y n = ABS (MINMAX x y n, junk)
+            
+-- make a MINMAX node that is not to be optimised into a plus or star
+mkMinMaxDef x y n other = ABS (MINMAX x y n,other)
+
+-- make a repetition node into a nongreedy one
+mkNg n =
+           case n of 
+               (ABS (STAR n,junk)) -> mkAlt -- both nodes must be nullable as AugTrees
+                                             --(this is done by making them intervals)
+                                      (ABS (NGMINMAX 0 1 --prefer to match 0 length
+                                           (mkEl matchNull),junk))
+                                      (ABS (NGMIN 0  n ,junk))
+               (ABS (PLUS n,junk)) -> ABS (NGMIN 1  n ,junk)
+               (ABS (OPT n,junk)) -> mkAlt -- both nodes must be nullable as AugTrees
+                                            --(this is done by making them intervals)
+                                     (ABS (NGMINMAX 0 1  --prefer to match 0 length
+                                          (mkEl matchNull),junk))
+                                     (ABS (NGMINMAX 0 1  n,
+                                           junk))
+               (ABS (MIN x  n,junk)) -> ABS (NGMIN x  n ,junk)
+                                          
+               (ABS (MINMAX x y  n,junk)) 
+                       -> if (x /= y) then -- if matching exactly num times,
+                                           -- then non-greedy irrelevant
+                            ABS (NGMINMAX x y  n ,junk)
+                          else if x > 0 then
+                            ABS (NGMINMAX x y  n ,junk)
+                           else 
+                             mkAlt (ABS (NGMINMAX 0 1  
+                                        (mkEl matchNull),junk))
+                                   (ABS (NGMINMAX x y  n ,junk))
+                _ -> n
+
+-- binary nodes
+mkCon n1 n2 = ABS (CON n1 n2 ,junk)
+mkAlt n1 n2 = ABS (ALT n1 n2 ,junk)
+
+
+-- add a final node to the tree
+
+addEnd :: AbsTree a b  -- a tree without a final node
+       -> AbsTree a b  -- a tree with a final node
+addEnd n = ABS (CON n (ABS (END, junk)) ,junk)
+
+
+-- Interrogate regexps
+-- all of type AbsTree a b -> Bool
+
+isElem (ABS (EL _ _, _)) = True
+isElem _ = False
+
+isBref (ABS (BACKREF _ _ ,_)) = True
+isBref _ = False
+
+isEnd (ABS (END, _)) = True
+isEnd _ = False
+
+isSub (ABS (SUB _ _, _)) = True
+isSub _ = False
+
+isStar (ABS (STAR _, _)) = True 
+isStar _ = False
+
+isPlus (ABS (PLUS _, _)) = True
+isPlus _ = False
+
+isOpt (ABS (OPT _, _)) = True
+isOpt _ = False
+
+isMin (ABS (MIN _ _, _)) = True
+isMin (ABS (NGMIN _ _, _)) = True
+isMin _ = False
+
+isMinmax (ABS (MINMAX _ _ _, _)) = True
+isMinmax (ABS (NGMINMAX _ _ _, _)) = True
+isMinmax _ = False
+
+isNg (ABS (NGMIN _ _, _)) = True
+isNg (ABS (NGMINMAX _ _ _, _)) = True
+isNg _ = False
+
+isInterval x = isMinmax x || isMin x
+isRepeatable x = isMinmax x && snd (getMinMax x) > 1 || isMin x || isPlus x || isStar x
+
+isCon (ABS (CON _ _, _)) = True
+isCon _ = False
+
+isAlt (ABS (ALT _ _, _)) = True
+isAlt _ = False
+
+isLeaf x = isElem x || isBref x || isEnd x
+isUn x = isInterval x || isStar x || isPlus x || isOpt x || isSub x
+isBin x = isCon x || isAlt x
+
+
+-- get contents of regexps
+
+child :: AbsTree a b -> AbsTree a b
+child (ABS (SUB _ re, _)) = re
+child (ABS (STAR re, _)) = re
+child (ABS (PLUS re, _)) = re
+child (ABS (OPT re, _)) = re
+child (ABS (MIN _ re, _)) = re
+child (ABS (NGMIN _ re, _)) = re
+child (ABS (MINMAX _ _ re, _)) = re
+child (ABS (NGMINMAX _ _ re, _)) = re
+
+left :: AbsTree a b -> AbsTree a b
+left (ABS (CON re1 _, _)) = re1 
+left (ABS (ALT re1 _, _)) = re1
+
+right :: AbsTree a b -> AbsTree a b
+right (ABS (CON _ re2, _)) = re2
+right (ABS (ALT _ re2, _)) = re2
+
+-- get the extra info from an AbsTree
+getExtraRE :: AbsTree a b -> b
+getExtraRE (ABS (_,other)) = other
+
+-- get contents of an element regexps
+getElem :: AbsTree a b   -- a regexp (only an El one allowed)
+        -> MatcherImpl a         -- the matcher function at that leaf
+
+getElem (ABS (EL f _, _)) = f
+
+getPrefix :: AbsTree a b -- a regexp (only an El one allowed)
+          -> Bool       -- whether that regexp is a prefix only matcher
+getPrefix (ABS (EL _ prefix, _)) = prefix
+
+-- get contents of a backref regexp 
+getBref :: AbsTree a b
+       -> (String,           -- which subexp to refer to
+           [a] -> MatcherImpl a) -- the matcher function to use
+
+
+getBref (ABS (BACKREF x f, _)) = (x,f)
+
+
+-- get the minimum num interations from an interval regexp
+getMin :: AbsTree a b -> Int
+getMin (ABS (MIN x _, _)) = x
+getMin (ABS (MINMAX x _ _, _)) = x
+getMin (ABS (NGMIN x _, _)) = x
+getMin (ABS (NGMINMAX x _ _, _)) = x
+
+-- get the minimum & maximum num interations from a minmax regexp
+getMinMax :: AbsTree a b -> (Int,Int)
+getMinMax (ABS (MINMAX x y _ ,_)) = (x,y)
+getMinMax (ABS (NGMINMAX x y _ ,_)) = (x,y)
+
+-- get the name of the subexp to use to reference it
+getSEName :: AbsTree a b -> String
+getSEName (ABS (SUB s _,_)) = s
+
+-- update an AbsTree
+
+updateExtraRE :: b             -- new bit of extra info 
+             -> AbsTree a b    -- the regexp to be updated
+             -> AbsTree a b    -- the new regexp
+
+updateExtraRE newother (ABS (re,_)) = (ABS (re,newother))
+
+
+updateChild :: AbsTree a b -> AbsTree a b -> AbsTree a b
+updateChild newchild (ABS (MINMAX x y  child ,other))
+                     = (ABS (MINMAX x y  newchild ,other))
+updateChild newchild (ABS (MIN x  child ,other))
+                    = (ABS (MIN x  newchild ,other))
+updateChild newchild (ABS (NGMIN x  child ,other))
+                    = (ABS (NGMIN x  newchild ,other))
+updateChild newchild (ABS (NGMINMAX x  y  child ,other))
+                    = (ABS (NGMINMAX x y  newchild ,other))
+updateChild newchild (ABS (STAR child ,other)) 
+                    = (ABS (STAR newchild ,other))
+updateChild newchild (ABS (OPT child ,other))
+                    = (ABS (OPT newchild ,other))
+updateChild newchild (ABS (PLUS child ,other)) 
+                    = (ABS (PLUS newchild ,other))
+updateChild newchild (ABS (SUB s child ,other)) 
+                    = (ABS (SUB s newchild ,other))
+
+updateLeft :: AbsTree a b -> AbsTree a b -> AbsTree a b
+updateLeft newchild (ABS (CON l r ,other))
+                    = (ABS (CON newchild r ,other))
+updateLeft newchild (ABS (ALT l r ,other))
+                    = (ABS (ALT newchild r ,other))
+
+
+updateRight :: AbsTree a b -> AbsTree a b -> AbsTree a b
+updateRight newchild (ABS (CON l r ,other))
+                    = (ABS (CON l newchild ,other))
+updateRight newchild (ABS (ALT l r ,other))
+                    = (ABS (ALT l newchild ,other))
+
+
+
+
+foldPostT :: (AbsTree a b -> c -> c)   -- function to apply to each node
+          -> c                         -- initial      
+          -> AbsTree a b               -- Tree to fold over
+          -> c                         -- result
+
+foldPostT f a t 
+        | isLeaf t = f t a
+       | isUn t = f t (foldPostT f a (child t))
+       | isBin t = f t (foldPostT f (foldPostT f a (left t)) (right t))
+
+foldPreT  :: (AbsTree a b -> c -> c)   -- function to apply to each node
+          -> c                         -- initial      
+          -> AbsTree a b               -- Tree to fold over
+          -> c                         -- result
+
+foldPreT f a t 
+        | isLeaf t = f t a
+       | isUn t = (foldPostT f (f t a) (child t))
+       | isBin t =(foldPostT f (foldPostT f (f t a) (left t)) (right t))
+
+
+
+works (ABS (EL a x, other)) = (ABS (EL a x, 10))
+works (ABS (BACKREF a d, other)) = (ABS (BACKREF a d, 10))
+works (ABS (END,_)) = (ABS (END,10))
+works (ABS (SUB x c, other)) = (ABS (SUB x (works c), 10))
+works (ABS (STAR c,other)) = (ABS (STAR (works c),10))
+works (ABS (PLUS c,other)) = (ABS (PLUS (works c),10))
+works (ABS (OPT c,other)) = (ABS (OPT (works c),10))
+works (ABS (MIN a c,other)) = (ABS (MIN a (works c),10))
+works (ABS (NGMIN a c,other)) = (ABS (NGMIN a (works c),10))
+works (ABS (MINMAX a b c,other)) = (ABS (MINMAX a b (works c),10))
+works (ABS (NGMINMAX a b c,other)) = (ABS (NGMINMAX a b (works c),10))
+works (ABS (CON l r,_)) = (ABS (CON (works l) (works r),10))
+works (ABS (ALT l r,_)) = (ABS (ALT (works l) (works r),10))
+
+
+
+
+
diff --git a/testsuite/driver/basicRxLib/Assertions.hs b/testsuite/driver/basicRxLib/Assertions.hs
new file mode 100644 (file)
index 0000000..c9e6f45
--- /dev/null
@@ -0,0 +1,83 @@
+module Assertions 
+        (Assert,
+         doAssert,
+         prefix,
+        suffix,
+        bol,
+        eol,
+        wordBound,
+        notWordBound)
+
+where
+
+import Matchers
+
+-- a lookahead/lookbehind assertion to be applied to matcher 
+type Assert a =        [a]     -- before this position (look behind)
+                    -> [a]     -- after this position (look ahead)
+                    -> Bool    -- whether assertion about these holds
+
+
+
+doAssert :: Assert a         -- assertions that must be tried
+         -> MatcherImpl a        -- The matcher
+
+doAssert assertion bef as
+           = if assertion bef as then
+               Just ([],as)
+             else
+              Nothing
+
+-- make the given matcher accept only prefixes
+prefix :: Assert a 
+prefix [] _ = True
+prefix (x:xs) _ = False
+
+-- make the given matcher accept only suffixes
+suffix :: Assert a
+suffix _ [] = True
+suffix _ (x:xs) = False 
+
+-- make an assertion to allow matching from only beginning of lines
+bol:: Assert Char
+bol [] _ = True
+bol ('\n':xs) _ = True
+bol _ _ = False
+
+-- make an assertion to allow matching at only end of lines
+eol:: Assert Char
+eol _ [] = True
+eol _ ('\n':xs) = True
+eol _ _ = False
+
+wordBound:: Assert Char
+wordBound = wbound True
+
+notWordBound:: Assert Char
+notWordBound = wbound False
+
+-- make an assertion about word boundaries.
+-- will pass if for two adjoining characters one is a \w & one is a \W
+
+wbound     :: Bool    -- whether this is a positive assertion (want wboundary) 
+           -> Assert Char      -- the resulting assertion
+wbound _ [] [] = False
+
+wbound isWbound [] (m:_) = (isWordChar m) ==  isWbound
+
+-- before info is reversed!!!
+wbound isWbound (b:_) [] = (isWordChar b) == isWbound
+
+                   -- exclusive or combination, as
+                   -- either want to have a \w & be looking for \W
+                   -- or want to have a \W & be looking for \w
+wbound isWbound (b:_) (m:_) = 
+                          ((isWordChar b && not (isWordChar m))
+                          || (not (isWordChar b) && (isWordChar m)))  
+                          == isWbound
+
+
+
+
+
+
diff --git a/testsuite/driver/basicRxLib/AugTreeDefs.hs b/testsuite/driver/basicRxLib/AugTreeDefs.hs
new file mode 100644 (file)
index 0000000..2f99f69
--- /dev/null
@@ -0,0 +1,115 @@
+module AugTreeDefs 
+     (Aug,AugTree,
+      AugInfo(..),updateAugTree,
+      getAugInfo,
+      getLbl,
+      firstPos,
+      lastPos,children,followPos,
+      followInfo,followInfoNoInt,follows,followsWithoutInt,
+      isNullable)      
+
+where
+
+
+import OrdList
+import BagRE
+import FiniteMap
+import AbsTreeDefs
+
+{- An augmented Abstract syntax tree contains more info:
+     1 Labels on the leafs
+   and for each node, n, info about
+     2 firstpos (the leafs with which the regexp rooted at n can start)
+     3 lastpos  (the leafs with which the regexp rooted at n can end)
+     4 children (all the leaf nodes which are child nodes of n)
+     5 followpos information about what follows each leaf node, based
+                on regexp rooted at n.
+                 this is a pair, there's follow info counting intervals,
+                 and follow info without counting intervals.
+                 Adding subexp info requires the first, adding
+                interval info requires the second.
+     6 Nullable (Whether regular expression rooted at n can match 0 times)
+-}
+
+type AugTree a = AbsTree a (Aug a)
+data Aug a = AUG (Maybe Int) -- label for node, only labelled if its a leaf
+                AugInfo     -- extra AugInfo
+
+data AugInfo = AUGINFO (OrdList Int, -- The firstpos info
+                       OrdList Int, -- The lastpos info
+                       OrdList Int, -- The children info
+                        ([(Int,BagRE Int)],  -- without interval follows
+                                            -- for use with HandleInterval
+                        [(Int,OrdList Int)])-- including interval follows
+                                             -- for use with HandleSubexp
+                      )             -- follow info for regexp rooted here
+                      Bool      -- Nullable
+
+-- update an AugTree
+
+updateAugTree :: Maybe Int 
+             -> (OrdList Int,
+                 OrdList Int,
+                 OrdList Int,
+                  ([(Int,BagRE Int)],
+                   [(Int,OrdList Int)]))
+             -> Bool
+             -> AugTree a
+             -> AugTree a
+updateAugTree a b c re = updateExtraRE (AUG a (AUGINFO b c)) re 
+
+
+-- interrogate AugTree
+
+getAugInfo :: AugTree a        -- an augmented tree 
+           -> AugInfo  -- the firstpos,lastpos... info
+
+getAugInfo re = case (getExtraRE re) of
+                (AUG _ ainfo) -> ainfo
+
+getLbl :: AugTree a -> Maybe Int
+getLbl re = case (getExtraRE re) of
+             (AUG lbl _) -> lbl 
+
+firstPos :: AugTree a -> OrdList Int
+firstPos re = case (getAugInfo re) of
+                 (AUGINFO (fs,_,_,_) _) -> fs 
+
+lastPos :: AugTree a -> OrdList Int
+lastPos re = case (getAugInfo re) of
+                 (AUGINFO (_,ls,_,_) _) -> ls 
+
+children :: AugTree a -> OrdList Int
+children re = case (getAugInfo re) of
+                 (AUGINFO (_,_,chs,_) _) -> chs 
+
+followInfoNoInt :: AugTree a -> [(Int,BagRE Int)]
+followInfoNoInt re = case (getAugInfo re) of
+                      (AUGINFO (_,_,_,fi) _) -> fst fi
+
+followInfo :: AugTree a -> [(Int,OrdList Int)]
+followInfo re = case (getAugInfo re) of
+                   (AUGINFO (_,_,_,fi) _) -> snd fi
+
+followPos :: Int -> AugTree a -> OrdList Int
+followPos x re = (snd.head.(filter ((== x).fst)).followInfo) re
+
+follows :: OrdList Int -> AugTree a -> [(Int,OrdList Int)]
+{- For instance with "((a)(b))*c{2,}", if there are 3 nodes, "a", "b" and "c".
+   follows [2,3] will give, [(2,[1,3]),(3,[3,4])].
+
+-}
+follows xs t = filter (\(a,b) -> a `elem` xs) (followInfo t)
+
+followsWithoutInt :: OrdList Int -> AugTree a -> [(Int,OrdList Int)]
+{- For instance with "((a)(b))*c{2,}", if there are 3 nodes, "a", "b" and "c".
+   follows [2,3] will give, [(2,[1,3]),(3,[4])].
+-}
+followsWithoutInt xs t = map (\(a,b) -> (a,bagREToOL b)) 
+                             ( filter (\(a,b) -> a `elem` xs) 
+                                      (followInfoNoInt t) )
+
+isNullable :: AugTree a -> Bool
+isNullable t = case getAugInfo t of
+                  (AUGINFO _ null) -> null
+
diff --git a/testsuite/driver/basicRxLib/AugmentTree.hs b/testsuite/driver/basicRxLib/AugmentTree.hs
new file mode 100644 (file)
index 0000000..e8d93c1
--- /dev/null
@@ -0,0 +1,124 @@
+module AugmentTree 
+  (augmentT)
+where
+
+
+import FiniteMap
+import OrdList
+import BagRE
+import AbsTreeDefs
+import AugTreeDefs
+import ConstructorMonad
+
+-- Augment the abstract syntax tree to contain extra info
+
+augmentT :: AugTree a -> (AugTree a,Int)
+augmentT t = initLbl (mapCM augM t) 1
+
+augM :: AugTree a -> LblM (AugTree a)
+augM t      | isLeaf t = getNewLbl `thenLbl` \name ->
+                        returnLbl (doAug (Just name) t) 
+           | otherwise = returnLbl (doAug Nothing t)
+
+
+doAug :: Maybe Int -> AugTree a -> AugTree a
+doAug x t 
+    | isLeaf t = 
+       let (Just n) = x
+       in                 
+          updateAugTree x
+                      (singletonOL n,singletonOL n,singletonOL n,([],[]))
+                      False
+                      t
+
+    | isUn t = let (AUGINFO (fst,lst,chs,(flwNI,flwI)) nullable) = getAugInfo (child t)
+                   followers = if isRepeatable t && isInterval t then
+                                  (flwNI,
+                                   foldS (update fst) flwI lst )
+                               else 
+                                 if isRepeatable t && (not (isInterval t)) then
+                                  (foldS (updateNoInt fst) flwNI lst,
+                                   foldS (update fst) flwI lst)
+                               else
+                                  (flwNI,flwI)
+
+                   auginfo = (fst,lst,chs,followers)  
+              in
+                     if isInterval t then
+                        updateAugTree x auginfo (nullable || (getMin t == 0)) t
+                      else if isOpt t || isStar t then
+                       updateAugTree x auginfo True t
+                     else 
+                       updateAugTree x auginfo nullable t
+
+    | isBin t = 
+       let
+          (AUGINFO (fst1,lst1,chs1,(flw1a,flw1b)) null1) = getAugInfo (left t) 
+          (AUGINFO (fst2,lst2,chs2,(flw2a,flw2b)) null2) = getAugInfo (right t)
+
+       in
+          if isCon t then
+                 let 
+                     fstn = if null1 then 
+                                 unionOL fst1 fst2
+                            else    
+                                  fst1
+                     lstn = if null2 then
+                                  unionOL lst1 lst2
+                            else
+                                  lst2
+                     nulln = null1 && null2
+
+                     followers = 
+                       (foldS (updateNoInt (firstPos (right t)))
+                              (flw1a++flw2a)
+                              (lastPos (left t))
+                        ,
+                        foldS (update (firstPos (right t)))
+                              (flw1b++flw2b)
+                              (lastPos (left t))
+                       )
+
+                 in
+                    updateAugTree x (fstn,lstn,unionOL chs1 chs2,followers) nulln t
+
+
+          else -- is an "ALT" node 
+            let followers = (flw1a++flw2a,flw1b++flw2b)
+            in
+            updateAugTree x (unionOL fst1 fst2, unionOL lst1 lst2, unionOL chs1 chs2,followers)
+                          (null1 || null2) t 
+    
+
+
+updateNoInt :: OrdList Int      -- followers 
+         -> Int                 -- node to follow
+          -> [(Int,BagRE Int)] -- current follow info
+          -> [(Int,BagRE Int)] -- updated follow info
+
+updateNoInt newnodes node [] = [(node,listToBagRE newnodes)]
+updateNoInt newnodes node ((cn,cfollows):xs) = 
+                if cn == node then
+                   (cn,cfollows `unionBagRE` (listToBagRE newnodes)):xs
+                else if cn < node then
+                   (cn,cfollows):(updateNoInt newnodes node xs)
+                else
+                   (node, listToBagRE newnodes):(cn,cfollows):xs
+                     
+
+update :: OrdList Int  -- followers 
+       -> Int          -- node to follow
+       -> [(Int,OrdList Int)] -- current follow info
+       -> [(Int,OrdList Int)] -- updated follow info
+
+update newnodes node [] = [(node,newnodes)]
+update newnodes node ((cn,cfollows):xs) = 
+                if cn == node then
+                   (cn,cfollows `unionOL` newnodes):xs
+                else if cn < node then
+                   (cn,cfollows):(update newnodes node xs)
+                else
+                   (node,newnodes):(cn,cfollows):xs
+                     
+
+
diff --git a/testsuite/driver/basicRxLib/BagRE.hs b/testsuite/driver/basicRxLib/BagRE.hs
new file mode 100644 (file)
index 0000000..0441a4f
--- /dev/null
@@ -0,0 +1,43 @@
+module BagRE where
+
+{- 
+       a Bag module, also offering minusBag, based on finite map.
+-}
+
+import FiniteMap
+import OrdList
+
+type BagRE a = FiniteMap a Int
+
+
+emptyBagRE :: BagRE a 
+emptyBagRE = emptyFM
+
+unitBagRE :: elt -> BagRE elt
+unitBagRE x = unitFM x 1
+
+unionBagRE :: Ord elt => BagRE elt -> BagRE elt -> BagRE elt
+unionBagRE b1 b2 = plusFM_C (+) b1 b2
+
+listToBagRE :: Ord elt => [elt] -> BagRE elt
+listToBagRE xs = foldr (\x fm -> addToFM_C (+) fm x 1) emptyFM xs 
+
+bagREToList :: Ord elt => BagRE elt -> [elt]
+bagREToList b = foldFM (\k el xs -> xs ++ take el (repeat k)) [] b
+
+elemBagRE :: Ord elt => elt -> BagRE elt -> Bool 
+elemBagRE e b = maybeToBool (lookupFM b e)
+     where
+          maybeToBool (Just x) = True
+          maybeToBool Nothing = False
+
+filterBagRE :: Ord elt => (elt -> Bool) -> BagRE elt -> BagRE elt
+filterBagRE f b = filterFM (\ a b -> f a) b
+
+minusBagRE :: Ord elt => BagRE elt -> BagRE elt -> BagRE elt
+minusBagRE b1 b2 = (filterFM (\ a b -> b > 0)) (plusFM_C (-) b1 b2)
+
+bagREToOL ::  Ord elt => BagRE elt -> OrdList elt
+bagREToOL = (listToOL.keysFM)
+
+
diff --git a/testsuite/driver/basicRxLib/CompileREP.hs b/testsuite/driver/basicRxLib/CompileREP.hs
new file mode 100644 (file)
index 0000000..c27818d
--- /dev/null
@@ -0,0 +1,45 @@
+module CompileREP where
+
+
+import OrdList
+
+import FiniteMap
+import AbsTreeDefs
+import AugTreeDefs
+import Assertions(Assert)
+import Matchers(Matcher,MatcherFlag)
+import NFADefs
+import ParsePolyRegexp(mkAbstreeP)
+import IsPrefix(isPrefix)
+import ConstructorMonad(initLbl)
+import AugmentTree(augmentT)
+import MakeNFA(makeNFA)
+
+
+compileRegexpP :: (Ord a,Enum a,Read a,Show a) =>
+                     String    -- AbsTree in string format
+                  -> [MatcherFlag]-- matcher flags
+                  -> [Matcher a]-- Extra matcher functions 
+                  -> [Assert a] -- extra assertions
+                  -> Maybe 
+                      (NFA a,  -- The Resulting NFA
+                       Int,    -- The last node of the NFA
+                       [Node], -- The initial nodes of the NFA
+                       Int,    -- The number of intervals in the AbsTree
+                       Bool)   -- Whether we are just matching a prefix
+
+
+compileRegexpP re flags fs as
+    = let abstree1 = (mkAbstreeP re fs as)
+          abstree = case abstree1 of
+                     (Just a) -> a
+          prefix = isPrefix abstree
+          (augtree,numnodes) = augmentT abstree
+          nfa1 = initNFA numnodes
+          (nfa2,numintervals) = makeNFA augtree nfa1
+          initnodes = firstPos augtree
+      in 
+         case abstree1 of
+          Just a ->
+            Just (nfa2,numnodes,initnodes,numintervals,False)
+          Nothing -> Nothing
diff --git a/testsuite/driver/basicRxLib/CompileREPB.hs b/testsuite/driver/basicRxLib/CompileREPB.hs
new file mode 100644 (file)
index 0000000..4a6bdc8
--- /dev/null
@@ -0,0 +1,46 @@
+module CompileREPB where
+
+
+import OrdList
+
+import FiniteMap
+import AbsTreeDefs
+import AugTreeDefs
+import Assertions(Assert)
+import Matchers(Matcher,MatcherFlag)
+import NFADefs
+import ParsePolyRegexpBasic(mkAbstreePB)
+import IsPrefix(isPrefix)
+import ConstructorMonad(initLbl)
+import AugmentTree(augmentT)
+import MakeNFA(makeNFA)
+
+
+
+compileRegexpPB :: (Eq a,Read a,Show a) =>
+                      String   -- AbsTree in string format
+                   -> [MatcherFlag]-- matcher flags
+                   -> [Matcher a]-- Extra matcher functions 
+                   -> [Assert a] -- extra assertions
+                   -> Maybe 
+                       (NFA a, -- The Resulting NFA
+                        Int,   -- The last node of the NFA
+                        [Node],        -- The initial nodes of the NFA
+                        Int,   -- The number of intervals in the AbsTree
+                        Bool)  -- Whether we are just matching a prefix
+
+
+compileRegexpPB re flags fs as
+    = let abstree1 = (mkAbstreePB re fs as)
+          abstree = case abstree1 of
+                     (Just a) -> a
+          prefix = isPrefix abstree
+          (augtree,numnodes) = augmentT abstree
+          nfa1 = initNFA numnodes
+          (nfa2,numintervals) = makeNFA augtree nfa1
+          initnodes = firstPos augtree
+      in 
+         case abstree1 of
+          Just a ->
+            Just (nfa2,numnodes,initnodes,numintervals,False)
+          Nothing -> Nothing
diff --git a/testsuite/driver/basicRxLib/CompileRES.hs b/testsuite/driver/basicRxLib/CompileRES.hs
new file mode 100644 (file)
index 0000000..66683c2
--- /dev/null
@@ -0,0 +1,58 @@
+module CompileRES where
+
+
+import FiniteMap   
+import AbsTreeDefs
+import AugTreeDefs(firstPos,Aug)
+import Assertions(Assert)
+import Matchers(Matcher,MatcherFlag)
+import NFADefs(Node,NFA,NFANode,initNFA) 
+import ParseStringRegexp(mkAbstreeS)
+import IsPrefix(isPrefix)
+import ConstructorMonad(initLbl)
+import AugmentTree(augmentT)
+import MakeNFA(makeNFA)
+
+
+compileRegexpS :: 
+                     String    -- AbsTree in string format
+                 -> [MatcherFlag]-- matcher flags
+                  -> [Matcher Char]-- Extra matcher functions 
+                  -> [Assert Char] -- extra assertions
+                  -> Maybe
+                      (NFA Char,-- The Resulting NFA
+                       Int,    -- The last node of the NFA
+                       [Node], -- The initial nodes of the NFA
+                       Int,    -- The number of intervals in the AbsTree
+                       Bool)   -- Whether we are just matching a prefix
+
+
+compileRegexpS re flags fs as 
+    = let (abstree0) = (mkAbstreeS re fs as flags)
+          abstree = case abstree0 of
+                      (Just a) -> a
+          prefix = isPrefix abstree
+          (augtree,numnodes) = augmentT abstree
+          nfa1 = initNFA numnodes
+          (nfa2,numintervals) = makeNFA augtree nfa1
+          initnodes = firstPos augtree
+      in 
+         case abstree0 of 
+          Just a ->
+           Just (nfa2,numnodes,initnodes,numintervals,prefix)
+          Nothing -> Nothing
+
+
+
+
+makeit re = 
+ let      (abstree0) = (mkAbstreeS re [] [] [])
+          abstree = case abstree0 of
+                      (Just a) -> a
+          prefix = isPrefix abstree
+          (augtree,numnodes) = augmentT abstree
+          nfa1 = initNFA numnodes
+          (nfa2,numintervals) = makeNFA augtree nfa1
+          initnodes = firstPos augtree
+      in 
+         augtree
diff --git a/testsuite/driver/basicRxLib/ConstructorMonad.hs b/testsuite/driver/basicRxLib/ConstructorMonad.hs
new file mode 100644 (file)
index 0000000..3d094f4
--- /dev/null
@@ -0,0 +1,95 @@
+module ConstructorMonad 
+       (LblM,
+        initLbl,
+        returnLbl,
+        getNewLbl,
+        thenLbl,
+        thenLbl_,
+        foldPostM,foldPreM,mapCM,foldlM
+       )
+
+where
+
+
+import FiniteMap
+import AbsTreeDefs
+
+infixr 9 `thenLbl_`, `thenLbl`
+
+{- This monad is used to allow easy inclusion of
+   a name supply for the compileRegexp functions -}
+type LblM a   =  Int            -- name supply
+              -> (a,            -- result of the LblM action
+                  Int)          -- the remaining name supply
+
+-- run the Lbl thing and return result, and new name supply 
+-- (number of names used = new_name_supply - 1)
+initLbl :: LblM a -> Int -> (a,Int)
+initLbl act ns = case (act ns) of
+                  (result,new_ns) -> (result,new_ns-1)
+
+-- make a LblM thing from a thing
+returnLbl :: a -> LblM a 
+returnLbl thing ns  = (thing,ns)
+        
+-- get a new name from the name supply
+getNewLbl :: LblM Int 
+getNewLbl ns = (ns,ns+1)
+
+-- sequence two actions; the second uses the result of the first
+thenLbl :: LblM a  -> (a -> LblM c ) -> LblM c 
+thenLbl act1 act2 ns  
+    = case (act1 ns ) of
+           (result,newns) -> act2 result newns
+
+-- sequence two actions; the second doesn't care about the result of
+-- the first
+thenLbl_ :: LblM a  -> LblM c  -> LblM c 
+thenLbl_ act1 act2 ns 
+    = case (act1 ns ) of
+           (_,newns) -> act2 newns 
+
+
+foldPostM :: (AbsTree a b -> c -> LblM c) -> c -> AbsTree a b -> LblM c
+
+foldPostM f res re | isLeaf re = f re res
+foldPostM f res re | isUn re = foldPostM f res (child re) `thenLbl` \res1 ->
+                               f re res1
+foldPostM f res re | isBin re = foldPostM f res (left re) `thenLbl` \res1 ->
+                                foldPostM f res1 (right re) `thenLbl` \res2 ->
+                                f re res2
+
+
+foldPreM :: (AbsTree a b -> c -> LblM c) -> c -> AbsTree a b -> LblM c
+
+foldPreM f res re | isLeaf re = f re res
+foldPreM f res re | isUn re =  f re res `thenLbl` \res1 -> 
+                               foldPreM f res1 (child re) 
+foldPreM f res re | isBin re =  f re res `thenLbl` \res1 ->
+                               foldPreM f res1 (left re) `thenLbl` \res2 ->
+                                foldPreM f res2 (right re) 
+
+
+mapCM :: (AbsTree a b -> LblM (AbsTree a b)) -> AbsTree a b 
+     -> LblM (AbsTree a b)
+mapCM f t | isLeaf t = f t 
+        | isUn t = mapCM f (child t) `thenLbl` \res1 ->
+                    f (updateChild res1 t)
+         | isBin t = mapCM f (left t) `thenLbl` \res1 ->
+                     mapCM f (right t) `thenLbl` \res2 ->
+                     f (updateLeft res1 (updateRight res2 t))
+
+
+foldrM :: (a -> b -> LblM b) -> b -> [a] -> LblM b
+foldrM f a [] = returnLbl a
+foldrM f a (x:xs) = foldrM f a xs `thenLbl` \res ->
+                    f x res    
+
+
+
+foldlM :: (a -> b -> LblM b) -> b -> [a] -> LblM b
+foldlM f a [] = returnLbl a
+foldlM f a (x:xs) = f x a `thenLbl` \res ->
+                    foldlM f res xs 
+
diff --git a/testsuite/driver/basicRxLib/ExecRE.hs b/testsuite/driver/basicRxLib/ExecRE.hs
new file mode 100644 (file)
index 0000000..63b1540
--- /dev/null
@@ -0,0 +1,562 @@
+module ExecRE 
+      (execRegexp,
+       ReturnREM)
+where
+
+import OrdList
+import FiniteMap
+import Array
+import List
+import NFADefs
+
+{- A REM contains matchinfo used when running the nfa, nfaRun returns
+a list of them. If there is no altered interval or subexp info, &
+every match is of the same length then said list will be of length 1,
+otherwise we can take the first of them, which reaches a totally final
+state. This makes the match in a totally perlesque manner.
+-}
+type REM a = (OrdList Node,    -- current nodes 
+              ([a],    -- what matched
+               [a],    -- what's left to match 
+               Altered (Intervals,   -- state of all interval matches
+                        Subexps a))) -- state of all subexp matches
+
+     
+mkInitrem :: [REM a]   -- takes an initial
+          -> [a]       -- and rest of input
+          -> [REM a]   --  adds "rest of input" info
+mkInitrem [(ns,(ms,[],other))] xs = [(ns,(ms,xs,other))]  
+
+
+type ReturnREM a = Maybe (FiniteMap String [a], -- subexp matchinfo
+                          [a],                 -- what's before the match
+                          [a],                 -- what matched
+                          [a])                 -- what's after the match
+
+type Intervals = Array Int Interval  -- state of all interval matches
+data Interval = NILL   -- not entered interval yet
+              | IN Int -- IN n: still inside interval, 
+                       --       and have matched n times,
+              | OUT    -- have matched the minimum number of times
+                       -- required for a min interval
+              deriving Eq
+
+type Subexps a = FiniteMap String (SE a) -- state of all subexp matches
+
+data SE a = OPEN [a]   -- OPEN xs: entered subexp, and matched xs so far
+          | CLOSED [a] -- CLOSED xs: finished subexp, and matched xs
+
+data Altered a = OLD a -- subexp or interval info is unchanged
+               | NEW a -- subexp or interval info has changed
+
+extractcore :: Altered a -> a
+extractcore (OLD a) = a
+extractcore (NEW a) = a
+
+execRegexp :: (Show a,Read a,Eq a) =>  
+                   (NFA a,      -- the nfa
+                    Node,      -- the final node of the nfa
+                    [Node],    -- the initial nodes of the nfa
+                    Int,       -- number of intervals in nfa
+                   Bool)       -- whether we're just matching a prefix
+
+               -> [a]          -- input list
+               -> ReturnREM a  -- either "Nothing", or "Just" the 
+                               -- match results
+
+execRegexp (nfa,final,inits,numintervals,pre) inp =
+    let
+       initSE = emptyFM 
+       initIntervals = listArray (0,numintervals) (repeat NILL)        
+       initREM = [(inits,([],[],OLD (initIntervals,initSE)))]
+        resultses ses = (mapFM change.snd.extractcore) ses
+
+    in 
+       case (runNFA nfa final initREM (mkInitrem initREM inp) [] inp pre) of
+         ([],[]) -> Nothing
+         (((_,(whole,after,ses)):xs),before) ->
+              Just (resultses ses,reverse before,
+                    reverse whole,after)
+      
+
+change :: String -> SE a -> [a]
+change _ (OPEN xs) = xs
+change _ (CLOSED xs) = xs
+runNFA :: (Eq a) =>  
+                   NFA a        -- the nfa
+               -> Node         -- the final node of the nfa
+               -> [REM a]      -- the initial REM info, for
+                               -- restarting search
+               -> [REM a]      -- the current REM info
+               -> [a]          -- everything before the start of the
+                               -- current match
+               -> [a]          -- everything after the start of the
+                               -- current match
+               -> Bool         -- whether we're just matching a prefix
+
+               -> ([REM a],-- the new REM info, after this step
+                    [a])       -- what's in the input list before the
+                               -- current match
+{- runNFA -
+     we step through the nfa. A REM stores match info, and current nodes. 
+     We are therefore currently in all the states stored in the REM's.
+     All the nodes in one REM state have matched exactly the same
+     thing, and have the same interval information. 
+     We keep matching until we reach a purely final state, or until
+     a match fails. If we were to stop when one of the initial states
+     was a final one, then we'd stop after a repeatable thing had
+     matched only once. Eg a* will initially be in a final state, as it can
+     match 0 times. 
+
+     We don't stop when there is no input left. Instead we try
+     matching again! Why? Assertions are full nodes. They may have to
+     be applied at the end of a match, when there is no input left.
+     eg a$ against "a". after matching the "a" node there's no input
+     left. But we wish to try firing the "$" (suffix) node.
+     Assertions are usually the only nodes that can fire against empty
+     input. A user defined matcher function could match empty input,  
+     this case is ignored so runNFA could loop infinitely. Eg a<<1>>*
+     where function 1 matches the empty list would loop, as we keep
+     trying to match <<1>> as it's repeatable, and it never fails.
+     But then this would happen whatever we do. 
+
+     Order matters. We're only interested in when the head of the REM
+     list reaches a final state. If we put left's of "|" before right,
+     and move to beginning of repeatable expression before moving out
+     of it then we have fulfilled the matching semantics. Non-greedy
+     nodes simply put results of moving out of interval before those of
+     moving to start of interval.
+-}
+
+runNFA nfa final initrem rems@((ns,(_,as,_)):_) before rest prefix 
+        | ns ==[final] = (rems,before) 
+        -- in only final state so definitely finished
+       -- if we wanted to do full longest matching then we should not stop
+       -- until all states are final
+
+runNFA nfa final initrem rems@((ns,(_,as,_)):_) before rest prefix
+        = case (foldr (stepSingleREM nfa final before) [] rems) of
+           [] -> case (filter ((final `elem`). fst) rems) of
+                   [] -> if prefix then
+                          ([],[])
+                         else 
+                          case rest of
+                           [] -> ([],[]) -- no more to match against 
+                           (r:rs) ->     -- there is input left so try
+                             runNFA nfa final initrem (mkInitrem initrem rs) (r:before) rs prefix
+                                                     -- try matching from next
+                                                    -- position
+                   (rem:_) -> ([rem],before)
+           newrems@(y:ys) ->
+              runNFA nfa final initrem newrems before rest prefix
+            
+           
+
+
+
+
+stepSingleREM :: (Eq a) => 
+                    NFA a      -- the nfa
+                 -> Node       -- the final node of the nfa
+                 -> [a]                -- everything before the start of
+                               -- current match
+                 -> REM a      -- the current REM we're stepping on
+                 -> [REM a]    -- the results of REM steps so far
+                 -> [REM a]    -- the new results of REM steps
+
+stepSingleREM nfa final before (cns,(ms,as,extrabit)) sofar
+     = (foldS (combine (nfa,(ms,as,extractcore extrabit)) before) [] cns)
+       ++ sofar
+       -- step each node, from the current list & combine results
+
+   where
+     combine (nfa,stuff@(_,_,oldextra)) before  n newrems
+         = case (nfaStep nfa stuff before n) of
+
+             [] -> newrems -- that node did not match
+
+             (rem@(ns,(ms,as,OLD _)):[]) -> -- node matched & subexp
+                                            -- and interval info unchanged 
+                                            -- by stepping it through
+                 case newrems of
+                     [] -> [rem]  -- tis the first REM so just 
+                     all@((lastns,(lastms,_,OLD _)):xs) -> 
+                        (unionOL ns lastns,(ms,as,OLD oldextra)):xs
+                             -- this and last REM matched the same
+                             -- thing so combine them
+                     all@(x:xs) -> rem:all
+                             -- last REM did something fancy so just
+                             -- add new one to front
+             rems -> 
+                 rems ++ newrems
+                             -- this REM did something fancy so add it to front
+
+nfaStep :: Eq a => 
+              NFA a            -- the nfa
+           -> ([a],            -- what matched so far
+               [a],            -- what's left to match
+               (Intervals,     -- interval info
+                Subexps a))    -- subexp info
+          -> [a]               -- what's before the match
+           -> Node             -- the current node we're going to step
+           -> [REM a]          -- the results (possibly several for several)
+
+nfaStep nfa (whole,after,extra@(intervals,subexps)) before x
+     = case nfa!x of                   -- get the node
+        (Node n next ints ses) ->      
+         let bef = whole ++ before 
+         in
+          case (fire n bef after subexps) of 
+                                        -- fire it on current input
+            Nothing -> []              -- it failed to match anything
+            (Just (ms,as)) ->                  -- it did match 
+             let newms = (reverse ms) ++ whole -- we're returning
+                                               -- match back to front
+
+                -- handle changes to subexps and intervals
+                -- no subexp or interval changes here
+                 dealfancy [] [] =
+                   -- if length ms >1 then we've got something else
+                   -- fancy so just tell em we've got NEW stuff
+                    if length ms == 1 then
+                      [(next,(newms,as,OLD extra))]
+                    else 
+                      [(next,(newms,as,NEW extra))]
+
+                -- interval changes only
+                 dealfancy (x:xs) [] 
+                       = case (dealInts ints (intervals,next)) of
+                           s -> 
+                             map (dointerval newms as subexps) (nub s)
+
+                -- subexp changes only                       
+                 dealfancy [] (y:ys) 
+                       = case (dealSubexps1 ses subexps ms next) of
+                           newsubs ->
+                             map (dosubexp newms as intervals) newsubs
+
+
+                -- interval and subexp changes
+                 dealfancy (x:xs) (y:ys)
+                       = case (dealInts ints (intervals,next)) of
+                          
+                          s ->
+                           concat 
+                             (map (\(ints,ns)->
+                                  map (dosubexp newms as ints) 
+                                      (dealSubexps1 ses subexps ms ns)) 
+                                  (nub s))
+                                 
+
+                dosubexp newms as ints (subs,nexts) = 
+                                   (nexts,(newms,as,NEW (ints,subs)))
+                 dointerval newms as subs (ints,nexts) =
+                                   (nexts,(newms,as,NEW (ints,subs)))
+
+             in
+                dealfancy ints ses
+
+dealInts ::  
+               [IntervalInfo]  -- interval changes fired by node 
+            -> (Intervals,[Node])
+            -> [(Intervals,    -- new intervals
+                [Node])]       -- new possibly changed next nodes
+                       
+dealInts [] (intervals,ns) = [(intervals,ns)]
+dealInts (i:intRules) (intervals,ns) =
+            case (handle  i ns intervals) of
+
+              {- got an IntContinue from handle, we therefore store
+                 the current interval state, with the next nodes.
+                 when we come back round we'll try finishing
+                 the interval in them.
+                 If greedy we store state first so that we match longest. 
+                 (ie end interval in last place possible)
+                 otherwise (non-greedy) store state second so that try
+                 with this iteration of interval ending here first
+              -}
+              (_,Nothing,non_greedy,Just ns1,_) ->
+                 if non_greedy then
+                   (dealInts intRules (intervals,ns))++[(intervals,ns1)]
+                 else
+                   (intervals,ns1):(dealInts intRules  (intervals,ns))
+
+              -- done some form of interval start or end 
+              (x,Just el,non_greedy,nodes1,nodes2) -> 
+                 let newints = intervals // [(x,el)]
+                 in
+                  case (nodes1,nodes2) of
+
+                    -- done an interval start, so store nothing but move on
+                    (Nothing,Nothing) -> 
+                        dealInts intRules  (newints,ns)
+
+                    -- not looped min times yet, store this state, but
+                    -- don't move on 
+                    (Just ns1,Nothing) -> 
+                        [(newints,ns1)]
+
+                    -- looped max times, so don't store state yet. instead
+                    -- try passing on to higher intervals
+                    (Nothing,Just ns2) -> 
+                        dealInts intRules (newints,ns2)
+
+                    {- between min & max, or got min only interval
+                       either way store the state (going back to start
+                       of interval) and move on to higher intervals
+                       non-greedy move on to higher ones first, 
+                       greedy move to higher ones second, so we try
+                       continuing this interval as many times as possible first
+                    -}
+                    (Just ns1,Just ns2) -> 
+                        if non_greedy then
+                         (dealInts intRules  (newints,ns2))++[(newints,ns1)]
+                        else 
+                         (newints,ns1):(dealInts intRules (newints,ns2))
+
+    where    
+
+             
+             handle ::  
+                          IntervalInfo -- interval change we're trying
+                       -> [Node]    -- what the next nodes are supposed to be
+                       -> Intervals -- current intervals
+                       -> (Int,              -- interval to update
+                           Maybe Interval, -- what to update it with
+                           Bool,        -- non-greedy
+                           Maybe [Node],-- nodes to record
+                          Maybe [Node])-- nodes if leaving an interval 
+                                       -- or mid
+
+
+             -- just reset interval x, to NILL
+             handle  (Reset x) ns intervals =
+                                    (x,Just NILL,False,Nothing,Nothing)
+
+             -- start up interval x, if the lookbehind assertion holds
+             -- if it's already started then do nothing
+             handle (IntStart x) ns intervals = 
+                          case (intervals!x) of
+                            NILL -> (x,Just (IN 1),False,Nothing,Nothing)
+                                   
+                            (IN y) -> (x,Just (IN y),False,Nothing,Nothing)
+                            OUT ->   (x,Just OUT,False,Nothing,Nothing)
+
+
+             -- continue a greedy interval, by sending back the follow nodes
+             -- of this one, then we store current interval state
+             handle (IntContinue ns1) ns 
+                    intervals =
+                     (error "nothing",Nothing,False,Just ns1,Nothing)
+
+             -- continue a greedy interval, by sending back the follow nodes
+             -- of this one, then we store the current interval state
+             handle (NGIntContinue ns1) ns 
+                    intervals =
+                      (error "nothing",Nothing,True,Just ns1,Nothing)
+
+             -- end a minmax interval, if we've not looped enough then just
+            -- just try moving to ns1 (start), if we're between min & max 
+             -- try moving to ns1 (start) & ns2 (outside), ie send both back
+             -- if we've matched max times send back ns2 (outside) 
+             handle (IntEnd x min max ns1 ns2)  ns 
+                    intervals =
+                      case (intervals!x) of
+                        NILL -> error "NILL in IntEnd"
+                        (IN y) ->
+                                if y < min then
+                                   (x,Just (IN (y+1)),False,Just ns1,Nothing)
+                                else if (y>=min && y<max) then
+                                   (x,Just (IN (y+1)),False,Just ns1,Just ns2)
+                                else -- y > max
+                                  (x,Just NILL,False,Nothing,Just ns2)
+                               
+                        OUT -> error "out in IntEnd"
+
+             -- end a min interval, if we've not looped enough then just
+            -- just try moving to ns1 (start), (send ns1 back)
+             -- if we've matched min times try moving to start & to outside
+            -- send back ns1 (start) & ns2 (outside) 
+             handle (MinEnd x min ns1 ns2) ns  
+                    intervals =
+                     
+                          case (intervals!x) of 
+                              NILL -> error "NILL in MinEnd"
+                              (IN y) -> if y < min then
+                                         (x,Just (IN (y+1)),False,Just ns1,Nothing)
+                                        else
+                                          (x,Just OUT,False,Just ns1,Just ns2)
+                              OUT -> (x,Just OUT,False,Just ns1,Just ns2)
+                                   
+
+                {- 
+                   ns2 is nodes after end of interval, ns1 start of interval
+                   so want to jump to ns2 in preference to ns1 
+                -}
+
+             -- end a min interval, if we've not looped enough then just
+            -- just try moving to ns1 (start), (send ns1 back)
+             -- if we've matched min times try moving to start & to outside
+            -- send back  ns2 (outside) & ns1 (start) 
+             handle (NGMinEnd x min ns1 ns2) ns
+                    intervals =
+
+                       case (intervals!x) of 
+                         NILL -> error "NILL in MinEnd"
+                         (IN y) -> if y < min then
+                                    (x,Just (IN (y+1)),True,Just ns1,Nothing)
+                                   else 
+                                 
+                                     (x,Just OUT,True, Just ns1, Just ns2)
+                                
+                         OUT -> (x,Just OUT,True, Just ns1, Just ns2)
+                              
+             -- end a minmax NGinterval, if we've not looped enough then just
+            -- just try moving to ns1 (start), if we're between min & max 
+             -- try moving to ns2 (outside) & ns1 (start), ie send both back
+             -- if we've matched max times send back ns2 (outside) 
+             handle (NGIntEnd x min max ns1 ns2) ns 
+                     intervals =
+                          case (intervals!x) of
+                               NILL -> error "NILL in IntEnd"
+                               (IN y) -> 
+                                     if y < min then
+                                      (x,Just (IN (y+1)),True,Just ns1,Nothing)
+                                     else if (y>=min && y<max) then
+                                      (x,Just (IN (y+1)),True,Just ns1,Just ns2)
+                                     else -- y >= max
+                                       (x,Just NILL,True,Nothing,Just ns2)
+                                  
+                               OUT -> error "out in IntEnd"
+
+
+
+fire :: Eq a => NFAElem a   -- the matching function wrapped in an NFA node
+            -> [a]         -- everything before start of this match
+           -> [a]          -- list to match against
+            -> Subexps a    -- the subexp info (incase of backreferencing)
+            -> 
+                Maybe ([a], -- what matched  
+                       [a])-- what's left over
+
+fire (NFABack x f) before inps subexps  = 
+     case getsubexp (lookupFM subexps x) of
+      Nothing -> Nothing
+      (Just ms) -> f ms before inps
+     
+
+fire (NFAEl f) before inps  _ = f before inps
+
+fire NFAFinal before inps  _ = Just ([],inps)
+
+
+getsubexp:: Maybe (SE a)-- a subexpression
+            -> Maybe [a]-- what it's match contains, or nothing if its
+                       -- not been initialised
+-- both errors should have been caught at initial parser level
+getsubexp Nothing    = Nothing -- can happen, eg ((a)|(b))\\3 against "aa"
+                               -- b don't match anything, so is still NOUGHT
+getsubexp (Just (OPEN as)) = Just as-- can happen eg ((a){2})\\1 as
+                               -- closed at 2nd (\\1) node, and subexp
+                               -- stuff done AFTER matching 
+getsubexp (Just (CLOSED as)) = Just as
+{-
+dealsubexps :: [SubexpInfo] -- subexp alterations from this node
+               -> Subexps a -- the current subexps status
+               -> [a]      -- what to match against
+               -> Subexps a -- the new subexps status
+
+dealsubexps [] subexps ms = subexps
+
+dealsubexps (s:ses) subexps ms  
+   =   let 
+         updateSubStart el1 (OPEN ms) = 
+               case el1 of                    -- subexp's current status is
+                    OPEN xs -> OPEN (xs ++ ms)-- currently open so add more
+                    CLOSED xs -> OPEN ms      -- closed so restart it
+         updateSubMid el1 (OPEN ms) =
+               case el1 of     -- subexp's current status is
+                 OPEN xs -> OPEN (xs ++ ms)   -- currently open so add more
+                 CLOSED xs -> OPEN (xs ++ ms) -- closed too early, add more
+
+
+         newsubexps =
+             case s of
+              (NFASubStart x) -> -- start a subexpression
+                  addToFM_C updateSubStart subexps x (OPEN ms)
+                      -- default is to just newly open it
+              (NFASubMid x) -> -- in middle of a subexpression
+                  addToFM_C updateSubMid subexps x (OPEN ms)
+                      -- default should never be needed.
+
+              (NFASubEnd x) -> -- close a subexpression
+                case (lookupFM subexps x) of -- subexp's current status is
+                 Nothing  -> subexps     -- unstarted, leave it 
+                                         -- (eg match (a*)b against b,
+                                        -- a never fires, and so will
+                                        -- get Nothing in b
+                 (Just (OPEN xs)) -> addToFM subexps x (CLOSED xs) 
+                                         -- open so close it
+                 (Just (CLOSED xs)) -> addToFM subexps x (CLOSED xs) 
+                                         -- its closed so keep it closed
+
+       in
+                newsubexps --dealsubexps ses newsubexps ms
+-}
+
+
+dealSubexps1 :: [SubexpInfo]  -- subexp alterations from this node
+               -> Subexps a   -- the current subexps status
+               -> [a]        -- what to match against
+               -> [Node]      -- the next nodes, need to divide up to
+                             -- prevent premature closure
+               -> [(Subexps a,-- the new subexps status
+                  [Node])]
+
+dealSubexps1 [] subexps ms ns = [(subexps,ns)]
+
+dealSubexps1 (s:ses) subexps ms ns 
+   =   let 
+         updateSubAdd el1 (OPEN ms) = 
+               case el1 of                    -- subexp's current status is
+                    OPEN xs -> OPEN (xs ++ ms)-- currently open so add more
+                    CLOSED xs -> OPEN ms      -- closed so restart it
+
+         (newsubexps, newnodes) =
+             case s of
+              (NFASubAdd x) -> -- add match info to a subexpression
+                  (addToFM_C updateSubAdd subexps x (OPEN ms),Nothing)
+                      -- default is to just newly open it
+
+             (NFASubContinue nexts) -> -- this node may close a subexp
+               -- but there are others (nexts) after it, that could also 
+               -- do so. Make sure we don't close it prematurely.
+               -- Need this complexity to allow things like (a*b*)* to work.
+                   (subexps,Just (nexts `intersectOL` ns,ns `minusOL` nexts))    
+
+              (NFASubEnd x) -> -- close a subexpression
+                case (lookupFM subexps x) of -- subexp's current status is
+                 Nothing  -> (subexps,Nothing)
+                                        -- unstarted, leave it 
+                                         -- (eg match (a*)b against b,
+                                        -- a never fires, and so will
+                                        -- get Nothing in b
+                 (Just (OPEN xs)) -> (addToFM subexps x (CLOSED xs),Nothing) 
+                                         -- open so close it
+                 (Just (CLOSED xs)) -> (addToFM subexps x (CLOSED xs),Nothing) 
+                                         -- its closed so keep it closed
+
+       in
+            case newnodes of
+              Nothing -> dealSubexps1 ses newsubexps ms ns
+             (Just (ns1,ns2)) -> 
+                    (subexps,ns1):dealSubexps1 ses subexps ms ns2 
+
+
+
+
+
+
+
diff --git a/testsuite/driver/basicRxLib/FiniteMap.hs b/testsuite/driver/basicRxLib/FiniteMap.hs
new file mode 100644 (file)
index 0000000..298d331
--- /dev/null
@@ -0,0 +1,87 @@
+module FiniteMap where
+
+type FiniteMap key elt = [(key,elt)]
+
+-- Building
+emptyFM :: FiniteMap key elt
+emptyFM = []
+
+unitFM :: key -> elt -> FiniteMap key elt
+unitFM key elt = [(key,elt)]
+
+listToFM :: [(key,elt)] -> FiniteMap key elt
+listToFM l = l
+
+-- Adding to 
+
+addToFM :: Eq key => FiniteMap key elt -> key -> elt -> FiniteMap key elt
+addToFM [] key elt = [(key,elt)]
+addToFM ((k,e):xs) key elt = if (key == k) then 
+                               (k,elt):xs
+                             else
+                               (k,e):(addToFM xs key elt)
+
+addToFM_C :: Eq key => (elt -> elt -> elt) 
+                  -> FiniteMap key elt -> key -> elt -> FiniteMap key elt
+
+addToFM_C f [] key elt = [(key,elt)]
+addToFM_C f ((k,e):xs) key elt = if key == k then 
+                                   (k,f e elt):xs
+                                 else
+                                   (k,e):(addToFM_C f xs key elt)
+
+
+-- Combining
+
+       -- Bind right argument over left
+plusFM :: Eq key => FiniteMap key elt -> FiniteMap key elt -> FiniteMap key elt
+plusFM fm1 fm2 = foldr (\(k,e) fm -> addToFM fm k e) fm1 fm2
+       -- Combines bindings for the same thing with given function
+plusFM_C :: Eq key => (elt -> elt -> elt)
+                 -> FiniteMap key elt -> FiniteMap key elt -> FiniteMap key elt
+plusFM_C f fm1 fm2 = foldr (\(k,e) fm -> addToFM_C f fm k e) fm1 fm2
+
+--Interrogating
+
+sizeFM :: FiniteMap key elt -> Int
+sizeFM fm = length fm
+
+isEmptyFM :: FiniteMap key elt -> Bool
+isEmptyFM [] = True
+isEmptyFM (x:xs) = False
+
+elemFM :: Eq key => key -> FiniteMap key elt -> Bool
+elemFM key fm = key `elem` (keysFM fm)
+
+lookupFM :: Eq key => FiniteMap key elt -> key -> Maybe elt
+lookupFM [] key = Nothing
+lookupFM ((k,e):fm) key = if key == k then 
+                            Just e
+                          else
+                            lookupFM fm key
+
+
+
+--Mapping,Folding,Filtering
+
+foldFM :: (key -> elt -> a -> a) -> a -> FiniteMap key elt -> a
+foldFM f k fm = foldr (\(x,y)-> f x y) k fm 
+
+mapFM :: (key -> elt1 -> elt2) -> FiniteMap key elt1 -> FiniteMap key elt2
+mapFM f fm = map (\(x,y) -> (x,f x y)) fm
+
+filterFM :: (key -> elt -> Bool) -> FiniteMap key elt 
+         -> FiniteMap key elt
+filterFM f fm = filter (\(a,b) -> f a b) fm
+
+-- Listifying
+fmToList :: FiniteMap key elt -> [(key,elt)]
+fmToList xs = xs
+
+keysFM :: FiniteMap key elt -> [key]
+keysFM fm = map fst fm
+
+eltsFM :: FiniteMap key elt -> [elt]
+eltsFM fm = map snd fm
+
diff --git a/testsuite/driver/basicRxLib/Global.hs b/testsuite/driver/basicRxLib/Global.hs
new file mode 100644 (file)
index 0000000..ea30734
--- /dev/null
@@ -0,0 +1,12 @@
+module Global where
+
+data Maybe a = Nothing | Just a
+
+maybeToBool Nothing = False
+maybeToBool (Just _) = True
+maybeToA Nothing = error "tried to get something from Maybe Nothing"
+maybeToA (Just x) = x
+catMaybes [] = []
+catMaybes (Nothing:xs) = catMaybes xs
+catMaybes (Just x:xs) = x:catMaybes xs
+
diff --git a/testsuite/driver/basicRxLib/HandleInterval.hs b/testsuite/driver/basicRxLib/HandleInterval.hs
new file mode 100644 (file)
index 0000000..d73b331
--- /dev/null
@@ -0,0 +1,232 @@
+module HandleInterval
+    (handleInterval)
+where
+
+{- adds interval info to the nfa, eg a{1,3} stuff 
+   augtree is being parsed in post order, so
+   nested intervals: child has lower number than parent, 
+                     left child lower than right child 
+-}
+
+import OrdList
+import FiniteMap
+import BagRE
+import AbsTreeDefs
+import AugTreeDefs
+import ConstructorMonad
+import NFADefs
+
+
+handleInterval ::  AugTree a      -- The Info from the augmented tree
+               -> [(Int,BagRE Int)]-- the follow info from root of whole tree
+               -> NFA a                   -- The current nfa
+               -> LblM (NFA a)    -- The updated nfa
+handleInterval t followers nfa = 
+    let
+     rfollows = filter (\(a,b) -> a `elem` (lastPos t)) followers
+     newfollows = map (\(a,b)->bagREToOL (b `minusBagRE` (getFollow a (followInfoNoInt t )))) rfollows 
+     getFollow a fs = case (filter ((== a).fst) fs) of
+                        [] -> emptyBagRE
+                        ((_,x):_) -> x
+
+     nexts = foldr (\ns next -> next `unionOL` ns) emptyOL newfollows
+   {- the nodes we go to after leaving the interval, nexts, are all follow
+      nodes, not including those produced by operators inside the
+      interval. ie with (ab+){2} the nexts  nodes would be [1,3] where
+      node 1 is "a", and node 3 is the final node.
+   -}
+    in
+          getNewLbl `thenLbl` \name ->
+          returnLbl (dealInterval t name nexts nfa)    
+
+
+dealInterval :: AugTree a -- The Info from the augmented tree
+             -> Int      -- The label for this interval
+             -> OrdList Node -- the next nodes that follow after interval
+             -> NFA a     -- The current nfa
+             -> NFA a     -- The updated nfa
+
+{- For the expression, e,  rooted with this node: -}
+
+{-     MIN x - It starts in any of the first nodes of e
+               It ends in any of the last nodes of e,
+               Before matching x times, at end of e can go to start of e.
+               After matching x times, can go to start of e, or next after e.
+               It must be reset in any node following the last nodes
+               of e. (nested mins otherwise are never restarted.)
+                Interval may end prematurely if the last node of the
+                interval is nullable. In this case add IntContinues,
+                to make sure we try match through the necessary number
+               of times.
+                Eg (ab*c?){4} may end with a, b or c,
+                we would have [(2,[2,3]),(3,[3])] to allow the *, and
+               + operators to match as many times as possible
+                note with (a+|b){2}, that b should not follow a. We    
+               don't face this problem as we're using follownodes
+               based on what's inside the interval.
+                With (a{3,}b){4,}, we don't want Node "a" linking to
+               Node "a" (with an IntContinue), as this would 
+                interfere with the operation
+               of the inner interval. So we wish to use the follow
+               nodes without interval information added. 
+-}
+
+dealInterval t name nexts nfa | isMin t && not (isNg t)
+   = let 
+      fs = firstPos t
+      chs = children t
+      ls = lastPos t
+      nfa1 = foldS (updateNode (addIntervalStart name)) nfa fs
+      nfa2 = foldr (addIntContinue False) nfa1 (followsWithoutInt ls t) 
+      nfa3 = foldS (updateNode (addMinEnd name (getMin t) fs nexts)) nfa2 ls
+         in 
+                  foldS (updateNode (addReset name)) nfa3 
+                               (minusOL (followNodes ls nfa) chs)
+
+{-    NGMIN x - As for MIN above, except that given choice we want to
+               move out of interval as soon matched x times. (if possible)
+               
+-}
+
+dealInterval t name nexts nfa  | isMin t 
+       = let 
+          fs = firstPos t
+           chs = children t
+           ls = lastPos t
+           nfa1 = foldS (updateNode (addIntervalStart name)) nfa fs
+           nfa2 = foldr (addIntContinue True) nfa1 (followsWithoutInt ls t)
+           nfa3 = foldS (updateNode (addNGMinEnd name (getMin t) fs nexts)) nfa2 ls
+         in  foldS (updateNode (addReset name)) nfa3
+                        (minusOL (followNodes ls nfa) chs)
+            
+{- MINMAX x y - Starts in any of the first nodes of e
+               Ends in any of the last nodes of e,
+               Before matching x times, at end of e can go to start of e.
+               Between x and y times, can go to start of e, or next after e.
+               After matching y times, can go to next after e.
+                It must be reset in any node following the last nodes
+               of e. (nested intervals otherwise are never restarted.)
+                Interval may end prematurely if the last node of the
+                interval is nullable. We therefore use IntContinues as
+               discussed above.
+-}
+  
+   
+dealInterval t name nexts nfa |isMinmax t && not (isNg t) 
+          = let 
+             fs = firstPos t
+             chs = children t
+             ls = lastPos t
+            (x,y) = getMinMax t
+             nfa1 = foldS (updateNode (addIntervalStart name)) nfa fs
+             nfa2 =foldr (addIntContinue False) nfa1 (followsWithoutInt ls t)
+             nfa3 = foldS (updateNode (addIntEnd name x y fs nexts)) nfa2 ls
+            in 
+                  foldS (updateNode (addReset name)) nfa3 
+                               (minusOL (followNodes ls nfa) chs)
+
+{- NGMINMAX x y - Same as MINMAX except that between x and y times,
+                 prefer to go t next after e, than start of e
+-}
+
+dealInterval t name nexts nfa | isMinmax t
+     = let fs = firstPos t
+           chs = children t
+           ls = lastPos t
+          (x,y) = getMinMax t
+           nfa1 = foldS (updateNode (addIntervalStart name)) nfa fs
+           nfa2 = foldr (addIntContinue True) nfa1 (followsWithoutInt ls t)
+           nfa3 = foldS (updateNode (addNGIntEnd name x y fs nexts)) nfa2 ls
+        in 
+                  foldS (updateNode (addReset name)) nfa3 
+                               (minusOL (followNodes ls nfa) chs)
+
+
+addIntervalStart :: Int                 -- the label for the Interval
+                    -> NFANode a -- The node (of the nfa) to be updated
+                   -> NFANode a -- The updated node
+
+addIntervalStart name node
+         = changeInts (IntStart name:getInts node) node
+  
+
+addMinEnd ::    Int    -- the label for the interval
+             -> Int    -- the minimum number of times we have to match
+             -> OrdList Node -- all the first nodes of the interval
+             -> OrdList Node -- all the follow nodes, excluding those that
+                             -- are formed from inside interval
+             -> NFANode a -- The node (of the nfa) to be updated
+            -> NFANode a -- The updated node
+
+addMinEnd name min fs nexts node =
+  changeInts ((getInts node)++[MinEnd name min fs nexts]) node
+      
+
+addNGMinEnd :: Int       -- the label for the interval
+               -> Int    -- the minimum number of times we have to match
+               -> OrdList Node -- all the first nodes of the interval
+               -> OrdList Node -- all the follow nodes, excluding those that
+                               -- are formed from inside interval
+               -> NFANode a -- The node (of the nfa) to be updated
+              -> NFANode a -- The updated node
+
+addNGMinEnd name min fs nexts  node =
+  changeInts ((getInts node)++[NGMinEnd name min fs nexts]) node
+
+addReset ::    Int     -- the label for the interval 
+            -> NFANode a -- The node (of the nfa) to be updated
+           -> NFANode a -- The updated node
+             
+
+addReset name node
+     = changeInts (Reset name:getInts node) node
+                 -- always want to Reset. as will never reset on
+                 -- node that started min interval, can't do harm to
+                -- put it first
+
+
+addIntEnd :: Int        -- the label for the interval
+             -> Int     -- the min number of times we can loop 
+             -> Int     -- the max number of times we can loop
+             -> OrdList Node -- all the first nodes of the interval
+             -> OrdList Node -- all the follow nodes, excluding those that
+                             -- are formed from inside interval
+             -> NFANode a -- The node (of the nfa) to be updated
+            -> NFANode a -- The updated node
+             
+
+addIntEnd name min max fs nexts  node
+     = changeInts ((getInts node)++[IntEnd name min max fs nexts]) node
+
+
+addNGIntEnd :: Int      -- the label for the interval
+             -> Int     -- the min number of times we can loop 
+             -> Int     -- the max number of times we can loop
+             -> OrdList Node -- all the first nodes of the interval
+             -> OrdList Node -- all the follow nodes, excluding those that
+                             -- are formed from inside interval
+             -> NFANode a -- The node (of the nfa) to be updated
+            -> NFANode a -- The updated node
+
+addNGIntEnd name min max fs nexts  node
+     = changeInts ((getInts node)++[NGIntEnd name min max fs nexts]) node
+
+
+
+addIntContinue :: Bool         -- whether it's non-greedy
+               -> (Node,[Node]) -- the node to modify & all follow nodes of it
+               -> NFA a                -- the nfa to update
+               -> NFA a                -- the updated nfa
+
+addIntContinue non_greedy (nodeLbl,nexts) nfa =
+  updateNode (\node -> (changeInts ((getInts node) ++[newint]) node))
+             nodeLbl nfa
+ where
+    newint = if non_greedy then
+               NGIntContinue nexts
+             else
+               IntContinue nexts
+   
diff --git a/testsuite/driver/basicRxLib/HandleSubexp.hs b/testsuite/driver/basicRxLib/HandleSubexp.hs
new file mode 100644 (file)
index 0000000..ab6973c
--- /dev/null
@@ -0,0 +1,117 @@
+module HandleSubexp
+    (handleSubexp)
+where
+
+{- This module provides functions to add subexp info to the nfa.
+-}
+
+
+
+import FiniteMap
+import OrdList
+import AbsTreeDefs
+import AugTreeDefs
+import NFADefs
+
+
+
+{- handleSubexp - 
+       add information about a subexp node, assumes it has been
+       given a subexp node.
+-}
+
+handleSubexp :: AugTree a -> NFA a -> NFA a
+handleSubexp t nfa
+              = dealSubexp (getSEName t) t nfa
+
+
+{- dealSubexp i t nfa 
+       Update an nfa with info about subexpression labelled i. The node
+        contains a few bits of info:
+
+        firsPos - all the nodes that can start the subexpression
+       lastPos - all the nodes that can end the subexpression
+       children - all the leaf nodes in the subexpression
+       (child t) - the immediate child node of the subexpression.
+
+        When we enter a subexpression, we want to start recording what
+       the subexp matched, with mkSubAdd i. We do this for all the child
+       nodes of the subexp
+
+       We want to close the subexp when we leave it. This happens
+       on any of the last nodes in the subexp. (lastPos n)
+
+       We don't want to end the subexp prematurely. We therefore use
+       NFASubContinue ns. This gives all the follownodes of a
+       particular lastpos node. These are calculated simply using the
+       subexpression, not operators outside of it. So
+       with (a+|b+)*, "a" will be a follownode of "a", and "b" of "b", 
+       but "b" will not follow "a", and vice versa, as the outer STAR
+       operator will not be included. This therefore assumes that the
+       NFA has only follow information for the regexp rooted at the
+       current subexpression. 
+
+-}             
+
+dealSubexp :: String           -- the label for the new node
+             -> AugTree a      -- the root of tree is node to update with
+             -> NFA a          -- the nfa to update
+             -> NFA a
+
+dealSubexp i t nfa =
+     let  
+       fs = firstPos t
+       chs = children t
+       ls = lastPos t
+       new1nfa = 
+           foldS (updateNode (mkSubAdd i)) nfa chs
+               -- start or continue a subexp node but add info about   
+               -- what matched here.
+
+
+       new2nfa = 
+           foldr mkSubContinue new1nfa (follows ls t)
+               -- a subexp should not be stopped prematurely, try
+               -- stopping it later first. We continue with the
+               -- subexp, moving to any follow nodes of that lastpos
+               -- node first, before moving on.
+               -- This allows things like it@(a+), to work, as the
+               -- inner repeatable operations will be allowed to
+               -- work. As we're only allowing operators insidee the 
+               -- subexpression to work, we don't have a problem with
+               -- the likes of (a+|b+)*: "a" is not a follownode of b,
+               -- and vice versa.
+
+     in
+           foldS (updateNode (mkSubend i)) new2nfa ls
+                       
+
+mkSubAdd      :: String           -- the label for the subexp
+              -> NFANode a -- the node (of the nfa) to be updated
+              -> NFANode a -- the node with new substart info in it
+        
+mkSubAdd i node 
+               = changeSES ((NFASubAdd i):(getSES node)) node 
+             
+mkSubend ::      String           -- the label for the subexp
+              -> NFANode a -- the node (of the nfa) to be updated
+              -> NFANode a -- the node with new subend info in it
+
+mkSubend i node 
+             = changeSES (getSES node ++ [NFASubEnd i]) node
+       
+
+
+mkSubContinue :: (Node,[Node]) -- the node to modify & all follow nodes of it
+              -> NFA a         -- the nfa to update
+              -> NFA a         -- the updated nfa
+
+mkSubContinue (nodeLbl,nexts) nfa = 
+         updateNode (\node -> (changeSES (getSES node ++ [NFASubContinue nexts]) node))
+                     nodeLbl nfa
+
+
+
+
+
+
diff --git a/testsuite/driver/basicRxLib/IsPrefix.hs b/testsuite/driver/basicRxLib/IsPrefix.hs
new file mode 100644 (file)
index 0000000..5c52cc9
--- /dev/null
@@ -0,0 +1,17 @@
+module IsPrefix 
+  (isPrefix)
+where
+
+
+
+import FiniteMap
+
+import AbsTreeDefs 
+
+isPrefix :: AbsTree a b -> Bool
+isPrefix t | isLeaf t = getPrefix t 
+           | isUn t = isPrefix (child t)
+           | isCon t = (isPrefix (left t))
+           | isAlt t = (isPrefix (left t)) && (isPrefix (right t))
+
+
diff --git a/testsuite/driver/basicRxLib/MakeNFA.hs b/testsuite/driver/basicRxLib/MakeNFA.hs
new file mode 100644 (file)
index 0000000..a208a5b
--- /dev/null
@@ -0,0 +1,45 @@
+module MakeNFA 
+  (makeNFA)
+where
+
+
+import OrdList
+import FiniteMap
+import Matchers
+import Assertions
+import AbsTreeDefs
+import AugTreeDefs
+import NFADefs
+import ConstructorMonad
+import HandleSubexp
+import HandleInterval
+import MakeNFANode
+import BagRE
+
+{- build an NFA from the augmented abstract syntax tree, given an
+   initial nfa
+   (contains follow info, interval info, and subexp info)
+-}
+
+--makeNFA :: AugTree a -> NFA a -> (NFA a,Int) 
+makeNFA t nfa = 
+        case (initLbl (foldPostM (handleNode (followInfoNoInt t)) nfa t) 1) of
+          (nfa,x) -> (addFollowInfo t nfa,x)
+
+-- Add subexp and interval info for nfa
+
+handleNode :: [(Int,BagRE Int)] -> AugTree a -> NFA a -> LblM (NFA a)
+
+handleNode fllws t nfa = 
+                   returnLbl (makeNode t nfa) `thenLbl` \newnfa ->
+                   (if isInterval t then
+                      handleInterval t fllws newnfa
+                    else
+                      returnLbl (newnfa)) `thenLbl` \newnfa1 ->
+                   if isSub t then
+                     returnLbl (handleSubexp t newnfa1)
+                   else
+                     returnLbl (newnfa1)
+
+
+
diff --git a/testsuite/driver/basicRxLib/MakeNFANode.hs b/testsuite/driver/basicRxLib/MakeNFANode.hs
new file mode 100644 (file)
index 0000000..d779d2c
--- /dev/null
@@ -0,0 +1,44 @@
+module MakeNFANode
+  (makeNode,
+   addFollowInfo)
+where
+
+
+import OrdList
+import FiniteMap
+import Matchers
+import Assertions
+import AbsTreeDefs
+import AugTreeDefs
+import NFADefs
+
+{- build an Nfa node from the augmented abstract syntax tree node, given an
+   initial nfa node.
+   (contains no follow info, or interval info, or subexp info)
+-}
+
+makeNode :: AugTree a -> NFA a -> NFA a
+makeNode t nfa = case (getLbl t) of
+                   (Just x) -> updateNode (mkNfanode x t) x nfa
+                   (Nothing) -> nfa
+
+mkNfanode :: Int -> AugTree a -> NFANode a -> NFANode a
+mkNfanode n re cnode
+                | isElem re =
+                    let  f = getElem re
+                     in  mkNfaEl f cnode
+
+               | isBref re =
+                    let (x,f) = getBref re
+                    in
+                        mkNfaBack x f cnode
+
+               | otherwise = mkNfaFinal n cnode
+
+{- Add info about what follows each node, to the nfa -}
+
+addFollowInfo :: AugTree a -> NFA a -> NFA a
+addFollowInfo t nfa = foldr addtoNFA nfa (followInfo t)
+  where
+   addtoNFA (x,nexts) nfa = updateNode (changeNexts nexts) x nfa
+
diff --git a/testsuite/driver/basicRxLib/Matchers.hs b/testsuite/driver/basicRxLib/Matchers.hs
new file mode 100644 (file)
index 0000000..0ac6edf
--- /dev/null
@@ -0,0 +1,146 @@
+module Matchers 
+       (MatcherFlag(..),
+         initFlags,
+         MatcherImpl,
+         Matcher,
+         wrapMatcher,
+         regseq,
+         isEl,
+        isWordChar,
+        matchEls,
+        matchAny,
+        matchAnyBut,
+         matchNull,
+        matchBref,
+        matchIBref)
+        
+where
+
+import Char
+import FiniteMap
+
+data MatcherFlag = Global_Match     -- replace every occurrence of match
+                                   -- rather than just the first in "subst"
+                 | Case_Insensitive -- ignore case when using strings
+                 | Case_Sensitive   -- don't ignore case when using strings 
+                 | Single_Line     -- treat string as a single line
+                                   -- . matches \n
+                 | Multi_Line      -- treat string as multi-line 
+                                  -- (^ ($) matches from beginning (end) of line)
+                | Default_Line    -- . does not match \n, but 
+                                  -- (^ does not match from beginning of line...)
+
+                 deriving (Read,Show,Eq)
+
+{-
+instance Read MatcherFlag where
+ readsPrec 0 "Global_Match" = [(Global_Match,"")]
+ readsPrec 0 "Case_Insensitive" = [(Case_Insensitive,"")]
+ readsPrec 0 "Case_Sensitive" = [(Case_Sensitive,"")]
+ readsPrec 0 "Single_Line" = [(Single_Line,"")]
+ readsPrec 0 "Multi_Line" = [(Multi_Line,"")]
+ readsPrec 0 "Default_Line" = [(Default_Line,"")]
+-}
+
+initFlags :: [MatcherFlag] -> [(String,MatcherFlag)]
+initFlags mflgs = let 
+                     casere = if Case_Insensitive `elem` mflgs then
+                               Case_Insensitive
+                              else 
+                               Case_Sensitive
+                     linere = if Multi_Line `elem` mflgs then
+                               Multi_Line
+                              else if Single_Line `elem` mflgs then
+                               Single_Line
+                              else 
+                               Default_Line
+                  in
+                     [("case",casere),("line",linere)]                    
+
+type Matcher a =  [a]          -- what to match against
+               -> Maybe ([a],  -- what matched
+                         [a])  -- everything after match
+
+wrapMatcher :: Matcher a -> MatcherImpl a
+wrapMatcher f bef inp = f inp
+
+type MatcherImpl a =  [a]       -- everything before start of this match
+                                -- (allows lookbehind assertions)
+                   -> [a]       -- what to match against
+                   -> Maybe ([a],-- what matched
+                             [a])-- everything after match
+
+regseq ::  (MatcherImpl a) -- a matcher function
+     -> (MatcherImpl a) -- the next matcher function
+     -> (MatcherImpl a) -- both functions sequenced so
+                   -- one follows the other
+regseq f g bef af
+    = case (f bef af) of 
+         Nothing -> Nothing
+         Just (ms,as) ->
+            case (g ((reverse ms)++bef) as) of
+               Nothing -> Nothing
+               Just (ms1,as1) -> Just (ms++ms1,as1)
+
+--isEl takes an element and returns a matching function for it.
+isEl :: Eq a => a -> a -> Bool
+isEl c = (c ==)
+
+-- match a \w 
+isWordChar c = isAlphaNum c || (isEl '_') c || (isEl '\'') c
+
+
+
+-- create a matcher that accepts an element if matched by f
+matchEls :: Eq a => (a -> Bool) -> MatcherImpl a
+matchEls f _ [] = Nothing
+matchEls f _ (a:as) = if f a then 
+                        Just ([a],as)
+                      else
+                        Nothing
+
+-- create a matcher that matches 0 elements of any non-empty list,  
+matchNull :: MatcherImpl a
+matchNull _ [] = Nothing 
+matchNull _ (x:xs) = Just ([],x:xs)
+
+-- create a matcher that matches any element
+matchAny :: MatcherImpl a
+matchAny _ [] = Nothing
+matchAny _ (a:as) = Just ([a],as)
+
+
+-- create a matcher that matches any element except '\n'
+matchAnyBut :: MatcherImpl Char
+matchAnyBut _ [] = Nothing
+matchAnyBut _ (a:as) = if a /= '\n' then
+                      Just ([a],as)
+                    else
+                      Nothing
+
+-- create a backreference matcher
+matchBref :: Eq a => [a]       -- what to try and match
+                   -> MatcherImpl a -- a matcher function       
+
+matchBref [] _ inps = Just ([],inps)
+matchBref (x:xs) _ [] = Nothing
+matchBref (x:xs) _ (i:inps) = if x==i then 
+                                  case (matchBref xs [] inps) of 
+                                    Nothing -> Nothing
+                                    Just (ms,afts) -> Just (i:ms,afts)
+                                else
+                                    Nothing
+
+-- create a backreference matcher, that is case insensitive (for strings)
+matchIBref ::  String   -- what to try and match
+           -> MatcherImpl Char -- a matcher function    
+
+matchIBref [] _ inps = Just ([],inps)
+matchIBref (x:xs) _ [] = Nothing
+matchIBref (x:xs) _ (i:inps) = if (toUpper x) == (toUpper i) then 
+                                  case (matchIBref xs [] inps) of 
+                                    Nothing -> Nothing
+                                    Just (ms,afts) -> Just (i:ms,afts)
+                                else
+                                    Nothing
+
diff --git a/testsuite/driver/basicRxLib/NFADefs.hs b/testsuite/driver/basicRxLib/NFADefs.hs
new file mode 100644 (file)
index 0000000..358f9ac
--- /dev/null
@@ -0,0 +1,180 @@
+module NFADefs where
+
+
+import OrdList
+import BagRE
+import Matchers
+import FiniteMap
+import Array
+
+type Node = Int        -- an NFA node is referenced by an integer
+
+type NFA a = Array Int (NFANode a) -- The NFA itself
+
+data NFAElem a = 
+                 NFAEl (MatcherImpl a) -- matcher function 
+
+               | NFABack String           -- matches same as the nth subexpression
+                         ([a] -> MatcherImpl a)-- the function to use to match
+                                
+               | NFAFinal         -- Final state of NFA
+
+               
+{- NFASubAdd n   -> we are inside of subexp n,  so add match info to it
+   NFASubContinue ns -> we're at a possible end of the subexp, but
+                        don't close it prematurely, try closing it in
+                        the other nodes as well.
+   NFASubEnd n  -> we have now left subexp n, so close it down
+-}
+
+data SubexpInfo = NFASubAdd String
+                | NFASubContinue (OrdList Node)
+                | NFASubEnd String
+
+
+{- IntStart n                  -> we have now entered the nth Interval 
+
+   IntEnd n min max ns1 ns2    -> we have now reached the end of an
+                                  iteration of the nth Interval,
+                                   it's a MinMax interval,
+                                   min the min number of times we can loop,
+                                   max is the max number of times we can loop
+                                   ns1, nodes go to before reaching min
+                                        firspos nodes of interval
+                                   ns2, nodes go to after reaching max
+                                        lastpos nodes of interval
+
+   MinEnd n min ns1 ns2        -> we have now reached the end of an iteration
+                          of the nth interval,
+                           it's a Min interval,
+                          min is the min number of times we can loop,
+                          ns1, nodes we can go to before reaching min
+                                firspos nodes of interval
+                           ns2, last nodes of the interval
+                                lastpos nodes of interval
+
+
+   Reset n             -> we have now finished with the nth interval,
+                          by moving on to the following node. We
+                          want to reset it, in case we
+                          come back to the start of it later. 
+                           (Important if we've got nested intervals)
+
+
+   NGIntEnd n min max ns1 ns2  -> As for IntEnd above, except we're
+                                  doing non-greedy matching. When
+                                  between min and max matches, we
+                                  therefore want to try jumping out
+                                  of the interval before we try
+                                  continuing it. More on this in
+                                  ExecRE module.
+
+   NGMinEnd n min max ns1 ns2 -> Non-Greedy MinEnd equiv. 
+                                 When we've matched min times,
+                                therefore want to try jumping out
+                                of the interval before we try
+                                continuing it. More on this in
+                                ExecRE module.  
+-}
+
+data IntervalInfo = IntStart Int 
+                  | IntContinue (OrdList Node)
+                  | NGIntContinue (OrdList Node)         
+                  | IntEnd Int Int Int (OrdList Node) (OrdList Node)
+                  | MinEnd Int Int (OrdList Node)  (OrdList Node)
+                  | Reset Int
+                  | NGIntEnd Int Int Int (OrdList Node) (OrdList Node)
+                  | NGMinEnd Int Int (OrdList Node) (OrdList Node)
+
+{- Node n ns is ses -> NFA state that matches something using "n".
+                       It will then jump to states "ns".
+                       Unless node is part of an interval, then
+                       nextnodes is calculated with "is".
+                       Node may be part of subexpression, dealt with
+                       using "ses".
+-}
+
+data NFANode a = Node (NFAElem a) (OrdList Node) [IntervalInfo] [SubexpInfo] 
+
+
+
+-- building nfa
+
+initNFA :: Int  -- number of nodes in NFA 
+        -> NFA a -- make an initial nfa with the correct number of nodes
+initNFA x 
+    = listArray (1,x) (repeat (Node NFAFinal emptyOL [] []))
+
+mkNfaBack :: String            -- which subexp to refer to  
+          -> ([a] -> MatcherImpl a) -- the matcher function to use
+          -> NFANode a         -- current node
+          -> NFANode a          -- an NFA node that does this
+mkNfaBack x f (Node _ nexts ses ints)
+    = Node (NFABack x f) nexts ses ints
+
+mkNfaEl :: MatcherImpl a       -- a matcher function for simple element
+        -> NFANode a           -- current node
+        -> NFANode a   -- a simple NFA element 
+mkNfaEl f (Node _ nexts ses ints)
+    = Node (NFAEl f) nexts ses ints
+
+mkNfaFinal :: Int      -- the label of the final node
+           -> NFANode a                -- current node
+           -> NFANode a -- a final node, that jumps back to itself if fired
+mkNfaFinal n (Node _ _ ses ints) = Node NFAFinal (singletonOL n) ses ints 
+
+
+-- updating nfa
+
+updateNode :: (NFANode a -> NFANode a) --updating function
+           -> Node     -- label of node to update
+           -> NFA a    -- nfa to update
+           -> NFA a    -- updated nfa
+updateNode f el nfa =  nfa // [(el, f (nfa!el))]
+
+alterNode  :: NFANode a -- new nfa node
+           -> Node     -- label of node to update
+           -> NFA a    -- old nfa
+           -> NFA a    -- updated nfa
+alterNode newnode el nfa =  nfa // [(el, newnode)]
+
+changeNexts :: [Node]   -- the new next nodes 
+            -> NFANode a -- the actual nfa node to update
+            -> NFANode a -- that updated node
+changeNexts newnexts (Node n _ int se) = Node n newnexts int se
+
+changeInts :: [IntervalInfo] -- the new interval info 
+           -> NFANode a             -- the actual nfa node to update
+           -> NFANode a      -- that updated node
+changeInts newint (Node n nexts _ se) = Node n nexts newint se
+
+changeSES :: [SubexpInfo] -- the new subexp info
+          -> NFANode a   -- the actual nfa node to update
+          -> NFANode a   -- that updated node
+changeSES newses (Node n nexts int _) = Node n nexts int newses
+
+-- interrogating the nfa
+
+getNfaElem :: NFANode a -> NFAElem a
+getNfaElem (Node n _ _ _) = n
+
+getNexts :: NFANode a -> [Node]
+getNexts (Node _ nexts _ _) = nexts
+
+getInts :: NFANode a -> [IntervalInfo]
+getInts (Node _ _ ints _) = ints
+
+getSES :: NFANode a -> [SubexpInfo] 
+getSES (Node _ _ _ ses) = ses
+
+
+followNodes :: OrdList Int        -- some nodes of an nfa
+             -> NFA a   -- the nfa
+             -> OrdList Int -- all the nodes that follow after those nodes
+
+followNodes s nfa = foldS (combine nfa) emptyOL s
+                 where
+                     combine nfa e s1 = unionOL (after (nfa!e)) s1
+                     after (Node _ xs _ _)  = xs
+
diff --git a/testsuite/driver/basicRxLib/OrdList.hs b/testsuite/driver/basicRxLib/OrdList.hs
new file mode 100644 (file)
index 0000000..9922f5d
--- /dev/null
@@ -0,0 +1,70 @@
+module OrdList where
+
+{- an OrdList is an ordered list, with no duplicates, and set like
+   operations on it
+-}
+
+type OrdList a = [a]
+
+
+emptyOL :: Ord a => OrdList a 
+emptyOL = []
+
+unionOL :: Ord a => OrdList a -> OrdList a -> OrdList a
+unionOL s1 s2 = foldr addEl s2 s1
+
+listToOL :: Ord a => [a] -> OrdList a
+listToOL xs = (foldr addEl [] xs)
+              
+addEl :: Ord a =>
+         a             -- element
+      -> OrdList a      -- ordered list
+      -> OrdList a      -- list with element added to it
+addEl e [] = [e]
+addEl e (n:ns) = if n == e then
+                   n:ns
+                 else if n<e then 
+                   n:(addEl e ns)
+                 else
+                   e:n:ns
+
+intersectOL :: Ord a => OrdList a -> OrdList a -> OrdList a
+intersectOL s1 s2 = foldr (inboth s2) [] s1
+                  where
+                     inboth :: Ord a => OrdList a -> a -> OrdList a -> OrdList a
+                     inboth s e new = if e `elem` s then 
+                                       addEl e new
+                                      else 
+                                       new                
+
+singletonOL :: Ord a => a -> OrdList a
+singletonOL x = [x]
+
+minusOL :: Ord a => OrdList a -> OrdList a -> OrdList a
+minusOL s1 s2 = foldr minusel s1 s2
+                 where
+                    minusel e [] = []
+                    minusel e (n:ns) = if n == e then
+                                         ns
+                                       else if n<e then
+                                         n:(minusel e ns)
+                                       else
+                                         n:ns
+
+member :: Ord a => a -> OrdList a -> Bool
+member x [] = False
+member x (s:ss) = if x == s then
+                    True
+                  else if x>s then
+                    member x ss
+                  else
+                    False
+
+foldS :: (a -> b -> b) -> b -> OrdList a -> b 
+foldS = foldr
+
+mapS :: (a -> b) -> OrdList a -> OrdList b
+mapS = map
+
+
+
diff --git a/testsuite/driver/basicRxLib/ParsePolyRegexp.hs b/testsuite/driver/basicRxLib/ParsePolyRegexp.hs
new file mode 100644 (file)
index 0000000..6b21b36
--- /dev/null
@@ -0,0 +1,189 @@
+module ParsePolyRegexp 
+  (mkAbstreeP)
+where
+
+{-
+This module provides functions to parse a polymorphic regexp.
+The main one is mkAbstree. It takes a string form of the AbsTree, and
+returns an Abstract Syntax tree for it. 
+-}
+
+import Matchers
+import Assertions
+import Parsers
+import FiniteMap
+import AbsTreeDefs
+
+
+-- Turn the regular expression concrete syntax into an abstract syntax tree
+
+mkAbstreeP :: (Read a, Show a, Eq a, Ord a, Enum a) => 
+                String                 -- The regexp in string form 
+             -> [Matcher a]            -- Extra matcher functions
+             -> [Assert a]             -- extra assertions
+             -> Maybe (AbsTree a b)            -- An abstract syntax tree
+              
+mkAbstreeP [] fs as = Just mkEnd
+mkAbstreeP re fs as
+     = let 
+         matchresults = initParser nnRegexp re fs as []
+         (match,rest) = head matchresults 
+         wellformed = (not (null matchresults)) && (null rest)
+         realmatch = addEnd match
+       in
+         if wellformed then
+           Just realmatch
+         else
+           Nothing
+
+
+--
+-- grammar for regular expressions:
+--
+{-
+  Elem          = "<" (character)+ ">"
+  Atom          = "." | "<<" Int ">>" | Element.
+                | "[" ["^"] (Element + | ( Element "-" Element)+) +"]". 
+  XAtom         = "\\" Int | "(" AbsTree ")" | "(?:" AbsTree ")" | Atom .
+  ExtAtom       = "(?=" Int ")"
+                | (XAtom ["*" | "+" | "?" 
+                         | "{" Int "}"
+                         | "{" Int "," [Int] "}" 
+                         ] ["?"])
+                | Atom +
+                | XAtom.
+  Factor        = "^" ExtAtom + "$".
+  AbsTree        = Factor "|" (Factor *).
+-}
+
+nnElem :: (Read a,Show a) => (Parser Char a (Matcher a) (Assert a)) 
+nnElem = lit '<' ..+ star (butC ['\\','>'] ||| (lit '\\' ..+ anyC)) +.. lit '>' <<< read 
+
+-- parse an atom
+nnAtom :: (Read a, Show a, Eq a, Ord a, Enum a) 
+           => (Parser Char (AbsTree a b) (Matcher a) (Assert a))
+nnAtom 
+  =
+       (lit '<' ..+ lit '<' ..+ anyPos +.. lit '>' +.. lit '>') 
+          `then_Px` (\x -> lookupFn x)
+          <<< mkEl.wrapMatcher
+    |||  lit '.' <<< const (mkEl matchAny)
+    |||  lit '[' ..+ opt (lit '^') 
+         +.+ (plus ((plus (nnElem  +.+ lit '-' ..+ nnElem) <<< handlerange)
+                ||| (plus nnElem <<< handleelems)))
+              +.. lit ']' <<< mkEl.matchEls.handleclass
+    |||  nnElem  <<< mkEl.matchEls.isEl
+
+      where 
+
+       handleelems es = (`elem` es)
+       handlerange es = foldr1 combine (map inrange es)
+       inrange (e1,e2) c = c >=e1 && c<=e2
+       combine f g c = (f c) || (g c)
+
+       -- deal with a class
+       handleclass  ([],fs) = (foldr1 combine fs)
+       handleclass  ([f],fs) = (not.(foldr1 combine fs))
+
+
+
+-- parse an extra atom
+nnXAtom :: (Read a,Show a, Eq a, Ord a, Enum a) 
+            => (Parser Char (AbsTree a b) (Matcher a) (Assert a))
+
+nnXAtom =
+
+         (lit '(' ..+ nnRegexp +.. lit ')'
+      ||| (lit ' ' ..+ (plus (satisfy isWordChar)) +.. lit '@') +.+ lit '(' ..+ nnRegexp +.. lit ')' <<< handlesub
+      ||| lit '$' ..+ lit '{' ..+ (plus (satisfy isWordChar)) +.. lit '}' 
+          <<< (\x -> mkBackref x matchBref)
+      ||| nnAtom)
+      where
+        handlesub (s,n) = mkSub s n
+
+
+     
+-- parse an extended atom
+nnExtAtom :: (Read a, Show a, Eq a, Ord a, Enum a) 
+             => (Parser Char (AbsTree a b) (Matcher a) (Assert a))
+
+nnExtAtom  =  (star 
+              ((lit '(' ..+ lit '?' ..+ lit '=' ..+ anyPos +.. lit ')')
+               `then_Px` (\x -> lookupAs x) <<< doAssert) <<< combineAssert)
+          +.+ ((nnXAtom  +.+ opt ((lit '*' <<< const mkStar 
+                              ||| lit '+' <<< const mkPlus
+                              ||| lit '?' <<< const mkOpt
+                              ||| lit '{' ..+ anyPos +.. lit '}'
+                                   <<< helpexact
+                              ||| lit '{' ..+ anyInt +.+    
+                                   lit ',' +.+ (opt anyInt) 
+                                   +.. lit '}'       <<< helpminmax 
+                                 ) +.+ opt (lit '?') )
+                    <<< helprepeat)
+          ||| plus (nnAtom  `notFollowedBy` oneofC "*+?{") <<< combine
+          ||| nnXAtom)
+          +.+
+              (star
+              ((lit '(' ..+ lit '?' ..+ lit '=' ..+ anyPos +.. lit ')')
+               `then_Px` (\x -> lookupAs x) <<< doAssert) <<< combineAssert)
+          <<< helper
+               where
+                  helpexact x = mkExact x
+
+                  helpminmax (x,(a,[])) = mkMin x
+                  helpminmax (x,(a,[y])) 
+                         = if x <= y then 
+                             mkMinMax x y  
+                           else 
+                             error "Invalid interval in Regular Expression"
+
+                  helprepeat (ea,[]) = ea
+                  helprepeat (ea,[(f,[])]) = f ea
+                  helprepeat (ea,[(f,[_])]) = mkNg (f ea)
+
+
+                  combine = (mkEl . foldl1 regseq . map getElem) 
+
+                  combineAssert [] = []
+                  combineAssert s@(x:xs) = [(mkEl.foldl1 regseq) s]
+                  helper ([],(t,[])) = t
+                  helper ([e1],(t,[])) =  mkCon e1 t
+                               
+                  helper ([e1],(t,[e2])) = mkCon e1 (mkCon t e2)
+
+                  helper ([],(t,[e2])) = mkCon t e2
+
+
+-- parse a factor
+nnFactor :: (Read a, Show a, Eq a, Ord a, Enum a) 
+            => (Parser Char (AbsTree a b)(Matcher a) (Assert a) )
+
+nnFactor = (opt (lit '^')) 
+           +.+ (plus nnExtAtom) 
+           +.+ (opt (lit '$')) 
+           <<< helper
+      where
+         helper ([],(xs,[])) = combine xs      -- not prefix or suffix
+         helper ([_],(xs,[])) =  mkCon (justPrefix (mkEl (doAssert prefix))) (combine xs)
+                                               -- is prefix
+         helper ([_],(xs,[_])) = mkCon (justPrefix (mkEl (doAssert prefix))) 
+                                       (mkCon (combine xs) 
+                                              (mkEl (doAssert suffix)))
+                                               -- is prefix & suffix
+         helper ([],(xs,[_])) = mkCon (combine xs) (mkEl (doAssert suffix))
+         combine (x:[]) = x
+         combine s@(x:xs) = foldl1 mkCon s
+         
+
+-- parse a regexp
+nnRegexp :: (Read a,Show a, Eq a, Ord a, Enum a) 
+            => (Parser Char (AbsTree a b) (Matcher a) (Assert a))
+
+nnRegexp = nnFactor +.+ star (lit '|' ..+ nnFactor) <<< helper
+               where
+                 helper (ea,[]) = ea
+                 helper (ea, s@(x:xs))= foldl mkAlt ea s
+
+
+
diff --git a/testsuite/driver/basicRxLib/ParsePolyRegexpBasic.hs b/testsuite/driver/basicRxLib/ParsePolyRegexpBasic.hs
new file mode 100644 (file)
index 0000000..e2f7347
--- /dev/null
@@ -0,0 +1,185 @@
+module ParsePolyRegexpBasic 
+  (mkAbstreePB)
+where
+
+{-
+This module provides functions to parse a polymorphic regexp.
+The main one is mkAbstree. It takes a string form of the AbsTree, and
+returns an Abstract Syntax tree for it. 
+-}
+
+import Matchers
+import Assertions
+import Parsers
+import FiniteMap
+import AbsTreeDefs
+
+
+-- Turn the regular expression concrete syntax into an abstract syntax tree
+
+mkAbstreePB :: (Read a, Show a, Eq a) => 
+                String                 -- The regexp in string form 
+             -> [Matcher a]            -- Extra matcher functions
+             -> [Assert a]             -- extra assertions
+             -> Maybe (AbsTree a b)            -- An abstract syntax tree
+              
+mkAbstreePB [] fs as = Just mkEnd
+mkAbstreePB re fs as
+     = let 
+         matchresults = initParser nnRegexpPB re fs as []
+         (match,rest) = head matchresults 
+         wellformed = (not (null matchresults)) && (null rest)
+         realmatch = addEnd match
+       in
+         if wellformed then
+           Just realmatch
+         else
+           Nothing
+
+
+--
+-- grammar for regular expressions:
+--
+{-
+  Elem          = "<" (character)+ ">"
+  Atom          = "." | "<<" Int ">>" | Element.
+                | "[" ["^"] Element +"]". 
+  XAtom         = "\\" Int | "(" AbsTree ")" | "(?:" AbsTree ")" | Atom .
+  ExtAtom       = "(?=" Int ")"
+                | (XAtom ["*" | "+" | "?" 
+                         | "{" Int "}"
+                         | "{" Int "," [Int] "}" 
+                         ] ["?"])
+                | Atom +
+                | XAtom.
+  Factor        = "^" ExtAtom + "$".
+  AbsTree        = Factor "|" (Factor *).
+-}
+
+nnElemPB :: (Read a, Show a) => (Parser Char a (Matcher a) (Assert a)) 
+nnElemPB = lit '<' ..+ star (butC ['\\','>'] ||| (lit '\\' ..+ anyC)) +.. lit '>' <<< read 
+
+-- parse an atom
+nnAtomPB :: (Read a, Show a, Eq a) 
+           => (Parser Char (AbsTree a b) (Matcher a) (Assert a))
+nnAtomPB 
+  =
+       (lit '<' ..+ lit '<' ..+ anyPos +.. lit '>' +.. lit '>') 
+          `then_Px` (\x -> lookupFn x)
+          <<< mkEl.wrapMatcher
+    |||  lit '.' <<< const (mkEl matchAny)
+    |||  lit '[' ..+ opt (lit '^') 
+           +.+ (plus nnElemPB <<< handleelems)
+         +.. lit ']' <<< mkEl.matchEls.handleclass
+    |||  nnElemPB  <<< mkEl.matchEls.isEl
+
+      where 
+
+       handleelems es = (`elem` es)
+
+       -- deal with a class
+       handleclass  ([],g) = g
+       handleclass  ([f],g) = (not.g)
+
+
+
+-- parse an extra atom
+nnXAtomPB :: (Read a, Show a, Eq a) 
+            => (Parser Char (AbsTree a b) (Matcher a) (Assert a))
+
+nnXAtomPB =
+
+         (lit '(' ..+ nnRegexpPB +.. lit ')'
+      ||| (lit ' ' ..+ (plus (satisfy isWordChar)) +.. lit '@') +.+ lit '(' ..+ nnRegexpPB +.. lit ')' <<< handlesub
+      ||| lit '$' ..+ lit '{' ..+ (plus (satisfy isWordChar)) +.. lit '}' 
+          <<< (\x -> mkBackref x matchBref)
+      ||| nnAtomPB)
+      where
+        handlesub (s,n) = mkSub s n
+
+
+     
+-- parse an extended atom
+nnExtAtomPB :: (Read a, Show a, Eq a) 
+             => (Parser Char (AbsTree a b) (Matcher a) (Assert a))
+
+nnExtAtomPB  =  (star 
+              ((lit '(' ..+ lit '?' ..+ lit '=' ..+ anyPos +.. lit ')')
+               `then_Px` (\x -> lookupAs x) <<< doAssert) <<< combineAssert)
+          +.+ ((nnXAtomPB  +.+ opt ((lit '*' <<< const mkStar 
+                              ||| lit '+' <<< const mkPlus
+                              ||| lit '?' <<< const mkOpt
+                              ||| lit '{' ..+ anyPos +.. lit '}'
+                                   <<< helpexact
+                              ||| lit '{' ..+ anyInt +.+    
+                                   lit ',' +.+ (opt anyInt) 
+                                   +.. lit '}'       <<< helpminmax 
+                                 ) +.+ opt (lit '?') )
+                    <<< helprepeat)
+          ||| plus (nnAtomPB  `notFollowedBy` oneofC "*+?{") <<< combine
+          ||| nnXAtomPB)
+          +.+
+              (star
+              ((lit '(' ..+ lit '?' ..+ lit '=' ..+ anyPos +.. lit ')')
+               `then_Px` (\x -> lookupAs x) <<< doAssert) <<< combineAssert)
+          <<< helper
+               where
+                  helpexact x = mkExact x
+
+                  helpminmax (x,(a,[])) = mkMin x
+                  helpminmax (x,(a,[y])) 
+                         = if x <= y then 
+                             mkMinMax x y  
+                           else 
+                             error "Invalid interval in Regular Expression"
+
+                  helprepeat (ea,[]) = ea
+                  helprepeat (ea,[(f,[])]) = f ea
+                  helprepeat (ea,[(f,[_])]) = mkNg (f ea)
+
+
+                  combine = (mkEl . foldl1 regseq . map getElem) 
+
+                  combineAssert [] = []
+                  combineAssert s@(x:xs) = [(mkEl.foldl1 regseq) s]
+                  helper ([],(t,[])) = t
+                  helper ([e1],(t,[])) =  mkCon e1 t
+                               
+                  helper ([e1],(t,[e2])) = mkCon e1 (mkCon t e2)
+
+                  helper ([],(t,[e2])) = mkCon t e2
+
+
+-- parse a factor
+nnFactorPB :: (Read a, Show a, Eq a) 
+            => (Parser Char (AbsTree a b)(Matcher a) (Assert a) )
+
+nnFactorPB = (opt (lit '^')) 
+           +.+ (plus nnExtAtomPB) 
+           +.+ (opt (lit '$')) 
+           <<< helper
+      where
+         helper ([],(xs,[])) = combine xs      -- not prefix or suffix
+         helper ([_],(xs,[])) =  mkCon (justPrefix (mkEl (doAssert prefix))) (combine xs)
+                                               -- is prefix
+         helper ([_],(xs,[_])) = mkCon (justPrefix (mkEl (doAssert prefix))) 
+                                       (mkCon (combine xs) 
+                                              (mkEl (doAssert suffix)))
+                                               -- is prefix & suffix
+         helper ([],(xs,[_])) = mkCon (combine xs) (mkEl (doAssert suffix))
+         combine (x:[]) = x
+         combine s@(x:xs) = foldl1 mkCon s
+         
+
+-- parse a regexp
+nnRegexpPB :: (Read a, Show a, Eq a) 
+            => (Parser Char (AbsTree a b) (Matcher a) (Assert a))
+
+nnRegexpPB = nnFactorPB +.+ star (lit '|' ..+ nnFactorPB) <<< helper
+               where
+                 helper (ea,[]) = ea
+                 helper (ea, s@(x:xs))= foldl mkAlt ea s
+
+
+
diff --git a/testsuite/driver/basicRxLib/ParseStringRegexp.hs b/testsuite/driver/basicRxLib/ParseStringRegexp.hs
new file mode 100644 (file)
index 0000000..efa0a0f
--- /dev/null
@@ -0,0 +1,349 @@
+module ParseStringRegexp 
+  (mkAbstreeS)
+where
+
+{-
+This module provides functions to parse a string regexp.
+The main one is mkAbstree. It takes a string form of the AbsTree, and
+returns an Abstract Syntax tree for it. 
+-}
+
+
+import Matchers
+import Assertions
+import Parsers
+import FiniteMap
+import AbsTreeDefs
+import Char
+
+-- Turn the regular expression concrete syntax into an abstract syntax tree
+
+mkAbstreeS ::  
+                String                 -- The regexp in string form 
+             -> [Matcher Char]         -- Extra matcher functions
+             -> [Assert Char]
+             -> [MatcherFlag]          -- The necessary matcher flags
+             -> Maybe (AbsTree Char b) -- An abstract syntax tree
+              
+
+mkAbstreeS [] fs as flags = Just mkEnd
+mkAbstreeS re fs as flags
+     = let 
+         matchresults = initParser nnRegexpS re fs as (initFlags flags)
+         (match,rest) = head matchresults 
+         wellformed = (not (null matchresults)) && (null rest)
+         realmatch = addEnd match
+       in
+         if wellformed then
+           Just realmatch
+         else
+           Nothing
+
+--
+-- grammar for regular expressions:
+--
+{-
+  Element       = nonmeta char | "\\" special meta char | "\\" character 
+  Atom          = ("(?" (Mode [","]) +")") 
+                  ( "." | "<<" Int ">>" | Element
+                  | "[" ["^"] (Element + | ( Element "-" Element)+) +"]"
+                  )("(?" (Mode [","]) +")"). 
+  XAtom         = "\\" Int | "(" AbsTree ")" | "(?:" AbsTree ")" | Atom .
+  ExtAtom       = "(?=" Int ")"
+                | (XAtom ["*" | "+" | "?" 
+                         | "{" Int "}"
+                         | "{" Int "," [Int] "}" 
+                         ] ["?"])
+                | Atom +
+                | XAtom.
+  Factor        = ("^" | "\\A") ExtAtom + ("$" | "\\Z").
+  AbsTree       = Factor "|" (Factor *).
+-}
+
+
+nnElemS :: (Parser Char Char (Matcher Char) (Assert Char))
+nnElemS = butC "$.*+?@|()^[]\\" ||| lit '\\' ..+ butC ("wWsSdDbBAZ"++['0'..'9'])
+
+-- match a character class element
+nnCCEl::(Parser Char Char (Matcher Char) (Assert Char))
+nnCCEl = butC "]\\" ||| lit '\\' ..+ butC ("wWsSdD") 
+
+--get a special meta character
+parseMeta :: (Parser Char (Char -> Bool) (Matcher Char) (Assert Char))
+parseMeta = 
+        lit '\\' ..+ lit 'w' <<< const isWordChar
+    ||| lit '\\' ..+ lit 'W' <<< const (not.isWordChar)
+    ||| lit '\\' ..+ lit 's' <<< const isSpace
+    ||| lit '\\' ..+ lit 'S' <<< const (not.isSpace)
+    ||| lit '\\' ..+ lit 'd' <<< const isDigit
+    ||| lit '\\' ..+ lit 'D' <<< const (not.isDigit)
+
+-- parse a mode change
+parseChange :: (Parser Char ([String]) (Matcher Char) (Assert Char))
+parseChange =     (lit '(' ..+ lit '?' 
+                   ..+ plus ((isWord "Case_Insensitive" 
+                         ||| isWord "Case_Sensitive"
+                         ||| isWord "Default_Line"
+                         ||| isWord "Multi_Line"
+                         ||| isWord "Single_Line") +.. opt (lit ','))
+                   +.. lit ')')
+                   `thenxP_` \xs -> changemode xs
+     where
+       changemode xs = foldl1 compose (map mkUpdate xs)
+       compose f g = f ..+ g  
+       mkUpdate "Case_Insensitive" = (updateEnv "case" Case_Insensitive)  
+       mkUpdate "Case_Sensitive" = (updateEnv "case" Case_Sensitive) 
+       mkUpdate "Default_Line" = (updateEnv "line" Default_Line) 
+       mkUpdate "Multi_Line" = (updateEnv "line" Multi_Line)  
+       mkUpdate "Single_Line" = (updateEnv "line" Single_Line) 
+
+-- parse an assertion
+parseAssert :: (Parser Char (MatcherImpl Char) (Matcher Char) (Assert Char))
+parseAssert = 
+             (lit '(' ..+ lit '?' ..+ lit '=' ..+ anyPos +.. lit ')')
+             `then_Px` (\x -> lookupAs x <<<  doAssert ) 
+         ||| lit '\\' ..+ (lit 'b' ||| lit 'B') <<< handlewbound
+    where
+      handlewbound 'b' = doAssert wordBound
+      handlewbound 'B' = doAssert notWordBound
+                    
+
+-- parse an atom
+nnAtomS :: (Parser Char (AbsTree Char b)(Matcher Char) (Assert Char))
+
+nnAtomS 
+  =
+     star parseChange 
+    ..+
+
+       (((lit '<' ..+ lit '<' ..+ anyPos +.. lit '>' +.. lit '>') 
+          `then_Px` \x -> lookupFn x)
+          <<< mkEl.wrapMatcher  
+
+    |||  lookupEnv "line" +.. 
+         lit '.' <<< mkEl.handleany
+
+    |||  lookupEnv "case" `then_Px` \x ->  
+       (lit '[' ..+ opt (lit '^') 
+         +.+ (plus (parseMeta
+                ||| (plus (nnCCEl  +.+ lit '-' ..+ nnCCEl) <<< handlerange x)
+                ||| (plus nnCCEl <<< handleelems x)))
+              +.. lit ']' <<< mkEl.matchEls.handleclass)
+
+    ||| parseMeta <<< mkEl.matchEls
+
+    ||| lookupEnv "case" +.+  
+        nnElemS  <<< mkEl.matchEls.handlecase)
+    +.. 
+     star parseChange
+
+      where 
+
+        handleany Single_Line = matchAny
+        handleany _ = matchAnyBut
+    
+        handlecase (Case_Sensitive,x) = isEl x
+        handlecase (Case_Insensitive,x) 
+                       | isLower x = \y -> isEl x y || isEl (toUpper x) y
+                       | isUpper x = \y -> isEl x y || isEl (toLower x) y
+                        | otherwise = isEl x
+
+       handleelems Case_Sensitive es el = (el `elem` es)
+        handleelems Case_Insensitive es el 
+                                        = (toUpper el) `elem` (map toUpper es)
+
+       handlerange Case_Sensitive es = foldr1 combine (map inrange es)
+       handlerange Case_Insensitive es = foldr1 combine (map inrangeI es)
+
+        inrange (e1,e2) c = c >=e1 && c<=e2
+       inrangeI (e1,e2) = doinIrange e1 e2
+       combine f g c = (f c) || (g c)
+
+       -- deal with a class
+       handleclass  ([],fs) = (foldr1 combine fs)
+       handleclass  ([f],fs) = (not.(foldr1 combine fs))
+
+{- 
+   handle a case insensitive range efficiently, by working out which
+   characters should be covered.
+   Upper case letters occur before lower case, with some characters in
+   between. This is ascii dependent.
+-}
+doinIrange :: Char -> Char -> (Char -> Bool)
+doinIrange e1 e2   = if (e1 <= 'A' && e2 >= 'z') || (e2 < 'A') || (e1 > 'z') 
+                        || (e1 >'Z' && e2 < 'a')   
+                     then -- either all letters already covered or none covered
+                       (\c -> c >=e1 && c<=e2)
+
+                    else if e1 <= 'A' then -- start before before uppers
+                       if e2 >= 'a' then    -- end in lower cases
+                       (\c -> c >= e1 && c<= 'z') -- all alpha have to be covered
+
+                      else if e2 < 'Z' then  -- covered some of
+                                             -- uppers, so cover equiv lowers
+                       (\c -> (c >=e1 && c<=e2) 
+                           ||  (c >= 'a' && c<= (toLower e2)))
+
+                      else -- all uppers covered and finish before lower
+                       (\c -> (c >=e1 && c<=e2) || isLower c) 
+                          -- so cover all lowers as well
+
+                    else if e2 >= 'z' then -- finish after lowers
+                      if e1 <= 'Z' then    -- start in uppers
+                       (\c -> c >= 'A' && c <= e2)-- all alpha have to be covered
+
+                      else if e1 > 'A' then -- covers some of lowers,
+                                            -- so cover equiv uppers
+                       (\c -> (c >=e1 && c<=e2) 
+                           || (c >= 'A' && c<= (toUpper e2)))  
+                      
+                      else -- all lowers covered and finish before upper
+                       (\c -> (c >=e1 && c<=e2) || isUpper c)--so cover all uppers too
+
+                    else if e1 < 'Z' then -- start in uppers
+                      if e2 <= 'Z' then  -- end in uppers, so cover equiv lowers
+                        (\c -> (c >=e1 && c<=e2) 
+                            || (c >= (toLower e1) && c<= (toLower e2)))
+
+                      else if e2 >= 'a' then -- end in lowers
+                       if (toLower e1) <= e2 then -- start in uppers
+                                           -- between the two all characters
+                                           -- have to be covered
+                         (\c -> (c>='A' && c<='z'))-- make all alpha to be covered
+                       else -- some letters covered, so cover equiv
+                         (\c -> (c >=e1 && c<=e2) 
+                            ||  (c >= 'A' && c <= (toUpper e2))
+                            ||  (c >=(toLower e1) && c<= 'z'))
+
+                      else -- start in uppers & end between uppers & lowers
+                       (\c -> (c >=e1 && c<=e2) -- cover eqiv lowers
+                           || (c >=(toLower e1) && c<= 'z'))
+
+                    else if e1 > 'a' then -- start in lowers & end in lowers
+                       (\c -> (c >=e1 && c<=e2) -- so cover equiv uppers
+                           || (c >=(toUpper e1) && c<= (toUpper e2)))
+
+                    else -- start between uppers & lowers & end in lowers
+                       (\c -> (c >=e1 && c<=e2) -- cover equiv uppers
+                          ||  (c >= 'A' && c <= (toUpper e2)))
+
+-- parse an XAtom
+nnXAtomS :: (Parser Char (AbsTree Char b)(Matcher Char) (Assert Char))
+
+nnXAtomS =
+     star parseChange
+      ..+
+         (lit '(' ..+ nnRegexpS +.. lit ')'
+      ||| startSubexp +.+ lit '(' ..+ nnRegexpS +.. lit ')' <<< handlesub
+      ||| lookupEnv "case" +.+  
+          (lit '$' ..+ lit '{' ..+ (plus (satisfy isWordChar)) +.. lit '}')
+          <<< handlecase   
+         )
+      +..
+     star parseChange 
+
+      where
+        handlecase (Case_Sensitive,x) = mkBackref x matchBref 
+        handlecase (Case_Insensitive,x) = mkBackref x matchIBref  
+        handlesub (s,n) = mkSub s n
+
+
+startSubexp = lit ' ' ..+ (plus (satisfy isWordChar)) +.. lit '@'
+
+-- parse an extended atom
+nnExtAtomS :: (Parser Char (AbsTree Char b)(Matcher Char) (Assert Char))
+
+nnExtAtomS  = star parseChange ..+
+              (star parseAssert <<< combineAssert)
+          +.+ ((nnXAtomS ||| nnAtomS)
+                         +.+    ((lit '*' <<< const mkStar 
+                              ||| lit '+' <<< const mkPlus
+                              ||| lit '?' <<< const mkOpt
+                              ||| lit '{' ..+ anyPos +.. lit '}'
+                                   <<< helpexact
+                              ||| lit '{' ..+ anyInt +.+    
+                                   lit ',' +.+ (opt anyInt) 
+                                   +.. lit '}'       <<< helpminmax 
+                                 ) +.+ opt (lit '?') ) <<< helprepeat
+         ||| nnXAtomS
+         ||| plus (nnAtomS `notFollowedBy` (startSubexp <<< const 'x' ||| oneofC "*+?{")) 
+             <<< combine
+             -- don't want to eat up the name for a subexpression
+             -- want to catch the last atom separately as it is to be
+             -- made into a repeatable node
+         ||| nnAtomS)
+         +.+ (star parseAssert <<< combineAssert)
+         +.. star parseChange
+         <<< helper
+
+               where
+                  helpexact x = mkExact x
+
+                  helpminmax (x,(a,[])) = mkMin x
+                  helpminmax (x,(a,[y])) 
+                         = if x <= y then 
+                             mkMinMax x y  
+                           else 
+                             error "Invalid interval in Regular Expression"
+
+                 
+                  helprepeat (ea,(f,[])) = f ea
+                  helprepeat (ea,(f,[_])) = mkNg (f ea)
+
+                  combine = mkEl . foldl1 regseq . map getElem 
+
+                 combineAssert [] = []
+                  combineAssert s@(x:xs) = [(mkEl.foldl1 regseq) s]
+
+                  helper ([],(t,[])) = t
+                  helper ([e1],(t,[])) =  mkCon e1 t
+                               
+                  helper ([e1],(t,[e2])) = mkCon e1 (mkCon t e2)
+
+                  helper ([],(t,[e2])) = mkCon t e2
+
+
+-- parse a factor
+nnFactorS :: (Parser Char (AbsTree Char b)(Matcher Char) (Assert Char))
+
+nnFactorS =    star parseChange ..+ 
+               (opt (lookupEnv "line" +.+ (lit '^' -- may match begin any line
+                                       ||| lit '\\' ..+ lit 'A'))) 
+                                                   -- match only begin string
+           +.+ (plus nnExtAtomS) 
+           +.+ (opt (lookupEnv "line" +.+ (lit '$' -- may match end any line
+                                      ||| lit '\\' ..+ lit 'Z'))) 
+                                                 -- match only end line
+               +.. star parseChange
+           <<< helper
+
+      where
+         helper ([],(xs,[])) = combine xs      -- not prefix or suffix
+        helper ([(mode,what)],(xs,[]))
+              = handlepre (mode,what) (combine xs)
+        helper ([],(xs,[(mode,what)]))
+             = handlesuff (mode,what) (combine xs) 
+         helper ([(mode1,what1)],(xs,[(mode2,what2)])) 
+              = handlepre (mode1,what1) (handlesuff (mode2,what2) (combine xs))
+
+        handlepre (_,'A') t = mkCon (justPrefix (mkEl (doAssert prefix))) t
+        handlepre (Multi_Line,'^') t = mkCon (mkEl (doAssert bol)) t
+         handlepre (_,'^') t = mkCon (justPrefix (mkEl (doAssert prefix))) t
+
+        handlesuff (_,'Z') t = mkCon t (mkEl (doAssert suffix))
+        handlesuff (Multi_Line,'$') t =  mkCon t (mkEl (doAssert eol))
+         handlesuff (_,'$') t = mkCon t (mkEl (doAssert suffix))
+
+         combine (x:[]) = x
+         combine s@(x:xs) = foldl1 mkCon s
+         
+
+-- parse a regexp
+nnRegexpS :: (Parser Char (AbsTree Char b)(Matcher Char) (Assert Char))
+
+nnRegexpS = nnFactorS +.+ star (lit '|' ..+ nnFactorS) <<< helper
+               where
+                 helper (ea,[]) = ea
+                 helper (ea, s@(x:xs))= foldl mkAlt ea s
+
diff --git a/testsuite/driver/basicRxLib/Parsers.hs b/testsuite/driver/basicRxLib/Parsers.hs
new file mode 100644 (file)
index 0000000..b5c5b2c
--- /dev/null
@@ -0,0 +1,272 @@
+{-
+This module contains combinator parser functions based on ones by
+Peter Thiemann.
+They have been tweaked with extra info to allow them to work for the 
+ParseRegexp module. Its a recursive descent DETERMINISTIC parser.
+Particularly that means that, it does not do full backtracking. 
+For instance, (rpt (lit 'a')) will return only the longest match it
+can.  ((rpt (lit 'a')) `thn` (lit 'a')) will not match "a".
+-}
+
+module Parsers 
+ (Parser,
+  initParser,
+  lookupEnv,
+  updateEnv,
+  lookupFn,
+  lookupAs,
+  satisfy,
+  lit,
+  isWord,
+  oneofC,
+  anyC,
+  butC,
+  anyInt,
+  anyPos,
+  unitL,
+  thenxPx,
+  thenxP_,
+  then_Px,
+  (+.+),
+  (..+),
+  (+..),
+  (|||),
+  (<<<),
+  (<<*),
+  plus,
+  star,
+  opt,
+  followedBy,
+  notFollowedBy
+ )
+
+where
+
+import FiniteMap
+import Matchers(MatcherFlag)
+
+infixr 8 +.+ , +.. , ..+
+infixl 7 <<< , <<* 
+infixr 6 |||
+
+
+type Env = FiniteMap String MatcherFlag
+
+type Parser a b c d =[c]       -- some kind of function list, labeled by 
+                               -- posn in list
+                  -> [d]       -- an assertion list, labeled by posn in list
+                  -> (Env,     -- Environment info about state of regexp
+                      [a])     -- The input list
+                  -> [(b,(Env,[a]))]-- Updated info
+                               -- The empty list here,
+                               -- represents a failed parse
+
+-- initParser - Run a parser 
+initParser :: Parser a b c d   -- the parser to run 
+              -> [a]           -- the list to parse
+              -> [c]           -- lookup environment, label by posn in list
+              -> [d]           -- another lookup environment for assertions
+              -> [(String,MatcherFlag)]        -- environment info about state we're in
+              -> [(b,          -- The result of parser
+                   [a])]       -- rest of list left over
+
+
+initParser p1 inp fs as mfs =
+    let   env =listToFM mfs
+    in 
+           case p1 fs as (env,inp) of
+             ((res,(env,after)):xs) -> [(res,after)]
+             [] -> []
+
+
+-- lookupFn - look for the nth item, from the function  list
+lookupFn :: Int -> Parser a c c d
+lookupFn key fs _ tkns
+  =  if key > length fs then
+       []
+     else -- finds eth function in given list, first is 1.
+       [(fs !! (key-1),tkns)] 
+      
+-- lookupAs - look for the nth item, from the assertion list
+lookupAs :: Int -> Parser a d e d
+lookupAs key fs as tkns
+  =  if key > length as then
+       []
+     else -- finds eth function in given list, first is 1.
+       [(as !! (key-1),tkns)] 
+
+-- lookupEnv - look for the nth item, from the environment list
+lookupEnv :: String -> Parser a MatcherFlag c d
+lookupEnv key fs as (env,tkns)
+  = case lookupFM env key of 
+       Just x -> [(x,(env,tkns))] 
+
+updateEnv :: String -> MatcherFlag -> Parser a MatcherFlag c d
+updateEnv key elt fs as (env,tkns)
+   = [(elt,(addToFM env key elt,tkns))]
+
+-- Sequence two parser actions, second uses result of first
+-- don't care about result returned by second         
+thenxP_ :: Parser a b c e -> (b -> Parser a d c e) -> Parser a b c e
+thenxP_ p1 p2 fs as tkns =
+        (concat
+       . map (\ (v1, tokens1) -> map (\ (v2, tokens2) -> (v1, tokens2)) (p2 v1 fs as tokens1)))
+       (p1 fs as tkns)
+
+-- Sequence two parser actions, second uses result of first
+-- don't care about result returned by first         
+then_Px :: Parser a b c e -> (b -> Parser a d c e) -> Parser a d c e
+then_Px p1 p2 fs as tkns =
+        (concat
+       . map (\ (v1, tokens1) -> map (\ (v2, tokens2) -> (v2, tokens2)) (p2 v1 fs as tokens1)))
+       (p1 fs as tkns)
+
+-- Sequence two parser actions, second uses result of first,
+-- pair off result of first and second action
+thenxPx :: Parser a b c e -> (b -> Parser a d c e) -> Parser a (b,d) c e
+thenxPx p1 p2 fs as tkns =
+        (concat
+       . map (\ (v1, tokens1) -> map (\ (v2, tokens2) -> ((v1,v2), tokens2)) (p2 v1 fs as tokens1)))
+       (p1 fs as tkns)
+
+
+-- have successfully matched something so return it
+
+succeed :: b -> Parser a b c e
+succeed value fs as rest = [(value, rest)]
+
+-- the parser
+--     satisfy p
+-- accepts the language { token | p(token) }
+
+satisfy :: (a -> Bool) -> Parser a a b e
+satisfy p fs as (_,[]) = []
+satisfy p fs as (env,(token:tokens)) | p token = succeed token fs as (env,tokens)
+                                 | otherwise = []
+
+isnull :: Parser a [b] c e
+isnull _ _ (env,[]) = [([],(env,[]))]
+isnull _ _ _ = []
+
+cut :: [a] -> [a] 
+cut [] = []
+cut (x:xs) = [x]
+
+unitL :: a -> [a]
+unitL = \x -> [x]
+
+-- match any element
+anyC :: Parser a a c e
+anyC  = satisfy (const True)
+
+-- match any element not a member of the list
+butC :: Eq a => [a] -> Parser a a c e
+butC cs = satisfy (not.(`elem` cs))
+
+oneofC :: Eq a => [a] -> Parser a a c e
+oneofC cs = satisfy (`elem` cs)
+
+isWord :: Eq a => [a] -> (Parser a [a] b e)
+isWord [x] =  (lit x <<< unitL)
+isWord (x:xs) = (lit x <<< unitL) +.+ (isWord xs) <<* (++)
+
+-- anyInt recognises any non-negative integer, from longest possible
+-- list of digit chars
+anyInt :: Parser Char Int a e
+anyInt = ((plus (satisfy (\c -> (c >= '0') && (c <= '9'))))) <<< read
+
+-- anyPos recognises any positive integer, from longest possible list
+-- of digit chars
+anyPos :: Parser Char Int a e
+anyPos = ((satisfy (\c -> (c > '0') && (c <= '9'))) <<< unitL)
+         +.+
+         ((star (satisfy (\c -> (c >= '0') && (c <= '9')))))
+         <<* (++)
+         <<< read 
+
+-- the parser
+--     lit word
+-- accepts { word }
+
+lit :: Eq a => a -> Parser a a b e
+lit token = satisfy (== token)
+
+
+-- if p1 and p2 are parsers accepting L1 and L2 then
+--     then p1 p2
+-- accepts L1.L2
+
+-- (+.+) - pair off result of first and second parser
+--(+.+) :: Parser a b c e -> Parser a d c e -> Parser a (b,d) c e
+p1 +.+ p2 = 
+   \fs as tkns ->
+        (concat
+        . map (\ (v1, tokens1) -> map (\ (v2, tokens2) -> ((v1,v2), tokens2)) (p2 fs as tokens1)))
+        (p1 fs as tkns)
+
+-- (+..) - don't care about result of second parser
+(+..) :: Parser a b c e -> Parser a d c e -> Parser a b c e
+p1 +.. p2 =
+   \fs as tkns ->
+        (concat
+       . map (\ (v1, tokens1) -> map (\ (v2, tokens2) -> (v1, tokens2)) (p2 fs as tokens1)))
+       (p1 fs as tkns)
+
+-- (..+) - don't care about result of first parser
+(..+) :: Parser a b c e -> Parser a d c e -> Parser a d c e
+p1 ..+ p2 =
+   \fs as tkns ->
+       (concat
+       . map (\ (v1, tokens1) -> map (\ (v2, tokens2) -> (v2,tokens2)) (p2 fs as tokens1)))
+       (p1 fs as tkns)
+
+
+-- if p1 and p2 are parsers accepting L1 and L2 then
+--     alt p1 p2
+-- accepts L1 | L2
+
+(|||) :: Parser a b c e -> Parser a b c e -> Parser a b c e
+p1 ||| p2 = \fs as tokens -> cut (p1 fs as tokens ++ p2 fs as tokens)
+
+-- if p1 is a parser then
+--     p1 <<< f
+-- is a parser that accepts the same language as p1
+-- but mangles the semantic value with f
+
+(<<<) :: Parser a b c e -> (b -> d) -> Parser a d c e
+p1 <<< f = \fs as tkns -> map (\ (v, tokens) -> (f v, tokens)) (p1 fs as tkns)
+
+(<<*) :: Parser a (b,c) d f -> (b -> c -> e) -> Parser a e d f
+p <<* f = \fs as tkns -> map ( \((v,w), tokens) -> (f v w, tokens)) (p fs as tkns)
+
+-- if p accepts L then plus p accepts L+
+
+plus :: Parser a b c e -> Parser a [b] c e
+plus p fs as tkns = cut  (((p +.+ star p) <<* (:)) fs as tkns)
+
+-- if p accepts L then star p accepts L*
+
+star :: Parser a b c e -> Parser a [b] c e
+star p fs as tkns = cut ((plus p ||| succeed []) fs as tkns)
+
+-- if p accepts L then opt p accepts L?
+
+opt :: Parser a b c e -> Parser a [b] c e
+opt p fs as tkns = cut (((p <<< \x -> [x]) ||| succeed []) fs as tkns)
+
+-- followedBy p1 p2 recognizes L(p1) if followed by a word in L (p2)
+
+followedBy :: Parser a b d e -> Parser a c d e -> Parser a b d e
+followedBy p q fs as tks = [(v, rest) | (v, rest) <- p fs as tks, x <- q fs as rest]
+
+
+notFollowedBy :: Parser a b d e -> Parser a c d e -> Parser a b d e
+notFollowedBy p q fs as tkns = --((p +.. q) ||| (p +.. isnull)) fs as tkns
+
+                   case p fs as tkns of
+                      res@([(a,(_,[]))]) -> res 
+                      res@([(a,res1)]) -> case q fs as res1 of
+                                                [] -> res
+                                                (x:xs) -> []
+    
+                      [] -> []
diff --git a/testsuite/driver/basicRxLib/Regexp.hs b/testsuite/driver/basicRxLib/Regexp.hs
new file mode 100644 (file)
index 0000000..84805fc
--- /dev/null
@@ -0,0 +1,368 @@
+module Regexp 
+   (MatcherFlag(..),
+    Assert,
+    Matcher,
+    REmatch,
+    legalRegexp,
+    matchedAny,
+    numSubexps,
+    subexpMatch,
+    matchedSubexp,
+    allSubexps,
+    wholeMatch,
+    beforeMatch,
+    afterMatch,
+    searchP,
+    searchS,
+    searchExtP,searchBasicP,
+    searchExtS,
+    substP,
+    substS,
+    substExtP,substExtS)
+
+where
+
+import Matchers(MatcherFlag(..),Matcher)
+import Assertions(Assert)
+import NFADefs(NFANode(..),NFAElem,IntervalInfo,SubexpInfo)
+import ExecRE(execRegexp)
+import CompileRES(compileRegexpS)
+import CompileREP(compileRegexpP)
+import CompileREPB(compileRegexpPB)
+import FiniteMap
+
+
+
+
+-- The search function returns an REmatch. The result from this can be
+-- accessed with the functions below.
+
+data REmatch a 
+   =  ILLEGAL
+   |  NOTHING    -- Match failed
+   |  JUST  (FiniteMap String [a], -- matched subexpressions ($1..$n)
+             [a],              -- everything before match ($` in perl)
+             [a],              -- entire match            ($& in perl)
+             [a]               -- everything after match  ($' in perl)
+            )              
+      
+
+matchedAny :: (REmatch a) -- given match result
+              -> Bool    -- whether there was a match
+
+matchedAny (JUST (_,_,_,_)) = True
+matchedAny NOTHING = False  
+matchedAny ILLEGAL = False
+
+legalRegexp :: (REmatch a) -> Bool
+legalRegexp ILLEGAL = False
+legalRegexp _ = True
+
+numSubexps :: (REmatch a)      -- given match result 
+           -> Int              -- how many subexpressions matched
+numSubexps (JUST (subexps,_,_,_)) =
+                length (fmToList subexps)
+
+numSubexps (NOTHING) = 0
+numSubexps ILLEGAL = 0
+
+matchedSubexp :: (REmatch a) -> String -> Bool
+matchedSubexp (JUST (subexps,_,_,_)) x  = case lookupFM subexps x of 
+                                             Nothing -> False 
+                                             (Just _) -> True
+matchedSubexp (NOTHING) x = False
+matchedSubexp ILLEGAL x = False
+subexpMatch :: (REmatch a)     -- given match result
+                -> String      -- the subexp we're interested in
+                               -- (referred to by number, the first is 1...)
+                -> [a]          -- what the subexp matched
+subexpMatch rem@(JUST (subexps,_,_,_)) x = 
+                case lookupFM subexps x of 
+                     Nothing -> []
+                     (Just xs) -> xs 
+subexpMatch NOTHING x = []   
+subexpMatch ILLEGAL x = []
+
+allSubexps :: REmatch a -> [(String,[a])] 
+allSubexps (JUST (subexps,_,_,_)) = fmToList subexps
+allSubexps NOTHING = []   
+allSubexps ILLEGAL = []
+
+wholeMatch :: (REmatch a)      -- given match result
+              -> [a]           -- the entire match
+wholeMatch (JUST (_,_,piece,_)) = piece
+wholeMatch NOTHING = [] 
+wholeMatch ILLEGAL = []
+
+beforeMatch :: (REmatch a)     -- given match result
+               -> [a]          -- everything before the match
+beforeMatch (JUST (_,before,_,_)) = before
+beforeMatch NOTHING = [] 
+beforeMatch ILLEGAL = []
+
+afterMatch :: (REmatch a)      -- given match result
+              -> [a]           -- everything after the match
+afterMatch (JUST (_,_,_,after)) = after
+afterMatch NOTHING = [] 
+afterMatch ILLEGAL = []
+
+
+-- The polymorphic search function, it compiles the regexp and then performs
+-- the match. It finds the first match, of longest(isH) length.
+-- It returns an REmatch, defined above.
+searchP :: (Eq a, Ord a, Enum a, Read a, Show a) =>
+             String            -- regexp
+          -> [a]               -- list to match along
+          -> (REmatch a)       -- what matched and where
+searchP re inp = searchExtP re [] [] inp
+
+searchExtP :: (Eq a, Ord a, Enum a, Read a, Show a) =>
+                String         -- regexp
+            -> [Matcher a]     -- pass in own match functions
+             -> [Assert a]      -- pass in own assertions
+             -> [a]            -- list to match along
+             -> (REmatch a)    -- what matched and where
+searchExtP re fs as inp 
+ = case (compileRegexpP re [] fs as) of 
+    (Just matcher) -> 
+      case (execRegexp matcher inp) of
+        Nothing -> NOTHING
+        Just stuff -> JUST stuff
+    Nothing -> ILLEGAL         
+
+
+-- a polymorphic regexp without the need for enum ...
+
+searchBasicP :: (Eq a, Read a, Show a) =>
+                String         -- regexp
+            -> [Matcher a]     -- pass in own match functions
+             -> [Assert a]      -- pass in own assertions
+             -> [a]            -- list to match along
+             -> (REmatch a)    -- what matched and where
+searchBasicP re fs as inp 
+ = case (compileRegexpPB re [] fs as) of 
+    (Just matcher) -> 
+      case (execRegexp matcher inp) of
+        Nothing -> NOTHING
+        Just stuff -> JUST stuff
+    Nothing -> ILLEGAL         
+
+-- The string search function, it compiles the regexp and then performs the
+-- match. It finds the first match, of longest(isH) length.
+-- It returns an REmatch, defined above.
+
+searchS :: 
+             String            -- regexp
+         -> [MatcherFlag]      -- flags to modify match
+          -> String            -- list to match along
+          -> (REmatch Char)    -- what matched and where
+searchS re flags inp = searchExtS re flags [] [] inp
+
+searchExtS :: 
+                String         -- regexp
+            -> [MatcherFlag]   -- flags to modify match
+            -> [Matcher Char]-- pass in own match functions
+             -> [Assert Char]      -- pass in own assertions
+             -> String         -- list to match along
+             -> (REmatch Char) -- what matched and where
+
+searchExtS re flags fs as inp
+ = case (compileRegexpS re flags fs as) of 
+    (Just matcher) -> 
+      case (execRegexp matcher inp) of
+        Nothing -> NOTHING
+        Just stuff -> JUST stuff
+    Nothing -> ILLEGAL         
+
+resultsS re flags fs as inp = case (searchExtS re flags fs as inp) of
+                            NOTHING -> Nothing
+                            JUST (ses,a,b,c) -> Just (eltsFM ses,a,b,c)
+
+
+
+
+-- search and replace functions.
+
+substP :: (Ord a,Enum a,Read a, Show a) => 
+          String       -- regexp
+       -> String       -- what to replace it with
+       -> [MatcherFlag]        -- flags to modify match
+       -> [a]          -- list to match along
+       -> [a]          -- result
+substP rexp repl flags inp 
+  = substExtP rexp repl flags [] [] inp
+
+
+substS :: String       -- regexp
+       -> String       -- what to replace it with
+       -> [MatcherFlag]        -- flags to modify match
+       -> String       -- list to match along
+       -> String       -- result
+substS rexp repl flags inp
+  = substExtS rexp repl flags []  [] inp
+
+
+substExtS :: String            -- regexp
+          -> String            -- what to replace it with
+          -> [MatcherFlag]     -- flags to modify match
+          -> [Matcher Char]    -- pass in own match functions
+          -> [Assert Char]     -- pass in own assertions
+          -> String            -- list to match along
+         -> String             -- result
+substExtS rexp repl flags fs as inp 
+   =  find inp
+   where
+    global = Global_Match `elem` flags
+    searcher= searchExtS rexp flags fs as
+    replacer = replaceS repl
+    find sub
+     = let
+       search_res = searcher sub
+       success = matchedAny search_res
+       in
+         if not success then
+           sub
+         else          
+           let
+             match = wholeMatch search_res
+             prefix = beforeMatch search_res
+             afterthis = afterMatch search_res
+             suffix 
+              = if global && ((not.null) match) then
+                  find afterthis
+               else
+                  afterthis
+           in
+               concat [prefix,
+                       replacer search_res,
+                       suffix]
+
+{-
+substExtP
+      - does a search and replace using Input regexp and replace info
+        of perl like format, single elements still in curly brackets.
+        Allowed MatcherFlag is Global_Match for doing global replacement;
+        otherwise only replaces first occurrence
+-}
+
+substExtP :: 
+         (Ord a,Enum a,Read a, Show a) =>
+         String                -- regexp
+      -> String                -- what to replace it with
+      -> [MatcherFlag] -- flags to modify match
+      -> [Matcher a]   -- pass in own match functions
+      -> [Assert a]    -- pass in own assertions
+      -> [a]           -- list to match along
+      -> [a]           -- result
+
+substExtP rexp repl flags as fs inp
+   =  find inp
+   where
+    global = Global_Match `elem` flags
+    searcher= searchExtP rexp as fs
+    replacer = replaceP repl
+    find sub
+     = let
+       search_res = searcher sub
+       success = matchedAny search_res
+       in
+         if not success then
+           sub
+         else          
+           let
+             match = wholeMatch search_res
+             prefix = beforeMatch search_res
+             afterthis = afterMatch search_res
+             suffix 
+              = if global && ((not.null) match) then
+                  find afterthis
+               else
+                  afterthis
+           in
+               concat [prefix,
+                       replacer search_res,
+                       suffix]
+
+
+---------------------------------------------------------
+{-
+replaceP - uses the REmatch given, and a string of replacement info to
+           build the replacement list.
+           eg if working on type Days of Week, and ${m} = [Monday,Tuesday]
+              replace rem "${m}<Sunday>" = [Monday,Tuesday,Sunday]
+-}
+replaceP :: (Read a, Show a) =>
+            String
+         -> REmatch a 
+         -> [a] 
+
+replaceP replacement rem = replace' replacement rem
+   where
+     replacer = searchS "\\< elem@(([^\\\\>]|\\.)+)\\>|\\$" []
+     replace' repl rem =
+        let matchres = replacer repl
+        in
+          if not (matchedAny matchres) then
+             []
+          else if matchedSubexp matchres "elem" then
+             [(read (subexpMatch matchres "elem"))] ++
+             replace' (afterMatch matchres) rem
+          else
+             case handleReference rem (afterMatch matchres) of
+               Nothing -> replace' (afterMatch matchres) rem
+               (Just (ms,as)) -> ms ++ replace' as rem   
+
+ref = searchS "^\\{( bef@(m_before_)| aft@(m_after_)| whole@(m)| sub@(\\w+))\\}" []
+
+handleReference :: (Read a, Show a) => 
+                   REmatch a -> String -> Maybe ([a],[Char]) 
+handleReference rem repl =
+       let matchres = ref repl
+       in 
+         if not (matchedAny matchres) then
+            Nothing
+         else if (matchedSubexp matchres "whole") then -- matched ${m}
+            Just (wholeMatch rem, afterMatch matchres)
+         else if matchedSubexp matchres "bef" then -- matched ${m_before_}
+            Just (beforeMatch rem, afterMatch matchres)
+         else if matchedSubexp matchres "aft" then -- matched ${m_after_}
+            Just (afterMatch rem,afterMatch matchres)
+         else --if matchedSubexp matchres "sub" then -- matched ${..}...
+            Just (subexpMatch rem (subexpMatch matchres "sub"),
+                  afterMatch matchres)
+
+{-
+replaceS - uses the REmatch given, and a string of replacement info to
+           build the replacement list.
+           eg if ${m} = "ab"
+              replace "${m}d" rem = "abd"
+-}
+replaceS replacement rem = replace' replacement rem
+  where
+     replacer = searchS "\\\\ el@(.)|\\$" [] 
+     replace' repl rem =
+        let matchres = replacer repl
+        in
+          if not (matchedAny matchres) then
+             repl
+          else if matchedSubexp matchres "el" then
+             beforeMatch matchres ++ subexpMatch matchres "el" 
+             ++ replace' (afterMatch matchres) rem
+          else
+             beforeMatch matchres ++ 
+             (case handleReference rem (afterMatch matchres) of
+               Nothing -> replace' (afterMatch matchres) rem
+               (Just (ms,as)) -> ms ++ replace' as rem) 
+     
+             
+
+
+
+
+