{-|
  Copyright   :  (C) 2012-2016, University of Twente
  License     :  BSD2 (see the file LICENSE)
  Maintainer  :  Christiaan Baaij <christiaan.baaij@gmail.com>

  Assortment of utility function used in the Clash library
-}

{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}

{-# OPTIONS_GHC -fno-warn-orphans #-}

module Clash.Util
  ( module Clash.Util
  , module X
  , makeLenses
  , SrcSpan
  , noSrcSpan
  , HasCallStack
  )
where

import Control.Applicative            as X (Applicative,(<$>),(<*>),pure)
import Control.Arrow                  as X ((***),(&&&),first,second)
import qualified Control.Exception    as Exception
import Control.Monad                  as X ((<=<),(>=>))
import Control.Monad.State            (MonadState,State,StateT,runState)
import qualified Control.Monad.State  as State
import Data.Typeable                  (Typeable)
import Data.Function                  as X (on)
import Data.Hashable                  (Hashable)
import Data.HashMap.Lazy              (HashMap)
import qualified Data.HashMap.Lazy    as HashMapL
import Data.Maybe                     (fromMaybe, listToMaybe, catMaybes)
import Data.Text.Prettyprint.Doc
import Data.Text.Prettyprint.Doc.Render.String
import Data.Version                   (Version)
import qualified Data.Time.Format     as Clock
import qualified Data.Time.Clock      as Clock
import Data.Time.Clock                (UTCTime)
import Control.Lens
import Debug.Trace                    (trace)
import GHC.Base                       (Int(..),isTrue#,(==#),(+#))
import GHC.Integer.Logarithms         (integerLogBase#)
import qualified GHC.LanguageExtensions.Type as LangExt
import GHC.Stack                      (HasCallStack, callStack, prettyCallStack)
import Type.Reflection                (tyConPackage, typeRepTyCon, typeOf)
import qualified Language.Haskell.TH  as TH

import SrcLoc                         (SrcSpan, noSrcSpan)
import Clash.Unique

#ifdef CABAL
import qualified Paths_clash_lib      (version)
#endif

data ClashException = ClashException SrcSpan String (Maybe String)

instance Show ClashException where
  show :: ClashException -> String
show (ClashException _ s :: String
s eM :: Maybe String
eM) = String
s String -> ShowS
forall a. [a] -> [a] -> [a]
++ "\n" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String -> ShowS -> Maybe String -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe "" ShowS
forall a. a -> a
id Maybe String
eM

instance Exception.Exception ClashException

assertPanic
  :: String -> Int -> a
assertPanic :: String -> Int -> a
assertPanic file :: String
file ln :: Int
ln = ClashException -> a
forall a e. Exception e => e -> a
Exception.throw
  (SrcSpan -> String -> Maybe String -> ClashException
ClashException SrcSpan
noSrcSpan ("ASSERT failed! file " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
file String -> ShowS
forall a. [a] -> [a] -> [a]
++ ", line " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
ln) Maybe String
forall a. Maybe a
Nothing)

assertPprPanic
  :: HasCallStack => String -> Int -> Doc ann -> a
assertPprPanic :: String -> Int -> Doc ann -> a
assertPprPanic _file :: String
_file _line :: Int
_line msg :: Doc ann
msg = String -> Doc ann -> a
forall ann a. String -> Doc ann -> a
pprPanic "ASSERT failed!" Doc ann
doc
 where
  doc :: Doc ann
doc = [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
sep [ Doc ann
msg, Doc ann
forall ann. HasCallStack => Doc ann
callStackDoc ]

pprPanic
  :: String -> Doc ann -> a
pprPanic :: String -> Doc ann -> a
pprPanic heading :: String
heading prettyMsg :: Doc ann
prettyMsg = ClashException -> a
forall a e. Exception e => e -> a
Exception.throw
  (SrcSpan -> String -> Maybe String -> ClashException
ClashException SrcSpan
noSrcSpan (SimpleDocStream ann -> String
forall ann. SimpleDocStream ann -> String
renderString (LayoutOptions -> Doc ann -> SimpleDocStream ann
forall ann. LayoutOptions -> Doc ann -> SimpleDocStream ann
layoutPretty LayoutOptions
defaultLayoutOptions Doc ann
doc)) Maybe String
forall a. Maybe a
Nothing)
 where
  doc :: Doc ann
doc = [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
sep [String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty String
heading, Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
nest 2 Doc ann
prettyMsg]

callStackDoc
  :: HasCallStack => Doc ann
callStackDoc :: Doc ann
callStackDoc =
  "Call stack:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
hang 4
    ([Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vcat ((String -> Doc ann) -> [String] -> [Doc ann]
forall a b. (a -> b) -> [a] -> [b]
map String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (String -> [String]
lines (CallStack -> String
prettyCallStack CallStack
HasCallStack => CallStack
callStack))))

warnPprTrace
  :: HasCallStack
  => Bool
  -- ^ Trigger warning?
  -> String
  -- ^ File name
  -> Int
  -- ^ Line number
  -> Doc ann
  -- ^ Message
  -> a
  -- ^ Pass value (like trace)
  -> a
warnPprTrace :: Bool -> String -> Int -> Doc ann -> a -> a
warnPprTrace _     _ _ _ x :: a
x | Bool -> Bool
not Bool
debugIsOn = a
x
warnPprTrace False _ _ _ x :: a
x = a
x
warnPprTrace True  file :: String
file ln :: Int
ln msg :: Doc ann
msg x :: a
x =
  (String -> a -> a) -> Doc ann -> Doc ann -> a -> a
forall a ann. (String -> a) -> Doc ann -> Doc ann -> a
pprDebugAndThen String -> a -> a
forall a. String -> a -> a
trace ([Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vcat [Doc ann
forall ann. Doc ann
heading0, Doc ann
forall ann. Doc ann
heading1]) Doc ann
msg a
x
 where
  heading0 :: Doc ann
heading0 = [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
hsep ["WARNING: file", String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty String
file Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
comma, "line", Int -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Int
ln]
  heading1 :: Doc ann
heading1 = "WARNING CALLSTACK:" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
line Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (CallStack -> String
prettyCallStack CallStack
HasCallStack => CallStack
callStack)

pprTrace
  :: String -> Doc ann -> a -> a
pprTrace :: String -> Doc ann -> a -> a
pprTrace str :: String
str = (String -> a -> a) -> Doc ann -> Doc ann -> a -> a
forall a ann. (String -> a) -> Doc ann -> Doc ann -> a
pprDebugAndThen String -> a -> a
forall a. String -> a -> a
trace (String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty String
str)

pprTraceDebug
  :: String -> Doc ann -> a -> a
pprTraceDebug :: String -> Doc ann -> a -> a
pprTraceDebug str :: String
str doc :: Doc ann
doc x :: a
x
  | Bool
debugIsOn = (String -> a -> a) -> Doc ann -> Doc ann -> a -> a
forall a ann. (String -> a) -> Doc ann -> Doc ann -> a
pprDebugAndThen String -> a -> a
forall a. String -> a -> a
trace (String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty String
str) Doc ann
doc a
x
  | Bool
otherwise = a
x

pprDebugAndThen
  :: (String -> a) -> Doc ann -> Doc ann -> a
pprDebugAndThen :: (String -> a) -> Doc ann -> Doc ann -> a
pprDebugAndThen cont :: String -> a
cont heading :: Doc ann
heading prettyMsg :: Doc ann
prettyMsg =
  String -> a
cont (SimpleDocStream ann -> String
forall ann. SimpleDocStream ann -> String
renderString (LayoutOptions -> Doc ann -> SimpleDocStream ann
forall ann. LayoutOptions -> Doc ann -> SimpleDocStream ann
layoutPretty LayoutOptions
defaultLayoutOptions Doc ann
doc))
 where
  doc :: Doc ann
doc = [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
sep [Doc ann
heading, Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
nest 2 Doc ann
prettyMsg]

-- | A class that can generate unique numbers
class Monad m => MonadUnique m where
  -- | Get a new unique
  getUniqueM :: m Int

instance Monad m => MonadUnique (StateT Int m) where
  getUniqueM :: StateT Int m Int
getUniqueM = do
    Int
supply <- StateT Int m Int
forall s (m :: Type -> Type). MonadState s m => m s
State.get
    (Int -> Int) -> StateT Int m ()
forall s (m :: Type -> Type). MonadState s m => (s -> s) -> m ()
State.modify (Int -> Int -> Int
forall a. Num a => a -> a -> a
+1)
    Int -> StateT Int m Int
forall (m :: Type -> Type) a. Monad m => a -> m a
return Int
supply

-- | Create a TH expression that returns the a formatted string containing the
-- name of the module 'curLoc' is spliced into, and the line where it was spliced.
curLoc :: TH.Q TH.Exp
curLoc :: Q Exp
curLoc = do
  (TH.Loc _ _ modName :: String
modName (startPosL :: Int
startPosL,_) _) <- Q Loc
TH.location
  Lit -> Q Exp
TH.litE (String -> Lit
TH.StringL (String -> Lit) -> String -> Lit
forall a b. (a -> b) -> a -> b
$ String
modName String -> ShowS
forall a. [a] -> [a] -> [a]
++ "(" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
startPosL String -> ShowS
forall a. [a] -> [a] -> [a]
++ "): ")

-- | Cache the result of a monadic action
makeCached :: (MonadState s m, Hashable k, Eq k)
           => k -- ^ The key the action is associated with
           -> Lens' s (HashMap k v) -- ^ The Lens to the HashMap that is the cache
           -> m v -- ^ The action to cache
           -> m v
makeCached :: k -> Lens' s (HashMap k v) -> m v -> m v
makeCached key :: k
key l :: Lens' s (HashMap k v)
l create :: m v
create = do
  HashMap k v
cache <- Getting (HashMap k v) s (HashMap k v) -> m (HashMap k v)
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
use Getting (HashMap k v) s (HashMap k v)
Lens' s (HashMap k v)
l
  case k -> HashMap k v -> Maybe v
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMapL.lookup k
key HashMap k v
cache of
    Just value :: v
value -> v -> m v
forall (m :: Type -> Type) a. Monad m => a -> m a
return v
value
    Nothing -> do
      v
value <- m v
create
      (HashMap k v -> Identity (HashMap k v)) -> s -> Identity s
Lens' s (HashMap k v)
l ((HashMap k v -> Identity (HashMap k v)) -> s -> Identity s)
-> (HashMap k v -> HashMap k v) -> m ()
forall s (m :: Type -> Type) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= k -> v -> HashMap k v -> HashMap k v
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HashMapL.insert k
key v
value
      v -> m v
forall (m :: Type -> Type) a. Monad m => a -> m a
return v
value

-- | Cache the result of a monadic action using a 'UniqMap'
makeCachedU
  :: (MonadState s m, Uniquable k)
  => k
  -- ^ Key the action is associated with
  -> Lens' s (UniqMap v)
  -- ^ Lens to the cache
  -> m v
  -- ^ Action to cache
  -> m v
makeCachedU :: k -> Lens' s (UniqMap v) -> m v -> m v
makeCachedU key :: k
key l :: Lens' s (UniqMap v)
l create :: m v
create = do
  UniqMap v
cache <- Getting (UniqMap v) s (UniqMap v) -> m (UniqMap v)
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
use Getting (UniqMap v) s (UniqMap v)
Lens' s (UniqMap v)
l
  case k -> UniqMap v -> Maybe v
forall a b. Uniquable a => a -> UniqMap b -> Maybe b
lookupUniqMap k
key UniqMap v
cache of
    Just value :: v
value -> v -> m v
forall (m :: Type -> Type) a. Monad m => a -> m a
return v
value
    Nothing -> do
      v
value <- m v
create
      (UniqMap v -> Identity (UniqMap v)) -> s -> Identity s
Lens' s (UniqMap v)
l ((UniqMap v -> Identity (UniqMap v)) -> s -> Identity s)
-> (UniqMap v -> UniqMap v) -> m ()
forall s (m :: Type -> Type) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= k -> v -> UniqMap v -> UniqMap v
forall a b. Uniquable a => a -> b -> UniqMap b -> UniqMap b
extendUniqMap k
key v
value
      v -> m v
forall (m :: Type -> Type) a. Monad m => a -> m a
return v
value

-- | Run a State-action using the State that is stored in a higher-layer Monad
liftState :: (MonadState s m)
          => Lens' s s' -- ^ Lens to the State in the higher-layer monad
          -> State s' a -- ^ The State-action to perform
          -> m a
liftState :: Lens' s s' -> State s' a -> m a
liftState l :: Lens' s s'
l m :: State s' a
m = do
  s'
s <- Getting s' s s' -> m s'
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
use Getting s' s s'
Lens' s s'
l
  let (a :: a
a,s' :: s'
s') = State s' a -> s' -> (a, s')
forall s a. State s a -> s -> (a, s)
runState State s' a
m s'
s
  (s' -> Identity s') -> s -> Identity s
Lens' s s'
l ((s' -> Identity s') -> s -> Identity s) -> s' -> m ()
forall s (m :: Type -> Type) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= s'
s'
  a -> m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return a
a

-- | Functorial version of 'Control.Arrow.first'
firstM :: Functor f
       => (a -> f c)
       -> (a, b)
       -> f (c, b)
firstM :: (a -> f c) -> (a, b) -> f (c, b)
firstM f :: a -> f c
f (x :: a
x,y :: b
y) = (,b
y) (c -> (c, b)) -> f c -> f (c, b)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> f c
f a
x

-- | Functorial version of 'Control.Arrow.second'
secondM :: Functor f
        => (b -> f c)
        -> (a, b)
        -> f (a, c)
secondM :: (b -> f c) -> (a, b) -> f (a, c)
secondM f :: b -> f c
f (x :: a
x,y :: b
y) = (a
x,) (c -> (a, c)) -> f c -> f (a, c)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> b -> f c
f b
y

combineM :: (Applicative f)
         => (a -> f b)
         -> (c -> f d)
         -> (a,c)
         -> f (b,d)
combineM :: (a -> f b) -> (c -> f d) -> (a, c) -> f (b, d)
combineM f :: a -> f b
f g :: c -> f d
g (x :: a
x,y :: c
y) = (,) (b -> d -> (b, d)) -> f b -> f (d -> (b, d))
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> f b
f a
x f (d -> (b, d)) -> f d -> f (b, d)
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> c -> f d
g c
y

-- | Performs trace when first argument evaluates to 'True'
traceIf :: Bool -> String -> a -> a
traceIf :: Bool -> String -> a -> a
traceIf True  msg :: String
msg = String -> a -> a
forall a. String -> a -> a
trace String
msg
traceIf False _   = a -> a
forall a. a -> a
id
{-# INLINE traceIf #-}

-- | A version of 'concatMap' that works with a monadic predicate.
concatMapM :: Monad m => (a -> m [b]) -> [a] -> m [b]
concatMapM :: (a -> m [b]) -> [a] -> m [b]
concatMapM f :: a -> m [b]
f as :: [a]
as = [[b]] -> [b]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat ([[b]] -> [b]) -> m [[b]] -> m [b]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> [m [b]] -> m [[b]]
forall (t :: Type -> Type) (m :: Type -> Type) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence ((a -> m [b]) -> [a] -> [m [b]]
forall a b. (a -> b) -> [a] -> [b]
map a -> m [b]
f [a]
as)
{-# INLINE concatMapM #-}

-- | Monadic version of 'Data.List.partition'
partitionM :: Monad m
           => (a -> m Bool)
           -> [a]
           -> m ([a], [a])
partitionM :: (a -> m Bool) -> [a] -> m ([a], [a])
partitionM _ []     = ([a], [a]) -> m ([a], [a])
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([], [])
partitionM p :: a -> m Bool
p (x :: a
x:xs :: [a]
xs) = do
  Bool
test      <- a -> m Bool
p a
x
  (ys :: [a]
ys, ys' :: [a]
ys') <- (a -> m Bool) -> [a] -> m ([a], [a])
forall (m :: Type -> Type) a.
Monad m =>
(a -> m Bool) -> [a] -> m ([a], [a])
partitionM a -> m Bool
p [a]
xs
  ([a], [a]) -> m ([a], [a])
forall (m :: Type -> Type) a. Monad m => a -> m a
return (([a], [a]) -> m ([a], [a])) -> ([a], [a]) -> m ([a], [a])
forall a b. (a -> b) -> a -> b
$ if Bool
test then (a
xa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
ys, [a]
ys') else ([a]
ys, a
xa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
ys')

-- | Monadic version of 'Data.List.mapAccumL'
mapAccumLM :: (Monad m)
           => (acc -> x -> m (acc,y))
           -> acc
           -> [x]
           -> m (acc,[y])
mapAccumLM :: (acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, [y])
mapAccumLM _ acc :: acc
acc [] = (acc, [y]) -> m (acc, [y])
forall (m :: Type -> Type) a. Monad m => a -> m a
return (acc
acc,[])
mapAccumLM f :: acc -> x -> m (acc, y)
f acc :: acc
acc (x :: x
x:xs :: [x]
xs) = do
  (acc' :: acc
acc',y :: y
y) <- acc -> x -> m (acc, y)
f acc
acc x
x
  (acc'' :: acc
acc'',ys :: [y]
ys) <- (acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, [y])
forall (m :: Type -> Type) acc x y.
Monad m =>
(acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, [y])
mapAccumLM acc -> x -> m (acc, y)
f acc
acc' [x]
xs
  (acc, [y]) -> m (acc, [y])
forall (m :: Type -> Type) a. Monad m => a -> m a
return (acc
acc'',y
yy -> [y] -> [y]
forall a. a -> [a] -> [a]
:[y]
ys)

-- | if-then-else as a function on an argument
ifThenElse :: (a -> Bool)
           -> (a -> b)
           -> (a -> b)
           -> a
           -> b
ifThenElse :: (a -> Bool) -> (a -> b) -> (a -> b) -> a -> b
ifThenElse t :: a -> Bool
t f :: a -> b
f g :: a -> b
g a :: a
a = if a -> Bool
t a
a then a -> b
f a
a else a -> b
g a
a

infixr 5 <:>
-- | Applicative version of 'GHC.Types.(:)'
(<:>) :: Applicative f
      => f a
      -> f [a]
      -> f [a]
x :: f a
x <:> :: f a -> f [a] -> f [a]
<:> xs :: f [a]
xs = (:) (a -> [a] -> [a]) -> f a -> f ([a] -> [a])
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> f a
x f ([a] -> [a]) -> f [a] -> f [a]
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> f [a]
xs

-- | Safe indexing, returns a 'Nothing' if the index does not exist
indexMaybe :: [a]
           -> Int
           -> Maybe a
indexMaybe :: [a] -> Int -> Maybe a
indexMaybe [] _     = Maybe a
forall a. Maybe a
Nothing
indexMaybe (x :: a
x:_)  0 = a -> Maybe a
forall a. a -> Maybe a
Just a
x
indexMaybe (_:xs :: [a]
xs) n :: Int
n = [a] -> Int -> Maybe a
forall a. [a] -> Int -> Maybe a
indexMaybe [a]
xs (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-1)

-- | Same as 'indexNote' with last two arguments swapped
indexNote'
  :: HasCallStack
  => String
  -- ^ Error message to display
  -> Int
  -- ^ Index /n/
  -> [a]
  -- ^ List to index
  -> a
  -- ^ Error or element /n/
indexNote' :: String -> Int -> [a] -> a
indexNote' = ([a] -> Int -> a) -> Int -> [a] -> a
forall a b c. (a -> b -> c) -> b -> a -> c
flip (([a] -> Int -> a) -> Int -> [a] -> a)
-> (String -> [a] -> Int -> a) -> String -> Int -> [a] -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [a] -> Int -> a
forall a. HasCallStack => String -> [a] -> Int -> a
indexNote

-- | Unsafe indexing, return a custom error message when indexing fails
indexNote
  :: HasCallStack
  => String
  -- ^ Error message to display
  -> [a]
  -- ^ List to index
  -> Int
  -- ^ Index /n/
  -> a
  -- ^ Error or element /n/
indexNote :: String -> [a] -> Int -> a
indexNote note :: String
note = \xs :: [a]
xs i :: Int
i -> a -> Maybe a -> a
forall a. a -> Maybe a -> a
fromMaybe (String -> a
forall a. HasCallStack => String -> a
error String
note) ([a] -> Int -> Maybe a
forall a. [a] -> Int -> Maybe a
indexMaybe [a]
xs Int
i)

-- | Safe version of 'head'
headMaybe :: [a] -> Maybe a
headMaybe :: [a] -> Maybe a
headMaybe (a :: a
a:_) = a -> Maybe a
forall a. a -> Maybe a
Just a
a
headMaybe _ = Maybe a
forall a. Maybe a
Nothing

-- | Safe version of 'tail'
tailMaybe :: [a] -> Maybe [a]
tailMaybe :: [a] -> Maybe [a]
tailMaybe (_:as :: [a]
as) = [a] -> Maybe [a]
forall a. a -> Maybe a
Just [a]
as
tailMaybe _ = Maybe [a]
forall a. Maybe a
Nothing

-- | Split the second list at the length of the first list
splitAtList :: [b] -> [a] -> ([a], [a])
splitAtList :: [b] -> [a] -> ([a], [a])
splitAtList [] xs :: [a]
xs         = ([], [a]
xs)
splitAtList _ xs :: [a]
xs@[]       = ([a]
xs, [a]
xs)
splitAtList (_:xs :: [b]
xs) (y :: a
y:ys :: [a]
ys) = (a
ya -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
ys', [a]
ys'')
    where
      (ys' :: [a]
ys', ys'' :: [a]
ys'') = [b] -> [a] -> ([a], [a])
forall b a. [b] -> [a] -> ([a], [a])
splitAtList [b]
xs [a]
ys

clashLibVersion :: Version
#ifdef CABAL
clashLibVersion :: Version
clashLibVersion = Version
Paths_clash_lib.version
#else
clashLibVersion = error "development version"
#endif

-- | Return number of occurrences of an item in a list
countEq
  :: Eq a
  => a
  --  ^ Needle
  -> [a]
  -- ^ Haystack
  -> Int
  -- ^ Times needle was found in haystack
countEq :: a -> [a] -> Int
countEq a :: a
a as :: [a]
as = [a] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length ((a -> Bool) -> [a] -> [a]
forall a. (a -> Bool) -> [a] -> [a]
filter (a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
a) [a]
as)

-- | \x y -> floor (logBase x y), x > 1 && y > 0
flogBase :: Integer -> Integer -> Maybe Int
flogBase :: Integer -> Integer -> Maybe Int
flogBase x :: Integer
x y :: Integer
y | Integer
x Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> 1 Bool -> Bool -> Bool
&& Integer
y Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> 0 = Int -> Maybe Int
forall a. a -> Maybe a
Just (Int# -> Int
I# (Integer -> Integer -> Int#
integerLogBase# Integer
x Integer
y))
flogBase _ _ = Maybe Int
forall a. Maybe a
Nothing

-- | \x y -> ceiling (logBase x y), x > 1 && y > 0
clogBase :: Integer -> Integer -> Maybe Int
clogBase :: Integer -> Integer -> Maybe Int
clogBase x :: Integer
x y :: Integer
y | Integer
x Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> 1 Bool -> Bool -> Bool
&& Integer
y Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> 0 =
  case Integer
y of
    1 -> Int -> Maybe Int
forall a. a -> Maybe a
Just 0
    _ -> let z1 :: Int#
z1 = Integer -> Integer -> Int#
integerLogBase# Integer
x Integer
y
             z2 :: Int#
z2 = Integer -> Integer -> Int#
integerLogBase# Integer
x (Integer
yInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
-1)
         in  if Int# -> Bool
isTrue# (Int#
z1 Int# -> Int# -> Int#
==# Int#
z2)
                then Int -> Maybe Int
forall a. a -> Maybe a
Just (Int# -> Int
I# (Int#
z1 Int# -> Int# -> Int#
+# 1#))
                else Int -> Maybe Int
forall a. a -> Maybe a
Just (Int# -> Int
I# Int#
z1)
clogBase _ _ = Maybe Int
forall a. Maybe a
Nothing

-- | Determine whether two lists are of equal length
equalLength
  :: [a] -> [b] -> Bool
equalLength :: [a] -> [b] -> Bool
equalLength [] [] = Bool
True
equalLength (_:as :: [a]
as) (_:bs :: [b]
bs) = [a] -> [b] -> Bool
forall a b. [a] -> [b] -> Bool
equalLength [a]
as [b]
bs
equalLength _ _ = Bool
False

-- | Determine whether two lists are not of equal length
neLength
  :: [a] -> [b] -> Bool
neLength :: [a] -> [b] -> Bool
neLength [] [] = Bool
False
neLength (_:as :: [a]
as) (_:bs :: [b]
bs) = [a] -> [b] -> Bool
forall a b. [a] -> [b] -> Bool
neLength [a]
as [b]
bs
neLength _ _ = Bool
True

-- | Zip two lists of equal length
--
-- NB Errors out for a DEBUG compiler when the two lists are not of equal length
zipEqual
  :: [a] -> [b] -> [(a,b)]
#if !defined(DEBUG)
zipEqual = zip
#else
zipEqual :: [a] -> [b] -> [(a, b)]
zipEqual [] [] = []
zipEqual (a :: a
a:as :: [a]
as) (b :: b
b:bs :: [b]
bs) = (a
a,b
b) (a, b) -> [(a, b)] -> [(a, b)]
forall a. a -> [a] -> [a]
: [a] -> [b] -> [(a, b)]
forall a b. [a] -> [b] -> [(a, b)]
zipEqual [a]
as [b]
bs
zipEqual _ _ = String -> [(a, b)]
forall a. HasCallStack => String -> a
error "zipEqual"
#endif

-- | Is this a DEBUG compiler?
debugIsOn
  :: Bool
#if defined(DEBUG)
debugIsOn :: Bool
debugIsOn = Bool
True
#else
debugIsOn = False
#endif

-- | Short-circuiting monadic version of 'any'
anyM
  :: (Monad m)
  => (a -> m Bool)
  -> [a]
  -> m Bool
anyM :: (a -> m Bool) -> [a] -> m Bool
anyM _ []     = Bool -> m Bool
forall (m :: Type -> Type) a. Monad m => a -> m a
return Bool
False
anyM p :: a -> m Bool
p (x :: a
x:xs :: [a]
xs) = do
  Bool
q <- a -> m Bool
p a
x
  if Bool
q then
    Bool -> m Bool
forall (m :: Type -> Type) a. Monad m => a -> m a
return Bool
True
  else
    (a -> m Bool) -> [a] -> m Bool
forall (m :: Type -> Type) a.
Monad m =>
(a -> m Bool) -> [a] -> m Bool
anyM a -> m Bool
p [a]
xs

-- | short-circuiting monadic version of 'or'
orM
  :: (Monad m)
  => [m Bool]
  -> m Bool
orM :: [m Bool] -> m Bool
orM [] = Bool -> m Bool
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Bool
False
orM (x :: m Bool
x:xs :: [m Bool]
xs) = do
  Bool
p <- m Bool
x
  if Bool
p then
    Bool -> m Bool
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Bool
True
  else
    [m Bool] -> m Bool
forall (m :: Type -> Type). Monad m => [m Bool] -> m Bool
orM [m Bool]
xs

-- | Get the package id of the type of a value
-- >>> pkgIdFromTypeable (undefined :: TopEntity)
-- "clash-prelude-0.99.3-64904d90747cb49e17166bbc86fec8678918e4ead3847193a395b258e680373c"
pkgIdFromTypeable :: Typeable a => a -> String
pkgIdFromTypeable :: a -> String
pkgIdFromTypeable = TyCon -> String
tyConPackage (TyCon -> String) -> (a -> TyCon) -> a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeRep a -> TyCon
forall k (a :: k). TypeRep a -> TyCon
typeRepTyCon (TypeRep a -> TyCon) -> (a -> TypeRep a) -> a -> TyCon
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> TypeRep a
forall a. Typeable a => a -> TypeRep a
typeOf

reportTimeDiff :: UTCTime -> UTCTime -> String
reportTimeDiff :: UTCTime -> UTCTime -> String
reportTimeDiff start :: UTCTime
start end :: UTCTime
end =
  TimeLocale -> String -> UTCTime -> String
forall t. FormatTime t => TimeLocale -> String -> t -> String
Clock.formatTime TimeLocale
Clock.defaultTimeLocale String
fmt
    (Day -> DiffTime -> UTCTime
Clock.UTCTime (Int -> Day
forall a. Enum a => Int -> a
toEnum 0) (Rational -> DiffTime
forall a. Fractional a => Rational -> a
fromRational (NominalDiffTime -> Rational
forall a. Real a => a -> Rational
toRational NominalDiffTime
diff)))
 where
  diff :: NominalDiffTime
diff = UTCTime -> UTCTime -> NominalDiffTime
Clock.diffUTCTime UTCTime
start UTCTime
end
  fmt :: String
fmt  | NominalDiffTime
diff NominalDiffTime -> NominalDiffTime -> Bool
forall a. Ord a => a -> a -> Bool
>= 3600
       = "%-Hh%-Mm%-S%03Qs"
       | NominalDiffTime
diff NominalDiffTime -> NominalDiffTime -> Bool
forall a. Ord a => a -> a -> Bool
>= 60
       = "%-Mm%-S%03Qs"
       | Bool
otherwise
       = "%-S%03Qs"

-- | Converts a curried function to a function on a triple
uncurry3
  :: (a -> b -> c -> d)
  -> (a,b,c)
  -> d
uncurry3 :: (a -> b -> c -> d) -> (a, b, c) -> d
uncurry3 = \f :: a -> b -> c -> d
f (a :: a
a,b :: b
b,c :: c
c) -> a -> b -> c -> d
f a
a b
b c
c
{-# INLINE uncurry3 #-}

allM :: (Monad m) => (a -> m Bool) -> [a] -> m Bool
allM :: (a -> m Bool) -> [a] -> m Bool
allM _ [] = Bool -> m Bool
forall (m :: Type -> Type) a. Monad m => a -> m a
return Bool
True
allM p :: a -> m Bool
p (x :: a
x:xs :: [a]
xs) = do
  Bool
q <- a -> m Bool
p a
x
  if Bool
q then
    (a -> m Bool) -> [a] -> m Bool
forall (m :: Type -> Type) a.
Monad m =>
(a -> m Bool) -> [a] -> m Bool
allM a -> m Bool
p [a]
xs
  else
    Bool -> m Bool
forall (m :: Type -> Type) a. Monad m => a -> m a
return Bool
False

traceWith :: (a -> String) -> a -> a
traceWith :: (a -> String) -> a -> a
traceWith f :: a -> String
f a :: a
a = String -> a -> a
forall a. String -> a -> a
trace (a -> String
f a
a) a
a

traceShowWith :: Show b => (a -> b) -> a -> a
traceShowWith :: (a -> b) -> a -> a
traceShowWith f :: a -> b
f a :: a
a = String -> a -> a
forall a. String -> a -> a
trace (b -> String
forall a. Show a => a -> String
show (a -> b
f a
a)) a
a

-- | Left-biased choice on maybes
orElse :: Maybe a -> Maybe a -> Maybe a
orElse :: Maybe a -> Maybe a -> Maybe a
orElse x :: Maybe a
x@(Just _) _y :: Maybe a
_y = Maybe a
x
orElse _x :: Maybe a
_x y :: Maybe a
y = Maybe a
y

-- | Left-biased choice on maybes
orElses :: [Maybe a] -> Maybe a
orElses :: [Maybe a] -> Maybe a
orElses = [a] -> Maybe a
forall a. [a] -> Maybe a
listToMaybe ([a] -> Maybe a) -> ([Maybe a] -> [a]) -> [Maybe a] -> Maybe a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe a] -> [a]
forall a. [Maybe a] -> [a]
catMaybes

-- These language extensions are used for
--  * the interactive session inside clashi
--  * compiling files with clash
--  * running output tests with runghc
--  * compiling (local) Template/Blackbox functions with Hint
wantedLanguageExtensions, unwantedLanguageExtensions :: [LangExt.Extension]
wantedLanguageExtensions :: [Extension]
wantedLanguageExtensions =
  [ Extension
LangExt.BinaryLiterals
  , Extension
LangExt.ConstraintKinds
  , Extension
LangExt.DataKinds
  , Extension
LangExt.DeriveAnyClass
  , Extension
LangExt.DeriveGeneric
  , Extension
LangExt.DeriveLift
  , Extension
LangExt.DerivingStrategies
  , Extension
LangExt.ExplicitForAll
  , Extension
LangExt.ExplicitNamespaces
  , Extension
LangExt.FlexibleContexts
  , Extension
LangExt.FlexibleInstances
  , Extension
LangExt.KindSignatures
  , Extension
LangExt.MagicHash
  , Extension
LangExt.MonoLocalBinds
  , Extension
LangExt.QuasiQuotes
  , Extension
LangExt.ScopedTypeVariables
  , Extension
LangExt.TemplateHaskell
  , Extension
LangExt.TemplateHaskellQuotes
  , Extension
LangExt.TypeApplications
  , Extension
LangExt.TypeFamilies
  , Extension
LangExt.TypeOperators
#if !MIN_VERSION_ghc(8,6,0)
  , LangExt.TypeInType
#endif
  ]

unwantedLanguageExtensions :: [Extension]
unwantedLanguageExtensions =
  [ Extension
LangExt.ImplicitPrelude
  , Extension
LangExt.MonomorphismRestriction
#if MIN_VERSION_ghc(8,6,0)
  , Extension
LangExt.StarIsType
#endif
  , Extension
LangExt.Strict
  , Extension
LangExt.StrictData
  ]

filterOnFst :: (a -> Bool) -> [(a, b)] -> [b]
filterOnFst :: (a -> Bool) -> [(a, b)] -> [b]
filterOnFst f :: a -> Bool
f xs :: [(a, b)]
xs = ((a, b) -> b) -> [(a, b)] -> [b]
forall a b. (a -> b) -> [a] -> [b]
map (a, b) -> b
forall a b. (a, b) -> b
snd (((a, b) -> Bool) -> [(a, b)] -> [(a, b)]
forall a. (a -> Bool) -> [a] -> [a]
filter (a -> Bool
f (a -> Bool) -> ((a, b) -> a) -> (a, b) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, b) -> a
forall a b. (a, b) -> a
fst) [(a, b)]
xs)

filterOnSnd :: (b -> Bool) -> [(a, b)] -> [a]
filterOnSnd :: (b -> Bool) -> [(a, b)] -> [a]
filterOnSnd f :: b -> Bool
f xs :: [(a, b)]
xs = ((a, b) -> a) -> [(a, b)] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map (a, b) -> a
forall a b. (a, b) -> a
fst (((a, b) -> Bool) -> [(a, b)] -> [(a, b)]
forall a. (a -> Bool) -> [a] -> [a]
filter (b -> Bool
f (b -> Bool) -> ((a, b) -> b) -> (a, b) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, b) -> b
forall a b. (a, b) -> b
snd) [(a, b)]
xs)