module HandleRe2hs where
import Regexp
import Re2hsBasics
import HandlePattern

mkSubexps :: [String]	-- the list of subexpressions 
          -> String	-- what to indent expression with 
          -> String	-- the matchResult we're looking up
          -> String	-- code to declare all the subexps in the
			-- given list
mkSubexps ses spaces mresult = foldr (toRealSE spaces) "" ses
	where 
	  toRealSE :: String -> String -> String -> String
	  toRealSE spaces sename s = spaces ++ sename ++ 
				     " = subexpMatch " ++ mresult ++ " \""
		                     ++ sename ++ "\"\n" ++ s



mkMainMatch :: String	-- the label to bind the main match info to 
            -> String	-- what to indent it all with
            -> String	-- the matchResult we're looking up
            -> String	-- code to bind the main match info to a 
			-- relevant as pattern, if there was none
                        -- then return an empty string
mkMainMatch name spaces mresult = 
	      case name of
		   "" -> ""
		   (x:xs) -> mkMainMatch name 
		             ++ mkBeforeMatch name
			     ++ mkAfterMatch name
	where
            mkMainMatch n = spaces ++ n ++ 
			    " = wholeMatch " ++ mresult ++ "\n"
	    mkBeforeMatch n= spaces ++ n ++ "_before_" ++
			    " = beforeMatch " ++ mresult ++ "\n"
	    mkAfterMatch n = spaces ++ n ++ "_after_" ++
			     " = afterMatch " ++ mresult ++ "\n"

data Type = STRING
          | POLY
          | POLYBASIC
          | NOTYET


mkSearcher :: String	-- the regexp 
           -> String	-- any flags
           -> [String]	-- user-defined matcher functions
           -> [String]	-- user-defined assertions
           -> Type	-- is it polymorphic, simple polymorphic, or string
           -> String

mkSearcher re flags mfs afs retype = 
  let    
              realmfs = mkToList mfs
              realafs = mkToList afs
              rflags = mkFlags flags
              regexp = " (\""++re++"\") "
           
  in
    case retype of
      STRING -> " searchExtS"++ regexp ++ rflags ++ realmfs ++ realafs ++ "\n"
      POLY -> "searchExtP" ++ regexp ++ realmfs ++ realafs ++ "\n"
      POLYBASIC -> "searchExtPBasic" ++ regexp ++ realmfs ++ realafs ++ "\n"


mkFlags :: String -- a string containing all the flags 
        -> String -- all the flags minus the poly flag
mkFlags flags = let stage1 = substS "PolyBasic|Poly" "" [Global_Match] flags
		    stage2 = substS ",{2,}" "," [Global_Match] stage1
                in
                    "[" ++ substS "^,|,$" "" [Global_Match] stage2 ++ "]"


mkToList :: [String]	-- a list of values 
         -> String	-- the string equivalent
mkToList xs = if null xs then
		"[]"
	      else 
                "[" ++ (foldr1 mklist xs) ++ "]"
	where
          mklist x s = x ++ "," ++ s


-- do stuff for case expressions

data CaseProg = PAT String	-- regexp pattern name 
                    String	-- regexp itself
                    String	-- the flags
                    String	-- the whole of the </.../> ->

              | CODE String	-- all the original code up to same point
                     String	-- code to go with a case

              | ELSE String	-- a default case, string is "_ ... ->"

	      | AFTER Int	-- the next label to use to distinguish a matchResult
                      String	-- unparsed code



handleCase :: Int	-- label to distinguish matchResults
           -> String	-- the list to match against
           -> String	-- all the original code before the case
                        -- expression
           -> [CaseProg]-- all the patterns and corresponding code
           -> (String,	-- the new code
               String,	-- all the original code up to the final point
               String,	-- what's left to match against
               Int)	-- the next label that can be used for a matchResult
handleCase numnow list before cases =
         let 
             (numnew,realre,ses,mfs,afs,def,retype,pre,rest) = 
                                         mkPattern numnow cases before 

	     spaces' = mkSpaces numspaces
             mresult = "matchResult"++ show numnow
             numspaces = indent before
	in
       (
        "let\n" ++ spaces' ++ 
	mresult++" = " ++ mkSearcher realre "" mfs afs retype ++
        spaces' ++ "    " ++ list ++ "\n" ++ -- the list with indentation 
        spaces' ++ "in\n" ++
        dealCases mresult ses spaces' def 
 
       ,
        pre
       ,
        rest,
        numnew)

mkPattern :: Int		-- the label to use to distinguish matchResults
          -> [CaseProg]		-- the patterns and code 
          -> String		-- the original code before start of case
          -> (Int,String,	-- regexp so far
              [(Int,String,	-- name of subexp group (case group)
                Int,		-- indentation required before code
                [String],	-- all the subexps in this case group
                String)],	-- the code to go with this case
              [String],		-- the user defined matcher functions
	      [String],		-- the user defined assertions
	      Bool,		-- is there a default for case expr
              Type,		--is it polymorphic, polybasic or string regexp
              String,		-- everything before end of case in 
                                -- original code
              String		-- any code still to parse
	     )

mkPattern numnow cases before = 
    case mkpattern cases 1 poly (numnow+1,[],[],[],[],False,before,"") of
      (num,re,ses,mfs,afs,def,bef,rest) -> 
                         (num,re,ses,mfs,afs,def,retype,bef,rest)
 where

  poly = case retype of
           STRING -> False
           _ -> True

  retype = case cases of 
            (PAT _ _ flags _ : _) ->
                       if (matchedAny (searchS "PolyBasic" [] flags)) then
                         POLYBASIC
                       else if (matchedAny (searchS "Poly" [] flags)) then
                         POLY
                       else
                         STRING

  mkpattern :: [CaseProg] -- the patterns and code
            -> Int	-- extra label for this pattern to distinguish it
			-- current data on ...    
            -> Bool	-- is it polymorphic

            -> (Int,String,	-- regexp so far
                [(Int,String,	-- name of subexp group (case group)
                  Int,		-- indentation required before code
                  [String],	--all the subexps in this case group
                  String)],	--the code to go with this case
                [String],	-- the user defined matcher functions
	        [String],	--the user defined assertions
	        Bool,		-- is there a default for case expr 
                String,
                String
	       )

		  -- updated data on ...
            -> (Int,String,	-- regexp so far
                [(Int,String,	-- name of subexp group (case group)
                  Int,		-- indentation required before code
                  [String],	-- all the subexps in this case group
                  String)],	-- the code to go with this case
                [String],	-- the user defined matcher functions
	        [String],	-- the user defined assertions
	        Bool,		-- is there a default for case expr
                String,		-- all original code before this point
                String		-- any code left over, has not been parsed
	       )

  mkpattern [] _ _ stuff = stuff
  mkpattern ((PAT name re flags whole):(CODE orig code):rest) n poly
            (nnew,res,ses,mfs,afs,def,before,last) =
	let 
          nspaces = indent (before ++ whole)
          (realre,se,mf,af) = initReM handleRegexp re n (length mfs + 1) 
                                                        (length afs + 1)
          reg2 = case rest of 
                    (PAT _ _ _ _ :xs) -> reg1++"|"
                    _ -> reg1
          reg1 = " "++ show n ++ name++"@("++reg++")"

          reg = if poly then
                  realre
                else
                 case mkFlags flags of
                  "[]" -> realre ++ "(?Default_Line,Case_Sensitive)"
                  '[':xs -> 
                     "(?"++ (init xs) ++ ")" ++ realre ++ "(?Default_Line,Case_Sensitive)"
        in
           mkpattern rest (n+1) poly
           (nnew,res++reg2,
	    ses ++ [(n,name,nspaces,se,code)],
            mfs ++ mf,
            afs ++ af,
            def,
	    orig,
            ""
           )

  -- excess unparsed code
  mkpattern [AFTER nnew code] _ _ (_,res,ses,mfs,afs,def,before,_) =  
             (nnew,res,ses,mfs,afs,def,before, code)
 
  -- a default case
  mkpattern ((ELSE wh):(AFTER nnew code):[]) n _ (_,res,ses,mfs,afs,_,bef,_) =
               (nnew,res,ses,mfs,afs,True,bef++wh,
                (mkSpaces (indent bef)) ++ code)  



dealCases :: String		-- the matchResult name
          -> [(Int,             -- label to go with subexp name
               String,		-- name of subexp group (case group)
               Int,		-- indentation required before code
               [String],	-- all the subexps in this case group
               String)]		-- the code to go with this case
          -> String		-- spaces to indent to level of case expression
          -> Bool		-- whether there's a default case
          -> String		-- the resulting code

{- we've got a default case, so place the default (not matchedAny)
   if expression at the bottom to be with it's code
-}
dealCases mresult cases spaces True = 
              dealCaseSubexps mresult cases spaces True
              ++ "\n" ++ spaces ++ 
              "else -- if not (matchedAny "++mresult++") then\n" 
                              

{- we've no default case, so place the default (not matchedAny)
   expression, at the top with an error message. It should never be
   called, but this is consistent with normal case expressions.
-}
dealCases mresult cases spaces False = spaces ++ 
                               "if not (matchedAny " ++ mresult++") then\n" ++
                               spaces ++ "  error \"no default specified\"\n\n"
			       ++
                               dealCaseSubexps mresult (init cases) spaces False ++
                               "\n" ++ spaces ++ "else\n" ++
                               caseBody mresult (last cases) spaces ""


  -- make an if expression to deal with a case...
dealCaseSubexps _ [] spaces' _ = ""
dealCaseSubexps mresult (info@(n,name,nspaces,ses,code):rest) spaces' first =
   let bit = if first then "" 
             else "else "
       last = if null rest then "" 
              else "\n"
   in
	spaces' ++ bit ++ "if (matchedSubexp "++mresult++" \"" ++ 
                    (show n ++ name) ++ "\") then\n" ++
        caseBody mresult info spaces' last
        ++ dealCaseSubexps mresult rest spaces' False

  -- make the actual body of the case expression, this includes a let
  -- expression to put all as-pattern variables into scope, and then
  -- the real code
caseBody mresult (_,name,nspaces,ses,code) spaces' last = 
	spaces' ++ "let\n" ++
        mkMainMatch name (spaces'++"  ") mresult ++
        mkSubexps ses (spaces'++"  ")	mresult ++
        spaces' ++ "in\n"    ++
        mkSpaces nspaces ++ code ++ last





parse_re2hs_subst :: String -- name of the pattern for reference
		  -> String -- the regexp
                  -> String -- what to replace it with
                  -> String -- any flags
                  -> String -- all the original code before the pattern
                  -> String -- the whole of the subst </.../.../> expression
                  -> Int    -- a label to distinguish the match info?
                  -> String -- the resulting real code

parse_re2hs_subst name re replace flags before whole numnow = 
	let (realre,ses,mfs,afs) = initReM handleRegexp re 1 1 1  
                                        -- strip out the regexp
	    (realreplace,_,_,_) = initReM handleReplace replace 1 1 1
                                        -- strip out the replace pattern
            poly = if (matchedAny (searchS "PolyBasic" [] flags)) then
                      POLYBASIC
                   else if (matchedAny (searchS "Poly" [] flags)) then
                      POLY
                   else
                      STRING

	    spaces = "    " ++ spaceslet -- indentation before inner let expression
            spaces' = mkSpaces (indent (before++whole)) 
                                         -- indentation before rest of code
	    spaceslet = mkSpaces 13 ++ spacesouter
                                         -- indentation before inner let expression
            spacesouter = mkSpaces (indent before)
                                         -- indentation before subst </../../>
            mresult = "matchResult"++show numnow
                                         -- name for matchResult
            name1 = case name of 
                      "" -> "m"
                      (x:xs) -> name
            
            suffix = if matchedAny (searchS "Global_Match" [] flags) then 
                        spaces ++ "  let suffix = if ((not.null) " ++ name1 
                        ++ "_after_) then\n" ++
                        spaces ++ "                substRE"++show numnow++ " "++name1++
                                  "_after_\n" ++ spaces ++
                                  "               else \n" ++
                        spaces ++ "                "++name1++"_after_\n"
                      else
                        spaces ++ "  let suffix = "++name1++"_after_\n"  
             -- are we doing a global match or not?
        in 
           "let searcher = " ++ mkSearcher realre flags mfs afs poly ++
               spacesouter ++ "    substRE"++show numnow++" xs = \n" ++ 
               spaceslet ++ "let \n" ++ 
               spaces ++
	       mresult++" = searcher xs\n" ++ 
	       (mkSubexps ses spaces mresult) ++
	       (mkMainMatch name1 spaces mresult) ++
               spaceslet ++ "in \n" ++
               spaces ++ " if not (matchedAny "++mresult++") then\n" ++
	       spaces ++ "   xs\n"  ++
               spaces ++ " else \n" ++
               suffix ++
               spaces ++ "  in " ++ name1 ++ "_before_ ++ (\"" 
                      ++ realreplace ++ "\") ++ suffix \n" ++
               spacesouter ++ "in\n"++spacesouter++"substRE"++show numnow ++"\n"++
               spaces' 


parse_re2hs_simple :: String    -- the name of the pattern for reference 
		   -> String	-- the regexp
		   -> String	-- possible flags
		   -> String	-- everything before the pattern
                   -> String	-- the whole of the </.../> = expression
                   -> Int	-- start label to distinguish this matchresult
		   -> String	-- the real code 


parse_re2hs_simple name re flags before whole numnow =
	let (realre,ses,mfs,afs) = initReM handleRegexp re 1 1 1
					-- strip out regexp
            mresult = "matchResult"++show numnow
	    spaces = mkSpaces (indent before) -- spaces pattern
	    spaces' = mkSpaces (indent (before++whole)) 
                       -- spacing before new list
            retype = if (matchedAny (searchS "PolyBasic" [] flags)) then
                      POLYBASIC
                   else if (matchedAny (searchS "Poly" [] flags)) then
                      POLY
                   else
                      STRING
	in
 
	   "\n"++(mkSubexps ses spaces mresult) ++
	   (mkMainMatch name spaces mresult) ++
	   spaces ++ mresult ++ " = " ++ mkSearcher realre flags mfs afs retype ++ 
           spaces'
	   









