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

  {-  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 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_old_grammar
-- Copyright   :  Andrew G. Seniuk 2014-2015
-- License     :  BSD-style (see the file LICENSE)
--
-- Maintainer  :  Andrew Seniuk <rasfar@gmail.com>
-- Stability   :  experimental, deprecated
-- Portability :  portable
--

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

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

      compilePat'

  )
  where

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

  import Control.DeepSeq.Bounded.Pattern
  import Control.DeepSeq.Bounded.Compile_shared_utils

  import Data.Maybe ( isNothing, fromJust )
  import Data.Maybe ( isJust )

  import Debug.Trace ( trace )

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

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

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

  -- compilePat' parameters:
  --  spark    - the next node parsed will, when matched, spark parallel
  --             evaluation of its subpatterns
  --  mpn      - says what the last PatNode parsed was (list args are empty)
  --           - what do I mean "list args are empty"?
  --              - oh: T* nodes have a list arg
  --           - I see that mpn is never used (except in some dead code)...
  --  mn       - says what n is for rnfn (eg. 3 for "*3")
  --           - note that, when Just, this signals to parser that * is for
  --             a WN/TN node rather than a WW/TW node
  --  (t:ts)   - the list of type constraints (currently, constructor names)
  --           - list must be empty iff node is a T* node
  --  mptc     - Just pre-constraint character (Nothing is not possible)
  --  (c:cs)   - is what's left of the input string we're parsing
  --  acc      - is an accumulator parameter, collecting patterns parsed
  compilePat' :: Bool -> Maybe PatNode -> Maybe Int -> [String] -> Maybe Char -> String -> [Pattern] -> ([Pattern], String)
  -- This first binding in the compilePat' group is only for
  -- some error trapping (only matches in case of parse errors).
  compilePat' spark mpn mn (t:ts) (Just c) cs _
-- XXX Now we need to allow there to be /no/ pre-treps char...
#if 1
   | not $ c `elem` ".*#"  = error $ "compilePat: parse error: pre-treps pattern char " ++ show c ++ " not one of .*#"
#else
   -- ?? it /seems/ okay without the '{'; not sure why it was included...
--- | not $ c `elem` "{"  = error $ "compilePat: parse error: pre-treps pattern char " ++ show c ++ " not '{'"
   | not $ c `elem` "{.*#"  = error $ "compilePat: parse error: pre-treps pattern char " ++ show c ++ " not one of {.*#"
#endif
  compilePat' spark mpn mn _  mptc [] acc = mytrace "EMPTY" $ (acc, [])
--compilePat' spark mpn mn [] mptc [] acc = mytrace "EMPTY" $ (acc, [])
  compilePat' spark mpn mn [] mptc (' ':cs) acc = mytrace "space" $ compilePat' spark mpn mn [] mptc cs acc
  compilePat' spark mpn mn [] mptc ('}':'{':cs) acc = error $ "compilePat: opening brace cannot follow closing brace"
  compilePat' spark mpn mn [] mptc ('}':cs) acc
#if 0
        -- Lenient parser tolerates subpatterns of these.
        -- (The semantics is that any such subpatterns are ignored --
        -- discarded with a warning.)
#if USE_WW_DEEPSEQ
   | isJust mpn, Just WW <- mpn  = trace "compilePat-\"}\": warning: * with subpattern" $ mytrace "}" $ (acc, cs)
#endif
   | isJust mpn, Just WI <- mpn  = trace "compilePat-\"}\": warning: # with subpattern" $ mytrace "}" $ (acc, cs)
#endif
   | otherwise  = mytrace "}" $ (acc, cs)
  compilePat' spark mpn mn [] mptc (c:':':cs) acc
   | null treps  = error $ "compilePat: colon must be followed by at least one type name"
   | otherwise   = compilePat' spark mpn mn treps (Just c) cs' acc
   where
--  !_ = trace ("Boo: " ++ show (treps, cs')) ()
    (treps, cs') = compileTypeReps cs
  compilePat' spark mpn Nothing [] mptc ('@':cs) acc
   | isNothing mn  = error $ "compilePat: internal error @2 (please report this bug!)"
   | otherwise     = compilePat' spark mpn mn [] mptc ('@':cs') acc  -- mn is Just n
   where
--  !_ = trace ("Boo: " ++ show (mn, cs')) ()
    (mn_, cs') = parseInt cs ""
    mn | isNothing mn_  = Nothing
       | otherwise      = Just ( read (fromJust mn_) :: Int )
  compilePat' spark mpn (Just n) [] mptc ('@':cs) acc
   = compilePat' False mpn Nothing [] mptc cs (acc++[node])
#if PARALLELISM_EXPERIMENT
    where node | spark      = Node (PN n) []
               | otherwise  = Node (WN n) []
#else
    where node = Node (WN n) []
#endif
  compilePat' spark mpn (Just n) [] mptc (c:cs) acc
   = error $ "compilePat: internal error @1(" ++ [c] ++ ") (please report this bug!)"
  compilePat' spark mpn mn [] mptc (c:'{':cs) acc = compilePat' spark mpn mn [] mptc cs' (acc++[node])
   where
    (chs, cs') = mytrace (".{-cs="++cs) $ compilePat' spark mpn mn [] mptc cs []
    node = case c of
        '.' -> mytrace (".{-recurs: "++show chs) $ Node WR chs
        -- Lenient parser tolerates subpatterns of these.
        -- (The semantics is that any such subpatterns are ignored --
        -- discarded with a warning.)
-- It's more convenient to keep the subpatterns, if want to issue
-- a warning when they don't match for type-constrained patterns.
-- True the semantics is the same except for the warning message,
-- but, well, I want to see it at the moment!
#if NEVER_IGNORE_SUBPATTERNS
#if ! WARN_IGNORED_SUBPATTERNS
#if USE_WW_DEEPSEQ
        '*' -> Node WW chs
#endif
        '#' -> Node WI chs
#else
#if USE_WW_DEEPSEQ
        '*' -> trace "compilePat-\"{\": warning: * with subpattern" $ Node WW chs
#endif
        '#' -> trace "compilePat-\"{\": warning: # with subpattern" $ Node WI chs
#endif
#else
#if ! WARN_IGNORED_SUBPATTERNS
#if USE_WW_DEEPSEQ
        '*' -> Node WW []
#endif
        '#' -> Node WI []
#else
#if USE_WW_DEEPSEQ
        '*' -> trace "compilePat-\"{\": warning: * with subpattern" $ Node WW []
#endif
        -- Yes, we do see the error for each test we expect a warning from!
--      '#' -> error "compilePat-\"{\": warning: # with subpattern"
--      '#' -> force $! trace "compilePat-\"{\": warning: # with subpattern" $! Node WI []
        '#' -> trace "compilePat-\"{\": warning: # with subpattern" $ Node WI []
#endif
#endif
        _ -> error $ "compilePat-\"{\": unexpected " ++ show c ++ " (cs'=" ++ cs'
  compilePat' spark mpn mn treps mptc ('{':cs) acc = compilePat' spark mpn mn [] mptc cs' (acc++[node])
   where
    (chs, cs') = mytrace ("T-{-cs="++cs) $ compilePat' spark mpn mn [] mptc cs []
    node
     | isJust mptc  = let c = fromJust mptc in case c of
        '.' -> mytrace ("T-{-recurs: "++show chs) $ Node (TR treps) chs
#if NEVER_IGNORE_SUBPATTERNS
#if ! WARN_IGNORED_SUBPATTERNS
#if USE_WW_DEEPSEQ
        '*' -> Node (TW treps) chs
#endif
        '#' -> Node (TI treps) chs
#else
#if USE_WW_DEEPSEQ
        '*' -> trace "compilePat-T-\"{\": warning: * with subpattern" $ Node (TW treps) chs
#endif
        '#' -> trace "compilePat-T-\"{\": warning: # with subpattern" $ Node (TI treps) chs
#endif
#else
#if ! WARN_IGNORED_SUBPATTERNS
#if USE_WW_DEEPSEQ
        '*' -> Node (TW treps) []
#endif
        '#' -> Node (TI treps) []
#else
#if USE_WW_DEEPSEQ
        '*' -> trace "compilePat-T-\"{\": warning: * with subpattern" $ Node (TW treps) []
#endif
        '#' -> trace "compilePat-T-\"{\": warning: # with subpattern" $ Node (TI treps) []
#endif
#endif
        _ -> error $ "compilePat-T-\"{\": unexpected " ++ show c ++ " (cs'=" ++ cs'
     | otherwise = error $ "T-{-recurs-OLDGRAM: "++show chs
#if PARALLELISM_EXPERIMENT
  compilePat' spark mpn mn treps mptc ('=':cs) acc = compilePat' True mpn mn treps mptc cs acc
#endif
  compilePat' spark mpn mn treps mptc (c:cs) acc = compilePat' False mpn mn [] mptc cs (acc++[node])
--compilePat' spark mpn mn treps mptc (c:cs) acc = compilePat' False mpn mn [] mptc cs $ force (acc++[node])
   where
    node
#if PARALLELISM_EXPERIMENT
     | spark = case c of
        '.' -> mytrace ".:cs" $ Node PR []
#if USE_WW_DEEPSEQ
        '*' -> mytrace "*:cs" $ Node PW []
#endif
        _ -> error $ "compilePat-\"c:cs\"-spark: unexpected " ++ show c ++ " (cs=" ++ cs
#endif
     | null treps = case c of
        '.' -> mytrace ".:cs" $ Node WS []  -- sic!
#if USE_WW_DEEPSEQ
        '*' -> mytrace "*:cs" $ Node WW []
#endif
        '#' -> mytrace "#:cs" $ Node WI []
        _ -> error $ "compilePat-\"c:cs\": unexpected " ++ show c ++ " (cs=" ++ cs
     | otherwise = case c of
        '.' -> mytrace ".:cs" $ Node (TR treps) []
--      '.' -> mytrace ".:cs" $ Node (TS treps) []
#if USE_WW_DEEPSEQ
        '*' -> mytrace "*:cs" $ Node (TW treps) []
#endif
        '#' -> mytrace "#:cs" $ Node (TI treps) []
        _ -> error $ "compilePat-T-\"c:cs\": unexpected " ++ show c ++ " (cs=" ++ cs

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