#define DO_TRACE 0
#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
#error Please set at most one of the flags ABBREV_WN_AND_TN_CONCRETE_SYNTAX_TO_NUMBER_ALONE__SAFE_ONLY_TO_DEPTH_19 and ABBREV_WN_AND_TN_CONCRETE_SYNTAX_TO_SINGLE_DIGIT__CAN_ONLY_EXPRESS_DOWN_TO_DEPTH_9 to True.
#endif
#define ALLOW_ESCAPED_TYPE_LIST_SEPARATOR 1
#define SAVE_ME_HERE 1
#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_new_grammar
#if 1
(
#if USE_ATTOPARSEC
#if HASKELL98_FRAGMENT
#error Sorry, HASKELL98_FRAGMENT incompatible with NEW_IMPROVED_PATTERN_GRAMMAR, because only USE_ATTOPARSEC parser is working. With some artful CPP you could cut out the Pattern parser/compiler, and then resort to the bare PatNode constructors...
#endif
compileUsingAttoparsec ,
#else
compilePat' ,
#endif
)
#endif
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 USE_ATTOPARSEC
#if 0
#if 1
import Data.Attoparsec.Text
import qualified Data.Text as T
#else
import Data.Attoparsec.Char8
import qualified Data.ByteString.Char8 as B
#endif
import Control.Applicative ( (<*), (<|>) )
#endif
import Control.Applicative
#if 0
import Data.ByteString.Builder
(Builder, byteString, toLazyByteString, charUtf8, word8)
#endif
import Control.Applicative ((*>), (<$>), (<*), liftA2, pure)
import Control.Applicative ( (<|>) )
#if 0
import Data.Attoparsec.ByteString.Char8 (Parser, char, endOfInput, scientific,
skipSpace, string)
import Data.Bits ((.|.), shiftL)
import Data.ByteString (ByteString)
import Data.Char (chr)
import Data.Monoid (mappend, mempty)
import Data.Text (Text)
import Data.Text.Encoding (decodeUtf8')
#endif
import qualified Data.Text as T
#if 0
import Data.Word (Word8)
#endif
#if 0
import qualified Data.Attoparsec.ByteString as A
import qualified Data.Attoparsec.Lazy as AL
import qualified Data.Attoparsec.Zepto as Z
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL
import qualified Data.ByteString.Unsafe as B
#endif
import qualified Data.Attoparsec.Text as AT
import Data.Char ( isLetter )
import Data.Char ( isDigit )
import Control.Monad ( liftM )
import Data.Monoid ( mempty )
import Data.Char ( ord )
import Control.Monad ( mzero )
#endif
#if DO_TRACE
mytrace = trace
#else
mytrace _ = id
#endif
#if USE_ATTOPARSEC
parsePatsTop :: AT.Parser [Pattern]
parsePatsTop = do
!_ <- mytrace ("parsePatsTop.") $ return ()
let as = emptyPatNodeAttrs
AT.many' (AT.skipSpace *> parsePat as <* AT.skipSpace)
parsePats :: AT.Parser [Pattern]
#if 1
parsePats = do
!_ <- mytrace "parsePats." $ return ()
(AT.endOfInput *> pure [])
<|> (do
c <- AT.peekChar'
#if USE_CURLY_BRACE_INSTEAD_OF_PAREN_FOR_SUBPATTERNS
if c == '}'
#else
if c == ')'
#endif
then pure []
else let as = emptyPatNodeAttrs in
AT.many' (AT.skipSpace *> parsePat as <* AT.skipSpace))
#else
parsePats = AT.manyTill'
(AT.skipSpace *> parsePat emptyPatNodeAttrs)
(AT.endOfInput <|> (AT.char ')' *> return ()))
#endif
parsePat :: PatNodeAttrs -> AT.Parser Pattern
parsePat as = do
!_ <- mytrace "parsePat." $ return ()
#if 1
foldr (<|>) mempty $
( map
(\ (c,s,p,b,a) -> do
let q = (c,s,b,a)
#if SAVE_ME_HERE
if c == '\0'
then fail ""
else do
#endif
#if 0
mempty
<|> (parsePat1''' as)
<|> (parsePat1' as)
#if USE_PSEQ_PATNODE
<|> (parsePat1'' as)
#endif
<|> ( AT.char c <* AT.skipSpace )
#endif
( p c b a s <* AT.skipSpace )
)
#if SAVE_ME_HERE
[
( '\0' , "" , dud_parser , const False , as )
, ( ':' , "types" , types_parser , doConstrainType , as_types )
, ( '@' , "delay" , delay_parser , doDelay , as_delay )
#if USE_PAR_PATNODE
, ( '=' , "spark" , no_arg_parser , doSpark , as_spark )
#endif
#if USE_PSEQ_PATNODE
, ( '>' , "pseq" , pseq_parser , doPseq , as_pseq )
#endif
#if USE_TRACE_PATNODE
, ( '+' , "trace" , no_arg_parser , doTrace , as_trace )
#endif
#if USE_PING_PATNODE
, ( '^' , "ping" , no_arg_parser , doPing , as_ping )
#endif
#if USE_DIE_PATNODE
, ( '/' , "die" , no_arg_parser , doDie , as_die )
#endif
#if USE_TIMING_PATNODE
, ( '%' , "timing" , no_arg_parser , doTiming , as_timing )
#endif
]
) ++ [ parsePat3 as ]
#else
[
#if USE_PAR_PATNODE
( '=' , "spark" , doSpark , as_spark )
#endif
#if USE_PSEQ_PATNODE
#if USE_PAR_PATNODE
, ( '+' , "trace" , doTrace , as_trace )
#else
( '>' , "pseq" , doPseq , as_pseq )
#endif
#endif
#if USE_TRACE_PATNODE
, ( '+' , "trace" , doTrace , as_trace )
#endif
#if USE_PING_PATNODE
, ( '^' , "ping" , doPing , as_ping )
#endif
#if USE_DIE_PATNODE
, ( '/' , "die" , doDie , as_die )
#endif
]
) ++ [ parsePat2 as ]
#endif
#else
( AT.char '='
>> if doSpark as
then fail "compilePat: duplicate '=' (spark) node attribute"
else parsePat as_spark)
<|> ( AT.char '+'
>> if doTrace as
then fail "compilePat: duplicate '+' (trace) node attribute"
else parsePat as_trace)
<|> ( AT.char '^'
>> if doPing as
then fail "compilePat: duplicate '^' (ping) node attribute"
else parsePat as_ping)
<|> (parsePat2 as)
#endif
where
dud_parser _ _ _ _ = fail "dud_parser"
no_arg_parser c b a s = do
( (AT.char c) <* AT.skipSpace )
>> (
if b as
then fail $ "compilePat: duplicate "
++ show c ++ " (" ++ s ++ ") "
++ "node attribute"
else parsePat a)
types_parser _ _ a _ = parsePat1''' a
delay_parser _ _ a _ = parsePat1' a
pseq_parser _ _ a _ = parsePat1'' a
as_types = as { doConstrainType = True }
as_delay = as { doDelay = True }
#if USE_PAR_PATNODE
as_spark = as { doSpark = True }
#endif
#if USE_PSEQ_PATNODE
as_pseq = as { doPseq = True }
#endif
#if USE_TRACE_PATNODE
as_trace = as { doTrace = True }
#endif
#if USE_PING_PATNODE
as_ping = as { doPing = True }
#endif
#if USE_DIE_PATNODE
as_die = as { doDie = True }
#endif
#if USE_TIMING_PATNODE
as_timing = as { doTiming = True }
#endif
parsePat1''' :: PatNodeAttrs -> AT.Parser Pattern
parsePat1''' as = do
!_ <- mytrace "parsePat1'''." $ return ()
AT.char ':'
>> ( ( parse_type_constraints True <* AT.skipSpace )
>>= \ (tcs,ncol)
-> let as' = as { doConstrainType = True
, typeConstraints = map T.unpack tcs }
#if 0
in return as' )
#else
in do
#if 0
roi <- AT.takeText
error $ "DEVEXIT: " ++ show tcs ++ " " ++ show roi ++ "\n" ++ show as'
#endif
parsePat as' )
#endif
parsePat1' :: PatNodeAttrs -> AT.Parser Pattern
parsePat1' as = do
!_ <- mytrace "parsePat1'." $ return ()
AT.char '@'
>> ( ( AT.decimal <* AT.skipSpace )
>>= \ dly -> let as' = as { doDelay = True
, delayus = dly }
#if 0
in return as' )
#else
in parsePat as' )
#endif
#if USE_PSEQ_PATNODE
parsePat1'' :: PatNodeAttrs -> AT.Parser Pattern
parsePat1'' as = do
!_ <- mytrace "parsePat1''." $ return ()
AT.char '>'
>> ( ( AT.many1' AT.letter ) <* AT.skipSpace
>>= \ perm -> let perm' = map (\c -> ord c ord 'a') perm
as' = as { doPseq = True
, pseqPerm = Just perm' }
#if 0
in return as' )
#else
in parsePat as' )
#endif
#endif
#if 0
parsePat2 :: PatNodeAttrs -> AT.Parser Pattern
parsePat2 as = do
!_ <- mytrace "parsePat2." $ return ()
(AT.char ':' >> parsePat2_t as)
<|> (parsePat3 as)
parsePat2_t :: PatNodeAttrs -> AT.Parser Pattern
parsePat2_t as = do
!_ <- mytrace "parsePat2_t." $ return ()
(tcs,ncol) <- parse_type_constraints True
!_ <- mytrace ("(ncol,tcs)=("++show ncol ++ "," ++ (T.unpack $ T.intercalate " " tcs)) $ return ()
if ncol > 0
then fail "compilePat: unexpected \"::\""
else do
let as_t = as { typeConstraints = map T.unpack tcs }
parsePat_TR_tail 'x' as_t
#endif
parsePat3 :: PatNodeAttrs -> AT.Parser Pattern
parsePat3 as = do
!_ <- mytrace "parsePat3." $ return ()
b <- AT.peekChar'
#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 )
AT.anyChar
#endif
!_ <- mytrace ("boo-0: "++show b) $ return ()
#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 )
!_ <- mytrace ("boo-1: "++show b) $ return ()
if b == '*'
#else
!_ <- mytrace ("boo-1-_19__9: "++show b) $ return ()
if isDigit b
#endif
then do ( (parsePat3_aux b as)
<|> (do
#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
#if 1
#if ABBREV_WN_AND_TN_CONCRETE_SYNTAX_TO_SINGLE_DIGIT__CAN_ONLY_EXPRESS_DOWN_TO_DEPTH_9
AT.anyChar
(case b of
#if 1
'0' -> parsePat4 '0' Nothing as
'1' -> parsePat4 '1' Nothing as
#else
#if NEW_CONCRETE_WI_AND_WS
'0' -> parsePat4 '.' Nothing as
'1' -> parsePat4 '!' Nothing as
#else
'0' -> parsePat4 '#' Nothing as
'1' -> parsePat4 '.' Nothing as
#endif
#endif
_ -> parsePat4 '*' Nothing as
) ) )
#else
(parsePat4 '*' Nothing as) ) )
#endif
#else
!_ <- mytrace ("parsePat3: unexpected digit " ++ [b]) $ return ()
fail $ "parsePat3: unexpected digit " ++ [b] ) )
#endif
#else
(parsePat4 '*' Nothing as) ) )
#endif
else do
#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
AT.anyChar
#endif
parsePat4 b Nothing as
parsePat3_aux :: Char -> PatNodeAttrs -> AT.Parser Pattern
parsePat3_aux b as = do
!_ <- mytrace "parsePat3_aux." $ return ()
!_ <- mytrace ("boo-2: "++show b) $ return ()
!_ <- mytrace ("boo-3: "++show b) $ return ()
#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 )
AT.skipSpace
#endif
#if ABBREV_WN_AND_TN_CONCRETE_SYNTAX_TO_NUMBER_ALONE__SAFE_ONLY_TO_DEPTH_19
n_integer_cs <- if b == '1'
then AT.anyChar *> AT.option "1" (AT.digit >>= \ c -> return ('1':[c]))
else AT.anyChar *> return [b]
!_ <- mytrace ("boo-3.2: n_integer_ns="++n_integer_cs) $ return ()
let n_integer = read n_integer_cs :: Integer
#elif ABBREV_WN_AND_TN_CONCRETE_SYNTAX_TO_SINGLE_DIGIT__CAN_ONLY_EXPRESS_DOWN_TO_DEPTH_9
n_integer_c <- AT.anyChar :: AT.Parser Char
!_ <- mytrace ("n_integer_c="++show n_integer_c) $ return ()
n_integer <- case n_integer_c of
'0' -> mytrace ("ANDDD...(0):") $ fail ""
'1' -> mytrace ("ANDDD...(1):") $ fail ""
_ -> parsePat4 '*' Nothing as
!_ <- mytrace "oops!!!!" $ return ()
let n_integer = read [n_integer_c] :: Integer
#else
n_integer <- AT.decimal :: AT.Parser Integer
#endif
!_ <- mytrace ("boo-3.5: "++show b) $ return ()
let n_integer_str = show n_integer
!_ <- mytrace ("boo-4: "++show b++" "++n_integer_str) $ return ()
if length n_integer_str > 9
then fail $ "compilePat: *" ++ n_integer_str ++ " is too large"
else parsePat4 '*' (Just (read n_integer_str :: Int)) as
#if 1
parsePat4 :: Char -> Maybe Int -> PatNodeAttrs -> AT.Parser Pattern
parsePat4 b mdepth as = do
!_ <- mytrace "parsePat4." $ return ()
!_ <- mytrace ("GOO-1: "++show b++" "++show (doConstrainType as)) $ return ()
if doConstrainType as
then parsePat4_t b mdepth 0 as
else parsePat4_w b mdepth as
#else
parsePat4 :: Char -> Maybe Int -> PatNodeAttrs -> AT.Parser Pattern
parsePat4 b mdepth as = do
!_ <- mytrace "parsePat4." $ return ()
!_ <- mytrace ("GOO-1: "++show b) $ return ()
parsePat4_aux b mdepth as <|> parsePat4_w b mdepth as
parsePat4_aux :: Char -> Maybe Int -> PatNodeAttrs -> AT.Parser Pattern
parsePat4_aux b mdepth as = do
#if 0
roi <- AT.takeText
error $ "DEVEXIT -- " ++ T.unpack roi
#endif
!_ <- mytrace "parsePat4_aux." $ return ()
!_ <- mytrace ("GOO-2.1: b="++show b++" mdepth="++show mdepth) $ return ()
c <- AT.peekChar'
!_ <- mytrace ("GOO-2.2: c="++show c) $ return ()
if c == ':'
then do
!_ <- mytrace ("GOO-2.3.1: "++show b) $ return ()
(tcs,ncol) <- parse_type_constraints False
!_ <- mytrace ("GOO-2.3.2: "++show (tcs,ncol)) $ return ()
let as_t = as { typeConstraints = map T.unpack tcs }
!_ <- mytrace ("GOO-2.3.3: "++show (typeConstraints as_t)) $ return ()
parsePat4_t b mdepth ncol as_t
else do
!_ <- mytrace ("GOO-2.4: "++show b) $ return ()
parsePat4_w b mdepth as
#endif
parsePat4_w :: Char -> Maybe Int -> PatNodeAttrs -> AT.Parser Pattern
parsePat4_w b mdepth as = do
!_ <- mytrace "parsePat4_w." $ return ()
!_ <- mytrace ("GOO-3: "++show b) $ return ()
case b of
#if VACANT_HASH
' ' -> return (Node (WI as) [])
'#' -> return (Node (WI as) [])
#else
#if NEW_CONCRETE_WI_AND_WS
#if ABBREV_WN_AND_TN_CONCRETE_SYNTAX_TO_SINGLE_DIGIT__CAN_ONLY_EXPRESS_DOWN_TO_DEPTH_9
'0' -> return (Node (WI as) [])
#else
'.' -> return (Node (WI as) [])
#endif
#else
'#' -> return (Node (WI as) [])
#endif
#endif
#if NEW_CONCRETE_WI_AND_WS
#if ABBREV_WN_AND_TN_CONCRETE_SYNTAX_TO_SINGLE_DIGIT__CAN_ONLY_EXPRESS_DOWN_TO_DEPTH_9
'1' -> return (Node (WS as) [])
#else
'!' -> return (Node (WS as) [])
#endif
#else
'.' -> return (Node (WS as) [])
#endif
'*' -> if isNothing mdepth
then return (Node (WW as) [])
else return (Node (WN as_n) [])
#if USE_CURLY_BRACE_INSTEAD_OF_PAREN_FOR_SUBPATTERNS
'{' -> parsePat_WR_tail b as
#else
'(' -> parsePat_WR_tail b as
#endif
#if USE_CURLY_BRACE_INSTEAD_OF_PAREN_FOR_SUBPATTERNS
_ -> fail $ "compilePat: expected one of \"#.*{\" (got " ++ show b ++ ")"
#else
_ -> fail $ "compilePat: expected one of \"#.*(\" (got " ++ show b ++ ")"
#endif
where
as_n = as { depth = fromJust mdepth }
parsePat4_t :: Char -> Maybe Int -> Int -> PatNodeAttrs -> AT.Parser Pattern
parsePat4_t b mdepth ncol as_t = do
!_ <- mytrace "parsePat4_t." $ return ()
#if 1
#if 0
!_ <- mytrace "parsePat4_t: trying to eat ':'..." $ return ()
AT.char ':'
!_ <- mytrace "parsePat4_t: ate ':'!" $ return ()
#endif
if False
then fail "dummy"
#else
if ncol /= 2
then do
c <- AT.peekChar'
fail $ "compilePat: after \"" ++ [c] ++ "\", expect \"::\" not \":\""
#endif
else do
#if NEW_SEMICOLON_TYPE_LIST
!_ <- mytrace ("parsePat4_t: b="++show b) $ return ()
case b of
#if USE_CURLY_BRACE_INSTEAD_OF_PAREN_FOR_SUBPATTERNS
'{' -> do
#else
'(' -> do
#endif
!_ <- mytrace "parsePat4_t: entering TR_tail..." $ return ()
parsePat_TR_tail 'x' as_t
#if VACANT_HASH
' ' -> return (Node (TI as_t) [])
'#' -> return (Node (TI as_t) [])
#else
#if NEW_CONCRETE_WI_AND_WS
#if ABBREV_WN_AND_TN_CONCRETE_SYNTAX_TO_SINGLE_DIGIT__CAN_ONLY_EXPRESS_DOWN_TO_DEPTH_9
'0' -> return (Node (TI as_t) [])
#else
'.' -> return (Node (TI as_t) [])
#endif
#else
'#' -> return (Node (TI as_t) [])
#endif
#endif
'*' -> if isNothing mdepth
then return (Node (TW as_t) [])
else return (Node (TN as_t_n) [])
#else
#if USE_CURLY_BRACE_INSTEAD_OF_PAREN_FOR_SUBPATTERNS
let endch = '}'
#else
let endch = ')'
#endif
case b of
#if VACANT_HASH
' ' -> AT.char endch >> return (Node (TI as_t) [])
'#' -> AT.char endch >> return (Node (TI as_t) [])
#else
#if NEW_CONCRETE_WI_AND_WS
#if ABBREV_WN_AND_TN_CONCRETE_SYNTAX_TO_SINGLE_DIGIT__CAN_ONLY_EXPRESS_DOWN_TO_DEPTH_9
'0' -> AT.char endch >> return (Node (TI as_t) [])
#else
'.' -> AT.char endch >> return (Node (TI as_t) [])
#endif
#else
'#' -> AT.char endch >> return (Node (TI as_t) [])
#endif
#endif
'*' -> AT.char endch >> if isNothing mdepth
then return (Node (TW as_t) [])
else return (Node (TN as_t_n) [])
#endif
#if NEW_CONCRETE_WI_AND_WS
#if ABBREV_WN_AND_TN_CONCRETE_SYNTAX_TO_SINGLE_DIGIT__CAN_ONLY_EXPRESS_DOWN_TO_DEPTH_9
_ -> fail $ "compilePat: expected '*' or digit (got " ++ show b ++ ")"
#elif ABBREV_WN_AND_TN_CONCRETE_SYNTAX_TO_SINGLE_DIGIT__SAFE_DOWN_TO_DEPTH_19
_ -> fail $ "compilePat: expected '.' or '*' or digit (got " ++ show b ++ ")"
#else
_ -> fail $ "compilePat: expected '.' or '*' (got " ++ show b ++ ")"
#endif
#else
_ -> fail $ "compilePat: expected '#' or '*' (got " ++ show b ++ ")"
#endif
where
as_t_n = as_t { depth = fromJust mdepth }
#if 0
parsePat_WR :: PatNodeAttrs -> AT.Parser Pattern
parsePat_WR as = AT.char '{' *> parsePat_WR_tail as
#endif
parsePat_WR_tail :: Char -> PatNodeAttrs -> AT.Parser Pattern
parsePat_WR_tail x as
= do
!_ <- mytrace "parsePat_WR_tail." $ return ()
!_ <- mytrace ("**HWR1**: "++show x) $ return ()
#if 0
#if NEW_SEMICOLON_TYPE_LIST
#if USE_CURLY_BRACE_INSTEAD_OF_PAREN_FOR_SUBPATTERNS
AT.skipSpace *> AT.char '{'
#else
AT.skipSpace *> AT.char '('
#endif
#endif
#endif
!_ <- mytrace ("**HWR1.5**: "++show x) $ return ()
pats <- parsePats <|> pure []
!_ <- mytrace ("**HWR2**: "++show x) $ return ()
#if USE_CURLY_BRACE_INSTEAD_OF_PAREN_FOR_SUBPATTERNS
AT.char '}'
#else
AT.char ')'
#endif
!_ <- mytrace ("**HWR3**: "++show x) $ return ()
return (Node (WR as) pats)
#if 0
parsePat_TR :: PatNodeAttrs -> AT.Parser Pattern
parsePat_TR as = AT.char '{' *> parsePat_TR_tail as
#endif
parsePat_TR_tail :: Char -> PatNodeAttrs -> AT.Parser Pattern
parsePat_TR_tail x as_t
= do
!_ <- mytrace "parsePat_TR_tail." $ return ()
!_ <- mytrace ("**HTR1**: "++show x) $ return ()
#if 0
roi <- AT.takeText
error $ "DEVEXIT: " ++ show roi
#endif
#if 0
#if NEW_SEMICOLON_TYPE_LIST
#if USE_CURLY_BRACE_INSTEAD_OF_PAREN_FOR_SUBPATTERNS
AT.skipSpace *> AT.char '{'
#else
AT.skipSpace *> AT.char '('
#endif
#endif
#endif
!_ <- mytrace ("**HTR1.5**: "++show x) $ return ()
pats <- parsePats <|> pure []
!_ <- mytrace ("**HTR2**: "++show x) $ return ()
#if USE_CURLY_BRACE_INSTEAD_OF_PAREN_FOR_SUBPATTERNS
AT.char '}'
#else
AT.char ')'
#endif
!_ <- mytrace ("**HTR3**: "++show x) $ return ()
return (Node (TR as_t) pats)
parse_type_constraints :: Bool -> AT.Parser ( [T.Text], Int )
parse_type_constraints isTR = do
!_ <- mytrace "parse_type_constraints." $ return ()
#if NEW_SEMICOLON_TYPE_LIST
let endchar = ':'
#else
#if USE_CURLY_BRACE_INSTEAD_OF_PAREN_FOR_SUBPATTERNS
let endchar = '{'
#else
let endchar = '('
#endif
#endif
#if TYPE_CONSTRAINTED_NODES_USE_UNESCAPED_SPACE_AS_TYPE_LIST_SEPARATOR
let sepchar = ' '
#else
#if NEW_SEMICOLON_TYPE_LIST
let sepchar = ';'
#else
let sepchar = ':'
#endif
#endif
#if NEW_SEMICOLON_TYPE_LIST
ncs <- if isTR
then pure 0
else AT.string "::" *> pure 2
#endif
#if NEW_SEMICOLON_TYPE_LIST
let loop = do
seg <- AT.takeWhile (\c->c/=endchar&&c/='\\') :: AT.Parser T.Text
!_ <- mytrace ("loop: seg="++T.unpack seg) $ return ()
if T.null seg
then do
!_ <- mytrace "loop: T.null seg" $ return ()
return []
else do
mnc <- AT.peekChar
!_ <- mytrace ("loop: mnc="++show mnc) $ return ()
let nc = fromJust mnc
if isNothing mnc
then do
!_ <- mytrace "trace: \"parse_type_constraints: unexpected end of input #1\"" $ return ()
fail "parse_type_constraints: unexpected end of input"
else do
AT.take 1
if nc == '\\'
then do
mnc' <- AT.peekChar
!_ <- mytrace ("loop: mnc'="++show mnc') $ return ()
let nc' = fromJust mnc'
if isNothing mnc'
then do
!_ <- mytrace "trace: \"parse_type_constraints: unexpected end of input #2\"" $ return ()
fail "parse_type_constraints: unexpected end of input"
else do
!_ <- mytrace "loop: <appending backslash>" $ return ()
AT.take 1 *> ( ( ( T.snoc seg '\\' `T.snoc` nc' ) : ) <$> loop )
else do
!_ <- mytrace ("loop: [seg]="++show [seg]) $ return ()
return [seg]
segs <- loop
!_ <- mytrace ("segs="++show segs) $ return ()
let seg = T.concat segs
!_ <- mytrace ("seg="++T.unpack seg) $ return ()
#else
seg' <- AT.takeWhile (/=endchar) :: AT.Parser T.Text
!_ <- mytrace ("seg'="++T.unpack seg') $ return ()
#endif
#if NEW_SEMICOLON_TYPE_LIST
if isTR
then do
!_ <- mytrace "HERE isTR" $ return ()
mnc <- AT.peekChar
!_ <- mytrace ("isTR: mnc="++show mnc) $ return ()
let nc = fromJust mnc
if isNothing mnc
then do
!_ <- mytrace "isTR: \"parse_type_constraints: unexpected end of input\"" $ return ()
fail "parse_type_constraints: unexpected end of input"
else do
!_ <- mytrace ("isTR: nc="++show nc) $ return ()
if nc == ':'
then do
!_ <- mytrace "isTR: \"parse_type_constraints: unexpected end of input\"" $ return ()
fail "parse_type_constraints: unexpected end of input"
else do
AT.take 0
else do
AT.take 0
#else
AT.take 1
#endif
!_ <- mytrace ("HERE!") $ return ()
#if ! NEW_SEMICOLON_TYPE_LIST
let (ecs :: Either String T.Text) = AT.parseOnly ((AT.takeWhile (==':')) :: AT.Parser T.Text) seg
!_ <- mytrace ("ecs="++show ecs) $ return ()
#endif
#if NEW_SEMICOLON_TYPE_LIST
let (eblocksncs :: Either String ([T.Text],Int)) =
AT.parseOnly
( ( AT.sepBy1'
(AT.takeWhile (/=';'))
(AT.char ';')
)
>>= \ y -> return (y,ncs)
)
seg
!_ <- mytrace ("eblocksncs="++show eblocksncs) $ return ()
let (blocks,ncs) = case eblocksncs of
Left msg -> error $ "parse_type_constraints: eblocks parse failure: " ++ msg
Right (blocks,ncs) -> (blocks,ncs) :: ([T.Text],Int)
!_ <- mytrace ("(blocks,ncs)="++show (blocks,ncs)) $ return ()
let blocks' = map (helper False) blocks
return (blocks',ncs)
#else
let (eblocksncs :: Either String ([T.Text],Int)) =
case ecs of
Left msg -> fail $ "parse_type_constraints: expected colon: " ++ msg
Right cs -> let ncs = T.length cs
seg' = T.drop ncs seg
in
#if 0
#if 0
#elif 1
AT.sepBy1' (AT.many1' AT.anyChar) (AT.string $ T.singleton sepchar)
>>= (\x -> return (x,ncs))
#elif 0
AT.sepBy1' (liftM T.concat $ AT.many1' AT.anyChar) (AT.string $ T.singleton sepchar)
>>= (\x -> return (x,ncs))
#elif 0
AT.sepBy1' (liftM T.concat $ AT.many1' AT.anyChar) (AT.char sepchar)
>>= (\x -> return (x,ncs))
#endif
#else
AT.parseOnly
( ( AT.sepBy1'
#if 1
(AT.takeWhile (/=':'))
(AT.char ':')
#else
(AT.many1' AT.anyChar)
(AT.symbol ":")
#endif
)
>>= \ x -> return x
>>= \ y -> return (y,ncs)
)
seg'
#endif
!_ <- mytrace ("eblocksncs="++show eblocksncs) $ return ()
#if 0
let blocks = map T.pack eblocks :: [T.Text]
#else
let (blocks,ncs) = case eblocksncs of
Left msg -> error $ "parse_type_constraints: eblocks parse failure: " ++ msg
Right (blocks,ncs) -> (blocks,ncs) :: ([T.Text],Int)
#endif
!_ <- mytrace ("(blocks,ncs)="++show (blocks,ncs)) $ return ()
#if ! ALLOW_ESCAPED_TYPE_LIST_SEPARATOR
let blocks' = map (helper False) blocks
return (blocks',ncs)
#else
let blocks' = (map (helper True) . dealWithEscapedSeparators) blocks
!_ <- mytrace ("blocks'="++show blocks') $ return ()
return (blocks',ncs)
#endif
#endif
where
helper :: Bool -> T.Text -> T.Text
helper b t
| T.null t = t
| otherwise = T.cons (T.head t) $ helper b $ T.tail t
#if ALLOW_ESCAPED_TYPE_LIST_SEPARATOR
dealWithEscapedSeparators :: [T.Text] -> [T.Text]
dealWithEscapedSeparators (t1:t2:ts)
| dofuse = t' : dealWithEscapedSeparators ts
| otherwise = t' : dealWithEscapedSeparators (t2:ts)
where
dofuse
| T.null t1 || T.null t2 = True
| T.last (T.init t1) == '\\' = False
| otherwise = T.last t1 == '\\'
t' | dofuse = T.concat [t1,':' `T.cons` t2]
| otherwise = t1
dealWithEscapedSeparators x = x
#endif
#if 1
compileUsingAttoparsec input
= AT.feed (AT.parse parsePatsTop input) T.empty
#else
compileUsingAttoparsec :: T.Text -> Either String [Pattern]
compileUsingAttoparsec input
= AT.parseOnly parsePatsTop input
#endif
#else
compilePat' :: String -> Pattern
compilePat' _ = error "\nSorry, at this time (version 0.6.0.*) there is no non-attoparsec parser\nfor the new pattern grammar. This also implies that HASKELL98_FRAGMENT\nhas no pattern DSL facilities (except for showPat), and it is necessary\nto work with the PatNode constructors directly. The situation should\nbe remedied by version 0.6.1."
#endif