Pattern.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

-- Now specified via --flag=[-]USE_WWW_DEEPSEQ
--- #define USE_WW_DEEPSEQ 1

-------------------------------------------------------------------------------

-- Good idea: Let * be followed by an integer N.
-- This shall have the semantics that, when that node
-- is matched in the pattern, instead of rnf it is forcen N'd.

-- There may be fusion possible (which is worth trying here
-- for practise, even if this lib is not used much):
--
--   forcep p1 . forcep p2 = forcep (unionPat [p1,p2])
--
-- This holds if pattern doesn't contain #, or any (type-)constrained
-- subpatterns -- the latter might work out, if exclude # from them too,
-- but I'm not sure.  With #, we lose even monotonicity, let alone
-- the above law.
--
-- For the above to hold, remember, the union must have exactly
-- the "forcing potential" of the LHS -- no more, no less.

-------------------------------------------------------------------------------

#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.Pattern
-- Copyright   :  (c) 2014, Andrew G. Seniuk
-- License     :  BSD-style (see the file LICENSE)
--
-- Maintainer  :  Andrew Seniuk <rasfar@gmail.com>
-- Stability   :  experimental
-- Portability :  portable
--

-------------------------------------------------------------------------------

  module Control.DeepSeq.Bounded.Pattern

  (

     -- * Pattern datatype

       Pattern, PatNode(..)

--   , patternShapeOK  -- useful for defining instances of NFDataP

     -- * Pattern DSL

  -- | __Grammar__
  --
  -- @
  -- /pat/ /->/ /[/ __=__ /]/ __.__ /[/ __{__ /{/ /pat/ /}/ __}__ /]/
  --     /|/  /(/ /[/ __=__ /]/ __*__ /[/ /decimalint/ /]/ /|/ __#__ /)/
  --     /|/  __.:__ /ctorname/ /{/ /space/ /ctorname/ /}/ __{__ /[/ /{/ /pat/ /}/ /]/ __}__
  --     /|/  /(/ __*__ /[/ /decimalint/ /]/ /|/ __#__ /)/ __:__ /typename/ /{/ /space/ /typename/ /}/ __{}__
  -- /typename/ -> /string/
  -- /ctorname/ -> /string/
  -- /decimalint/ -> /digit string not beginning with zero/
  -- /space/ -> /space character ASCII 0x32/
  -- @
  --
  -- [I regret that Haddock cannot offer better markup for distinguishing
  -- the metasyntax.  The bold is not bold enough.  The alternation symbol,
  -- although \/|\/ in the document comment, does not show as slanted for me.
  -- Had no luck using color, also Unicode support seems pretty sketchy.
  -- Embedding an image is possible via data URL, but this has been known
  -- to crash Haddock except for very small images.]
  --
  -- __Examples__
  --
  -- @".{...}"@ will match any ternary constructor.
  --
  -- @'rnfp' ".{...}" expr@ will force evaluation of @expr@ to a depth of two,
  -- provided the head of @expr@ is a ternary constructor; otherwise it behaves
  -- as @'rnfp' "#" expr@ (i.e. do nothing).
  --
  -- @'rnfp' ".{###}" expr@ will force it to only a depth of one. That is,
  -- @'rnfp' ".{###}" expr = 'rnfp' "." expr@ when the head of @expr@
  -- is a ternary constructor; otherwise it won't perform any evaluation.
  --
  -- @'rnfp' "*" expr = 'rnf' expr@.
  --
  -- @'rnfp' ".{***}" expr@ will 'rnf' (deep) any ternary constructor, but
  -- will not touch any constructor of other arity.
  --
  -- @'rnfp' ".{..{*.}.}" expr@ will match any ternary constructor, then
  -- match the second subexpression constructor if it is binary, and
  -- if matching got this far, then the left sub-subexpression
  -- will be forced ('rnf'), but not the right.
  --
  -- @'rnfp' ".{.*:T{}#}" expr@ will unwrap (shallow 'seq') the first
  -- subexpression of @expr@, and the third subexpression won't be touched.
  -- As for the second subexpression, if its type is @T@ it will be
  -- completely evaluated ('rnf'), but otherwise it won't be touched.
  --
  -- @'rnfp' ".{=**}" expr@ will spark the /parallel/ complete evaluation of
  -- the two components of any pair. (Whether the computations actually
  -- run in parallel depends on resource availability, and the discretion
  -- of the RTS, as usual).
  --
  -- __Details__
  --
  -- The present pattern parser ignores any subpatterns of all
  -- pattern nodes except 'WR', 'TR' and 'PR', optionally emitting a warning.
  -- Hence, only 'WR', 'TR' and 'PR' patterns are potentially recursive.
  --
  -- When specifying a list of subpatterns with 'WR' or 'PR',
  -- in order for the match to succeed, the number of subpatterns must
  -- be equal to the arity of the named constructor.
  --
  -- Type constraints must always be followed by __{__ (opening brace) as delimiter.
  -- In the case of 'TR', if no recursion is desired, provide __{}__.
  -- In order for the match to succeed, the number of subpatterns must either
  -- be zero (__{}__), or be equal to the arity of the named constructor.
  --

     , compilePat
     , showPat

     -- * Why depend on whole containers package, when we only want a rose tree

     , Rose(..)

     -- * Preferred to have this in Seqable, but had cyclical dependency issues

     , SeqNodeKind(..)

  )

  where

-------------------------------------------------------------------------------

#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 ( intersperse )
  import Data.Char ( isDigit )
  import Data.Maybe ( isNothing, fromJust )

  import Debug.Trace ( trace )
#if USE_WW_DEEPSEQ
  -- 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 NFDATA_INSTANCE_PATTERN
  -- for helping trace debugging
  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

-------------------------------------------------------------------------------

  data Rose a = Node a [ Rose a ]
#if NFDATA_INSTANCE_PATTERN
#if DO_DERIVE_DATA_AND_TYPEABLE
   deriving (Show, Eq, GHC.Generic, Data, Typeable)
-- deriving (Show, Eq, Functor, GHC.Generic, Data, Typeable)
#elif DO_DERIVE_ONLY_TYPEABLE
   deriving (Show, Eq, GHC.Generic, Typeable)
#else
   deriving (Show, Eq, GHC.Generic)
#endif
#else
#if DO_DERIVE_DATA_AND_TYPEABLE
   deriving (Show, Eq, Data, Typeable)
#elif DO_DERIVE_ONLY_TYPEABLE
   deriving (Show, Eq, Typeable)
#else
   deriving (Show, Eq)
#endif
#endif
  type Pattern = Rose PatNode

  instance Functor Rose where
    fmap f (Node x chs) = Node (f x) (map (fmap f) chs)

#if NFDATA_INSTANCE_PATTERN
  instance NFData a => NFData (Rose a) where rnf = DSG.genericRnf
#endif

-------------------------------------------------------------------------------

  -- | Note that only 'WR', 'TR' and 'PR' allow for explicit recursion.
  -- The other 'PatNode's are in leaf position when they occur in a 'Pattern'.

  data PatNode
       =
         WR  -- ^ Continue pattern matching descendants.
       | WS  -- ^ Stop recursing (nothing more forced down this branch).
       | WN Int  -- ^ @'rnfn' n@ the branch under this node.
#if USE_WW_DEEPSEQ
       | WW  -- ^ Fully force ('rnf') the whole branch under this node.
#endif
       | WI  -- ^ Don't even unwrap the constructor of this node.
{--} -- XXX It's still unclear whether TI should allow subpatterns;
-- the alternative is for TI, when type doesn't match, to behave
-- as "." (no subpatterns); but since I say "otherwise behave as TR",
-- and TR says "continue pattern matching descendants", this seems to
-- say that subpatterns should be permitted.  Certainly it's no problem
-- to permit subpatterns in this case, but WI should still ignore
-- subpatterns since it will always be # regardless of node type.
-- (Subpatterns ought to be "safely redundant" in this case, but whether
-- they are depends on implementation and needs to be tested if allow
-- WI subpatterns to survive past the parser/compiler!)
--   And this all applies to TW and TN too, right? Yes.
-- It seems clear that TI, TW and TN should all allow subpatterns.
-- And that WI, WW and WN should elide them and issue a warning.
--   But, none of my present woes seem to be connected with this...
-- Nonetheless, it's important to pin down the semantics.
#if 1
       | TR [String]  -- ^ Match any of the types in the list (and continue pattern matching descendants); behave as 'WI' for nodes of type not in the list. (Note this behaviour is the complement of 'TI' behaviour.)
---    | TS [String]  -- ^ Same as 'TR' except no subpatterns present.
       | TN Int [String]  -- ^ @'rnfn' n@ the branch under this node, if the node type matches any of the types in the list.
#if USE_WW_DEEPSEQ
       | TW [String]  -- ^ Fully force ('rnf') the whole branch under this node, if the node type matches any of the types in the list; otherwise behave as 'WI'.
#endif
       | TI [String]  -- ^ Don't even unwrap the constructor of this node, if it's type is in the list; otherwise behave as 'WR'. (Note this behaviour is the complement of 'TR' behaviour.)
#else
       | TR [TypeRep]  -- ...
#endif
#if PARALLELISM_EXPERIMENT
       | PR  -- ^ Spark the pattern matching of this subtree.
       | PN Int  -- ^ Spark @'rnfn' n@ of this subtree.
#if USE_WW_DEEPSEQ
       | PW  -- ^ Spark the full forcing ('rnf') of this subtree.
#endif
#endif
#if NFDATA_INSTANCE_PATTERN
#if DO_DERIVE_DATA_AND_TYPEABLE
       deriving ( Show, Eq, Typeable, Data, GHC.Generic )
#elif DO_DERIVE_ONLY_TYPEABLE
       deriving ( Show, Eq, Typeable, GHC.Generic )
#else
       deriving ( Show, Eq, GHC.Generic )
#endif
#else
#if DO_DERIVE_DATA_AND_TYPEABLE
       deriving ( Show, Eq, Typeable )  -- Data apparently not needed
#elif DO_DERIVE_ONLY_TYPEABLE
       deriving ( Show, Eq, Typeable )
#else
       deriving ( Show, Eq )
#endif
#endif

#if NFDATA_INSTANCE_PATTERN
  instance NFData PatNode where rnf = DSG.genericRnf
#endif

-------------------------------------------------------------------------------

#if 0
  patternShapeOK :: Data a => Pattern -> a -> Bool
  patternShapeOK pat x = S.shapeOf pat == S.shapeOf x
#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

  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 [] 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

  parseInt :: String -> String -> ( Maybe String, String )
  parseInt [] acc = ( if null acc then Nothing else Just acc , "" )
  parseInt s@(c:cs) acc
   | length acc > 8  = error $ "compilePat: * followed by too many (>8) digits"
   | isDigit c       = parseInt cs (acc++[c])
   | otherwise       = ( if null acc then Nothing else Just acc , s )

  -- compilePat' parameters:
  --  spark    - the next node parsed will, when matched, spark parallel
  --             evaluation of its subpatterns
  --  mpn      - says what the last PatNode parsed was (list args are empty)
  --           - what do I mean "list args are empty"?
  --              - oh: T* nodes have a list arg
  --           - I see that mpn is never used (except in some dead code)...
  --  mn       - says what n is for rnfn (eg. 3 for "*3")
  --           - note that, when Just, this signals to parser that * is for
  --             a WN/TN node rather than a WW/TW node
  --  (t:ts)   - the list of type constraints (currently, constructor names)
  --           - empty list doesn't signal anything about whether W* or T* node
  --  (c:cs)   - is what's left of the input string we're parsing
  --  acc      - is an accumulator parameter, collecting patterns parsed
  compilePat' :: Bool -> Maybe PatNode -> Maybe Int -> [String] -> String -> [Pattern] -> ([Pattern], String)
  compilePat' spark mpn mn (t:ts) (c:cs) _
   | not $ c `elem` "{.*#"  = error $ "compilePat: parse error: post-treps pattern char " ++ show c ++ " not one of {.*#"
  compilePat' spark mpn mn [] [] acc = mytrace "EMPTY" $ (acc, [])
  compilePat' spark mpn mn [] (' ':cs) acc = mytrace "space" $ compilePat' spark mpn mn [] cs acc
  compilePat' spark mpn mn [] ('}':'{':cs) acc = error $ "compilePat: opening brace cannot follow closing brace"
  compilePat' spark mpn mn [] ('}':cs) acc
#if 0
        -- Lenient parser tolerates subpatterns of these.
        -- (The semantics is that any such subpatterns are ignored --
        -- discarded with a warning.)
#if USE_WW_DEEPSEQ
   | isJust mpn, Just WW <- mpn  = trace "compilePat-\"}\": warning: * with subpattern" $ mytrace "}" $ (acc, cs)
#endif
   | isJust mpn, Just WI <- mpn  = trace "compilePat-\"}\": warning: # with subpattern" $ mytrace "}" $ (acc, cs)
#endif
   | otherwise  = mytrace "}" $ (acc, cs)
  compilePat' spark mpn mn [] (c:':':cs) acc
   | null treps  = error $ "compilePat: colon must be followed by at least one type name"
   | otherwise   = compilePat' spark mpn mn treps (c:cs') acc
   where
--  !_ = trace ("Boo: " ++ show (treps, cs')) ()
    (treps, cs') = compileTypeReps cs
  compilePat' spark mpn Nothing [] ('@':cs) acc
   | isNothing mn  = error $ "compilePat: internal error @2 (please report this bug!)"
   | otherwise     = compilePat' spark mpn mn [] ('@':cs') acc  -- mn is Just n
   where
--  !_ = trace ("Boo: " ++ show (mn, cs')) ()
    (mn_, cs') = parseInt cs ""
    mn | isNothing mn_  = Nothing
       | otherwise      = Just ( read (fromJust mn_) :: Int )
  compilePat' spark mpn (Just n) [] ('@':cs) acc
   = compilePat' False mpn Nothing [] cs (acc++[node])
#if PARALLELISM_EXPERIMENT
    where node | spark      = Node (PN n) []
               | otherwise  = Node (WN n) []
#else
    where node = Node (WN n) []
#endif
  compilePat' spark mpn (Just n) [] (c:cs) acc
   = error $ "compilePat: internal error @1(" ++ [c] ++") (please report this bug!)"
  compilePat' spark mpn mn treps (c:'{':cs) acc = compilePat' spark mpn mn [] cs' (acc++[node])
   where
    (chs, cs') = mytrace (".{-cs="++cs) $ compilePat' spark mpn mn [] cs []
    node
     | null treps = case c of
        '.' -> mytrace (".{-recurs: "++show chs) $ Node WR chs
        -- Lenient parser tolerates subpatterns of these.
        -- (The semantics is that any such subpatterns are ignored --
        -- discarded with a warning.)
-- It's more convenient to keep the subpatterns, if want to issue
-- a warning when they don't match for type-constrained patterns.
-- True the semantics is the same except for the warning message,
-- but, well, I want to see it at the moment!
#if NEVER_IGNORE_SUBPATTERNS
#if ! WARN_IGNORED_SUBPATTERNS
#if USE_WW_DEEPSEQ
        '*' -> Node WW chs
#endif
        '#' -> Node WI chs
#else
#if USE_WW_DEEPSEQ
        '*' -> trace "compilePat-\"{\": warning: * with subpattern" $ Node WW chs
#endif
        '#' -> trace "compilePat-\"{\": warning: # with subpattern" $ Node WI chs
#endif
#else
#if ! WARN_IGNORED_SUBPATTERNS
#if USE_WW_DEEPSEQ
        '*' -> Node WW []
#endif
        '#' -> Node WI []
#else
#if USE_WW_DEEPSEQ
        '*' -> trace "compilePat-\"{\": warning: * with subpattern" $ Node WW []
#endif
        -- Yes, we do see the error for each test we expect a warning from!
--      '#' -> error "compilePat-\"{\": warning: # with subpattern"
--      '#' -> force $! trace "compilePat-\"{\": warning: # with subpattern" $! Node WI []
        '#' -> trace "compilePat-\"{\": warning: # with subpattern" $ Node WI []
#endif
#endif
        _ -> error $ "compilePat-\"{\": unexpected " ++ show c ++ " (cs'=" ++ cs'
     | otherwise = case c of
        '.' -> mytrace ("T-.{-recurs: "++show chs) $ Node (TR treps) chs
#if NEVER_IGNORE_SUBPATTERNS
#if ! WARN_IGNORED_SUBPATTERNS
#if USE_WW_DEEPSEQ
        '*' -> Node (TW treps) chs
#endif
        '#' -> Node (TI treps) chs
#else
#if USE_WW_DEEPSEQ
        '*' -> trace "compilePat-\"{\": warning: * with subpattern" $ Node (TW treps) chs
#endif
        '#' -> trace "compilePat-\"{\": warning: # with subpattern" $ Node (TI treps) chs
#endif
#else
#if ! WARN_IGNORED_SUBPATTERNS
#if USE_WW_DEEPSEQ
        '*' -> Node (TW treps) []
#endif
        '#' -> Node (TI treps) []
#else
#if USE_WW_DEEPSEQ
        '*' -> trace "compilePat-\"{\": warning: * with subpattern" $ Node (TW treps) []
#endif
        '#' -> trace "compilePat-\"{\": warning: # with subpattern" $ Node (TI treps) []
#endif
#endif
        _ -> error $ "compilePat-T-\"{\": unexpected " ++ show c ++ " (cs'=" ++ cs'
#if PARALLELISM_EXPERIMENT
  compilePat' spark mpn mn treps ('=':cs) acc = compilePat' True mpn mn treps cs acc
#endif
  compilePat' spark mpn mn treps (c:cs) acc = compilePat' False mpn mn [] cs (acc++[node])
--compilePat' spark mpn mn treps (c:cs) acc = compilePat' False mpn mn [] cs $ force (acc++[node])
   where
    node
#if PARALLELISM_EXPERIMENT
     | spark = case c of
        '.' -> mytrace ".:cs" $ Node PR []
#if USE_WW_DEEPSEQ
        '*' -> mytrace "*:cs" $ Node PW []
#endif
        _ -> error $ "compilePat-\"c:cs\"-spark: unexpected " ++ show c ++ " (cs=" ++ cs
#endif
     | null treps = case c of
        '.' -> mytrace ".:cs" $ Node WS []  -- sic!
#if USE_WW_DEEPSEQ
        '*' -> mytrace "*:cs" $ Node WW []
#endif
        '#' -> mytrace "#:cs" $ Node WI []
        _ -> error $ "compilePat-\"c:cs\": unexpected " ++ show c ++ " (cs=" ++ cs
     | otherwise = case c of
        '.' -> mytrace ".:cs" $ Node (TR treps) []
--      '.' -> mytrace ".:cs" $ Node (TS treps) []
#if USE_WW_DEEPSEQ
        '*' -> mytrace "*:cs" $ Node (TW treps) []
#endif
        '#' -> mytrace "#:cs" $ Node (TI treps) []
        _ -> error $ "compilePat-T-\"c:cs\": unexpected " ++ show c ++ " (cs=" ++ cs

-------------------------------------------------------------------------------

  -- | Using String instead of TypeRep since I wasn't sure
  -- how to avoid mandatory recursion to complete the latter.
  -- (Probably it can be done -- ':~:' perhaps -- but I was
  -- unsure and this is working for the moment.)
  compileTypeReps :: String -> ([String], String)
--compileTypeReps :: String -> ([TypeRep], String)
  compileTypeReps cs = (treps,cs')
   where
    (tnames, cs') = parseTyNames cs
    parseTyNames :: String -> ([String], String)
    parseTyNames s = (sps', s')
     where
      sps' = map (dropWhile pstop) sps
--    !_ = trace ("(sps,s') = " ++ show (sps,s')) ()
      (sps,s') = splitPred psplit pstop s
--    (sps,s') = splitPred p s
      pstop x = x == '{' || x == '}'
--    pstop x = x == '{'
      psplit x = x == ' ' || pstop x
--    p x = x == ' ' || x == '{'
--    p x = not $ isAlphaNum x || x == '_' || x == '\''
#if 1
-- XXX In consideration of the recursion problem with mkTyConApp below,
-- try to use typeOf instead -- but, this won't work! Because we are
-- starting with a String encoding the ...
-- ... or will it? We have to compare two strings; one comes from
-- the user-supplied pattern string we're parsing; the other? We
-- are not "comparing equality" here, it will be done later; we're
-- only compiling a pattern...  So if the treps remain strings
-- in a Pattern, until we're ready to make comparisons; it's
-- inefficient unfortunately, but I feel this will work.
--   More detail: B/c when it comes time to match the pattern,
-- you DO have a concrete value (of some type); it is THEN that
-- you apply (show . typeRepTyCon . typeOf) to it, and then
-- make your Eq String comparison. [This can be optimised later;
-- I'm concerned now with a proof-of-concept, without TH.]
    treps = tnames
#else
    treps = map mktrep tnames
-- XXX You need the recursion for (==) to work; that may not mean
-- we can't use it, but will need some form of pattern-matching,
-- as full equality is going to be disfunctional. (B/c user would
-- have to specify the fully-recursive pattern [when they want to
-- use wildcards or stop nodes down there] -- totally ridiculous.)
--   This could be what :~: is for? (It's recursive, but you perhaps
-- can use in patterns without going full depth?)
-- mkTyConApp (mkTyCon3 "base" "Data.Either" "Either") [typeRep (Proxy::Proxy Bool), typeRep (Proxy::Proxy Int)] == typeRep (Proxy :: Proxy (Either Bool Int))
    mktrep :: String -> TypeRep
    mktrep tname = trep
     where
      tcon = mkTyCon3 "" "" tname
      trep = mkTyConApp tcon []
--mkTyCon3 :: 3xString -> TypeCon
--mkTyConApp :: TyCon -> [TypeRep] -> TypeRep
#endif

-------------------------------------------------------------------------------

  -- Split on the psplit predicate, stop consuming the list
  -- on the pstop predicate.
  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  = {-trace "-1-" $-} (acc, rest)
   | null rest   = {-trace "-2-" $-} (acc', [])  -- or (acc, rest), obv.
   | pstop h     = {-trace "-3-" $-} (acc', rest)
   | otherwise   = {-trace "-4-" $-} splitPred' psplit pstop t acc'
   where
    (first,rest) = break psplit list
    (h:t) = rest
    acc' = acc ++ [first]

-------------------------------------------------------------------------------

  -- | Inverse of 'compilePat'.
  --
  -- @'showPat' . 'compilePat' patstring  =  patstring@
  --
  -- provided that @'compilePat' patstring@ succeeds. (And, only up to
  -- subpatterns elided from # ('WI' or 'TI') or from * ('WW', 'WN',
  -- 'TW', 'TN', 'PW' or 'PN') nodes.)
  showPat :: Pattern -> String
  showPat (Node p chs)

    | WR         <- p  = "."  ++ descend chs ++ perhapsEmptyBraces
    | 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 ++ perhapsEmptyBraces
    | PN n       <- p  = error "PN PatNode not yet supported (sorry!)"
#if USE_WW_DEEPSEQ
    | PW         <- p  = "#"  ++ descend chs
#endif
#endif

    | TR treps   <- p  = ".:" ++ descendT treps chs ++ perhapsEmptyBraces
    | 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
    perhapsEmptyBraces = if null chs then "{}" else ""
  descend :: [Pattern] -> String
  descend chs
   | null chs = ""
   | otherwise = "{" ++ concatMap showPat chs ++ "}"
  descendT :: [String] -> [Pattern] -> String
  descendT treps chs = treps_ ++ descend chs
   where treps_ = concat (intersperse " " treps)

-------------------------------------------------------------------------------

  -- Note that Ord is derived, so the order that the constructors
  -- are listed matters!  (This only affects GHC rules, SFAIK.)
  -- (This data type is here, to avoid cyclical imports which
  -- GHC pretty much is useless with.)
  --------
  -- On the one hand, we want to keep this lightweight -- it can in
  -- principle be a single bit (Insulate/Propagate), as originally planned!
  -- But the Spark thing was too useful; and Print and Error would
  -- also be useful.  But they're more orthogonal.
#if 0
  type Spark = Bool
  type PrintPeriod = Int
  type ErrorMsg = String
  data SeqNodeKind =
           Insulate Spark PrintPeriod
         | Conduct Spark PrintPeriod
         | Force Spark PrintPeriod
         | Error ErrorMsg
    deriving ( Eq, Ord )
#else
  data SeqNodeKind =
           Insulate
---      | Conduct
         | Propagate  -- XXX if include Conduct, then rename Propagate to Force
#if PARALLELISM_EXPERIMENT
         | Spark
#endif
-- These would break the Ord; and besides, they're sort of orthogonal
-- (as is Spark)
---      | Print Int
---      | Error String
    deriving ( Eq, Ord )
#endif

-------------------------------------------------------------------------------