@@ -0,0 +1,73 @@
1+{-# LANGUAGE DeriveDataTypeable #-}
2+{-# LANGUAGE NoImplicitPrelude #-}
3+{-# LANGUAGE OverloadedStrings #-}
4+{-# LANGUAGE TypeFamilies #-}
5+module Stackage2.Prelude
6+ ( module X
7+ , module Stackage2.Prelude
8+ ) where
9+
10+import ClassyPrelude.Conduit as X
11+import Data.Conduit.Process as X
12+import Data.Typeable (TypeRep, typeOf)
13+import Distribution.Package as X (PackageName (PackageName))
14+import qualified Distribution.Text as DT
15+import Distribution.Version as X (Version (..))
16+import System.Exit (ExitCode (ExitSuccess))
17+
18+unPackageName :: PackageName -> Text
19+unPackageName (PackageName str) = pack str
20+
21+mkPackageName :: Text -> PackageName
22+mkPackageName = PackageName . unpack
23+
24+display :: (IsString text, Element text ~ Char, DT.Text a) => a -> text
25+display = fromString . DT.display
26+
27+simpleParse :: (MonadThrow m, DT.Text a, Typeable a, MonoFoldable text, Element text ~ Char)
28+ => text -> m a
29+simpleParse orig = withTypeRep $ \rep ->
30+ case DT.simpleParse str of
31+ Nothing -> throwM (ParseFailed rep (pack str))
32+ Just v -> return v
33+ where
34+ str = unpack orig
35+
36+ withTypeRep :: Typeable a => (TypeRep -> m a) -> m a
37+ withTypeRep f =
38+ res
39+ where
40+ res = f (typeOf (unwrap res))
41+
42+ unwrap :: m a -> a
43+ unwrap _ = error "unwrap"
44+
45+data ParseFailed = ParseFailed TypeRep Text
46+ deriving (Show, Typeable)
47+instance Exception ParseFailed
48+
49+data ProcessExitedUnsuccessfully = ProcessExitedUnsuccessfully CreateProcess ExitCode
50+ deriving Typeable
51+instance Show ProcessExitedUnsuccessfully where
52+ show (ProcessExitedUnsuccessfully cp ec) = concat
53+ [ "Process exited with "
54+ , show ec
55+ , ": "
56+ , showCmdSpec (cmdspec cp)
57+ ]
58+ where
59+ showCmdSpec (ShellCommand str) = str
60+ showCmdSpec (RawCommand x xs) = unwords (x:xs)
61+instance Exception ProcessExitedUnsuccessfully
62+
63+checkExitCode :: MonadThrow m => CreateProcess -> ExitCode -> m ()
64+checkExitCode _ ExitSuccess = return ()
65+checkExitCode cp ec = throwM $ ProcessExitedUnsuccessfully cp ec
66+
67+-- FIXME move into streaming-commons?
68+withCheckedProcess cp f = do
69+ (x, y, z, sph) <- streamingProcess cp
70+ res <- f x y z
71+ ec <- waitForStreamingProcess sph
72+ checkExitCode cp ec
73+ return res