content: {-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}
  module Util where
  
  import Data.Char(intToDigit)
  import Data.Word(Word8,Word32,Word64)
  import Data.Bits
  import Data.List(sort, sortBy, group, groupBy, nubBy, union, foldl')
  import Data.Bifunctor(first,second)
  import Control.Monad(foldM)
  import Debug.Trace(trace)
  import qualified Data.Set as S
  import qualified Data.Map as M
  -- import Numeric(showHex)
  
  import ErrorUtil(internalError)
  import qualified Log2
  import Sort(sortLe)
  
  -- Note:
  --   There are some list functions in Libs/ListUtil.hs
  --   They could be consolidated with this file.
  
  
  -- =====
  -- Not-to-be-checked-in trace functions
  
  {-
  import System.IO.Unsafe(unsafePerformIO)
  import IO(hPutStr, hFlush, stderr)
  import IOUtil(progArgs)
  
  doTrace = elem "-trace--debug" progArgs
  doTrace2 = length (filter (== "-trace-debug") progArgs) > 1
  doFull = elem "-trace-full" progArgs
  
  tracex s x = if doTrace then traces s x else x
  tracex2 s x = if doTrace2 then traces s x else x
  
  traceChars :: String -> a -> a
  traceChars cs x = unsafePerformIO (hPutStr stderr cs >> hFlush stderr >> return x)
  -}
  
  -- =====
  -- Common trace functions used in other modules
  
  traces :: String -> a -> a
  traces s x = if s==s then trace s x else internalError "Util.traces"
  
  tracep :: Bool -> String -> p -> p
  tracep p s x = if p then traces s x else x
  
  -- lets you peek at the answer to a computation
  -- e.g. "trace_answer (\x -> "answer is " ++ (show x)) (2+2)
  trace_answer :: (a -> String) -> a -> a
  trace_answer format x =
     trace (format x) $ x
  
  -- =====
  -- Configurable traces
  -- (currently only used in Id and XRef)
  
  dbgLevel :: Int
  dbgLevel = -1
  
  -- =====
  -- Internal compiler assertions
  
  assert :: Bool -> [Char] -> p -> p
  assert True msg v = v
  assert False msg v = internalError ("assertion failed: "++msg)
  
  
  -- =====
  -- String utilities
  
  quote :: String -> String
  quote s = "`" ++ s ++ "'"
  
  doubleQuote :: String -> String
  doubleQuote s = "\"" ++ s ++ "\""
  
  
  unwordsAnd, unwordsOr :: [String] -> String
  unwordsAnd = unwordsx "and"
  unwordsOr = unwordsx "or"
  
  unwordsx :: String -> [String] -> String
  unwordsx _ [] = ""
  unwordsx _ [x] = x
  unwordsx s [x1, x2] = unwords [x1, s, x2]
  unwordsx s xs = unwordsWith ", " (init xs++[s++" "++last xs])
  
  unwordsWith :: String -> [String] -> String
  unwordsWith d [] = ""
  unwordsWith d [x] = x
  unwordsWith d (x:xs) = x++d++unwordsWith d xs
  
  readOrErr :: (Read a) => String -> String -> a
  readOrErr err s = fst $ headOrErr err $ reads s
  
  -- =====
  -- ToString class
  
  class ToString a where
      to_string :: a -> String
      itos :: a -> String
  
  instance ToString Int where
      itos a = show a
      to_string a = internalError ("to_string applied to nonsymbol (Int) "
                                      ++ show a)
  
  instance ToString Integer where
      itos a = show a
      to_string a = internalError ("to_string applied to nonsymbol (Integer) "
                                      ++ show a)
  
  instance ToString Char where
      itos a = show a
      to_string a = case a of
          '\n' -> "\\n"
          '\r' -> "\\r"
          '\t' -> "\\t"
          '\a' -> "\\a"
          '\\' -> "\\\\"
          '"' -> "\\\""        -- backslash double-quote
          _ | n < 0 ||
              n > 0x100 -> internalError "quoting a character value " ++ show n
          _ | n < 0x20 || n >= 0x7F ->
              [ '\\', intToDigit highest, intToDigit middle, intToDigit lowest ]
          _ -> [a]
        where
          n = fromEnum a
          (top2, lowest) = quotRem n 8
          (highest, middle) = quotRem top2 8
  
  instance ToString String where
      itos a = internalError "itos applied to string" ++ show a
      to_string a = concatMap to_string a
  
  to_quoted_string :: ToString a => a -> String
  to_quoted_string s = "\"" ++ to_string s ++ "\""
  
  
  -- =====
  -- List utilities
  
  headOrErr :: String -> [elem] -> elem
  headOrErr _   (elt:_) = elt
  headOrErr err []      = internalError err
  
  tailOrErr :: String -> [elem] -> [elem]
  tailOrErr _   (_:rest) = rest
  tailOrErr err []       = internalError err
  
  initOrErr :: String -> [elem] -> [elem]
  initOrErr _   [x]    = []
  initOrErr err (x:xs) = x : initOrErr err xs
  initOrErr err []     = internalError err
  
  lastOrErr :: String -> [elem] -> elem
  lastOrErr _   [x]    = x
  lastOrErr err (_:xs) = lastOrErr err xs
  lastOrErr err []     = internalError err
  
  unconsOrErr :: String -> [elem] -> (elem, [elem])
  unconsOrErr _   (elt:rest) = (elt, rest)
  unconsOrErr err []         = internalError err
  
  take2OrErr :: String -> [elem] -> (elem, elem)
  take2OrErr _ (x1:x2:_) = (x1, x2)
  take2OrErr err _ = internalError err
  
  take3OrErr :: String -> [elem] -> (elem, elem, elem)
  take3OrErr _ (x1:x2:x3:_) = (x1, x2, x3)
  take3OrErr err _ = internalError err
  
  rTake, rDrop :: Int -> [a] -> [a]
  rTake n = reverse . take n . reverse
  rDrop n = reverse . drop n . reverse
  
  unions :: (Foldable t, Eq a) => t [a] -> [a]
  unions l = foldr union [] l
  
  concatMapM :: (Monad m) => (a -> m [b]) -> [a] -> m [b]
  concatMapM f as = do
    temp <- mapM f as
    return (concat temp)
  
  -- Haskell Prelude definition says that this is the same as "any (eq x)"
  elemBy                        :: (a -> a -> Bool) -> a -> [a] -> Bool
  elemBy eq _ []                = False
  elemBy eq x (y:ys)        = eq x y || elemBy eq x ys
  
  findSame :: (Ord a) => [a] -> [[a]]
  findSame = filter ((>1) . length) . group . sort
  
  findSameBy :: (a -> a -> Ordering) -> (a -> a -> Bool) -> [a] -> [[a]]
  findSameBy sortFn groupFn =
      filter ((>1) . length) . (groupBy groupFn) . (sortBy sortFn)
  
  toMaybe :: Bool -> a -> Maybe a
  toMaybe False _ = Nothing
  toMaybe True a = Just a
  
  -- A O(n^2) function to find duplicate entries in a list
  -- appears to find the first duplicated entry and then return it as a list
  findDup :: (Eq a) => [a] -> [a]
  findDup [] = []
  findDup (x:xs) =
      case filter (== x) xs of
      [] -> findDup xs
      xs' -> x:xs'
  
  sortGroup :: (a->a->Bool) -> [a] -> [[a]]
  sortGroup le = groupBy (\x y-> le x y && le y x) . sortLe le
  
  mergeWithCmp ::  (a -> a -> Ordering) -> (a -> a -> a) -> [a] -> [a] -> [a]
  mergeWithCmp _  _ xs [] = xs
  mergeWithCmp _  _ [] ys = ys
  mergeWithCmp cmp f xxs@(x:xs) yys@(y:ys) =
      case x `cmp` y of
          EQ -> f x y : mergeWithCmp cmp f xs ys
          LT -> x : mergeWithCmp cmp f xs yys
          GT -> y : mergeWithCmp cmp f xxs ys
  
  isOrdSubset :: (Ord a) => [a] -> [a] -> Bool
  isOrdSubset [] _  = True
  isOrdSubset _  [] = False
  isOrdSubset xxs@(x:xs) (y:ys) =
      case compare x y of
      LT -> False
      EQ -> isOrdSubset xs ys
      GT -> isOrdSubset xxs ys
  
  remOrdDup :: (Eq a) => [a] -> [a]
  remOrdDup (x:xxs@(x':_)) | x == x' = remOrdDup xxs
  remOrdDup (x:xs) = x : remOrdDup xs
  remOrdDup [] = []
  
  mergeOrdNoDup :: (Ord a) => [a] -> [a] -> [a]
  mergeOrdNoDup xxs@(x:xs) yys@(y:ys) =
      case compare x y of
      LT -> x : mergeOrdNoDup xs yys
      GT -> y : mergeOrdNoDup xxs ys
      EQ -> x : mergeOrdNoDup xs ys
  mergeOrdNoDup []         yys = yys
  mergeOrdNoDup xxs        []  = xxs
  
  -- removes duplicates faster than nub
  -- by using a sorted set (so it reorders elements)
  fastNub :: (Ord a) => [a] -> [a]
  fastNub = S.toList . S.fromList
  
  -- if you intend to sort and nub, you can be more efficient
  nubSort :: (Ord a) => [a] -> [a]
  nubSort = map head . group . sort
  
  stableOrdNub :: (Ord a) => [a] -> [a]
  stableOrdNub = stableOrdNub' S.empty
    where stableOrdNub' _ [] = []
          stableOrdNub' s (a:as)
            | a `S.member` s  = stableOrdNub' s as
            | otherwise = a : stableOrdNub' (S.insert a s) as
  
  -- =====
  -- Boolean List utilities
  
  boolCompress :: [Bool] -> [a] -> [a]
  boolCompress [] _  = []
  boolCompress _  [] = []
  boolCompress (True:bs) (x:xs) = x : boolCompress bs xs
  boolCompress (False:bs) (x:xs) = boolCompress bs xs
  
  anySame :: (Ord a) => [a] -> Bool
  anySame = same . sort
          where same (x:xs@(x':_)) = x == x' || same xs
                same _ = False
  
  allSame :: (Eq a) => [a] -> Bool
  allSame [] = True
  allSame (x:xs) = all (==x) xs
  
  
  -- =====
  -- List/Tuple utilities
  
  unzipWith :: (a -> (b,c)) -> [a] -> ([b], [c])
  unzipWith f l = unzip (map f l)
  
  concatUnzipMap :: (a -> ([b],[c])) -> [a] -> ([b],[c])
  concatUnzipMap f zs =
          let (xss, yss) = unzip (map f zs)
          in  (concat xss, concat yss)
  
  concatUnzip :: [([a],[b])] -> ([a],[b])
  concatUnzip xys =
      let (xss, yss) = unzip xys
      in  (concat xss, concat yss)
  
  concatUnzip3 :: [([a],[b],[c])] -> ([a],[b],[c])
  concatUnzip3 xyzs =
      let (xss, yss, zss) = unzip3 xyzs
      in  (concat xss, concat yss, concat zss)
  
  mapFst :: Functor f => (a -> b) -> f (a, c) -> f (b, c)
  mapFst = fmap . first
  
  mapSnd :: Functor f => (a -> b) -> f (c, a) -> f (c, b)
  mapSnd = fmap . second
  
  mapThd :: (t -> c) -> [(a, b, t)] -> [(a, b, c)]
  mapThd f xyzs = [(x, y, f z) | (x, y, z) <- xyzs]
  
  joinByFst :: (Ord a) => [(a, b)] -> [(a, [b])]
  joinByFst =
    let joinSameFirst xys@((x,_):_) = (x, map snd xys)
        joinSameFirst _ = internalError "joinByFst"
    in
      map joinSameFirst .
      groupBy (\ (x,_) (y,_) -> x==y) .
      sortBy (\ (x,_) (y,_) -> x `compare` y)
  
  mergeWith :: (Ord b) => (a -> a -> a) -> [(b, a)] -> [(b, a)] -> [(b, a)]
  mergeWith f = mergeWithCmp cmpFst f'
      where f' (k,v) (_,v') = (k, v `f` v')
  
  flattenPairs :: [(a,a)] -> [a]
  flattenPairs [] = []
  flattenPairs ((x,y):xys) = x:y:flattenPairs xys
  
  makePairs :: [a] -> [(a,a)]
  makePairs [] = []
  makePairs (x:y:xs) = (x, y) : makePairs xs
  makePairs _ = internalError "Util.makePairs: failed"
  
  -- all pairs except pairs of an item with itself
  allPairs :: [a] -> [(a, a)]
  allPairs [] = []
  allPairs (x:xs) = concat [[(x,x'), (x',x)] | x' <- xs] ++ allPairs xs
  
  -- all unique pairs -- i.e. only one of (x,y) and (y,x)
  uniquePairs :: [a] -> [(a, a)]
  uniquePairs [] = []
  uniquePairs (x:ys) = [(x,y) | y <- ys] ++ uniquePairs ys
  
  -- all pairs of an item with itself
  selfPairs :: [a] -> [(a, a)]
  selfPairs xs = [(x, x) | x <- xs ]
  
  mapFstM :: (Monad m) => (a -> m c) -> [(a, b)] -> m [(c, b)]
  mapFstM f xs = mapM f' xs
    where f' (a, b) = f a >>= \ c -> return (c, b)
  
  mapSndM :: (Monad m) => (b -> m c) -> [(a, b)] -> m [(a, c)]
  mapSndM f xs = mapM f' xs
    where f' (a, b) = f b >>= \ c -> return (a, c)
  
  appFstM :: (Monad m) => (a -> m c) -> (a, b) -> m (c , b)
  appFstM f (a, b) = do c <- f a
                        return (c, b)
  
  nubByFst :: (Eq a) => [(a, b)] -> [(a, b)]
  nubByFst xs = nubBy f xs
    where f a b = (fst a == fst b)
  
  sortPair :: (Ord a) => (a, a) -> (a, a)
  sortPair (x, y) = if (y < x) then (y, x) else (x, y)
  
  -- =====
  -- List/Either utilities
  
  checkEither :: [Either a b] -> Either [a] [b]
  checkEither xs = f xs [] []
          where f [] [] rs = Right (reverse rs)
                f [] ls _  = Left  (reverse ls)
                f (Left l :xs) ls rs = f xs (l:ls) rs
                f (Right r:xs) ls rs = f xs ls (r:rs)
  
  separate :: [Either a b] -> ([a],[b])
  separate abs =
      let f (Left a)  (as, bs) = (a:as,   bs)
          f (Right b) (as, bs) = (  as, b:bs)
      in  foldr f ([],[]) abs
  
  
  -- =====
  -- List/Maybe utilities
  
  fromJustOrErr :: String -> Maybe value -> value
  fromJustOrErr err Nothing  = internalError err
  fromJustOrErr _   (Just v) = v
  
  
  -- =====
  -- Tuple utilities
  
  pair :: a -> b -> (a, b)
  pair x y = (x, y)
  
  swap :: (b, a) -> (a, b)
  swap (x,y) = (y,x)
  
  apFst :: (t -> a) -> (t, b) -> (a, b)
  apFst f (x, y) = (f x, y)
  
  apSnd :: (t -> b) -> (a, t) -> (a, b)
  apSnd f (x, y) = (x, f y)
  
  fst3 :: (a, b, c) -> a
  fst3 (x,_,_) = x
  snd3 :: (a, b, c) -> b
  snd3 (_,x,_) = x
  thd :: (a, b, c) -> c
  thd (_,_,x) = x
  
  fst2of3 :: (a, b, c) -> (a, b)
  fst2of3 (x,y,_) = (x,y)
  
  fth4 :: (a, b, c, d) -> d
  fth4 (_,_,_,x) = x
  fst2of4 :: (a, b, c, d) -> (a, b)
  fst2of4 (x,y,_,_) = (x,y)
  fst3of4 :: (a, b, c, d) -> (a, b, c)
  fst3of4 (x,y,z,_) = (x,y,z)
  
  ordPair :: Ord a => (a, a) -> (a, a)
  ordPair (x,y) = if x < y then (x,y) else (y,x)
  
  ordPairBy :: (a -> a -> Ordering) -> (a, a) -> (a, a)
  ordPairBy cmp (x, y) = case (cmp x y) of
                           LT -> (x, y)
                           _  -> (y, x)
  
  cmpFst :: Ord x => (x,y) -> (x,y) -> Ordering
  cmpFst (a,_) (b,_) = compare a b
  
  cmpSnd :: Ord y => (x,y) -> (x,y) -> Ordering
  cmpSnd (_,a) (_,b) = compare a b
  
  eqFst :: Eq x => (x,y) -> (x,y) -> Bool
  eqFst (a,_) (b,_) = a == b
  
  eqSnd :: Eq y => (x,y) -> (x,y) -> Bool
  eqSnd (_,a) (_,b) = a == b
  
  
  -- =====
  -- Maybe utilities
  
  fromMaybeM :: (Monad m) => m a -> m (Maybe a) -> m a
  fromMaybeM def m = do
    mres <- m
    case mres of
      Nothing -> def
      Just res -> return res
  
  -- =====
  -- Either utilities
  
  apLeft :: (a -> c) -> Either a b -> Either c b
  apLeft f (Left x)  = Left (f x)
  apLeft f (Right x) = Right x
  
  apRight :: (b -> c) -> Either a b -> Either a c
  apRight f (Left x)  = Left x
  apRight f (Right x) = Right (f x)
  
  doLeft :: (a -> Either c b) -> Either a b -> Either c b
  doLeft f (Left x)  = f x
  doLeft f (Right x) = Right x
  
  doRight :: (b -> Either a c) -> Either a b -> Either a c
  doRight f (Left x)  = Left x
  doRight f (Right x) = f x
  
  isLeft :: Either a b -> Bool
  isLeft (Left _) = True
  isLeft _        = False
  
  isRight :: Either a b -> Bool
  isRight (Right _) = True
  isRight  _        = False
  
  -- =====
  -- Data.Map utilities
  
  map_insertMany :: (Ord k) => [(k,a)] -> M.Map k a -> M.Map k a
  map_insertMany kas m =
     foldr (uncurry M.insert) m kas
  
  map_insertManyWith :: (Ord k) =>
                        (a -> a -> a) -> [(k,a)] -> M.Map k a -> M.Map k a
  map_insertManyWith fn kas m =
     -- The choice of "foldr" is to match old OrdMap behavior
     foldr (uncurry (M.insertWith fn)) m kas
  
  map_deleteMany :: (Ord k) => [k] -> M.Map k a -> M.Map k a
  map_deleteMany ks m =
     foldr M.delete m ks
  
  -- XXX this is probably inefficient; try using M.mapAccum
  map_mapM :: (Ord k, Monad m) => (a -> m b) -> M.Map k a -> m (M.Map k b)
  map_mapM fn m = mapSndM fn (M.toList m) >>= return . M.fromList
  
  map_unionsWithM :: (Ord k, Monad m) =>
                     (a -> a -> m a) -> [M.Map k a] -> m (M.Map k a)
  map_unionsWithM fn [] = return M.empty
  map_unionsWithM fn [m] = return m
  map_unionsWithM fn (m:ms) = foldM (map_unionWithM fn) m ms
  
  map_unionWithM :: (Ord k, Monad m) =>
                    (a -> a -> m a) -> M.Map k a -> M.Map k a -> m (M.Map k a)
  map_unionWithM fn m1 m2 = map_insertManyWithM fn (M.toList m2) m1
  
  map_insertWithM :: (Ord k, Monad m) =>
                     (a -> a -> m a) -> k -> a -> M.Map k a -> m (M.Map k a)
  map_insertWithM fn k a m =
      case (M.lookup k m) of
        Nothing -> return $ M.insert k a m
        Just b  -> do c <- fn a b
                      return $ M.insert k c m
  
  map_insertManyWithM :: (Ord k, Monad m) =>
                         (a -> a -> m a) -> [(k, a)] -> M.Map k a -> m (M.Map k a)
  map_insertManyWithM fn kas m =
      let insertOne m' (k, a) = map_insertWithM fn k a m'
      in  foldM insertOne m kas
  
  map_insertWithKeyM ::
      (Ord k, Monad m) =>
      (k -> a -> a -> m a) -> k -> a -> M.Map k a -> m (M.Map k a)
  map_insertWithKeyM fn k a m =
      case (M.lookup k m) of
        Nothing -> return $ M.insert k a m
        Just b  -> do c <- fn k a b
                      return $ M.insert k c m
  
  map_insertManyWithKeyM ::
      (Ord k, Monad m) =>
      (k -> a -> a -> m a) -> [(k, a)] -> M.Map k a -> m (M.Map k a)
  map_insertManyWithKeyM fn kas m =
      let insertOne m' (k, a) = map_insertWithKeyM fn k a m'
      in  foldM insertOne m kas
  
  -- =====
  -- Data.Set utilities
  
  set_insertMany :: (Ord a) => [a] -> S.Set a -> S.Set a
  set_insertMany as m = foldr S.insert m as
  
  set_deleteMany :: (Ord a) => [a] -> S.Set a -> S.Set a
  set_deleteMany as m = foldr S.delete m as
  
  set_intersectMany :: (Ord a) => [S.Set a] -> S.Set a
  set_intersectMany [] = S.empty
  set_intersectMany ms = foldr1 S.intersection ms
  
  -- =====
  -- Numeric utilities
  
  log2 :: (Integral a, Integral b) => a -> b
  log2 = Log2.log2
  
  divC :: Integer -> Integer -> Integer
  divC x y = (x+y-1) `div` y
  
  integerToBits :: Integer -> Integer -> [Integer]
  integerToBits 0 0 = []
  integerToBits 0 n = internalError "integerToBits"
  integerToBits n i = integerToBits (n-1) q ++ [r]
    where (q, r) = i `quotRem` 2
  
  integerSqrt :: Integer -> Maybe Integer
  integerSqrt n =
      let n' :: Float
          n' = fromInteger n
          candidate :: Integer
          candidate = floor (sqrt n')
      in  if (candidate * candidate == n)
          then Just candidate
          else Nothing
  
  -- =====
  
  -- Is a character whitespace? (SV 3.1a LRM A.9.4)
  -- (Note that Verilog 2001 LRM section 2.2 -- but not its grammar -- also has \f)
  
  isWhitespace :: Char -> Bool
  isWhitespace ' ' = True
  isWhitespace '\t' = True
  isWhitespace '\n' = True
  isWhitespace '\f' = True
  isWhitespace '\r' = True
  isWhitespace _ = False
  
  
  -- =========================
  -- A computational simple hash
  -- 4000000063 and 1442968193 are large primes that fit in 32 bits
  
  data Hash = Hash !Word32 !Word32
  
  hashInit :: Hash
  hashInit = Hash 0 4000000063
  
  -- showpair (x,y) = "(" ++ (showHex x ("," ++ (showHex y ")")))
  
  nextHash :: Hash -> [Word8] -> Hash
  nextHash h s = foldl' f h s
      where f :: Hash -> Word8 -> Hash
            f (Hash x y) c =
                let y' = (rotate x 5) + (toEnum (fromEnum c))
                    x' = y + y' + 1442968193
                in Hash x' y'
  
  nextHash32 :: Hash -> Word32 -> Hash
  nextHash32 (Hash x y) n =
      let y' = (rotate x 20) + n
          x' = y + y' + 1442968193
      in Hash x' y'
  
  nextHash64 :: Hash -> Word64 -> Hash
  nextHash64 h n =
      let (hi,lo) = n `quotRem` (2^(32::Int))
      in nextHash32 (nextHash32 h (fromIntegral lo)) (fromIntegral hi)
  
  hashValue :: Hash -> Word64
  hashValue (Hash x y) = ((fromIntegral x) `shiftL` 32) .|. (fromIntegral y)
  
  showHash :: Hash -> String
  showHash h = show (hashValue h)
  