------------------------------------------------------------------------------- {- LANGUAGE CPP #-} #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 ------------------------------------------------------------------------------- #if USE_ATTOPARSEC {-# LANGUAGE OverloadedStrings #-} {- LANGUAGE ScopedTypeVariables #-} -- debugging only {-# LANGUAGE BangPatterns #-} -- for forcing tracelines in do blocks #endif ------------------------------------------------------------------------------- -- | -- Module : Control.DeepSeq.Bounded.Compile_new_grammar -- Copyright : Andrew G. Seniuk 2014-2015 -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Andrew Seniuk -- Stability : provisional -- Portability : attoparsec -- ------------------------------------------------------------------------------- module Control.DeepSeq.Bounded.Compile_new_grammar ( #if USE_ATTOPARSEC #if HASKELL98_FRAGMENT #error Sorry, HASKELL98_FRAGMENT incompatible with USE_ATTOPARSEC. #endif compileUsingAttoparsec , -- parsePat , #else compilePat' , #endif ) where ------------------------------------------------------------------------------- import Control.DeepSeq.Bounded.Pattern import Control.DeepSeq.Bounded.Compile_shared_utils import Data.Maybe ( isNothing, fromJust ) import Data.List ( intercalate ) import Debug.Trace ( trace ) #if USE_ATTOPARSEC import qualified Data.Attoparsec.Text as AT import qualified Data.Text as T import Control.Applicative import Data.Char ( isLetter ) import Data.Char ( isDigit ) import Data.Char ( ord ) import Control.Monad ( liftM ) --import Control.Monad ( foldM ) --import Data.Foldable ( fold ) import Control.Monad ( mzero ) import Data.Monoid ( mempty ) #else import Control.DeepSeq.Bounded.PatUtil ( liftPats ) import Data.Char ( isSpace ) import Data.Char ( isLower ) import Data.List ( sort ) import Data.Char ( ord ) import Data.Maybe ( isJust ) #endif ------------------------------------------------------------------------------- #if DO_TRACE mytrace = trace #else mytrace _ = id #endif #if USE_ATTOPARSEC ------------------------------------------------------------------------------- -- The caller (or someone up there) uses liftPat if -- multiple patterns are parsed (adds new common root). parsePatsTop :: AT.Parser [Pattern] parsePatsTop = do !_ <- mytrace ("parsePatsTop.") $ return () let as = emptyPatNodeAttrs AT.many' (AT.skipSpace *> parsePat as <* AT.skipSpace) ------------------------------------------------------------------------------- -- This differs from parsePatsTop in that it assumes an -- opening grouping token has been consumed (so will be -- expecting a corresponding closing token). 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 [] --- then AT.char '}' >> pure [] else let as = emptyPatNodeAttrs in AT.many' (AT.skipSpace *> parsePat as <* AT.skipSpace)) #else -- XXX Why does this work so badly? parsePats = AT.manyTill' (AT.skipSpace *> parsePat emptyPatNodeAttrs) (AT.endOfInput <|> (AT.char ')' *> return ())) #endif ------------------------------------------------------------------------------- -- Test if next character is non-attribute, up front, -- and skip all this attribute stuff in that case!... parsePat :: PatNodeAttrs -> AT.Parser Pattern parsePat as = do !_ <- mytrace "parsePat." $ return () let modchars = ":@=>+^/%" mc <- AT.peekChar let c = fromJust mc if isNothing mc then fail "parse_type_constraints: unexpected end-of-input" else if c `elem` modchars then parsePatAttributes as else parsePat3 as -- Note: Previously, type constraint was handled in a more -- ad hoc manner. The existence of separate T* nodes is -- evidence of this, but those will likely be removed in 0.7, -- making type constraint just another attribute of W* nodes. parsePatAttributes :: PatNodeAttrs -> AT.Parser Pattern parsePatAttributes as = do !_ <- mytrace "parsePatAttributes." $ return () foldr (<|>) mempty $ -- foldM (<|>) mempty $ -- fold (<|>) mempty $ -- fold (<|>) mzero $ ( map ( \ (c,s,p,b,a) -> do let q = (c,s,b,a) if c == '\0' then fail "" else p c b a s <* AT.skipSpace ) -- doConstrainType, doDelay, and doPseq handled specially, -- due to their taking arguments. [ ( '\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 ] where dud_parser _ _ _ _ = fail "dud_parser" -- (is never run; should use Proxy) 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 -- Parse the ":Int;Maybe Float:" typeConstraints attribute, if present. parsePat1''' :: PatNodeAttrs -> AT.Parser Pattern parsePat1''' as = do !_ <- mytrace "parsePat1'''." $ return () AT.char ':' >> ( ( parse_type_constraints <* AT.skipSpace ) >>= \ tcs -> let as' = as { doConstrainType = True , typeConstraints = map T.unpack tcs } in parsePat as' ) -- Parse the "@50000" delayus attribute, if present. 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 } in parsePat as' ) #if USE_PSEQ_PATNODE -- Parse the ">cdba" pseqPerm attribute, if present. 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' } in parsePat as' ) #endif ------------------------------------------------------------------------------- -- Handle "*23"-style (WN and TN) nodes. 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 if b == '*' #else 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 '0' -> parsePat4 '0' Nothing as '1' -> parsePat4 '1' Nothing as _ -> parsePat4 '*' Nothing as ) ) ) #else (parsePat4 '*' Nothing as) ) ) #endif #else 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 -- fail $ "parsePat3: #2 unexpected digit " ++ [b] AT.anyChar #endif parsePat4 b Nothing as -- Actual handler, in case it /was/ WN or TN node. parsePat3_aux :: Char -> PatNodeAttrs -> AT.Parser Pattern parsePat3_aux b as = do !_ <- mytrace "parsePat3_aux." $ return () -- These should be safe cutoffs without having to worry about exact figures. --- DEPTH_USES_INT64 isn't implemented yet, this is just a note --- for future consideration. (Should be in NFDataN if anywhere...). --- I'm not ready to make this sweeping change yet. --- #if DEPTH_USES_INT64 --- if length n_integer_str > 19 = fail $ "compilePat: *" ++ n_integer_str ++ " is too large" #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] 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 n_integer <- case n_integer_c of '0' -> mytrace ("ANDDD...(0):") $ fail "" '1' -> mytrace ("ANDDD...(1):") $ fail "" _ -> parsePat4 '*' Nothing as let n_integer = read [n_integer_c] :: Integer #else n_integer <- AT.decimal :: AT.Parser Integer #endif let n_integer_str = show n_integer if length n_integer_str > 9 then fail $ "compilePat: *" ++ n_integer_str ++ " is too large" else parsePat4 '*' (Just (read n_integer_str :: Int)) as ------------------------------------------------------------------------------- -- This handles whether or not it's a type-constrainted node. -- (The constraints themselves will have already been parsed.) parsePat4 :: Char -> Maybe Int -> PatNodeAttrs -> AT.Parser Pattern parsePat4 b mdepth as = do !_ <- mytrace "parsePat4." $ return () if doConstrainType as then parsePat4_t b mdepth as else parsePat4_w b mdepth as -- Actual handler, in case it was /NOT/ a type-constrained node; -- i.e. a WI, WR, WS (if still exists), WN or WW node. parsePat4_w :: Char -> Maybe Int -> PatNodeAttrs -> AT.Parser Pattern parsePat4_w b mdepth as = do !_ <- mytrace "parsePat4_w." $ return () case b of #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 #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 '*' -> if isNothing mdepth then return (Node (WW as) []) else return (Node (WN as_n) []) #if USE_CURLY_BRACE_INSTEAD_OF_PAREN_FOR_SUBPATTERNS '{' -> parsePat_WRTR_tail False b as #else '(' -> parsePat_WRTR_tail False 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 } -- This is a helper of patsePat4_aux. parsePat4_t :: Char -> Maybe Int -> PatNodeAttrs -> AT.Parser Pattern parsePat4_t b mdepth as_t = do !_ <- mytrace "parsePat4_t." $ return () case b of #if USE_CURLY_BRACE_INSTEAD_OF_PAREN_FOR_SUBPATTERNS '{' -> do #else '(' -> do #endif parsePat_WRTR_tail True 'x' as_t #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 '*' -> if isNothing mdepth then return (Node (TW as_t) []) else return (Node (TN as_t_n) []) #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_NUMBER_ALONE__SAFE_ONLY_TO_DEPTH_19 _ -> fail $ "compilePat: expected '.' or '*' or digit (got " ++ show b ++ ")" #else _ -> fail $ "compilePat: expected '.' or '*' (got " ++ show b ++ ")" #endif where as_t_n = as_t { depth = fromJust mdepth } ------------------------------------------------------------------------------- parsePat_WRTR_tail :: Bool -> Char -> PatNodeAttrs -> AT.Parser Pattern parsePat_WRTR_tail isTR x as = do !_ <- mytrace "parsePat_WRTR_tail." $ return () -- AT.takeText >>= \ roi -> error $ "DEVEXIT: " ++ show roi pats <- parsePats <|> pure [] #if USE_CURLY_BRACE_INSTEAD_OF_PAREN_FOR_SUBPATTERNS AT.char '}' #else AT.char ')' #endif if isTR then return (Node (TR as) pats) else return (Node (WR as) pats) ------------------------------------------------------------------------------- parse_type_constraints :: AT.Parser [T.Text] parse_type_constraints = do !_ <- mytrace "parse_type_constraints." $ return () let endchar = ':' let sepchar = ';' let loop = do seg <- AT.takeWhile (\c->c/=endchar&&c/='\\') :: AT.Parser T.Text if T.null seg then do return [] else do (do AT.char '\\' *> AT.anyChar >>= \ c -> ( ( seg `T.snoc` '\\' `T.snoc` c ) : ) <$> loop ) <|> (do AT.char endchar return [seg] ) <|> (fail "parse_type_constraints: unexpected end of input") segs <- loop let seg = T.concat segs let eblocks = AT.parseOnly ( AT.sepBy1' (AT.takeWhile (/=sepchar)) (AT.char sepchar) ) seg let blocks = case eblocks of Left msg -> fail $ "parse_type_constraints: eblocks parse failure: " ++ msg Right blocks -> map T.strip blocks return blocks {-# INLINE parse_type_constraints #-} ------------------------------------------------------------------------------- -- Try attoparsec. -- XXX If you toggle this, don't forget to also toggle -- the one in Compile_shared_utils2.hs (compilePat_). #if 1 compileUsingAttoparsec :: T.Text -> AT.Result [Pattern] 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 #if 1 -- This was such a pleasure to write after the attoparsec -- learning curve above!!... I wonder if the atto parser -- could ever be made to be as concise as this? compilePat' :: String -> Pattern compilePat' s | not $ null s' = error $ "\ncompilePat: input rejected: " ++ s ++ if isNothing mmsg then "" else "\nParser message: " ++ fromJust mmsg ++ "\nPatterns parsed so far: [" ++ intercalate ", " (map show pats) ++ "]" | otherwise = case pats of [] -> error $ "\ncompilePat: " ++ if null s then "empty input" else "vacuous input" [pat] -> setPatternPatNodeUniqueIDs 0 pat pats -> setPatternPatNodeUniqueIDs 0 $ liftPats pats where (pats, mmsg, s') = compilePats s [] -- String in last component of result is unconsumed input. compilePats :: String -> [Pattern] -> ([Pattern], Maybe String, String) compilePats s acc | null s_ltrim = (reverse acc, Nothing, s_ltrim) | otherwise = case cpat s of (Left "", s') -> (reverse acc, Nothing, s') -- (Left "", s') -> compilePats s' acc (Left msg, s') -> (reverse acc, Just msg, s') (Right pat, s') -> compilePats s' (pat:acc) where s_ltrim = dropWhile isSpace s #if 0 -- nice one from http://stackoverflow.com/a/6270337 trim :: String -> String trim = let f = reverse . dropWhile isSpace in f . f #endif -- XXX Don't forget to do a post-pass to change W* nodes -- to corresponding T* nodes, when : modifier was present! cpat :: String -> (Either String Pattern, String) --cpat _ | trace "J-1: " $ False = undefined cpat [] = (Left "unexpected end of input", []) --cpat s | trace ("J-2: "++show s) $ False = undefined cpat s | null s'' = error "\ncompilePat: type constraint must precede a pattern node" | isW = case c of '.' -> (Right $ Node (WI as) [], cs) '!' -> (Right $ Node (WS as) [], cs) '*' -> case parseInt cs [] of (Nothing, cs'') -> (Right $ Node (WW as ) [], cs'') (Just is, cs'') -> (Right $ Node (WN $ asn is) [], cs'') '(' -> if isNothing mmsg_subpats then (Right $ Node (WR as) subpats, cs_subpats) else (Left $ fromJust mmsg_subpats, cs_subpats) ')' -> (Left "", cs) c -> error $ "\ncompilePat: unexpected character '" ++ [c] ++ "'" | otherwise = case c of '.' -> (Right $ Node (TI as) [], cs) -- '!' -> (Right $ Node (TS as) [], cs) '*' -> case parseInt cs [] of (Nothing, cs'') -> (Right $ Node (TW as ) [], cs'') (Just is, cs'') -> (Right $ Node (TN $ asn is) [], cs'') '(' -> if isNothing mmsg_subpats then (Right $ Node (TR as) subpats, cs_subpats) else (Left $ fromJust mmsg_subpats, cs_subpats) ')' -> (Left "", cs) c -> error $ "\ncompilePat: unexpected character '" ++ [c] ++ "'" where s' = dropWhile isSpace s (c:cs) = s'' (as_mods, mmsg_mods, s'') = cmods s' -- collect any prefix modifiers as = case mmsg_mods of Nothing -> as_mods Just msg -> error $ "\ncompilePat: " ++ msg asn is = as { depth = read is :: Int } isW = not $ doConstrainType as (subpats, mmsg_subpats, cs_subpats) = compilePats cs [] -- Accumulate any prefix modifiers into an empty PatNodeAttrs structure. cmods :: String -> (PatNodeAttrs, Maybe String, String) cmods s = cmods' s emptyPatNodeAttrs cmods' :: String -> PatNodeAttrs -> (PatNodeAttrs, Maybe String, String) cmods' [] as = (as, Nothing, []) --cmods' [] as = (as, Just "cmods': unexpected end of input", []) cmods' s as = case c of ':' -> cmods' cs_types as_types '@' -> cmods' cs_delay as_delay #if USE_PAR_PATNODE '=' -> cmods' cs_par as_par #endif #if USE_PSEQ_PATNODE '>' -> cmods' cs_pseq as_pseq #endif #if USE_TRACE_PATNODE '+' -> cmods' cs_trace as_trace #endif #if USE_PING_PATNODE '^' -> cmods' cs_ping as_ping #endif #if USE_DIE_PATNODE '/' -> cmods' cs_die as_die #endif #if USE_TIMING_PATNODE '%' -> cmods' cs_timing as_timing #endif _ -> (as, Nothing, s) where s'@(c:cs) = dropWhile isSpace s ( cs_types , as_types ) = parse_type_constraints cs as ( cs_delay , as_delay ) = parse_delay cs as #if USE_PAR_PATNODE ( cs_par , as_par ) = ( cs, as { doSpark = True } ) #endif #if USE_PSEQ_PATNODE ( cs_pseq , as_pseq ) = parse_pseq cs as #endif #if USE_TRACE_PATNODE ( cs_trace , as_trace ) = ( cs, as { doTrace = True } ) #endif #if USE_PING_PATNODE ( cs_ping , as_ping ) = ( cs, as { doPing = True } ) #endif #if USE_DIE_PATNODE ( cs_die , as_die ) = ( cs, as { doDie = True } ) #endif #if USE_TIMING_PATNODE ( cs_timing , as_timing ) = ( cs, as { doTiming = True } ) #endif parse_type_constraints :: String -> PatNodeAttrs -> (String, PatNodeAttrs) parse_type_constraints s'' as --- | doConstrainType as = trace "\nwarning: type constraints (:...:) mod given multiple times to a single node, so aggregating type lists." $ (s', as') | otherwise = (s', as') where s = dropWhile isSpace s'' as' = as { doConstrainType = True , typeConstraints = typeConstraints as ++ tys } (tys, s') = f s "" [] -- Take up to the next ';', ':', or '\\' and deal. f :: String -> String -> [String] -> ([String],String) f s'' tyacc tysacc | null s' = error "\ncompilePat: type constraint list not ':'-terminated" | '\\' == c = if null cs then f cs (c:tyacc) tysacc else if ':' == head cs -- note ty is already reversed then f (tail cs) ((':':'\\':ty) ++ tyacc) tysacc else f cs (('\\':ty) ++ tyacc) tysacc | ':' == c = ( reverse $ (reverse $ tyacc ++ ty) : tysacc , dropWhile isSpace cs ) -- otherwise ';' == c | otherwise = f cs "" $ (reverse $ tyacc ++ ty) : tysacc where s = dropWhile isSpace s'' (c:cs) = s' (ty',s') = span (\c->c/=';'&&c/=':'&&c/='\\') s ty = dropWhile isSpace $ reverse ty' -- yeah yeah parse_delay :: String -> PatNodeAttrs -> (String, PatNodeAttrs) parse_delay [] as = error "\nparse_delay: unexpected end of input" parse_delay s'' as --- | doDelay as = error "\ncompilePat: delay (@) modifier given multiple times to a single node" --- | doDelay as = trace "\nwarning: delay (@) mod given multiple times to a single node, so summing." $ (s', as') | isNothing mis = error $ "\nparse_delay: expected a digit 1-9 (not '" ++ [head s] ++ "')" | otherwise = (s', as') where s = dropWhile isSpace s'' as' = as { doDelay = True -- (convenient to set both here) , delayus = delayus as + i } (mis, s') = parseInt s [] is = fromJust mis i = read is :: Int #if USE_PSEQ_PATNODE parse_pseq :: String -> PatNodeAttrs -> (String, PatNodeAttrs) parse_pseq s'' as | doPseq as = error "\ncompilePat: pseq (>) modifier given multiple times to a single node" | not ok = error "\ncompilePat: pseq permutation must cover an initial segment of abc..yz" -- No harm in allowing it; as for testing arity mismatch, that is not -- in the parser's purview (at least at this time). It is easily done -- as a post-parsing check. --- | null perm = error "\ncompilePat: empty pseq permutation" | otherwise = (s', as') where s = dropWhile isSpace s'' as' = as { doPseq = True -- (convenient to set both here) , pseqPerm = Just $ map (\c -> ord c - ord 'a') perm } (perm, s') = span isLower s ok = sort perm == take (length perm) ['a'..'z'] #endif #else err = intercalate "\n" [ "\n" , "Sorry, at this time (version 0.6.0.*) there is no non-attoparsec parser" , "for the new pattern grammar. This also implies that HASKELL98_FRAGMENT" , "has no pattern DSL facilities (except for showPat), and it is necessary" , "to work with the PatNode constructors directly. The situation should" , "be remedied by version 0.6.1." ] compilePat' :: String -> Pattern compilePat' _ = error err #endif #endif -------------------------------------------------------------------------------