1{-# LANGUAGE NoImplicitPrelude #-}
2{-# LANGUAGE DataKinds #-}
3{-# LANGUAGE OverloadedStrings #-}
4{-# LANGUAGE DeriveDataTypeable #-}
5{-# LANGUAGE DeriveGeneric #-}
6{-# LANGUAGE FlexibleInstances #-}
7{-# LANGUAGE TypeFamilies #-}
8
9module Stack.Types.Compiler
10  ( ActualCompiler (..)
11  , WhichCompiler (..)
12  , CompilerRepository (..)
13  , CompilerException (..)
14  , defaultCompilerRepository
15  , getGhcVersion
16  , whichCompiler
17  , compilerVersionText
18  , compilerVersionString
19  , isWantedCompiler
20  , wantedToActual
21  , actualToWanted
22  , parseActualCompiler
23  ) where
24
25import           Data.Aeson
26import           Database.Persist
27import           Database.Persist.Sql
28import qualified Data.Text as T
29import           Stack.Prelude
30import           Stack.Types.Version
31import           Distribution.Version (mkVersion)
32
33-- | Variety of compiler to use.
34data WhichCompiler
35    = Ghc
36    deriving (Show, Eq, Ord)
37
38-- | Specifies a compiler and its version number(s).
39--
40-- Note that despite having this datatype, stack isn't in a hurry to
41-- support compilers other than GHC.
42data ActualCompiler
43    = ACGhc !Version
44    | ACGhcGit !Text !Text
45    deriving (Generic, Show, Eq, Ord, Data, Typeable)
46instance NFData ActualCompiler
47instance Display ActualCompiler where
48    display (ACGhc x) = display (WCGhc x)
49    display (ACGhcGit x y) = display (WCGhcGit x y)
50instance ToJSON ActualCompiler where
51    toJSON = toJSON . compilerVersionText
52instance FromJSON ActualCompiler where
53    parseJSON (String t) = either (const $ fail "Failed to parse compiler version") return (parseActualCompiler t)
54    parseJSON _ = fail "Invalid CompilerVersion, must be String"
55instance FromJSONKey ActualCompiler where
56    fromJSONKey = FromJSONKeyTextParser $ \k ->
57        case parseActualCompiler k of
58            Left _ -> fail $ "Failed to parse CompilerVersion " ++ T.unpack k
59            Right parsed -> return parsed
60instance PersistField ActualCompiler where
61  toPersistValue = toPersistValue . compilerVersionText
62  fromPersistValue = (mapLeft tshow . parseActualCompiler) <=< fromPersistValue
63instance PersistFieldSql ActualCompiler where
64  sqlType _ = SqlString
65
66data CompilerException
67  = GhcjsNotSupported
68  | PantryException PantryException
69
70instance Show CompilerException where
71    show GhcjsNotSupported = "GHCJS is no longer supported by Stack"
72    show (PantryException p) = displayException p
73instance Exception CompilerException
74
75wantedToActual :: WantedCompiler -> Either CompilerException ActualCompiler
76wantedToActual (WCGhc x) = Right $ ACGhc x
77wantedToActual (WCGhcjs _ _) = Left GhcjsNotSupported
78wantedToActual (WCGhcGit x y) = Right $ ACGhcGit x y
79
80actualToWanted :: ActualCompiler -> WantedCompiler
81actualToWanted (ACGhc x) = WCGhc x
82actualToWanted (ACGhcGit x y) = WCGhcGit x y
83
84parseActualCompiler :: T.Text -> Either CompilerException ActualCompiler
85parseActualCompiler =
86  either (Left . PantryException) wantedToActual .
87  parseWantedCompiler
88
89compilerVersionText :: ActualCompiler -> T.Text
90compilerVersionText = utf8BuilderToText . display
91
92compilerVersionString :: ActualCompiler -> String
93compilerVersionString = T.unpack . compilerVersionText
94
95whichCompiler :: ActualCompiler -> WhichCompiler
96whichCompiler ACGhc{} = Ghc
97whichCompiler ACGhcGit{} = Ghc
98
99isWantedCompiler :: VersionCheck -> WantedCompiler -> ActualCompiler -> Bool
100isWantedCompiler check (WCGhc wanted) (ACGhc actual) =
101    checkVersion check wanted actual
102isWantedCompiler _check (WCGhcGit wCommit wFlavour) (ACGhcGit aCommit aFlavour) =
103    wCommit == aCommit && wFlavour == aFlavour
104isWantedCompiler _ _ _ = False
105
106getGhcVersion :: ActualCompiler -> Version
107getGhcVersion (ACGhc v) = v
108getGhcVersion (ACGhcGit _ _) =
109   -- We can't return the actual version without running the installed ghc.
110   -- For now we assume that users of ghc-git use it with a recent commit so we
111   -- return a version far in the future. This disables our hacks for older
112   -- versions and passes version checking when we use newer features.
113   mkVersion [999,0,0]
114
115-- | Repository containing the compiler sources
116newtype CompilerRepository
117  = CompilerRepository Text
118  deriving (Show)
119
120instance FromJSON CompilerRepository where
121  parseJSON = withText "CompilerRepository" (return . CompilerRepository)
122
123defaultCompilerRepository :: CompilerRepository
124defaultCompilerRepository = CompilerRepository "https://gitlab.haskell.org/ghc/ghc.git"
125