deepseq-bounded-0.6.0.2: 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 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
-------------------------------------------------------------------------------