hasufell/ghcup-hs
1
1
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Lala

Browse Source
This commit is contained in:
Julian Ospald
2020-03-05 18:02:59 +01:00
parent 718442a1e7
commit 2d51ad8940
19 changed files with 635 additions and 307 deletions
Download Patch File Download Diff File Expand all files Collapse all files

28
lib/GHCup.hs
View File

@@ -21,7 +21,8 @@ import GHCup.Types.Optics
import GHCup.Utils
import GHCup.Utils.File
import GHCup.Utils.Prelude
import GHCup.Version
import GHCup.Utils.String.QQ
import GHCup.Utils.Version.QQ
import Control.Applicative
import Control.Exception.Safe
@@ -37,7 +38,6 @@ import Data.Foldable
import Data.List
import Data.Maybe
import Data.String.Interpolate
import Data.String.QQ
import Data.Versions
import Data.Word8
import GHC.IO.Exception
@@ -148,13 +148,19 @@ installGHC :: (MonadLogger m, MonadIO m)
-> Path Abs -- ^ Path to install to
-> Excepts '[ProcessError] m ()
installGHC path inst = do
lift $ $(logInfo) [s|Installing GHC|]
lEM $ liftIO $ exec [s|./configure|]
False
[[s|--prefix=|] <> toFilePath inst]
(Just path)
Nothing
lEM $ liftIO $ exec [s|make|] True [[s|install|]] (Just path) Nothing
lift $ $(logInfo) [s|Installing GHC (this may take a while)|]
lEM $ liftIO $ execLogged [s|./configure|]
False
[[s|--prefix=|] <> toFilePath inst]
([rel|ghc-configure.log|] :: Path Rel)
(Just path)
Nothing
lEM $ liftIO $ execLogged [s|make|]
True
[[s|install|]]
([rel|ghc-make.log|] :: Path Rel)
(Just path)
Nothing
pure ()
@@ -418,12 +424,12 @@ getDebugInfo = do
---------------
--[ Compile ]--
---------------
-- TODO: build config
compileGHC :: ( MonadReader Settings m
, MonadThrow m
, MonadResource m
@@ -544,7 +550,7 @@ upgradeGHCup dls mtarget = do
dli <- liftE $ getDownloadInfo dls (ToolRequest GHCup latestVer) Nothing
tmp <- lift withGHCupTmpDir
let fn = [rel|ghcup|] :: Path Rel
p <- liftE $ download dli tmp (Just fn)
p <- liftE $ download dli tmp (Just fn)
case mtarget of
Nothing -> do
dest <- liftIO $ ghcupBinDir

2
lib/GHCup/Download.hs
View File

@@ -17,6 +17,7 @@ import GHCup.Types.Optics
import GHCup.Utils
import GHCup.Utils.File
import GHCup.Utils.Prelude
import GHCup.Utils.String.QQ
import Control.Applicative
import Control.Exception.Safe
@@ -32,7 +33,6 @@ import Data.ByteString.Builder
import Data.IORef
import Data.Maybe
import Data.String.Interpolate
import Data.String.QQ
import Data.Versions
import GHC.IO.Exception
import HPath

2
lib/GHCup/Platform.hs
View File

@@ -13,6 +13,7 @@ import GHCup.Types.JSON ( )
import GHCup.Utils.Bash
import GHCup.Utils.File
import GHCup.Utils.Prelude
import GHCup.Utils.String.QQ
import Control.Applicative
import Control.Exception.Safe
@@ -23,7 +24,6 @@ import Control.Monad.Trans.Class ( lift )
import Data.Foldable
import Data.Maybe
import Data.String.Interpolate
import Data.String.QQ
import Data.Text ( Text )
import Data.Versions
import HPath

29
lib/GHCup/Types/JSON.hs
View File

@@ -12,11 +12,12 @@
module GHCup.Types.JSON where
import GHCup.Types
import GHCup.Utils.Prelude
import GHCup.Utils.String.QQ
import Data.Aeson
import Data.Aeson.TH
import Data.Aeson.Types
import Data.String.QQ
import Data.Text.Encoding ( decodeUtf8 )
import Data.Text.Encoding as E
import Data.Versions
@@ -28,20 +29,18 @@ import qualified Data.ByteString as BS
import qualified Data.Text as T
deriveJSON defaultOptions ''Architecture
deriveJSON defaultOptions ''LinuxDistro
deriveJSON defaultOptions ''Mess
deriveJSON defaultOptions ''Platform
deriveJSON defaultOptions ''SemVer
deriveJSON defaultOptions ''Tool
deriveJSON defaultOptions ''VSep
deriveJSON defaultOptions ''VUnit
deriveJSON defaultOptions ''VersionInfo
deriveJSON defaultOptions ''Tag
deriveJSON defaultOptions ''DownloadInfo
deriveJSON defaultOptions ''GHCupDownloads
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } { fieldLabelModifier = removeLensFieldLabel } ''Architecture
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''LinuxDistro
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Mess
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Platform
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''SemVer
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Tool
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''VSep
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''VUnit
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''VersionInfo
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Tag
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''DownloadInfo
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''GHCupDownloads
instance ToJSON URI where

134
lib/GHCup/Utils.hs
View File

@@ -4,14 +4,20 @@
{-# LANGUAGE TemplateHaskell #-}
module GHCup.Utils where
module GHCup.Utils
( module GHCup.Utils.Dirs
, module GHCup.Utils
)
where
import GHCup.Errors
import GHCup.Types
import GHCup.Types.JSON ( )
import GHCup.Utils.Dirs
import GHCup.Utils.File
import GHCup.Utils.Prelude
import GHCup.Utils.String.QQ
import Control.Applicative
import Control.Exception.Safe
@@ -25,7 +31,6 @@ import Data.ByteString ( ByteString )
import Data.List
import Data.Maybe
import Data.String.Interpolate
import Data.String.QQ
import Data.Versions
import Data.Word8
import GHC.IO.Exception
@@ -38,7 +43,6 @@ import Prelude hiding ( abs
, writeFile
)
import Safe
import System.Posix.Env.ByteString ( getEnv )
import System.Posix.FilePath ( takeFileName )
import System.Posix.Files.ByteString ( readSymbolicLink )
import URI.ByteString
@@ -54,27 +58,11 @@ import qualified Data.Text.Encoding as E
-----------------
--[ Utilities ]--
-----------------
ghcupBaseDir :: IO (Path Abs)
ghcupBaseDir = do
getEnv [s|GHCUP_INSTALL_BASE_PREFIX|] >>= \case
Just r -> parseAbs r
Nothing -> do
home <- liftIO getHomeDirectory
pure (home </> ([rel|.ghcup|] :: Path Rel))
ghcupGHCBaseDir :: IO (Path Abs)
ghcupGHCBaseDir = ghcupBaseDir <&> (</> ([rel|ghc|] :: Path Rel))
ghcupGHCDir :: Version -> IO (Path Abs)
ghcupGHCDir ver = do
ghcbasedir <- ghcupGHCBaseDir
verdir <- parseRel (verToBS ver)
pure (ghcbasedir </> verdir)
------------------------
--[ Symlink handling ]--
------------------------
-- | The symlink destination of a ghc tool.
@@ -95,6 +83,13 @@ ghcLinkVersion = either (throwM . ParseError) pure . parseOnly parser
Right r -> pure r
-----------------------------------
--[ Set/Installed introspection ]--
-----------------------------------
ghcInstalled :: Version -> IO Bool
ghcInstalled ver = do
ghcdir <- ghcupGHCDir ver
@@ -110,11 +105,6 @@ ghcSet = do
link <- readSymbolicLink $ toFilePath ghcBin
Just <$> ghcLinkVersion link
ghcupBinDir :: IO (Path Abs)
ghcupBinDir = ghcupBaseDir <&> (</> ([rel|bin|] :: Path Rel))
ghcupCacheDir :: IO (Path Abs)
ghcupCacheDir = ghcupBaseDir <&> (</> ([rel|cache|] :: Path Rel))
cabalInstalled :: Version -> IO Bool
cabalInstalled ver = do
@@ -132,6 +122,13 @@ cabalSet = do
Left e -> throwM e
Right r -> pure r
-----------------------------------------
--[ Major version introspection (X.Y) ]--
-----------------------------------------
-- | We assume GHC is in semver format. I hope it is.
getGHCMajor :: MonadThrow m => Version -> m (Int, Int)
getGHCMajor ver = do
@@ -160,10 +157,12 @@ getGHCForMajor major' minor' = do
$ semvers
urlBaseName :: MonadThrow m
=> ByteString -- ^ the url path (without scheme and host)
-> m (Path Rel)
urlBaseName = parseRel . snd . B.breakEnd (== _slash) . urlDecode False
-----------------
--[ Unpacking ]--
-----------------
-- | Unpack an archive to a temporary directory and return that path.
@@ -191,6 +190,55 @@ unpackToDir dest av = do
| otherwise -> throwE $ UnknownArchive fn
------------
--[ Tags ]--
------------
-- | Get the tool versions that have this tag.
getTagged :: BinaryDownloads -> Tool -> Tag -> [Version]
getTagged av tool tag = toListOf
( ix tool
% to (Map.filter (\VersionInfo {..} -> elem tag _viTags))
% to Map.keys
% folded
)
av
getLatest :: BinaryDownloads -> Tool -> Maybe Version
getLatest av tool = headOf folded $ getTagged av tool Latest
getRecommended :: BinaryDownloads -> Tool -> Maybe Version
getRecommended av tool = headOf folded $ getTagged av tool Recommended
-----------------------
--[ Settings Getter ]--
-----------------------
getUrlSource :: MonadReader Settings m => m URLSource
getUrlSource = ask <&> urlSource
getCache :: MonadReader Settings m => m Bool
getCache = ask <&> cache
-------------
--[ Other ]--
-------------
urlBaseName :: MonadThrow m
=> ByteString -- ^ the url path (without scheme and host)
-> m (Path Rel)
urlBaseName = parseRel . snd . B.breakEnd (== _slash) . urlDecode False
-- Get tool files from ~/.ghcup/bin/ghc/<ver>/bin/*
-- while ignoring *-<ver> symlinks.
ghcToolFiles :: (MonadThrow m, MonadFail m, MonadIO m)
@@ -214,27 +262,3 @@ ghcToolFiles ver = do
when (B.null symver)
(throwIO $ userError $ "Fatal: ghc symlink target is broken")
pure $ filter (\x -> not $ symver `B.isSuffixOf` toFilePath x) files
-- | Get the tool versions that have this tag.
getTagged :: BinaryDownloads -> Tool -> Tag -> [Version]
getTagged av tool tag = toListOf
( ix tool
% to (Map.filter (\VersionInfo {..} -> elem tag _viTags))
% to Map.keys
% folded
)
av
getLatest :: BinaryDownloads -> Tool -> Maybe Version
getLatest av tool = headOf folded $ getTagged av tool Latest
getRecommended :: BinaryDownloads -> Tool -> Maybe Version
getRecommended av tool = headOf folded $ getTagged av tool Recommended
getUrlSource :: MonadReader Settings m => m URLSource
getUrlSource = ask <&> urlSource
getCache :: MonadReader Settings m => m Bool
getCache = ask <&> cache

92
lib/GHCup/Utils/Dirs.hs Normal file
View File

@@ -0,0 +1,92 @@
{-# LANGUAGE QuasiQuotes #-}
module GHCup.Utils.Dirs where
import GHCup.Types.JSON ( )
import GHCup.Utils.Prelude
import GHCup.Utils.String.QQ
import Control.Applicative
import Control.Exception.Safe
import Control.Monad
import Control.Monad.Reader
import Control.Monad.Trans.Resource
import Data.Maybe
import Data.Versions
import HPath
import HPath.IO
import Optics
import Prelude hiding ( abs
, readFile
, writeFile
)
import System.Posix.Env.ByteString ( getEnv
, getEnvDefault
)
import System.Posix.Temp.ByteString ( mkdtemp )
import qualified Data.ByteString.UTF8 as UTF8
import qualified System.Posix.FilePath as FP
import qualified System.Posix.User as PU
-------------------------
--[ GHCup directories ]--
-------------------------
ghcupBaseDir :: IO (Path Abs)
ghcupBaseDir = do
getEnv [s|GHCUP_INSTALL_BASE_PREFIX|] >>= \case
Just r -> parseAbs r
Nothing -> do
home <- liftIO getHomeDirectory
pure (home </> ([rel|.ghcup|] :: Path Rel))
ghcupGHCBaseDir :: IO (Path Abs)
ghcupGHCBaseDir = ghcupBaseDir <&> (</> ([rel|ghc|] :: Path Rel))
ghcupGHCDir :: Version -> IO (Path Abs)
ghcupGHCDir ver = do
ghcbasedir <- ghcupGHCBaseDir
verdir <- parseRel (verToBS ver)
pure (ghcbasedir </> verdir)
ghcupBinDir :: IO (Path Abs)
ghcupBinDir = ghcupBaseDir <&> (</> ([rel|bin|] :: Path Rel))
ghcupCacheDir :: IO (Path Abs)
ghcupCacheDir = ghcupBaseDir <&> (</> ([rel|cache|] :: Path Rel))
ghcupLogsDir :: IO (Path Abs)
ghcupLogsDir = ghcupBaseDir <&> (</> ([rel|logs|] :: Path Rel))
mkGhcupTmpDir :: (MonadThrow m, MonadIO m) => m (Path Abs)
mkGhcupTmpDir = do
tmpdir <- liftIO $ getEnvDefault [s|TMPDIR|] [s|/tmp|]
tmp <- liftIO $ mkdtemp $ (tmpdir FP.</> [s|ghcup-|])
parseAbs tmp
withGHCupTmpDir :: (MonadResource m, MonadThrow m, MonadIO m) => m (Path Abs)
withGHCupTmpDir = snd <$> allocate mkGhcupTmpDir deleteDirRecursive
--------------
--[ Others ]--
--------------
getHomeDirectory :: IO (Path Abs)
getHomeDirectory = do
e <- getEnv [s|HOME|]
case e of
Just fp -> parseAbs fp
Nothing -> do
h <- PU.homeDirectory <$> (PU.getEffectiveUserID >>= PU.getUserEntryForID)
parseAbs $ UTF8.fromString h -- this is a guess

60
lib/GHCup/Utils/File.hs
View File

@@ -3,19 +3,17 @@
module GHCup.Utils.File where
import GHCup.Utils.Dirs
import GHCup.Utils.Prelude
import Control.Exception.Safe
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Trans.Resource
import Data.ByteString
import Data.ByteString.Unsafe ( unsafeUseAsCStringLen )
import Data.Char
import Data.Foldable
import Data.Functor
import Data.Maybe
import Data.String.QQ
import GHC.Foreign ( peekCStringLen )
import GHC.IO.Encoding ( getLocaleEncoding )
import GHC.IO.Exception
@@ -27,28 +25,23 @@ import Streamly.External.ByteString
import Streamly.External.ByteString.Lazy
import System.IO
import System.Posix.Directory.ByteString
import System.Posix.Env.ByteString
import System.Posix.FD as FD
import System.Posix.FilePath hiding ( (</>) )
import System.Posix.Foreign ( oExcl )
import "unix" System.Posix.IO.ByteString
hiding ( openFd )
import System.Posix.Process ( ProcessStatus(..) )
import System.Posix.Temp.ByteString
import System.Posix.Types
import qualified System.Posix.Process.ByteString
as SPPB
import qualified System.Posix.FilePath as FP
import qualified System.Posix.User as PU
import Streamly.External.Posix.DirStream
import qualified Streamly.Internal.Memory.ArrayStream
as AS
import qualified Streamly.FileSystem.Handle as FH
import qualified Streamly.Internal.Data.Unfold as SU
import qualified Streamly.Prelude as S
import qualified Data.ByteString.UTF8 as UTF8
import qualified Data.ByteString.Lazy as L
@@ -115,6 +108,36 @@ executeOut path args chdir = captureOutStreams $ do
SPPB.executeFile (toFilePath path) True args Nothing
execLogged :: ByteString -- ^ thing to execute
-> Bool -- ^ whether to search PATH for the thing
-> [ByteString] -- ^ args for the thing
-> Path Rel -- ^ log filename
-> Maybe (Path Abs) -- ^ optionally chdir into this
-> Maybe [(ByteString, ByteString)] -- ^ optional environment
-> IO (Either ProcessError ())
execLogged exe spath args lfile chdir env = do
ldir <- ghcupLogsDir
let logfile = ldir </> lfile
bracket (createFile (toFilePath logfile) newFilePerms) closeFd action
where
action fd = do
pid <- SPPB.forkProcess $ do
-- dup stdout
void $ dupTo fd stdOutput
-- dup stderr
void $ dupTo fd stdError
-- execute the action
maybe (pure ()) (changeWorkingDirectory . toFilePath) chdir
SPPB.executeFile exe spath args env
SPPB.getProcessStatus True True pid >>= \case
i@(Just (SPPB.Exited es)) -> pure $ toProcessError exe args i
i -> pure $ toProcessError exe args i
-- | Capture the stdout and stderr of the given action, which
-- is run in a subprocess. Stdin is closed. You might want to
-- 'race' this to make sure it terminates.
@@ -193,27 +216,6 @@ toProcessError exe args mps = case mps of
Nothing -> Left $ NoSuchPid exe args
mkGhcupTmpDir :: (MonadThrow m, MonadIO m) => m (Path Abs)
mkGhcupTmpDir = do
tmpdir <- liftIO $ getEnvDefault [s|TMPDIR|] [s|/tmp|]
tmp <- liftIO $ mkdtemp $ (tmpdir FP.</> [s|ghcup-|])
parseAbs tmp
withGHCupTmpDir :: (MonadResource m, MonadThrow m, MonadIO m) => m (Path Abs)
withGHCupTmpDir = snd <$> allocate mkGhcupTmpDir deleteDirRecursive
getHomeDirectory :: IO (Path Abs)
getHomeDirectory = do
e <- getEnv [s|HOME|]
case e of
Just fp -> parseAbs fp
Nothing -> do
h <- PU.homeDirectory <$> (PU.getEffectiveUserID >>= PU.getUserEntryForID)
parseAbs $ UTF8.fromString h -- this is a guess
-- | Convert the String to a ByteString with the current
-- system encoding.
unsafePathToString :: Path b -> IO FilePath

53
lib/GHCup/Utils/Logger.hs
View File

@@ -1,28 +1,59 @@
{-# LANGUAGE QuasiQuotes #-}
module GHCup.Utils.Logger where
import GHCup.Utils
import Control.Monad.Logger
import HPath
import HPath.IO
import Prelude hiding ( appendFile )
import System.Console.Pretty
import System.IO.Error
import qualified Data.ByteString as B
import qualified Data.ByteString as B
data LoggerConfig = LoggerConfig {
lcPrintDebug :: Bool
, outter :: B.ByteString -> IO ()
}
data LoggerConfig = LoggerConfig
{ lcPrintDebug :: Bool -- ^ whether to print debug in colorOutter
, colorOutter :: B.ByteString -> IO () -- ^ how to write the color output
, rawOutter :: B.ByteString -> IO () -- ^ how to write the full raw output
}
myLoggerT :: LoggerConfig -> LoggingT m a -> m a
myLoggerT LoggerConfig{..} loggingt = runLoggingT loggingt mylogger
myLoggerT LoggerConfig {..} loggingt = runLoggingT loggingt mylogger
where
mylogger :: Loc -> LogSource -> LogLevel -> LogStr -> IO ()
mylogger _ _ level str' = do
-- color output
let l = case level of
LevelDebug -> if lcPrintDebug then toLogStr (style Bold $ color Blue "[ Debug ]") else mempty
LevelInfo -> toLogStr (style Bold $ color Green "[ Info ]")
LevelDebug -> if lcPrintDebug
then toLogStr (style Bold $ color Blue "[ Debug ]")
else mempty
LevelInfo -> toLogStr (style Bold $ color Green "[ Info ]")
LevelWarn -> toLogStr (style Bold $ color Yellow "[ Warn ]")
LevelError -> toLogStr (style Bold $ color Red "[ Error ]")
LevelError -> toLogStr (style Bold $ color Red "[ Error ]")
LevelOther t -> toLogStr "[ " <> toLogStr t <> toLogStr " ]"
let out = fromLogStr (l <> toLogStr " " <> str' <> toLogStr "\n")
outter out
let out = fromLogStr (l <> toLogStr " " <> str' <> toLogStr "\n")
colorOutter out
-- raw output
let lr = case level of
LevelDebug -> toLogStr "Debug: "
LevelInfo -> toLogStr "Info:"
LevelWarn -> toLogStr "Warn:"
LevelError -> toLogStr "Error:"
LevelOther t -> toLogStr t <> toLogStr ":"
let outr = fromLogStr (lr <> toLogStr " " <> str' <> toLogStr "\n")
rawOutter outr
initGHCupFileLogging :: Path Rel -> IO (Path Abs)
initGHCupFileLogging context = do
logs <- ghcupLogsDir
let logfile = logs </> context
createDirIfMissing newDirPerms logs
hideError doesNotExistErrorType $ deleteFile logfile
createRegularFile newFilePerms logfile
pure logfile

88
lib/GHCup/Utils/Prelude.hs
View File

@@ -1,15 +1,10 @@
{-# OPTIONS_GHC -Wno-orphans #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE DeriveLift #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE TypeFamilies #-}
module GHCup.Utils.Prelude where
@@ -21,20 +16,12 @@ import Control.Monad.IO.Class
import Control.Monad.Trans.Class ( lift )
import Data.Bifunctor
import Data.ByteString ( ByteString )
import Data.Data
import Data.Monoid ( (<>) )
import Data.String
import Data.Text ( Text )
import Data.Versions
import GHC.Base
import Haskus.Utils.Types.List
import Haskus.Utils.Variant.Excepts
import Language.Haskell.TH
import Language.Haskell.TH.Quote ( QuasiQuoter(..) )
import Language.Haskell.TH.Syntax ( Exp(..)
, Lift
, dataToExpQ
)
import System.IO.Error
import qualified Data.ByteString.Lazy as L
@@ -45,7 +32,6 @@ import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Builder as B
import qualified Data.Text.Lazy.Builder.Int as B
import qualified Data.Text.Lazy.Encoding as TLE
import qualified Language.Haskell.TH.Syntax as TH
@@ -197,84 +183,20 @@ hideExcept' _ action =
catchLiftLeft ((\_ -> pure ()) :: (e -> Excepts es' m ())) action
throwEither :: (Exception a, MonadThrow m) => Either a b -> m b
throwEither a = case a of
Left e -> throwM e
Right r -> pure r
deriving instance Data Versioning
deriving instance Lift Versioning
deriving instance Data Version
deriving instance Lift Version
deriving instance Data SemVer
deriving instance Lift SemVer
deriving instance Data Mess
deriving instance Lift Mess
deriving instance Data PVP
deriving instance Lift PVP
deriving instance Lift (NonEmpty Word)
deriving instance Lift VSep
deriving instance Data VSep
deriving instance Lift VUnit
deriving instance Data VUnit
instance Lift Text
qq :: (Text -> Q Exp) -> QuasiQuoter
qq quoteExp' = QuasiQuoter
{ quoteExp = (\s -> quoteExp' . T.pack $ s)
, quotePat = \_ ->
fail "illegal QuasiQuote (allowed as expression only, used as a pattern)"
, quoteType = \_ ->
fail "illegal QuasiQuote (allowed as expression only, used as a type)"
, quoteDec = \_ -> fail
"illegal QuasiQuote (allowed as expression only, used as a declaration)"
}
vver :: QuasiQuoter
vver = qq mkV
where
mkV :: Text -> Q Exp
mkV = either (fail . show) liftDataWithText . version
mver :: QuasiQuoter
mver = qq mkV
where
mkV :: Text -> Q Exp
mkV = either (fail . show) liftDataWithText . mess
sver :: QuasiQuoter
sver = qq mkV
where
mkV :: Text -> Q Exp
mkV = either (fail . show) liftDataWithText . semver
vers :: QuasiQuoter
vers = qq mkV
where
mkV :: Text -> Q Exp
mkV = either (fail . show) liftDataWithText . versioning
pver :: QuasiQuoter
pver = qq mkV
where
mkV :: Text -> Q Exp
mkV = either (fail . show) liftDataWithText . pvp
-- https://stackoverflow.com/questions/38143464/cant-find-inerface-file-declaration-for-variable
liftText :: T.Text -> Q Exp
liftText txt = AppE (VarE 'T.pack) <$> TH.lift (T.unpack txt)
liftDataWithText :: Data a => a -> Q Exp
liftDataWithText = dataToExpQ (\a -> liftText <$> cast a)
verToBS :: Version -> ByteString
verToBS = E.encodeUtf8 . prettyVer
intToText :: Integral a => a -> T.Text
intToText = TL.toStrict . B.toLazyText . B.decimal
removeLensFieldLabel :: String -> String
removeLensFieldLabel str' =
maybe str' T.unpack . T.stripPrefix (T.pack "_") . T.pack $ str'

48
lib/GHCup/Utils/String/QQ.hs Normal file
View File

@@ -0,0 +1,48 @@
{-# LANGUAGE TemplateHaskell #-}
-- | QuasiQuoter for non-interpolated strings, texts and bytestrings.
--
-- The "s" quoter contains a multi-line string with no interpolation at all,
-- except that the leading newline is trimmed and carriage returns stripped.
--
-- @
-- {-\# LANGUAGE QuasiQuotes #-}
-- import Data.Text (Text)
-- import Data.String.QQ
-- foo :: Text -- "String", "ByteString" etc also works
-- foo = [s|
-- Well here is a
-- multi-line string!
-- |]
-- @
--
-- Any instance of the IsString type is permitted.
--
-- (For GHC versions 6, write "[$s||]" instead of "[s||]".)
--
module GHCup.Utils.String.QQ
( s
)
where
import Data.Char
import GHC.Exts ( IsString(..) )
import Language.Haskell.TH.Quote
-- | QuasiQuoter for a non-interpolating ASCII IsString literal.
-- The pattern portion is undefined.
s :: QuasiQuoter
s = QuasiQuoter
(\s' -> case and $ fmap isAscii s' of
True -> (\a -> [|fromString a|]) . trimLeadingNewline . removeCRs $ s'
False -> fail "Not ascii"
)
(error "Cannot use q as a pattern")
(error "Cannot use q as a type")
(error "Cannot use q as a dec")
where
removeCRs = filter (/= '\r')
trimLeadingNewline ('\n' : xs) = xs
trimLeadingNewline xs = xs

89
lib/GHCup/Utils/Version/QQ.hs Normal file
View File

@@ -0,0 +1,89 @@
{-# OPTIONS_GHC -Wno-orphans #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveLift #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
module GHCup.Utils.Version.QQ where
import Data.Data
import Data.Text ( Text )
import Data.Versions
import GHC.Base
import Language.Haskell.TH
import Language.Haskell.TH.Quote ( QuasiQuoter(..) )
import Language.Haskell.TH.Syntax ( Exp(..)
, Lift
, dataToExpQ
)
import qualified Data.Text as T
import qualified Language.Haskell.TH.Syntax as TH
deriving instance Data Versioning
deriving instance Lift Versioning
deriving instance Data Version
deriving instance Lift Version
deriving instance Data SemVer
deriving instance Lift SemVer
deriving instance Data Mess
deriving instance Lift Mess
deriving instance Data PVP
deriving instance Lift PVP
deriving instance Lift (NonEmpty Word)
deriving instance Lift VSep
deriving instance Data VSep
deriving instance Lift VUnit
deriving instance Data VUnit
instance Lift Text
qq :: (Text -> Q Exp) -> QuasiQuoter
qq quoteExp' = QuasiQuoter
{ quoteExp = (\s -> quoteExp' . T.pack $ s)
, quotePat = \_ ->
fail "illegal QuasiQuote (allowed as expression only, used as a pattern)"
, quoteType = \_ ->
fail "illegal QuasiQuote (allowed as expression only, used as a type)"
, quoteDec = \_ -> fail
"illegal QuasiQuote (allowed as expression only, used as a declaration)"
}
vver :: QuasiQuoter
vver = qq mkV
where
mkV :: Text -> Q Exp
mkV = either (fail . show) liftDataWithText . version
mver :: QuasiQuoter
mver = qq mkV
where
mkV :: Text -> Q Exp
mkV = either (fail . show) liftDataWithText . mess
sver :: QuasiQuoter
sver = qq mkV
where
mkV :: Text -> Q Exp
mkV = either (fail . show) liftDataWithText . semver
vers :: QuasiQuoter
vers = qq mkV
where
mkV :: Text -> Q Exp
mkV = either (fail . show) liftDataWithText . versioning
pver :: QuasiQuoter
pver = qq mkV
where
mkV :: Text -> Q Exp
mkV = either (fail . show) liftDataWithText . pvp
-- https://stackoverflow.com/questions/38143464/cant-find-inerface-file-declaration-for-variable
liftText :: T.Text -> Q Exp
liftText txt = AppE (VarE 'T.pack) <$> TH.lift (T.unpack txt)
liftDataWithText :: Data a => a -> Q Exp
liftDataWithText = dataToExpQ (\a -> liftText <$> cast a)

3
lib/GHCup/Version.hs
View File

@@ -3,8 +3,9 @@
module GHCup.Version where
import GHCup.Utils.Version.QQ
import Data.Versions
import GHCup.Utils.Prelude
ghcUpVer :: PVP
ghcUpVer = [pver|0.1.0|]