{-|
Copyright   :  (C) 2024, Martijn Bastiaan
License     :  BSD2 (see the file LICENSE)
Maintainer  :  QBayLogic B.V. <devops@qbaylogic.com>

Utilities to detect and report GHC / operating system combinations that are
known to be buggy.
-}

{-# LANGUAGE CPP #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE QuasiQuotes #-}

module Clash.Driver.BrokenGhcs where

import Data.Maybe (listToMaybe)
import Data.Version (Version(Version, versionBranch))
import GHC.Platform (OS(..))

#if __GLASGOW_HASKELL__ > 810
import System.Info (fullCompilerVersion)
#endif

import qualified Clash.Util.Interpolate as I
import qualified System.Info

#if __GLASGOW_HASKELL__ <= 810
fullCompilerVersion :: Version
fullCompilerVersion :: Version
fullCompilerVersion = Version
System.Info.compilerVersion
#endif

-- | Current OS. Currently only recognizes Linux, Windows, and macOS.
os :: OS
os :: OS
os = case String
System.Info.os of
  String
"darwin" -> OS
OSDarwin
  String
"linux" -> OS
OSLinux
  String
"mingw32" -> OS
OSMinGW32
  String
_ -> OS
OSUnknown

-- | What OS GHC is broken on (or all)
data BrokenOn = All | SomeOs OS

data GhcVersion = Ghc
  { GhcVersion -> Int
major0 :: Int
  , GhcVersion -> Int
major1 :: Int
  , GhcVersion -> Int
patch :: Int
  }
  deriving (GhcVersion -> GhcVersion -> Bool
(GhcVersion -> GhcVersion -> Bool)
-> (GhcVersion -> GhcVersion -> Bool) -> Eq GhcVersion
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: GhcVersion -> GhcVersion -> Bool
$c/= :: GhcVersion -> GhcVersion -> Bool
== :: GhcVersion -> GhcVersion -> Bool
$c== :: GhcVersion -> GhcVersion -> Bool
Eq, Eq GhcVersion
Eq GhcVersion
-> (GhcVersion -> GhcVersion -> Ordering)
-> (GhcVersion -> GhcVersion -> Bool)
-> (GhcVersion -> GhcVersion -> Bool)
-> (GhcVersion -> GhcVersion -> Bool)
-> (GhcVersion -> GhcVersion -> Bool)
-> (GhcVersion -> GhcVersion -> GhcVersion)
-> (GhcVersion -> GhcVersion -> GhcVersion)
-> Ord GhcVersion
GhcVersion -> GhcVersion -> Bool
GhcVersion -> GhcVersion -> Ordering
GhcVersion -> GhcVersion -> GhcVersion
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: GhcVersion -> GhcVersion -> GhcVersion
$cmin :: GhcVersion -> GhcVersion -> GhcVersion
max :: GhcVersion -> GhcVersion -> GhcVersion
$cmax :: GhcVersion -> GhcVersion -> GhcVersion
>= :: GhcVersion -> GhcVersion -> Bool
$c>= :: GhcVersion -> GhcVersion -> Bool
> :: GhcVersion -> GhcVersion -> Bool
$c> :: GhcVersion -> GhcVersion -> Bool
<= :: GhcVersion -> GhcVersion -> Bool
$c<= :: GhcVersion -> GhcVersion -> Bool
< :: GhcVersion -> GhcVersion -> Bool
$c< :: GhcVersion -> GhcVersion -> Bool
compare :: GhcVersion -> GhcVersion -> Ordering
$ccompare :: GhcVersion -> GhcVersion -> Ordering
$cp1Ord :: Eq GhcVersion
Ord)

data GhcRange = GhcRange
  { GhcRange -> GhcVersion
from :: GhcVersion
  -- ^ Start of range, inclusive
  , GhcRange -> GhcVersion
to :: GhcVersion
  -- ^ End of range, exclusive
  }

-- | Check if a 'GhcVersion' is within a 'GhcRange'
ghcInRange :: GhcVersion -> GhcRange -> Bool
ghcInRange :: GhcVersion -> GhcRange -> Bool
ghcInRange GhcVersion
ghc GhcRange{GhcVersion
from :: GhcVersion
from :: GhcRange -> GhcVersion
from, GhcVersion
to :: GhcVersion
to :: GhcRange -> GhcVersion
to} = GhcVersion
from GhcVersion -> GhcVersion -> Bool
forall a. Ord a => a -> a -> Bool
<= GhcVersion
ghc Bool -> Bool -> Bool
&& GhcVersion
ghc GhcVersion -> GhcVersion -> Bool
forall a. Ord a => a -> a -> Bool
< GhcVersion
to

-- | Construct a range of all GHC versions matching a major version
ghcMajor :: Int -> Int -> GhcRange
ghcMajor :: Int -> Int -> GhcRange
ghcMajor Int
major0 Int
major1 = GhcRange :: GhcVersion -> GhcVersion -> GhcRange
GhcRange
  { from :: GhcVersion
from=Int -> Int -> Int -> GhcVersion
Ghc Int
major0 Int
major1 Int
0
  , to :: GhcVersion
to=Int -> Int -> Int -> GhcVersion
Ghc Int
major0 (Int
major1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Int
0
  }

data Why = Why
  { Why -> String
what :: String
    -- ^ What is broken
  , Why -> String
solution :: String
    -- ^ What can be done to work around or solve the issue
  , Why -> String
issue :: String
    -- ^ Link to issue
  , Why -> [(BrokenOn, GhcRange)]
brokenOn :: [(BrokenOn, GhcRange)]
    -- ^ What operation systems are affected
  }

-- | Get current GHC version expressed as a triple. It probably does something
-- non-sensible on unreleased GHCs.
ghcVersion :: GhcVersion
ghcVersion :: GhcVersion
ghcVersion = Ghc :: Int -> Int -> Int -> GhcVersion
Ghc{Int
major0 :: Int
major0 :: Int
major0, Int
major1 :: Int
major1 :: Int
major1, Int
patch :: Int
patch :: Int
patch}
 where
  (Int
major0, Int
major1, Int
patch) =
    case Version
fullCompilerVersion of
      Version{[Int]
versionBranch :: [Int]
versionBranch :: Version -> [Int]
versionBranch} ->
        case [Int]
versionBranch of
          [] -> (Int
0, Int
0, Int
1)
          [Int
a] -> (Int
a, Int
0, Int
1)
          [Int
a, Int
b] -> (Int
a, Int
b, Int
1)
          [Int
a, Int
b, Int
c] -> (Int
a, Int
b, Int
c)
          (Int
a:Int
b:Int
c:[Int]
_) -> (Int
a, Int
b, Int
c)

-- | Pretty print 'Why' into an error message
whyPp :: Why -> String
whyPp :: Why -> String
whyPp Why{String
what :: String
what :: Why -> String
what, String
solution :: String
solution :: Why -> String
solution, String
issue :: String
issue :: Why -> String
issue}= [I.i|
  Clash has known issues on #{major0}.#{major1}.#{patch} on your current
  OS. While not completely preventing the compiler from working, we recommend
  switching to another GHC version. Symptoms:

    #{what}

  Consider the following work around or solution:

    #{solution}

  More information can be found at:

    #{issue}

  If you want to ignore this message, pass the following flag to Clash:

    -fclash-ignore-broken-ghcs

  Alternatively, you can set the environment variable CLASH_IGNORE_BROKEN_GHCS
  to 'True'.
  |]
 where
  Ghc{Int
major0 :: Int
major0 :: GhcVersion -> Int
major0, Int
major1 :: Int
major1 :: GhcVersion -> Int
major1, Int
patch :: Int
patch :: GhcVersion -> Int
patch} = GhcVersion
ghcVersion

-- | Which GHCs are broken and why
brokenGhcs :: [Why]
brokenGhcs :: [Why]
brokenGhcs = [Why
brokenClashCores, Why
brokenTypeErrors, Why
slowStarts]
 where
  brokenClashCores :: Why
brokenClashCores = Why :: String -> String -> String -> [(BrokenOn, GhcRange)] -> Why
Why
    { what :: String
what = String
"GHC is known to fail compilation of libraries used by the Clash compiler test suite"
    , solution :: String
solution = String
"Upgrade to GHC 9.4 or downgrade to GHC 8.10"
    , issue :: String
issue = String
"<no link>"
    , brokenOn :: [(BrokenOn, GhcRange)]
brokenOn = [(OS -> BrokenOn
SomeOs OS
OSMinGW32, Int -> Int -> GhcRange
ghcMajor Int
9 Int
0)]
    }

  brokenTypeErrors :: Why
brokenTypeErrors = Why :: String -> String -> String -> [(BrokenOn, GhcRange)] -> Why
Why
    { what :: String
what = String
"Clash type error messages are indecipherable"
    , solution :: String
solution = String
"Upgrade to GHC 9.4 or downgrade to GHC 9.0"
    , issue :: String
issue = String
"<no link>"
    , brokenOn :: [(BrokenOn, GhcRange)]
brokenOn = [(BrokenOn
All, Int -> Int -> GhcRange
ghcMajor Int
9 Int
2)]
    }

  slowStarts :: Why
slowStarts = Why :: String -> String -> String -> [(BrokenOn, GhcRange)] -> Why
Why
    { what :: String
what = String
"Clash starts really slowly from GHC 9.4.8 up to and including 9.6.2"
    , solution :: String
solution = String
"Upgrade to GHC 9.6.3 or newer, or downgrade to GHC 9.4.7"
    , issue :: String
issue = String
"https://github.com/clash-lang/clash-compiler/issues/2710"
    , brokenOn :: [(BrokenOn, GhcRange)]
brokenOn = [(BrokenOn
All, GhcRange :: GhcVersion -> GhcVersion -> GhcRange
GhcRange{from :: GhcVersion
from=Int -> Int -> Int -> GhcVersion
Ghc Int
9 Int
4 Int
8, to :: GhcVersion
to=Int -> Int -> Int -> GhcVersion
Ghc Int
9 Int
6 Int
3})]
    }

-- | Given a 'BrokenOn', determine whether current OS matches
matchOs :: BrokenOn -> Bool
matchOs :: BrokenOn -> Bool
matchOs BrokenOn
All = Bool
True
matchOs (SomeOs OS
brokenOs) = OS
os OS -> OS -> Bool
forall a. Eq a => a -> a -> Bool
== OS
brokenOs

-- | Given a 'BrokenOn' and 'GhcVersion', determine whether it matches current OS and GHC
matchBroken :: (BrokenOn, GhcRange) -> Bool
matchBroken :: (BrokenOn, GhcRange) -> Bool
matchBroken (BrokenOn
brokenOs, GhcRange
brokenRange) = BrokenOn -> Bool
matchOs BrokenOn
brokenOs Bool -> Bool -> Bool
&& GhcVersion -> GhcRange -> Bool
ghcInRange GhcVersion
ghcVersion GhcRange
brokenRange

-- | Get first reason for GHC/OS being broken, if any
broken :: Maybe Why
broken :: Maybe Why
broken = [Why] -> Maybe Why
forall a. [a] -> Maybe a
listToMaybe [Why
why | Why
why <- [Why]
brokenGhcs, ((BrokenOn, GhcRange) -> Bool) -> [(BrokenOn, GhcRange)] -> Bool
forall (t :: Type -> Type) a.
Foldable t =>
(a -> Bool) -> t a -> Bool
any (BrokenOn, GhcRange) -> Bool
matchBroken (Why -> [(BrokenOn, GhcRange)]
brokenOn Why
why)]

-- | Throw an error if current OS / GHC version is known to be buggy
assertWorking :: IO ()
assertWorking :: IO ()
assertWorking = case Maybe Why
broken of
  Maybe Why
Nothing -> () -> IO ()
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ()
  Just Why
why -> String -> IO ()
forall a. HasCallStack => String -> a
error (Why -> String
whyPp Why
why)