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

import SrcLoc                         (SrcSpan, noSrcSpan)

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

-- | 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
+Int
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 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
"): ")

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

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

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

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

-- | \x y -> floor (logBase x y), x > 1 && y > 0
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

-- | \x y -> ceiling (logBase x y), x > 1 && y > 0
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

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

-- | 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 a
_) Maybe a
_y = Maybe a
x
orElse Maybe a
_x 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 :: [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
  , Extension
LangExt.MonomorphismRestriction
#if MIN_VERSION_ghc(8,6,0)
  , Extension
LangExt.StarIsType
#endif
  , Extension
LangExt.Strict
  , Extension
LangExt.StrictData
  ]