{-# 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.Arrow as X ((***),(&&&),first,second)
import qualified Control.Exception as Exception
import Control.Lens
import Control.Monad as X ((<=<),(>=>))
import Control.Monad.State (MonadState,StateT)
import qualified Control.Monad.State as State
import Data.Function as X (on)
import Data.Hashable (Hashable)
import Data.HashMap.Lazy (HashMap)
import qualified Data.HashMap.Lazy as HashMapL
import qualified Data.List.Extra as List
import Data.Maybe (fromMaybe, listToMaybe, catMaybes)
import Data.Map.Ordered (OMap)
import qualified Data.Map.Ordered as OMap
import Data.Text.Prettyprint.Doc
import Data.Text.Prettyprint.Doc.Render.String
import Data.Time.Clock (UTCTime)
import qualified Data.Time.Clock as Clock
import qualified Data.Time.Format as Clock
import Data.Typeable (Typeable)
import Data.Version (Version)
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
#if MIN_VERSION_ghc(9,0,0)
import GHC.Types.SrcLoc (SrcSpan, noSrcSpan)
#else
import SrcLoc (SrcSpan, noSrcSpan)
#endif
import Clash.Debug
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 SrcSpan
_ String
s Maybe String
eM) = String
s String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String -> ShowS -> Maybe String -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" ShowS
forall a. a -> a
id Maybe String
eM
instance Exception.Exception ClashException
assertPanic
:: String -> Int -> a
assertPanic :: String -> Int -> a
assertPanic String
file Int
ln = ClashException -> a
forall a e. Exception e => e -> a
Exception.throw
(SrcSpan -> String -> Maybe String -> ClashException
ClashException SrcSpan
noSrcSpan (String
"ASSERT failed! file " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
file String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
", 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 String
_file Int
_line Doc ann
msg = String -> Doc ann -> a
forall ann a. String -> Doc ann -> a
pprPanic String
"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 String
heading 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 Int
2 Doc ann
prettyMsg]
callStackDoc
:: HasCallStack => Doc ann
callStackDoc :: Doc ann
callStackDoc =
Doc ann
"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 Int
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
-> String
-> Int
-> Doc ann
-> a
-> a
warnPprTrace :: Bool -> String -> Int -> Doc ann -> a -> a
warnPprTrace Bool
_ String
_ Int
_ Doc ann
_ a
x | Bool -> Bool
not Bool
debugIsOn = a
x
warnPprTrace Bool
False String
_ Int
_ Doc ann
_ a
x = a
x
warnPprTrace Bool
True String
file Int
ln Doc ann
msg 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 [Doc ann
"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, Doc ann
"line", Int -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Int
ln]
heading1 :: Doc ann
heading1 = Doc ann
"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 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 String
str Doc ann
doc a
x
| Bool
debugIsOn = String -> Doc ann -> a -> a
forall ann a. String -> Doc ann -> a -> a
pprTrace 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 String -> a
cont Doc ann
heading 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 Int
2 Doc ann
prettyMsg]
class Monad m => MonadUnique m where
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
+Int
1)
Int -> StateT Int m Int
forall (m :: Type -> Type) a. Monad m => a -> m a
return Int
supply
curLoc :: TH.Q TH.Exp
curLoc :: Q Exp
curLoc = do
(TH.Loc String
_ String
_ String
modName (Int
startPosL,Int
_) (Int, Int)
_) <- 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
"(" 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]
++ String
"): ")
makeCached :: (MonadState s m, Hashable k, Eq k)
=> k
-> Lens' s (HashMap k v)
-> m v
-> m v
makeCached :: k -> Lens' s (HashMap k v) -> m v -> m v
makeCached k
key Lens' s (HashMap k v)
l 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 v
value -> v -> m v
forall (m :: Type -> Type) a. Monad m => a -> m a
return v
value
Maybe v
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
makeCachedU
:: (MonadState s m, Uniquable k)
=> k
-> Lens' s (UniqMap v)
-> m v
-> m v
makeCachedU :: k -> Lens' s (UniqMap v) -> m v -> m v
makeCachedU k
key Lens' s (UniqMap v)
l 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 v
value -> v -> m v
forall (m :: Type -> Type) a. Monad m => a -> m a
return v
value
Maybe v
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
makeCachedO
:: (MonadState s m, Uniquable k)
=> k
-> Lens' s (OMap Unique v)
-> m v
-> m v
makeCachedO :: k -> Lens' s (OMap Int v) -> m v -> m v
makeCachedO k
key Lens' s (OMap Int v)
l m v
create = do
OMap Int v
cache <- Getting (OMap Int v) s (OMap Int v) -> m (OMap Int v)
forall s (m :: Type -> Type) a.
MonadState s m =>
Getting a s a -> m a
use Getting (OMap Int v) s (OMap Int v)
Lens' s (OMap Int v)
l
case Int -> OMap Int v -> Maybe v
forall k v. Ord k => k -> OMap k v -> Maybe v
OMap.lookup (k -> Int
forall a. Uniquable a => a -> Int
getUnique k
key) OMap Int v
cache of
Just v
value -> v -> m v
forall (m :: Type -> Type) a. Monad m => a -> m a
return v
value
Maybe v
Nothing -> do
v
value <- m v
create
(OMap Int v -> Identity (OMap Int v)) -> s -> Identity s
Lens' s (OMap Int v)
l ((OMap Int v -> Identity (OMap Int v)) -> s -> Identity s)
-> (OMap Int v -> OMap Int v) -> m ()
forall s (m :: Type -> Type) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= ((OMap Int v -> (Int, v) -> OMap Int v)
-> (Int, v) -> OMap Int v -> OMap Int v
forall a b c. (a -> b -> c) -> b -> a -> c
flip OMap Int v -> (Int, v) -> OMap Int v
forall k v. Ord k => OMap k v -> (k, v) -> OMap k v
(OMap.|>)) (k -> Int
forall a. Uniquable a => a -> Int
getUnique k
key, v
value)
v -> m v
forall (m :: Type -> Type) a. Monad m => a -> m a
return v
value
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 a -> f b
f c -> f d
g (a
x,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
indexNote'
:: HasCallStack
=> String
-> Int
-> [a]
-> a
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
indexNote
:: HasCallStack
=> String
-> [a]
-> Int
-> a
indexNote :: String -> [a] -> Int -> a
indexNote String
note = \[a]
xs 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
List.indexMaybe [a]
xs Int
i)
clashLibVersion :: Version
#ifdef CABAL
clashLibVersion :: Version
clashLibVersion = Version
Paths_clash_lib.version
#else
clashLibVersion = error "development version"
#endif
flogBase :: Integer -> Integer -> Maybe Int
flogBase :: Integer -> Integer -> Maybe Int
flogBase Integer
x Integer
y | Integer
x Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
1 Bool -> Bool -> Bool
&& Integer
y Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
0 = Int -> Maybe Int
forall a. a -> Maybe a
Just (Int# -> Int
I# (Integer -> Integer -> Int#
integerLogBase# Integer
x Integer
y))
flogBase Integer
_ Integer
_ = Maybe Int
forall a. Maybe a
Nothing
clogBase :: Integer -> Integer -> Maybe Int
clogBase :: Integer -> Integer -> Maybe Int
clogBase Integer
x Integer
y | Integer
x Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
1 Bool -> Bool -> Bool
&& Integer
y Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
0 =
case Integer
y of
Integer
1 -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
0
Integer
_ -> 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
-Integer
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#
+# Int#
1#))
else Int -> Maybe Int
forall a. a -> Maybe a
Just (Int# -> Int
I# Int#
z1)
clogBase Integer
_ Integer
_ = Maybe Int
forall a. Maybe a
Nothing
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 UTCTime
start 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 Int
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
>= NominalDiffTime
3600
= String
"%-Hh%-Mm%-S%03Qs"
| NominalDiffTime
diff NominalDiffTime -> NominalDiffTime -> Bool
forall a. Ord a => a -> a -> Bool
>= NominalDiffTime
60
= String
"%-Mm%-S%03Qs"
| Bool
otherwise
= String
"%-S%03Qs"
orElse :: Maybe a -> Maybe a -> Maybe a
orElse :: Maybe a -> Maybe a -> Maybe a
orElse x :: Maybe a
x@(Just a
_) Maybe a
_y = Maybe a
x
orElse Maybe a
_x Maybe a
y = Maybe a
y
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
wantedLanguageExtensions :: [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 :: [LangExt.Extension]
unwantedLanguageExtensions :: [Extension]
unwantedLanguageExtensions =
[ Extension
LangExt.ImplicitPrelude
#if MIN_VERSION_ghc(8,6,0)
, Extension
LangExt.StarIsType
#endif
, Extension
LangExt.Strict
, Extension
LangExt.StrictData
]