deepseq-bounded-0.6.2.0: src/Control/DeepSeq/Bounded/Compile_shared_utils2.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_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
import Control.DeepSeq.Bounded.Compile_new_grammar ( compilePat' )
#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
compilePat_ :: String -> Pattern
compilePat_ str = compilePat' str
#else
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
-------------------------------------------------------------------------------