deepseq-bounded-0.6.0.0: src/Control/DeepSeq/Bounded/Compile_old_grammar.hs
-------------------------------------------------------------------------------
{- 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
-------------------------------------------------------------------------------