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