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

  {-  LANGUAGE CPP #-}

#define DO_TRACE 0

#define WARN_IGNORED_SUBPATTERNS 1
#define NEVER_IGNORE_SUBPATTERNS 0

-- Formerly DEBUG_WITH_DEEPSEQ_GENERICS.
-- Now also needed to force issuance of all compilePat warnings
-- (so not strictly a debugging flag anymore).
-- [Except it didn't work...]
--- #define NFDATA_INSTANCE_PATTERN 0  -- now a .cabal flag

#define DO_DERIVE_DATA_AND_TYPEABLE 0
#define DO_DERIVE_ONLY_TYPEABLE 1
#if DO_DERIVE_ONLY_TYPEABLE && DO_DERIVE_DATA_AND_TYPEABLE
#undef DO_DERIVE_ONLY_TYPEABLE
#warning DO_DERIVE_ONLY_TYPEABLE forced 0, due to DO_DERIVE_DATA_AND_TYPEABLE being 1.
#define DO_DERIVE_ONLY_TYPEABLE 0
#endif

-- Now specified via --flag=[-]USE_WWW_DEEPSEQ
--- #define USE_WW_DEEPSEQ 1

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

#if USE_ATTOPARSEC
  {-# LANGUAGE OverloadedStrings #-}
#endif

#if DO_DERIVE_DATA_AND_TYPEABLE
  {-# LANGUAGE DeriveDataTypeable #-}
#endif
-- XXX Only needed for something in Blah.hs.
-- Check into it, and see if can't get rid of the need
-- for Typeable instances in here!
#if DO_DERIVE_ONLY_TYPEABLE
  {-# LANGUAGE DeriveDataTypeable #-}
#endif
#if NFDATA_INSTANCE_PATTERN
  -- For testing only (controlling trace interleaving):
  {-# LANGUAGE DeriveGeneric #-}
#endif
  {-  LANGUAGE DeriveFunctor #-}

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

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

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

  module Control.DeepSeq.Bounded.Compile_shared_utils2
--- {-# DEPRECATED "Use Wobble instead" #-}
  (

    compilePat  ,
    showPat  ,

  )
  where

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

  import Control.DeepSeq.Bounded.Pattern
  import Control.DeepSeq.Bounded.PatUtil ( liftPats )
  import Control.DeepSeq.Bounded.Compile_shared_utils ( parseInt )

#if 0

#if DO_DERIVE_DATA_AND_TYPEABLE
  import Data.Data ( Data )
  import Data.Typeable ( Typeable )
#elif DO_DERIVE_ONLY_TYPEABLE
  import Data.Typeable ( Typeable )
#endif

#if USE_WW_DEEPSEQ
  import Control.DeepSeq ( NFData )
#endif

#endif
  import Data.List ( intercalate )
#if 0
  import Data.Char ( isDigit )
  import Data.Maybe ( isNothing, fromJust )
  import Data.Maybe ( isJust )

#endif
  import Debug.Trace ( trace )
  -- The only uses of force in this module are for debugging purposes
  -- (including trying to get messages to be displayed in a timely
  -- manner, although that problem has not been completely solved).
  import Control.DeepSeq ( force )
#if 0
#if NFDATA_INSTANCE_PATTERN
  -- for helping trace debugging
  import qualified Control.DeepSeq.Generics as DSG
  import qualified GHC.Generics as GHC ( Generic )
#endif
#endif

-- Temporary until commit to new grammar exclusively (or decide to
-- really continue supporting both)...
#if NEW_IMPROVED_PATTERN_GRAMMAR
#if USE_ATTOPARSEC
  import qualified Data.Attoparsec.Text as AT ( IResult(..) )
--import qualified Data.Attoparsec.ByteString as AB ( IResult(..) )
--import Data.Attoparsec.ByteString.Lazy
  import qualified Data.Text as T
  import qualified Data.ByteString.Lazy as BL
  import Control.DeepSeq.Bounded.Compile_new_grammar ( compileUsingAttoparsec )
#else
  import Control.DeepSeq.Bounded.Compile_new_grammar ( compilePat' )
#endif
#else
  import Control.DeepSeq.Bounded.Compile_old_grammar ( compilePat' )
#endif

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

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

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

  -- XXX Doing this to ensure issuance of all warning messages
  -- pertaining to the pattern to be compiled!
  -- Which isn't quite working?!?.... [Never did resolve this.]
  compilePat :: String -> Pattern
#if NFDATA_INSTANCE_PATTERN
  compilePat s = force $ compilePat_ s
--compilePat s = let pat = force $! compilePat_ s in trace (show pat) $! pat
--compilePat s = let pat = force $ compilePat_ s in trace (show pat) $! pat
--compilePat s = let !pat = force $ compilePat_ s in trace (show pat) $ pat
--compilePat s = let pat = force $ compilePat_ s in trace (show pat) $ pat
#else
  compilePat = compilePat_
#endif

#if NEW_IMPROVED_PATTERN_GRAMMAR

#if USE_ATTOPARSEC

  compilePat_ :: String -> Pattern
  compilePat_ str
   | null plst        = error "compilePat: syntax error"
--- | null plst         = error "compilePat: empty pattern (syntax error)"
#if 1
   | length plst > 1  = setPatternPatNodeUniqueIDs 0 $ liftPats plst
#else
   | length plst > 1  = error $ "compilePat: disconnected pattern (not rooted)"
#if USE_CURLY_BRACE_INSTEAD_OF_PAREN_FOR_SUBPATTERNS
                                ++ "\nPerhaps you used parentheses instead of braces?"
#else
                                ++ ""
#endif
#endif
--- | not $ null s'     = error $ "compilePat: parse error: not all input consumed\nRemaining: " ++ s'
   | otherwise         = setPatternPatNodeUniqueIDs 0 $ head plst
--- | otherwise         = head plst
   where

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

#if 1
#if 0
    plst = ff (compileUsingAttoparsec $ str)
--  plst = ff (compileUsingAttoparsec $ BL.pack str)
    ff :: AT.IResult BL.ByteString [Pattern] -> [Pattern]
#else
    plst = ff (compileUsingAttoparsec $ T.pack str)
    ff :: AT.IResult T.Text [Pattern] -> [Pattern]
#endif
    ff rslt = plst
     where
      plst = case rslt of
              AT.Fail leftovers ctxs msg
               -> error $ "compilePat: " ++ msg ++ "\nInput remaining: " ++ T.unpack leftovers
              AT.Partial f_leftovers
               -> ff $ f_leftovers ""
---            -> error $ "compilePat: parser demands more input"
---            -> error_leftovers leftovers r
              AT.Done leftovers r
               -> if T.null leftovers then r
                  else error_leftovers leftovers r
#else
    rslt = compileUsingAttoparsec str
    plst = case rslt of
            Fail leftovers ctxs msg
             -> error $ "compilePat: " ++ msg ++ "\nInput remaining: " ++ T.unpack leftovers
            Partial f_leftovers
             -> f_leftovers ""
---          -> error $ "compilePat: parser demands more input"
---          -> error_leftovers leftovers r
            Done leftovers r
             -> if T.null leftovers then r
                else error_leftovers leftovers r
#endif
    error_leftovers s r = error $ "compilePat: input not completely consumed\nInput remaining: " ++ T.unpack s ++ "\nPatterns so far parsed: " ++ show r

#else

    esp = compileUsingAttoparsec $ T.pack str
    plst = case esp of
            Left s -> error $ "compilePat: parse error: " ++ s
            Right plst -> plst

#endif

#else
-- else ! USE_ATTOPARSEC

  compilePat_ :: String -> Pattern
  compilePat_ str = compilePat' str

#endif

#else
-- else ! NEW_IMPROVED_PATTERN_GRAMMAR

  compilePat_ :: String -> Pattern
--compilePat_ :: String -> (Pattern, String)
--compilePat_ s = Node WW []
  compilePat_ s
   | null plst         = error "compilePat: empty pattern (syntax error)"
   | length plst > 1   = error "compilePat: disconnected pattern (not rooted)\nPerhaps you used parentheses instead of braces?"
   | not $ null s'     = error $ "compilePat: parse error: not all input consumed\nRemaining: " ++ s'
#if 1
   | otherwise   = head plst
   where
#else
-- When find the time, should add a CPP switch to enable emitting
-- a warning message in these cases; but it's too common/useful to
-- brutally disallow like this!...
   | WI <- p      = error "compilePat: top pattern node cannot be #"
   | TR _ <- p    = error "compilePat: top pattern node cannot be .:<qual>"
   | TN _ _ <- p  = error "compilePat: top pattern node cannot be *:<qual>"
   | TW _ <- p    = error "compilePat: top pattern node cannot be *:<qual>"
   | TI _ <- p    = error "compilePat: top pattern node cannot be #:<qual>"
   | otherwise    = hplst
   where
    hplst@(Node p _) = head plst
#endif
    (plst, s') = compilePat' False Nothing Nothing [] Nothing s_ []  -- XXX ??
    s_ = translateStarN s

  translateStarN [] = []
  translateStarN ('@':cs) = error $ "compilePat: parse error: unexpected '@'"
  translateStarN ('*':cs)
   | isNothing mn  = '*' : translateStarN cs'  -- or cs
   | otherwise     = '@' : ( fromJust mn ++ translateStarN cs' )
   where
--  !_ = trace ("Boo: " ++ show (mn, cs')) ()
    (mn, cs') = parseInt cs ""
  translateStarN (c:cs) = c : translateStarN cs

#endif

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

  -- | Inverse of 'compilePat'.
  --
  -- @showPat . compilePat patstring  =  patstring@
  --
  -- (up to optional whitespace, and canonical ordering of any attributes),
  -- provided that @compilePat patstring@ succeeds.
  -- /(And, only up to subpatterns elided from # ('WI' or 'TI') or from * ('WW', 'WN', 'TW', or 'TN') nodes, in case these are still accepted by the parser!)/

#if NEW_IMPROVED_PATTERN_GRAMMAR

  showPat :: Pattern -> String
  showPat (Node pas chs)

    | doDelay  as  = "@" ++ show (delayus as)
                         ++ let as' = as { doDelay = False }
                            in showPat (Node (setPatNodeAttrs pas as') chs)
#if USE_PAR_PATNODE
    | doSpark  as  = "=" ++ let as' = as { doSpark = False }
                            in showPat (Node (setPatNodeAttrs pas as') chs)
#endif
#if USE_PSEQ_PATNODE
    | doPseq   as  = ">" ++ showPerm (pseqPerm as)
                         ++ let as' = as { doPseq  = False }
                            in showPat (Node (setPatNodeAttrs pas as') chs)
#endif
#if USE_TRACE_PATNODE
    | doTrace  as  = "+" ++ let as' = as { doTrace = False }
                            in showPat (Node (setPatNodeAttrs pas as') chs)
#endif
#if USE_PING_PATNODE
    | doPing   as  = "^" ++ let as' = as { doPing  = False }
                            in showPat (Node (setPatNodeAttrs pas as') chs)
#endif
#if USE_DIE_PATNODE
    | doDie    as  = "/" ++ let as' = as { doDie   = False }
                            in showPat (Node (setPatNodeAttrs pas as') chs)
#endif
#if USE_TIMING_PATNODE
    | doTiming as  = "%" ++ let as' = as { doTiming   = False }
                            in showPat (Node (setPatNodeAttrs pas as') chs)
#endif
    | doConstrainType as
       =
--       trace "showPat-doConstraintType HERE!" $
         ":" ++ treps_str
             ++ let as' = as { doConstrainType = False }
                in showPat (Node (setPatNodeAttrs pas as') chs)

#if ABBREV_WN_AND_TN_CONCRETE_SYNTAX_TO_SINGLE_DIGIT__CAN_ONLY_EXPRESS_DOWN_TO_DEPTH_9
    | WI{} <- pas  = "0"   ++ descend chs
#else
    | WI{} <- pas  = "."   ++ descend chs
#endif
    | WR{} <- pas  = ""    ++ descend chs ++ perhapsEmptySubpatterns
#if ABBREV_WN_AND_TN_CONCRETE_SYNTAX_TO_SINGLE_DIGIT__CAN_ONLY_EXPRESS_DOWN_TO_DEPTH_9
    | WS{} <- pas  = "1"   ++ descend chs
#else
    | WS{} <- pas  = "!"   ++ descend chs
#endif
#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
    | WN{} <- pas  =          show n ++ descend chs
#else
    | WN{} <- pas  = "*"   ++ show n ++ descend chs
#endif
#if USE_WW_DEEPSEQ
    | WW{} <- pas  = "*"   ++ descend chs
#endif

#if ABBREV_WN_AND_TN_CONCRETE_SYNTAX_TO_SINGLE_DIGIT__CAN_ONLY_EXPRESS_DOWN_TO_DEPTH_9
    | TI{} <- pas  = "0"   ++ descend chs
#else
    | TI{} <- pas  = "."   ++ descend chs
#endif
    | TR{} <- pas  = ""    ++ descend chs ++ perhapsEmptySubpatterns
--- #if ABBREV_WN_AND_TN_CONCRETE_SYNTAX_TO_SINGLE_DIGIT__CAN_ONLY_EXPRESS_DOWN_TO_DEPTH_9
---     | TS{} <- pas  = "1"   ++ descend chs
--- #else
---     | TS{} <- pas  = "!"   ++ descend chs
--- #endif
#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
    | TN{} <- pas  =          show n ++ descend chs
#else
    | TN{} <- pas  = "*"   ++ show n ++ descend chs
#endif
#if USE_WW_DEEPSEQ
    | TW{} <- pas  = "*"   ++ descend chs
#endif

   where
#if USE_CURLY_BRACE_INSTEAD_OF_PAREN_FOR_SUBPATTERNS
    emptySubpatterns = "{}"
#else
    emptySubpatterns = "()"
#endif
    perhapsEmptySubpatterns = if null chs then emptySubpatterns else ""
    as = getPatNodeAttrs pas
    n = depth as
    treps = typeConstraints as
    treps_str = intercalate ";" treps ++ ":"

#else

-- XXX This looks to be wrong in several ways, but I'm going
-- to leave it alone (it's as per 0.5.5), and focus on the
-- new grammar case above.

  showPat :: Pattern -> String
  showPat (Node p chs)

    | WR         <- p  = "."  ++ descend chs ++ perhapsEmptySubpatterns
    | WS         <- p  = "."  ++ descend chs
    | WN n       <- p  = "*"  ++ show n
    | WI         <- p  = "#"  ++ descend chs
#if USE_WW_DEEPSEQ
    | WW         <- p  = "*"  ++ descend chs
#endif

#if PARALLELISM_EXPERIMENT
    | PR         <- p  = "=." ++ descend chs ++ perhapsEmptySubpatterns
    | PN n       <- p  = "=*" ++ show n ++ ":" ++ descend chs
#if USE_WW_DEEPSEQ
    | PW         <- p  = "=*"  ++ descend chs
#endif
#endif

    | TR treps   <- p  = ".:" ++ descendT treps chs ++ perhapsEmptySubpatterns
    | TI treps   <- p  = "#:" ++ descendT treps chs
--- | TS treps   <- p  = ".:" ++ descendT treps chs
    | TN n treps <- p  = "*"  ++ show n ++ ":" ++ descendT treps chs
#if USE_WW_DEEPSEQ
    | TW treps   <- p  = "*:" ++ descendT treps chs
#endif
   where
#if USE_CURLY_BRACE_INSTEAD_OF_PAREN_FOR_SUBPATTERNS
    emptySubpatterns = "{}"
#else
    emptySubpatterns = "()"
#endif
    perhapsEmptySubpatterns = if null chs then emptySubpatterns else ""

  descendT :: [String] -> [Pattern] -> String
  descendT treps chs = treps_ ++ descend chs
   where treps_ = intercalate " " treps

#endif

  descend :: [Pattern] -> String
  descend chs
   | null chs = ""
#if USE_CURLY_BRACE_INSTEAD_OF_PAREN_FOR_SUBPATTERNS
   | otherwise = "{" ++ concatMap showPat chs ++ "}"
#else
   | otherwise = "(" ++ concatMap showPat chs ++ ")"
#endif

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