{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}
module Stack.Types.Compiler
( ActualCompiler (..)
, WhichCompiler (..)
, CompilerRepository (..)
, CompilerException (..)
, defaultCompilerRepository
, getGhcVersion
, whichCompiler
, compilerVersionText
, compilerVersionString
, isWantedCompiler
, wantedToActual
, actualToWanted
, parseActualCompiler
) where
import Data.Aeson
import Database.Persist
import Database.Persist.Sql
import qualified Data.Text as T
import Stack.Prelude
import Stack.Types.Version
import Distribution.Version ( mkVersion )
data CompilerException
= GhcjsNotSupported
| PantryException PantryException
deriving (Int -> CompilerException -> ShowS
[CompilerException] -> ShowS
CompilerException -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CompilerException] -> ShowS
$cshowList :: [CompilerException] -> ShowS
show :: CompilerException -> String
$cshow :: CompilerException -> String
showsPrec :: Int -> CompilerException -> ShowS
$cshowsPrec :: Int -> CompilerException -> ShowS
Show, Typeable)
instance Exception CompilerException where
displayException :: CompilerException -> String
displayException CompilerException
GhcjsNotSupported =
String
"Error: [S-7903]\n"
forall a. [a] -> [a] -> [a]
++ String
"GHCJS is no longer supported by Stack."
displayException (PantryException PantryException
p) =
String
"Error: [S-7972]\n"
forall a. [a] -> [a] -> [a]
++ forall e. Exception e => e -> String
displayException PantryException
p
data WhichCompiler
= Ghc
deriving (Int -> WhichCompiler -> ShowS
[WhichCompiler] -> ShowS
WhichCompiler -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [WhichCompiler] -> ShowS
$cshowList :: [WhichCompiler] -> ShowS
show :: WhichCompiler -> String
$cshow :: WhichCompiler -> String
showsPrec :: Int -> WhichCompiler -> ShowS
$cshowsPrec :: Int -> WhichCompiler -> ShowS
Show, WhichCompiler -> WhichCompiler -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: WhichCompiler -> WhichCompiler -> Bool
$c/= :: WhichCompiler -> WhichCompiler -> Bool
== :: WhichCompiler -> WhichCompiler -> Bool
$c== :: WhichCompiler -> WhichCompiler -> Bool
Eq, Eq WhichCompiler
WhichCompiler -> WhichCompiler -> Bool
WhichCompiler -> WhichCompiler -> Ordering
WhichCompiler -> WhichCompiler -> WhichCompiler
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 :: WhichCompiler -> WhichCompiler -> WhichCompiler
$cmin :: WhichCompiler -> WhichCompiler -> WhichCompiler
max :: WhichCompiler -> WhichCompiler -> WhichCompiler
$cmax :: WhichCompiler -> WhichCompiler -> WhichCompiler
>= :: WhichCompiler -> WhichCompiler -> Bool
$c>= :: WhichCompiler -> WhichCompiler -> Bool
> :: WhichCompiler -> WhichCompiler -> Bool
$c> :: WhichCompiler -> WhichCompiler -> Bool
<= :: WhichCompiler -> WhichCompiler -> Bool
$c<= :: WhichCompiler -> WhichCompiler -> Bool
< :: WhichCompiler -> WhichCompiler -> Bool
$c< :: WhichCompiler -> WhichCompiler -> Bool
compare :: WhichCompiler -> WhichCompiler -> Ordering
$ccompare :: WhichCompiler -> WhichCompiler -> Ordering
Ord)
data ActualCompiler
= ACGhc !Version
| ACGhcGit !Text !Text
deriving (forall x. Rep ActualCompiler x -> ActualCompiler
forall x. ActualCompiler -> Rep ActualCompiler x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep ActualCompiler x -> ActualCompiler
$cfrom :: forall x. ActualCompiler -> Rep ActualCompiler x
Generic, Int -> ActualCompiler -> ShowS
[ActualCompiler] -> ShowS
ActualCompiler -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ActualCompiler] -> ShowS
$cshowList :: [ActualCompiler] -> ShowS
show :: ActualCompiler -> String
$cshow :: ActualCompiler -> String
showsPrec :: Int -> ActualCompiler -> ShowS
$cshowsPrec :: Int -> ActualCompiler -> ShowS
Show, ActualCompiler -> ActualCompiler -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ActualCompiler -> ActualCompiler -> Bool
$c/= :: ActualCompiler -> ActualCompiler -> Bool
== :: ActualCompiler -> ActualCompiler -> Bool
$c== :: ActualCompiler -> ActualCompiler -> Bool
Eq, Eq ActualCompiler
ActualCompiler -> ActualCompiler -> Bool
ActualCompiler -> ActualCompiler -> Ordering
ActualCompiler -> ActualCompiler -> ActualCompiler
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 :: ActualCompiler -> ActualCompiler -> ActualCompiler
$cmin :: ActualCompiler -> ActualCompiler -> ActualCompiler
max :: ActualCompiler -> ActualCompiler -> ActualCompiler
$cmax :: ActualCompiler -> ActualCompiler -> ActualCompiler
>= :: ActualCompiler -> ActualCompiler -> Bool
$c>= :: ActualCompiler -> ActualCompiler -> Bool
> :: ActualCompiler -> ActualCompiler -> Bool
$c> :: ActualCompiler -> ActualCompiler -> Bool
<= :: ActualCompiler -> ActualCompiler -> Bool
$c<= :: ActualCompiler -> ActualCompiler -> Bool
< :: ActualCompiler -> ActualCompiler -> Bool
$c< :: ActualCompiler -> ActualCompiler -> Bool
compare :: ActualCompiler -> ActualCompiler -> Ordering
$ccompare :: ActualCompiler -> ActualCompiler -> Ordering
Ord, Typeable ActualCompiler
ActualCompiler -> DataType
ActualCompiler -> Constr
(forall b. Data b => b -> b) -> ActualCompiler -> ActualCompiler
forall a.
Typeable a
-> (forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> a -> c a)
-> (forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c a)
-> (a -> Constr)
-> (a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c a))
-> (forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
-> ((forall b. Data b => b -> b) -> a -> a)
-> (forall r r'.
(r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall r r'.
(r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall u. (forall d. Data d => d -> u) -> a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> a -> u)
-> (forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> a -> m a)
-> Data a
forall u.
Int -> (forall d. Data d => d -> u) -> ActualCompiler -> u
forall u. (forall d. Data d => d -> u) -> ActualCompiler -> [u]
forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> ActualCompiler -> r
forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> ActualCompiler -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d)
-> ActualCompiler -> m ActualCompiler
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> ActualCompiler -> m ActualCompiler
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c ActualCompiler
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> ActualCompiler -> c ActualCompiler
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c ActualCompiler)
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c ActualCompiler)
gmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> ActualCompiler -> m ActualCompiler
$cgmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> ActualCompiler -> m ActualCompiler
gmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> ActualCompiler -> m ActualCompiler
$cgmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> ActualCompiler -> m ActualCompiler
gmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d)
-> ActualCompiler -> m ActualCompiler
$cgmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d)
-> ActualCompiler -> m ActualCompiler
gmapQi :: forall u.
Int -> (forall d. Data d => d -> u) -> ActualCompiler -> u
$cgmapQi :: forall u.
Int -> (forall d. Data d => d -> u) -> ActualCompiler -> u
gmapQ :: forall u. (forall d. Data d => d -> u) -> ActualCompiler -> [u]
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> ActualCompiler -> [u]
gmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> ActualCompiler -> r
$cgmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> ActualCompiler -> r
gmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> ActualCompiler -> r
$cgmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> ActualCompiler -> r
gmapT :: (forall b. Data b => b -> b) -> ActualCompiler -> ActualCompiler
$cgmapT :: (forall b. Data b => b -> b) -> ActualCompiler -> ActualCompiler
dataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c ActualCompiler)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c ActualCompiler)
dataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c ActualCompiler)
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c ActualCompiler)
dataTypeOf :: ActualCompiler -> DataType
$cdataTypeOf :: ActualCompiler -> DataType
toConstr :: ActualCompiler -> Constr
$ctoConstr :: ActualCompiler -> Constr
gunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c ActualCompiler
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c ActualCompiler
gfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> ActualCompiler -> c ActualCompiler
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> ActualCompiler -> c ActualCompiler
Data, Typeable)
instance NFData ActualCompiler
instance Display ActualCompiler where
display :: ActualCompiler -> Utf8Builder
display (ACGhc Version
x) = forall a. Display a => a -> Utf8Builder
display (Version -> WantedCompiler
WCGhc Version
x)
display (ACGhcGit Text
x Text
y) = forall a. Display a => a -> Utf8Builder
display (Text -> Text -> WantedCompiler
WCGhcGit Text
x Text
y)
instance ToJSON ActualCompiler where
toJSON :: ActualCompiler -> Value
toJSON = forall a. ToJSON a => a -> Value
toJSON forall b c a. (b -> c) -> (a -> b) -> a -> c
. ActualCompiler -> Text
compilerVersionText
instance FromJSON ActualCompiler where
parseJSON :: Value -> Parser ActualCompiler
parseJSON (String Text
t) = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Failed to parse compiler version") forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> Either CompilerException ActualCompiler
parseActualCompiler Text
t)
parseJSON Value
_ = forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Invalid CompilerVersion, must be String"
instance FromJSONKey ActualCompiler where
fromJSONKey :: FromJSONKeyFunction ActualCompiler
fromJSONKey = forall a. (Text -> Parser a) -> FromJSONKeyFunction a
FromJSONKeyTextParser forall a b. (a -> b) -> a -> b
$ \Text
k ->
case Text -> Either CompilerException ActualCompiler
parseActualCompiler Text
k of
Left CompilerException
_ -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Failed to parse CompilerVersion " forall a. [a] -> [a] -> [a]
++ Text -> String
T.unpack Text
k
Right ActualCompiler
parsed -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ActualCompiler
parsed
instance PersistField ActualCompiler where
toPersistValue :: ActualCompiler -> PersistValue
toPersistValue = forall a. PersistField a => a -> PersistValue
toPersistValue forall b c a. (b -> c) -> (a -> b) -> a -> c
. ActualCompiler -> Text
compilerVersionText
fromPersistValue :: PersistValue -> Either Text ActualCompiler
fromPersistValue = (forall a1 a2 b. (a1 -> a2) -> Either a1 b -> Either a2 b
mapLeft forall a. Show a => a -> Text
tshow forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either CompilerException ActualCompiler
parseActualCompiler) forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< forall a. PersistField a => PersistValue -> Either Text a
fromPersistValue
instance PersistFieldSql ActualCompiler where
sqlType :: Proxy ActualCompiler -> SqlType
sqlType Proxy ActualCompiler
_ = SqlType
SqlString
wantedToActual :: WantedCompiler -> Either CompilerException ActualCompiler
wantedToActual :: WantedCompiler -> Either CompilerException ActualCompiler
wantedToActual (WCGhc Version
x) = forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ Version -> ActualCompiler
ACGhc Version
x
wantedToActual (WCGhcjs Version
_ Version
_) = forall a b. a -> Either a b
Left CompilerException
GhcjsNotSupported
wantedToActual (WCGhcGit Text
x Text
y) = forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ Text -> Text -> ActualCompiler
ACGhcGit Text
x Text
y
actualToWanted :: ActualCompiler -> WantedCompiler
actualToWanted :: ActualCompiler -> WantedCompiler
actualToWanted (ACGhc Version
x) = Version -> WantedCompiler
WCGhc Version
x
actualToWanted (ACGhcGit Text
x Text
y) = Text -> Text -> WantedCompiler
WCGhcGit Text
x Text
y
parseActualCompiler :: T.Text -> Either CompilerException ActualCompiler
parseActualCompiler :: Text -> Either CompilerException ActualCompiler
parseActualCompiler =
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> Either a b
Left forall b c a. (b -> c) -> (a -> b) -> a -> c
. PantryException -> CompilerException
PantryException) WantedCompiler -> Either CompilerException ActualCompiler
wantedToActual forall b c a. (b -> c) -> (a -> b) -> a -> c
.
Text -> Either PantryException WantedCompiler
parseWantedCompiler
compilerVersionText :: ActualCompiler -> T.Text
compilerVersionText :: ActualCompiler -> Text
compilerVersionText = Utf8Builder -> Text
utf8BuilderToText forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Display a => a -> Utf8Builder
display
compilerVersionString :: ActualCompiler -> String
compilerVersionString :: ActualCompiler -> String
compilerVersionString = Text -> String
T.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. ActualCompiler -> Text
compilerVersionText
whichCompiler :: ActualCompiler -> WhichCompiler
whichCompiler :: ActualCompiler -> WhichCompiler
whichCompiler ACGhc{} = WhichCompiler
Ghc
whichCompiler ACGhcGit{} = WhichCompiler
Ghc
isWantedCompiler :: VersionCheck -> WantedCompiler -> ActualCompiler -> Bool
isWantedCompiler :: VersionCheck -> WantedCompiler -> ActualCompiler -> Bool
isWantedCompiler VersionCheck
check (WCGhc Version
wanted) (ACGhc Version
actual) =
VersionCheck -> Version -> Version -> Bool
checkVersion VersionCheck
check Version
wanted Version
actual
isWantedCompiler VersionCheck
_check (WCGhcGit Text
wCommit Text
wFlavour) (ACGhcGit Text
aCommit Text
aFlavour) =
Text
wCommit forall a. Eq a => a -> a -> Bool
== Text
aCommit Bool -> Bool -> Bool
&& Text
wFlavour forall a. Eq a => a -> a -> Bool
== Text
aFlavour
isWantedCompiler VersionCheck
_ WantedCompiler
_ ActualCompiler
_ = Bool
False
getGhcVersion :: ActualCompiler -> Version
getGhcVersion :: ActualCompiler -> Version
getGhcVersion (ACGhc Version
v) = Version
v
getGhcVersion (ACGhcGit Text
_ Text
_) =
[Int] -> Version
mkVersion [Int
999,Int
0,Int
0]
newtype CompilerRepository
= CompilerRepository Text
deriving (Int -> CompilerRepository -> ShowS
[CompilerRepository] -> ShowS
CompilerRepository -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CompilerRepository] -> ShowS
$cshowList :: [CompilerRepository] -> ShowS
show :: CompilerRepository -> String
$cshow :: CompilerRepository -> String
showsPrec :: Int -> CompilerRepository -> ShowS
$cshowsPrec :: Int -> CompilerRepository -> ShowS
Show)
instance FromJSON CompilerRepository where
parseJSON :: Value -> Parser CompilerRepository
parseJSON = forall a. String -> (Text -> Parser a) -> Value -> Parser a
withText String
"CompilerRepository" (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> CompilerRepository
CompilerRepository)
defaultCompilerRepository :: CompilerRepository
defaultCompilerRepository :: CompilerRepository
defaultCompilerRepository = Text -> CompilerRepository
CompilerRepository Text
"https://gitlab.haskell.org/ghc/ghc.git"