Compile_shared_utils.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
#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

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

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

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

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

  module Control.DeepSeq.Bounded.Compile_shared_utils
--- {-# DEPRECATED "Use Wobble instead" #-}
  (

    compileTypeReps  ,
    parseInt  ,

  )
  where

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

  import Data.Char ( isDigit )

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

#if DO_TRACE
  mytrace = trace
#else
  mytrace _ = id
#endif

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

  parseInt :: String -> String -> ( Maybe String, String )
  parseInt [] acc = ( if null acc then Nothing else Just acc , "" )
  parseInt s@(c:cs) acc
-- 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
---    | length acc > 19  = error $ "compilePat: * followed by too many (>19) digits"
--- #else
   | length acc > 9  = error $ "compilePat: * followed by too many (>9) digits"
--- #endif
   | isDigit c        = parseInt cs (acc++[c])
   | otherwise        = ( if null acc then Nothing else Just acc , s )

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

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

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