#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 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 DO_DERIVE_DATA_AND_TYPEABLE
#endif
#if DO_DERIVE_ONLY_TYPEABLE
#endif
#if NFDATA_INSTANCE_PATTERN
#endif
module Control.DeepSeq.Bounded.Compile
(
compilePat
, showPat
)
where
import Control.DeepSeq.Bounded.Pattern
import Control.DeepSeq.Bounded.PatUtil ( liftPats )
import Data.Char ( isSpace )
import Data.Char ( isLower )
import Data.Char ( ord )
import Data.Char ( isDigit )
import Data.List ( intercalate )
import Data.List ( sort )
import Data.Maybe ( isNothing, fromJust )
import Data.Maybe ( isJust )
#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 Debug.Trace ( trace )
import Control.DeepSeq ( force )
#if 0
#if NFDATA_INSTANCE_PATTERN
import qualified Control.DeepSeq.Generics as DSG
import qualified GHC.Generics as GHC ( Generic )
#endif
#endif
#if DO_TRACE
mytrace = trace
#else
mytrace _ = id
#endif
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 []
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 msg, s') -> (reverse acc, Just msg, s')
(Right pat, s') -> compilePats s' (pat:acc)
where s_ltrim = dropWhile isSpace s
cpat :: String -> (Either String Pattern, String)
cpat [] = (Left "unexpected end of input", [])
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 USE_CURLY_BRACE_INSTEAD_OF_PAREN_FOR_SUBPATTERNS
'{' ->
#else
'(' ->
#endif
if isNothing mmsg_subpats
then (Right $ Node (WR as) subpats, cs_subpats)
else (Left $ fromJust mmsg_subpats, cs_subpats)
#if USE_CURLY_BRACE_INSTEAD_OF_PAREN_FOR_SUBPATTERNS
'}' ->
#else
')' ->
#endif
(Left "", cs)
c -> error $ "\ncompilePat: unexpected character '" ++ [c] ++ "'"
| otherwise = case c of
'.' -> (Right $ Node (TI as) [], cs)
'*' -> case parseInt cs [] of
(Nothing, cs'') -> (Right $ Node (TW as ) [], cs'')
(Just is, cs'') -> (Right $ Node (TN $ asn is) [], cs'')
#if USE_CURLY_BRACE_INSTEAD_OF_PAREN_FOR_SUBPATTERNS
'{' ->
#else
'(' ->
#endif
if isNothing mmsg_subpats
then (Right $ Node (TR as) subpats, cs_subpats)
else (Left $ fromJust mmsg_subpats, cs_subpats)
#if USE_CURLY_BRACE_INSTEAD_OF_PAREN_FOR_SUBPATTERNS
'}' ->
#else
')' ->
#endif
(Left "", cs)
c -> error $ "\ncompilePat: unexpected character '" ++ [c] ++ "'"
where
s' = dropWhile isSpace s
(c:cs) = s''
(as_mods, mmsg_mods, s'') = cmods s'
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 []
cmods :: String -> (PatNodeAttrs, Maybe String, String)
cmods s = cmods' s emptyPatNodeAttrs
cmods' :: String -> PatNodeAttrs -> (PatNodeAttrs, Maybe String, String)
cmods' [] as = (as, Nothing, [])
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
| otherwise = (s', as')
where
s = dropWhile isSpace s''
as' = as { doConstrainType = True
, typeConstraints = typeConstraints as ++ tys }
(tys, s') = f s "" []
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
then f (tail cs) ((':':'\\':ty) ++ tyacc) tysacc
else f cs (('\\':ty) ++ tyacc) tysacc
| ':' == c = ( reverse $ (reverse $ tyacc ++ ty) : tysacc , dropWhile isSpace cs )
| 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'
parse_delay :: String -> PatNodeAttrs -> (String, PatNodeAttrs)
parse_delay [] as = error "\nparse_delay: unexpected end of input"
parse_delay 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
, 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"
| otherwise = (s', as')
where
s = dropWhile isSpace s''
as' = as { doPseq = True
, pseqPerm = Just $ map (\c -> ord c ord 'a') perm }
(perm, s') = span isLower s
ok = sort perm == take (length perm) ['a'..'z']
#endif
compilePat :: String -> Pattern
#if NFDATA_INSTANCE_PATTERN
compilePat s = force $ compilePat_ s
#else
compilePat = compilePat_
#endif
compilePat_ :: String -> Pattern
compilePat_ str = compilePat' str
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)
#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_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 ++ ":"
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
parseInt :: String -> String -> ( Maybe String, String )
parseInt [] acc = ( if null acc then Nothing else Just acc , "" )
parseInt s@(c:cs) acc
| length acc > 9 = error $ "compilePat: * followed by too many (>9) digits"
| isDigit c = parseInt cs (acc++[c])
| otherwise = ( if null acc then Nothing else Just acc , s )
compileTypeReps :: String -> ([String], String)
compileTypeReps cs = (treps,cs')
where
(tnames, cs') = parseTyNames cs
parseTyNames :: String -> ([String], String)
parseTyNames s = (sps', s')
where
sps' = map (dropWhile pstop) sps
(sps,s') = splitPred psplit pstop s
pstop x = x == '{' || x == '}'
psplit x = x == ' ' || pstop x
#if 1
treps = tnames
#else
treps = map mktrep tnames
mktrep :: String -> TypeRep
mktrep tname = trep
where
tcon = mkTyCon3 "" "" tname
trep = mkTyConApp tcon []
#endif
splitPred :: (a -> Bool) -> (a -> Bool) -> [a] -> ([[a]], [a])
splitPred psplit pstop list = splitPred' psplit pstop list []
splitPred' :: (a -> Bool) -> (a -> Bool) -> [a] -> [[a]] -> ([[a]], [a])
splitPred' psplit pstop list acc
| null first = (acc, rest)
| null rest = (acc', [])
| pstop h = (acc', rest)
| otherwise = splitPred' psplit pstop t acc'
where
(first,rest) = break psplit list
(h:t) = rest
acc' = acc ++ [first]