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

  {-  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

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

-- |
-- 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 :  portable (H98)
--

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

  module Control.DeepSeq.Bounded.Compile_new_grammar
  (

      compilePat'  ,

  )
  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 )

  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 )

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

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

  -- XXX This is still lacks support for the two condensed grammars:
  -- 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

  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

-- XXX Don't forget to do a post-pass to change W* nodes
-- to corresponding T* nodes, when : modifier was present!
-- Oops, guess I did it here; but the original idea would
-- be less cloning...

  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

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