#define DO_TRACE 0
#define WARN_IGNORED_SUBPATTERNS 1
#define NEVER_IGNORE_SUBPATTERNS 0
#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
#if USE_ATTOPARSEC
#endif
#if DO_DERIVE_DATA_AND_TYPEABLE
#endif
#if DO_DERIVE_ONLY_TYPEABLE
#endif
#if NFDATA_INSTANCE_PATTERN
#endif
module Control.DeepSeq.Bounded.Compile_shared_utils2
(
compilePat ,
showPat ,
)
where
import Control.DeepSeq.Bounded.Pattern
import Control.DeepSeq.Bounded.PatUtil ( liftPats )
import Control.DeepSeq.Bounded.Compile_shared_utils ( parseInt )
#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
import Data.List ( intercalate )
import Data.Char ( isDigit )
import Data.Maybe ( isNothing, fromJust )
import Data.Maybe ( isJust )
import Debug.Trace ( trace )
#if USE_WW_DEEPSEQ
import Control.DeepSeq ( force )
#if NFDATA_INSTANCE_PATTERN
import qualified Control.DeepSeq.Generics as DSG
import qualified GHC.Generics as GHC ( Generic )
#endif
#endif
#if NEW_IMPROVED_PATTERN_GRAMMAR
#if USE_ATTOPARSEC
import qualified Data.Attoparsec.Text as AT ( IResult(..) )
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
compilePat :: String -> Pattern
#if NFDATA_INSTANCE_PATTERN
compilePat s = force $ compilePat_ s
#else
compilePat = compilePat_
#endif
#if NEW_IMPROVED_PATTERN_GRAMMAR
#if USE_ATTOPARSEC
compilePat_ :: String -> Pattern
compilePat_ str
| null plst = error "compilePat: 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
| otherwise = setPatternPatNodeUniqueIDs 0 $ head plst
where
#if 1
#if 1
#if 0
plst = ff (compileUsingAttoparsec $ 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 ""
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 ""
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
compilePat_ :: String -> Pattern
compilePat_ str = compilePat' str
#endif
#else
compilePat_ :: String -> Pattern
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
| 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_ []
s_ = translateStarN s
translateStarN [] = []
translateStarN ('@':cs) = error $ "compilePat: parse error: unexpected '@'"
translateStarN ('*':cs)
| isNothing mn = '*' : translateStarN cs'
| otherwise = '@' : ( fromJust mn ++ translateStarN cs' )
where
(mn, cs') = parseInt cs ""
translateStarN (c:cs) = c : translateStarN cs
#endif
#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
=
":" ++ treps_str
++ let as' = as { doConstrainType = False }
in showPat (Node (setPatNodeAttrs pas as') chs)
| WR{} <- pas = "" ++ descend chs ++ perhapsEmptySubpatterns
#if NEW_CONCRETE_WI_AND_WS
#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
#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 VACANT_HASH
| WI{} <- pas = " " ++ descend chs
#else
#if NEW_CONCRETE_WI_AND_WS
#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
#else
| WI{} <- pas = "#" ++ descend chs
#endif
#endif
#if USE_WW_DEEPSEQ
| WW{} <- pas = "*" ++ descend chs
#endif
#if 1
| TR{} <- pas = "" ++ descend chs ++ perhapsEmptySubpatterns
#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 VACANT_HASH
| TI{} <- pas = " " ++ descend chs
#else
#if NEW_CONCRETE_WI_AND_WS
#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
#else
| TI{} <- pas = "#" ++ descend chs
#endif
#endif
#if USE_WW_DEEPSEQ
| TW{} <- pas = "*" ++ descend chs
#endif
#else
| TR{} <- pas = ":" ++ treps_str ++ descend chs ++ perhapsEmptySubpatterns
#if VACANT_HASH
| TI{} <- pas = " ::" ++ treps_str ++ closeTINW
#else
#if NEW_CONCRETE_WI_AND_WS
#if ABBREV_WN_AND_TN_CONCRETE_SYNTAX_TO_SINGLE_DIGIT__CAN_ONLY_EXPRESS_DOWN_TO_DEPTH_9
| TI{} <- pas = "0::" ++ treps_str ++ closeTINW
#else
| TI{} <- pas = ".::" ++ treps_str ++ closeTINW
#endif
#else
| TI{} <- pas = "#::" ++ treps_str ++ closeTINW
#endif
#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 ++ "::" ++ treps_str ++ closeTINW
#else
| TN{} <- pas = "*" ++ show n ++ "::" ++ treps_str ++ closeTINW
#endif
#if USE_WW_DEEPSEQ
| TW{} <- pas = "*::" ++ treps_str ++ closeTINW
#endif
#endif
where
#if USE_CURLY_BRACE_INSTEAD_OF_PAREN_FOR_SUBPATTERNS
emptySubpatterns = "{}"
#else
emptySubpatterns = "()"
#endif
#if NEW_SEMICOLON_TYPE_LIST
closeTINW = ""
#else
closeTINW = emptySubpatterns
#endif
perhapsEmptySubpatterns = if null chs then emptySubpatterns else ""
as = getPatNodeAttrs pas
n = depth as
treps = typeConstraints as
#if TYPE_CONSTRAINTED_NODES_USE_UNESCAPED_SPACE_AS_TYPE_LIST_SEPARATOR
treps_str = intercalate " " treps
#else
#if NEW_SEMICOLON_TYPE_LIST
treps_str = intercalate ";" treps ++ ":"
#else
treps_str = intercalate ":" treps
#endif
#endif
#else
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
| 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