-------------------------------------------------------------------------------

  {-  LANGUAGE CPP #-}

#define DO_TRACE 0

#if ABBREV_WN_AND_TN_CONCRETE_SYNTAX_TO_NUMBER_ALONE__SAFE_ONLY_TO_DEPTH_19 && ABBREV_WN_AND_TN_CONCRETE_SYNTAX_TO_SINGLE_DIGIT__CAN_ONLY_EXPRESS_DOWN_TO_DEPTH_9
#error Please set at most one of the flags ABBREV_WN_AND_TN_CONCRETE_SYNTAX_TO_NUMBER_ALONE__SAFE_ONLY_TO_DEPTH_19 and ABBREV_WN_AND_TN_CONCRETE_SYNTAX_TO_SINGLE_DIGIT__CAN_ONLY_EXPRESS_DOWN_TO_DEPTH_9 to True.
#endif

-------------------------------------------------------------------------------

#if USE_ATTOPARSEC
  {-# LANGUAGE OverloadedStrings #-}
  {-  LANGUAGE ScopedTypeVariables #-}  -- debugging only
  {-# LANGUAGE BangPatterns #-}  -- for forcing tracelines in do blocks
#endif

-------------------------------------------------------------------------------

-- |
-- Module      :  Control.DeepSeq.Bounded.Compile_new_grammar
-- Copyright   :  Andrew G. Seniuk 2014-2015
-- License     :  BSD-style (see the file LICENSE)
--
-- Maintainer  :  Andrew Seniuk <rasfar@gmail.com>
-- Stability   :  provisional
-- Portability :  attoparsec
--

-------------------------------------------------------------------------------

  module Control.DeepSeq.Bounded.Compile_new_grammar
  (

#if USE_ATTOPARSEC
#if HASKELL98_FRAGMENT
#error Sorry, HASKELL98_FRAGMENT incompatible with USE_ATTOPARSEC.
#endif
      compileUsingAttoparsec  ,
--    parsePat  ,
#else
      compilePat'  ,
#endif

  )
  where

-------------------------------------------------------------------------------

  import Control.DeepSeq.Bounded.Pattern

  import Control.DeepSeq.Bounded.Compile_shared_utils

  import Data.Maybe ( isNothing, fromJust )

  import Data.List ( intercalate )

  import Debug.Trace ( trace )

#if USE_ATTOPARSEC

  import qualified Data.Attoparsec.Text as AT
  import qualified Data.Text as T
  import Control.Applicative

  import Data.Char ( isLetter )
  import Data.Char ( isDigit )
  import Data.Char ( ord )

  import Control.Monad ( liftM )
--import Control.Monad ( foldM )
--import Data.Foldable ( fold )
  import Control.Monad ( mzero )
  import Data.Monoid ( mempty )

#else

  import Control.DeepSeq.Bounded.PatUtil ( liftPats )
  import Data.Char ( isSpace )
  import Data.Char ( isLower )
  import Data.List ( sort )
  import Data.Char ( ord )
  import Data.Maybe ( isJust )

#endif

-------------------------------------------------------------------------------

#if DO_TRACE
  mytrace = trace
#else
  mytrace _ = id
#endif

#if USE_ATTOPARSEC

-------------------------------------------------------------------------------

  -- The caller (or someone up there) uses liftPat if
  -- multiple patterns are parsed (adds new common root).
  parsePatsTop :: AT.Parser [Pattern]
  parsePatsTop = do
    !_ <- mytrace ("parsePatsTop.") $ return ()
    let as = emptyPatNodeAttrs
    AT.many' (AT.skipSpace *> parsePat as <* AT.skipSpace)

-------------------------------------------------------------------------------

  -- This differs from parsePatsTop in that it assumes an
  -- opening grouping token has been consumed (so will be
  -- expecting a corresponding closing token).
  parsePats :: AT.Parser [Pattern]
#if 1
  parsePats = do
        !_ <- mytrace "parsePats." $ return ()
        (AT.endOfInput *> pure [])
    <|> (do
            c <- AT.peekChar'
#if USE_CURLY_BRACE_INSTEAD_OF_PAREN_FOR_SUBPATTERNS
            if c == '}'
#else
            if c == ')'
#endif
              then pure []
---           then AT.char '}' >> pure []
              else let as = emptyPatNodeAttrs in
                   AT.many' (AT.skipSpace *> parsePat as <* AT.skipSpace))
#else
  -- XXX Why does this work so badly?
  parsePats = AT.manyTill'
                   (AT.skipSpace *> parsePat emptyPatNodeAttrs)
                   (AT.endOfInput <|> (AT.char ')' *> return ()))
#endif

-------------------------------------------------------------------------------

  -- Test if next character is non-attribute, up front,
  -- and skip all this attribute stuff in that case!...
  parsePat :: PatNodeAttrs -> AT.Parser Pattern
  parsePat as = do
    !_ <- mytrace "parsePat." $ return ()
    let modchars = ":@=>+^/%"
    mc <- AT.peekChar
    let c = fromJust mc
    if isNothing mc
      then fail "parse_type_constraints: unexpected end-of-input"
      else if c `elem` modchars
             then parsePatAttributes as
             else parsePat3 as

  -- Note: Previously, type constraint was handled in a more
  -- ad hoc manner. The existence of separate T* nodes is
  -- evidence of this, but those will likely be removed in 0.7,
  -- making type constraint just another attribute of W* nodes.
  parsePatAttributes :: PatNodeAttrs -> AT.Parser Pattern
  parsePatAttributes as = do
    !_ <- mytrace "parsePatAttributes." $ return ()
    foldr (<|>) mempty $
--  foldM (<|>) mempty $
--  fold (<|>) mempty $
--  fold (<|>) mzero $
      ( map
          ( \ (c,s,p,b,a)
                -> do 
                      let q = (c,s,b,a)
                      if c == '\0'
                      then fail ""
                      else p c b a s <* AT.skipSpace
          )
          -- doConstrainType, doDelay, and doPseq handled specially,
          -- due to their taking arguments.
          [
            ( '\0' , ""       , dud_parser    , const False     , as )
          , ( ':'  , "types"  , types_parser  , doConstrainType , as_types  )
          , ( '@'  , "delay"  , delay_parser  , doDelay         , as_delay  )
#if USE_PAR_PATNODE
          , ( '='  , "spark"  , no_arg_parser , doSpark         , as_spark  )
#endif
#if USE_PSEQ_PATNODE
          , ( '>'  , "pseq"   , pseq_parser   , doPseq          , as_pseq   )
#endif
#if USE_TRACE_PATNODE
          , ( '+'  , "trace"  , no_arg_parser , doTrace         , as_trace  )
#endif
#if USE_PING_PATNODE
          , ( '^'  , "ping"   , no_arg_parser , doPing          , as_ping   )
#endif
#if USE_DIE_PATNODE
          , ( '/'  , "die"    , no_arg_parser , doDie           , as_die    )
#endif
#if USE_TIMING_PATNODE
          , ( '%'  , "timing" , no_arg_parser , doTiming        , as_timing )
#endif
          ]
      ) ++ [ parsePat3 as ]
   where
    dud_parser _ _ _ _ = fail "dud_parser"  -- (is never run; should use Proxy)
    no_arg_parser c b a s = do
         ( (AT.char c) <* AT.skipSpace )
      >> (if b as
            then fail $    "compilePat: duplicate "
                        ++ show c ++ " (" ++ s ++ ") "
                        ++ "node attribute"
            else parsePat a)
    types_parser _ _ a _ = parsePat1''' a
    delay_parser _ _ a _ = parsePat1' a
    pseq_parser _ _ a _ = parsePat1'' a
    as_types   = as { doConstrainType  = True }
    as_delay   = as { doDelay          = True }
#if USE_PAR_PATNODE
    as_spark   = as { doSpark          = True }
#endif
#if USE_PSEQ_PATNODE
    as_pseq    = as { doPseq           = True }
#endif
#if USE_TRACE_PATNODE
    as_trace   = as { doTrace          = True }
#endif
#if USE_PING_PATNODE
    as_ping    = as { doPing           = True }
#endif
#if USE_DIE_PATNODE
    as_die     = as { doDie            = True }
#endif
#if USE_TIMING_PATNODE
    as_timing  = as { doTiming         = True }
#endif

  -- Parse the ":Int;Maybe Float:" typeConstraints attribute, if present.
  parsePat1''' :: PatNodeAttrs -> AT.Parser Pattern
  parsePat1''' as = do
          !_ <- mytrace "parsePat1'''." $ return ()
          AT.char ':'
          >> ( ( parse_type_constraints <* AT.skipSpace )
               >>= \ tcs -> let as' = as { doConstrainType = True
                                         , typeConstraints = map T.unpack tcs }
                            in parsePat as' )

  -- Parse the "@50000" delayus attribute, if present.
  parsePat1' :: PatNodeAttrs -> AT.Parser Pattern
  parsePat1' as = do
          !_ <- mytrace "parsePat1'." $ return ()
          AT.char '@'
          >> ( ( AT.decimal <* AT.skipSpace )
               >>= \ dly -> let as' = as { doDelay = True
                                         , delayus = dly }
                            in parsePat as' )

#if USE_PSEQ_PATNODE
  -- Parse the ">cdba" pseqPerm attribute, if present.
  parsePat1'' :: PatNodeAttrs -> AT.Parser Pattern
  parsePat1'' as = do
          !_ <- mytrace "parsePat1''." $ return ()
          AT.char '>'
          >> ( ( AT.many1' AT.letter ) <* AT.skipSpace
               >>= \ perm -> let perm' = map (\c -> ord c - ord 'a') perm
                                 as' = as { doPseq = True
                                          , pseqPerm = Just perm' }
                             in parsePat as' )
#endif

-------------------------------------------------------------------------------

  -- Handle "*23"-style (WN and TN) nodes.
  parsePat3 :: PatNodeAttrs -> AT.Parser Pattern
  parsePat3 as = do
    !_ <- mytrace "parsePat3." $ return ()
    b <- AT.peekChar'
#if ( ! ABBREV_WN_AND_TN_CONCRETE_SYNTAX_TO_NUMBER_ALONE__SAFE_ONLY_TO_DEPTH_19 ) && ( ! ABBREV_WN_AND_TN_CONCRETE_SYNTAX_TO_SINGLE_DIGIT__CAN_ONLY_EXPRESS_DOWN_TO_DEPTH_9 )
    AT.anyChar
    if b == '*'
#else
    if isDigit b
#endif
      then do (     (parsePat3_aux b as)
                <|> (do
#if ABBREV_WN_AND_TN_CONCRETE_SYNTAX_TO_NUMBER_ALONE__SAFE_ONLY_TO_DEPTH_19 || ABBREV_WN_AND_TN_CONCRETE_SYNTAX_TO_SINGLE_DIGIT__CAN_ONLY_EXPRESS_DOWN_TO_DEPTH_9
#if 1
#if ABBREV_WN_AND_TN_CONCRETE_SYNTAX_TO_SINGLE_DIGIT__CAN_ONLY_EXPRESS_DOWN_TO_DEPTH_9
                        AT.anyChar
                        (case b of
                          '0' -> parsePat4 '0' Nothing as
                          '1' -> parsePat4 '1' Nothing as
                          _   -> parsePat4 '*' Nothing as
                            ) ) )
#else
                        (parsePat4 '*' Nothing as) ) )
#endif
#else
                        fail $ "parsePat3: unexpected digit " ++ [b] ) )
#endif
#else
                        (parsePat4 '*' Nothing as) ) )
#endif
      else do
#if ABBREV_WN_AND_TN_CONCRETE_SYNTAX_TO_NUMBER_ALONE__SAFE_ONLY_TO_DEPTH_19 || ABBREV_WN_AND_TN_CONCRETE_SYNTAX_TO_SINGLE_DIGIT__CAN_ONLY_EXPRESS_DOWN_TO_DEPTH_9
--      fail $ "parsePat3: #2 unexpected digit " ++ [b]
        AT.anyChar
#endif
        parsePat4 b Nothing as

  -- Actual handler, in case it /was/ WN or TN node.
  parsePat3_aux :: Char -> PatNodeAttrs -> AT.Parser Pattern
  parsePat3_aux b as = do
    !_ <- mytrace "parsePat3_aux." $ return ()
-- These should be safe cutoffs without having to worry about exact figures.
--- DEPTH_USES_INT64 isn't implemented yet, this is just a note
--- for future consideration. (Should be in NFDataN if anywhere...).
--- I'm not ready to make this sweeping change yet.
--- #if DEPTH_USES_INT64
---    if length n_integer_str > 19  = fail $ "compilePat: *" ++ n_integer_str ++ " is too large"
#if ( ! ABBREV_WN_AND_TN_CONCRETE_SYNTAX_TO_NUMBER_ALONE__SAFE_ONLY_TO_DEPTH_19 ) && ( ! ABBREV_WN_AND_TN_CONCRETE_SYNTAX_TO_SINGLE_DIGIT__CAN_ONLY_EXPRESS_DOWN_TO_DEPTH_9 )
    AT.skipSpace
#endif
#if ABBREV_WN_AND_TN_CONCRETE_SYNTAX_TO_NUMBER_ALONE__SAFE_ONLY_TO_DEPTH_19
    n_integer_cs <- if b == '1'
                      then AT.anyChar *> AT.option "1" (AT.digit >>= \ c -> return ('1':[c]))
                      else AT.anyChar *> return [b]
    let n_integer = read n_integer_cs :: Integer
#elif ABBREV_WN_AND_TN_CONCRETE_SYNTAX_TO_SINGLE_DIGIT__CAN_ONLY_EXPRESS_DOWN_TO_DEPTH_9
    n_integer_c <- AT.anyChar :: AT.Parser Char
    n_integer <- case n_integer_c of
                     '0' -> mytrace ("ANDDD...(0):") $ fail ""
                     '1' -> mytrace ("ANDDD...(1):") $ fail ""
                     _   -> parsePat4 '*' Nothing as
    let n_integer = read [n_integer_c] :: Integer
#else
    n_integer <- AT.decimal :: AT.Parser Integer
#endif
    let n_integer_str = show n_integer
    if length n_integer_str > 9
      then fail $ "compilePat: *" ++ n_integer_str ++ " is too large"
      else parsePat4 '*' (Just (read n_integer_str :: Int)) as

-------------------------------------------------------------------------------

  -- This handles whether or not it's a type-constrainted node.
  -- (The constraints themselves will have already been parsed.)
  parsePat4 :: Char -> Maybe Int -> PatNodeAttrs -> AT.Parser Pattern
  parsePat4 b mdepth as = do
    !_ <- mytrace "parsePat4." $ return ()
    if doConstrainType as
      then parsePat4_t b mdepth as
      else parsePat4_w b mdepth as

  -- Actual handler, in case it was /NOT/ a type-constrained node;
  -- i.e. a WI, WR, WS (if still exists), WN or WW node.
  parsePat4_w :: Char -> Maybe Int -> PatNodeAttrs -> AT.Parser Pattern
  parsePat4_w b mdepth as = do
    !_ <- mytrace "parsePat4_w." $ return ()
    case b of
#if ABBREV_WN_AND_TN_CONCRETE_SYNTAX_TO_SINGLE_DIGIT__CAN_ONLY_EXPRESS_DOWN_TO_DEPTH_9
     '0' -> return (Node (WI as) [])
#else
     '.' -> return (Node (WI as) [])
#endif
#if ABBREV_WN_AND_TN_CONCRETE_SYNTAX_TO_SINGLE_DIGIT__CAN_ONLY_EXPRESS_DOWN_TO_DEPTH_9
     '1' -> return (Node (WS as) [])
#else
     '!' -> return (Node (WS as) [])
#endif
     '*' -> if isNothing mdepth
              then return (Node (WW as) [])
              else return (Node (WN as_n) [])
#if USE_CURLY_BRACE_INSTEAD_OF_PAREN_FOR_SUBPATTERNS
     '{' -> parsePat_WRTR_tail False b as
#else
     '(' -> parsePat_WRTR_tail False b as
#endif
#if USE_CURLY_BRACE_INSTEAD_OF_PAREN_FOR_SUBPATTERNS
     _ -> fail $ "compilePat: expected one of \".!*{\" (got " ++ show b ++ ")"
#else
     _ -> fail $ "compilePat: expected one of \".!*(\" (got " ++ show b ++ ")"
#endif
   where
    as_n = as { depth = fromJust mdepth }

  -- This is a helper of patsePat4_aux.
  parsePat4_t :: Char -> Maybe Int -> PatNodeAttrs -> AT.Parser Pattern
  parsePat4_t b mdepth as_t = do
    !_ <- mytrace "parsePat4_t." $ return ()
    case b of
#if USE_CURLY_BRACE_INSTEAD_OF_PAREN_FOR_SUBPATTERNS
     '{' -> do
#else
     '(' -> do
#endif
               parsePat_WRTR_tail True 'x' as_t
#if ABBREV_WN_AND_TN_CONCRETE_SYNTAX_TO_SINGLE_DIGIT__CAN_ONLY_EXPRESS_DOWN_TO_DEPTH_9
     '0' -> return (Node (TI as_t) [])
#else
     '.' -> return (Node (TI as_t) [])
#endif
     '*' -> if isNothing mdepth
              then return (Node (TW as_t) [])
              else return (Node (TN as_t_n) [])
#if ABBREV_WN_AND_TN_CONCRETE_SYNTAX_TO_SINGLE_DIGIT__CAN_ONLY_EXPRESS_DOWN_TO_DEPTH_9
     _ -> fail $ "compilePat: expected '*' or digit (got " ++ show b ++ ")"
#elif ABBREV_WN_AND_TN_CONCRETE_SYNTAX_TO_NUMBER_ALONE__SAFE_ONLY_TO_DEPTH_19
     _ -> fail $ "compilePat: expected '.' or '*' or digit (got " ++ show b ++ ")"
#else
     _ -> fail $ "compilePat: expected '.' or '*' (got " ++ show b ++ ")"
#endif
   where
    as_t_n = as_t { depth = fromJust mdepth }

-------------------------------------------------------------------------------

  parsePat_WRTR_tail :: Bool -> Char -> PatNodeAttrs -> AT.Parser Pattern
  parsePat_WRTR_tail isTR x as
   = do
        !_ <- mytrace "parsePat_WRTR_tail." $ return ()
--      AT.takeText >>= \ roi -> error $ "DEVEXIT: " ++ show roi
        pats <- parsePats <|> pure []
#if USE_CURLY_BRACE_INSTEAD_OF_PAREN_FOR_SUBPATTERNS
        AT.char '}'
#else
        AT.char ')'
#endif
        if isTR
          then return (Node (TR as) pats)
          else return (Node (WR as) pats)

-------------------------------------------------------------------------------

  parse_type_constraints :: AT.Parser [T.Text]
  parse_type_constraints = do
    !_ <- mytrace "parse_type_constraints." $ return ()
    let endchar = ':'
    let sepchar = ';'
    let loop = do
          seg <- AT.takeWhile (\c->c/=endchar&&c/='\\') :: AT.Parser T.Text
          if T.null seg
           then do
            return []
           else do
                 (do
                     AT.char '\\' *> AT.anyChar
                     >>= \ c -> ( ( seg `T.snoc` '\\' `T.snoc` c ) : ) <$> loop
                  )
             <|> (do
                     AT.char endchar
                     return [seg]
                  )
             <|> (fail "parse_type_constraints: unexpected end of input")
    segs <- loop
    let seg = T.concat segs
    let eblocks = AT.parseOnly
                    ( AT.sepBy1'
                          (AT.takeWhile (/=sepchar))
                          (AT.char sepchar)
                    )
                    seg
    let blocks = case eblocks of
         Left msg -> fail $ "parse_type_constraints: eblocks parse failure: " ++ msg
         Right blocks -> map T.strip blocks
    return blocks
  {-# INLINE parse_type_constraints #-}

-------------------------------------------------------------------------------

  -- Try attoparsec.

-- XXX If you toggle this, don't forget to also toggle
-- the one in Compile_shared_utils2.hs (compilePat_).
#if 1

  compileUsingAttoparsec :: T.Text -> AT.Result [Pattern]
  compileUsingAttoparsec input
   = AT.feed (AT.parse parsePatsTop input) T.empty

#else

  compileUsingAttoparsec :: T.Text -> Either String [Pattern]
  compileUsingAttoparsec input
   = AT.parseOnly parsePatsTop input

#endif

-------------------------------------------------------------------------------

#else

#if 1

  -- This was such a pleasure to write after the attoparsec
  -- learning curve above!!...  I wonder if the atto parser
  -- could ever be made to be as concise as this?

  compilePat' :: String -> Pattern
  compilePat' s
   | not $ null s'  = error $ "\ncompilePat: input rejected: "
                       ++ s
                       ++ if isNothing mmsg then "" else "\nParser message: "
                       ++ fromJust mmsg
                       ++ "\nPatterns parsed so far: ["
                       ++ intercalate ", " (map show pats)
                       ++ "]"
   | otherwise      = case pats of
       [] -> error $ "\ncompilePat: "
              ++ if null s then "empty input" else "vacuous input"
       [pat] -> setPatternPatNodeUniqueIDs 0 pat
       pats -> setPatternPatNodeUniqueIDs 0 $ liftPats pats
   where (pats, mmsg, s') = compilePats s []

  -- String in last component of result is unconsumed input.

  compilePats :: String -> [Pattern] -> ([Pattern], Maybe String, String)
  compilePats s acc
   | null s_ltrim  = (reverse acc, Nothing, s_ltrim)
   | otherwise     = case cpat s of
      (Left "", s') -> (reverse acc, Nothing, s')
--    (Left "", s') -> compilePats s' acc
      (Left msg, s') -> (reverse acc, Just msg, s')
      (Right pat, s') -> compilePats s' (pat:acc)
   where s_ltrim = dropWhile isSpace s

#if 0
  -- nice one from http://stackoverflow.com/a/6270337
  trim :: String -> String
  trim = let f = reverse . dropWhile isSpace in f . f
#endif

-- XXX Don't forget to do a post-pass to change W* nodes
-- to corresponding T* nodes, when : modifier was present!

  cpat :: String -> (Either String Pattern, String)
--cpat _ | trace "J-1: " $ False  = undefined
  cpat [] = (Left "unexpected end of input", [])
--cpat s | trace ("J-2: "++show s) $ False  = undefined
  cpat s
   | null s''   = error "\ncompilePat: type constraint must precede a pattern node"
   | isW        = case c of
      '.' -> (Right $ Node (WI as) [], cs)
      '!' -> (Right $ Node (WS as) [], cs)
      '*' -> case parseInt cs [] of
               (Nothing, cs'') -> (Right $ Node (WW   as    ) [], cs'')
               (Just is, cs'') -> (Right $ Node (WN $ asn is) [], cs'')
      '(' -> if isNothing mmsg_subpats
             then (Right $ Node (WR as) subpats, cs_subpats)
             else (Left $ fromJust mmsg_subpats, cs_subpats)
      ')' -> (Left "", cs)
      c -> error $ "\ncompilePat: unexpected character '" ++ [c] ++ "'"
   | otherwise  = case c of
      '.' -> (Right $ Node (TI as) [], cs)
--    '!' -> (Right $ Node (TS as) [], cs)
      '*' -> case parseInt cs [] of
               (Nothing, cs'') -> (Right $ Node (TW   as    ) [], cs'')
               (Just is, cs'') -> (Right $ Node (TN $ asn is) [], cs'')
      '(' -> if isNothing mmsg_subpats
             then (Right $ Node (TR as) subpats, cs_subpats)
             else (Left $ fromJust mmsg_subpats, cs_subpats)
      ')' -> (Left "", cs)
      c -> error $ "\ncompilePat: unexpected character '" ++ [c] ++ "'"
   where
    s' = dropWhile isSpace s
    (c:cs) = s''
    (as_mods, mmsg_mods, s'') = cmods s'  -- collect any prefix modifiers
    as = case mmsg_mods of
           Nothing -> as_mods
           Just msg -> error $ "\ncompilePat: " ++ msg
    asn is = as { depth = read is :: Int }
    isW = not $ doConstrainType as
    (subpats, mmsg_subpats, cs_subpats) = compilePats cs []

  -- Accumulate any prefix modifiers into an empty PatNodeAttrs structure.
  cmods :: String -> (PatNodeAttrs, Maybe String, String)
  cmods s = cmods' s emptyPatNodeAttrs
  cmods' :: String -> PatNodeAttrs -> (PatNodeAttrs, Maybe String, String)
  cmods' [] as = (as, Nothing, [])
--cmods' [] as = (as, Just "cmods': unexpected end of input", [])
  cmods' s as = case c of
    ':' -> cmods' cs_types  as_types
    '@' -> cmods' cs_delay  as_delay
#if USE_PAR_PATNODE
    '=' -> cmods' cs_par    as_par
#endif
#if USE_PSEQ_PATNODE
    '>' -> cmods' cs_pseq   as_pseq
#endif
#if USE_TRACE_PATNODE
    '+' -> cmods' cs_trace  as_trace
#endif
#if USE_PING_PATNODE
    '^' -> cmods' cs_ping   as_ping
#endif
#if USE_DIE_PATNODE
    '/' -> cmods' cs_die    as_die
#endif
#if USE_TIMING_PATNODE
    '%' -> cmods' cs_timing as_timing
#endif
    _ -> (as, Nothing, s)
   where
    s'@(c:cs) = dropWhile isSpace s
    ( cs_types  , as_types  ) = parse_type_constraints          cs as
    ( cs_delay  , as_delay  ) = parse_delay                     cs as
#if USE_PAR_PATNODE
    ( cs_par    , as_par    ) = ( cs, as { doSpark  = True } )
#endif
#if USE_PSEQ_PATNODE
    ( cs_pseq   , as_pseq   ) = parse_pseq                      cs as
#endif
#if USE_TRACE_PATNODE
    ( cs_trace  , as_trace  ) = ( cs, as { doTrace  = True } )
#endif
#if USE_PING_PATNODE
    ( cs_ping   , as_ping   ) = ( cs, as { doPing   = True } )
#endif
#if USE_DIE_PATNODE
    ( cs_die    , as_die    ) = ( cs, as { doDie    = True } )
#endif
#if USE_TIMING_PATNODE
    ( cs_timing , as_timing ) = ( cs, as { doTiming = True } )
#endif

  parse_type_constraints :: String -> PatNodeAttrs -> (String, PatNodeAttrs)
  parse_type_constraints s'' as
--- | doConstrainType as  = trace "\nwarning: type constraints (:...:) mod given multiple times to a single node, so aggregating type lists." $ (s', as')
   | otherwise           = (s', as')
   where
    s = dropWhile isSpace s''
    as' = as { doConstrainType = True
             , typeConstraints = typeConstraints as ++ tys }
    (tys, s') = f s "" []
    -- Take up to the next ';', ':', or '\\' and deal.
    f :: String -> String -> [String] -> ([String],String)
    f s'' tyacc tysacc
     | null s'    = error "\ncompilePat: type constraint list not ':'-terminated"
     | '\\' == c  = if null cs
                    then f cs (c:tyacc) tysacc
                    else if ':' == head cs    -- note ty is already reversed
                         then f (tail cs) ((':':'\\':ty) ++ tyacc) tysacc
                         else f cs (('\\':ty) ++ tyacc) tysacc
     | ':' == c   = ( reverse $ (reverse $ tyacc ++ ty) : tysacc , dropWhile isSpace cs )
    -- otherwise ';' == c
     | otherwise  = f cs "" $ (reverse $ tyacc ++ ty) : tysacc
     where
      s = dropWhile isSpace s''
      (c:cs) = s'
      (ty',s') = span (\c->c/=';'&&c/=':'&&c/='\\') s
      ty = dropWhile isSpace $ reverse ty'  -- yeah yeah

  parse_delay :: String -> PatNodeAttrs -> (String, PatNodeAttrs)
  parse_delay [] as = error "\nparse_delay: unexpected end of input"
  parse_delay s'' as
--- | doDelay as     = error "\ncompilePat: delay (@) modifier given multiple times to a single node"
--- | doDelay as  = trace "\nwarning: delay (@) mod given multiple times to a single node, so summing." $ (s', as')
   | isNothing mis  = error $ "\nparse_delay: expected a digit 1-9 (not '" ++ [head s] ++ "')"
   | otherwise      = (s', as')
   where
    s = dropWhile isSpace s''
    as' = as { doDelay = True  -- (convenient to set both here)
             , delayus = delayus as + i }
    (mis, s') = parseInt s []
    is = fromJust mis
    i = read is :: Int

#if USE_PSEQ_PATNODE
  parse_pseq :: String -> PatNodeAttrs -> (String, PatNodeAttrs)
  parse_pseq s'' as
   | doPseq as  = error "\ncompilePat: pseq (>) modifier given multiple times to a single node"
   | not ok     = error "\ncompilePat: pseq permutation must cover an initial segment of abc..yz"
-- No harm in allowing it; as for testing arity mismatch, that is not
-- in the parser's purview (at least at this time).  It is easily done
-- as a post-parsing check.
--- | null perm  = error "\ncompilePat: empty pseq permutation"
   | otherwise  = (s', as')
   where
    s = dropWhile isSpace s''
    as' = as { doPseq = True  -- (convenient to set both here)
             , pseqPerm = Just $ map (\c -> ord c - ord 'a') perm }
    (perm, s') = span isLower s
    ok = sort perm == take (length perm) ['a'..'z']
#endif

#else
  err = intercalate "\n"
   [ "\n"
   , "Sorry, at this time (version 0.6.0.*) there is no non-attoparsec parser"
   , "for the new pattern grammar.  This also implies that HASKELL98_FRAGMENT"
   , "has no pattern DSL facilities (except for showPat), and it is necessary"
   , "to work with the PatNode constructors directly.  The situation should"
   , "be remedied by version 0.6.1."
   ]
  compilePat' :: String -> Pattern
  compilePat' _ = error err
#endif

#endif

-------------------------------------------------------------------------------