#if __GLASGOW_HASKELL__ >= 707
#endif
module Distribution.Client.Dynamic.Query
( Selector(), selector
, Query(), query
, LocalBuildInfo()
, maybeDefault
, (>>>=), (=<<<)
, fmapS
, fmapQ
, on
, runQuery
, runRawQuery
, getCabalVersion
) where
import Control.Applicative
import Control.Category
import qualified Control.Exception as E
import Control.Monad
import Data.Version
import Data.Void
import qualified DynFlags
import qualified GHC
import qualified GHC.Paths
import Language.Haskell.Exts.Syntax
import Language.Haskell.Generate
import qualified MonadUtils
import Prelude hiding (id, (.))
import System.Directory
import System.FilePath
import System.IO.Error (isAlreadyExistsError)
import Text.ParserCombinators.ReadP
#if __GLASGOW_HASKELL__ >= 708
import Data.Dynamic hiding (Typeable1)
#else
import Data.Dynamic
#endif
#if __GLASGOW_HASKELL__ >= 707
type Typeable1 (f :: * -> *) = Typeable f
#endif
data LocalBuildInfo = LocalBuildInfo Void deriving (Typeable, Read)
newtype Selector i o = Selector (Version -> ExpG (i -> o))
instance Category Selector where
id = Selector $ const id'
Selector a . Selector b = Selector $ liftA2 (<>.) a b
(=<<<) :: Monad m => Selector b (m c) -> Selector a (m b) -> Selector a (m c)
Selector s =<<< Selector t = Selector $ \v -> applyE (flip' <>$ bind') (s v) <>. t v
(>>>=) :: Monad m => Selector a (m b) -> Selector b (m c) -> Selector a (m c)
(>>>=) = flip (=<<<)
fmapS :: Functor m => Selector a b -> Selector (m a) (m b)
fmapS (Selector s) = Selector $ \v -> applyE fmap' (s v)
zipSelector :: Selector i o -> Selector i p -> Selector i (o,p)
zipSelector (Selector s) (Selector t) = Selector $ \v -> expr $ \i -> applyE2 tuple2 (s v <>$ i) (t v <>$ i)
maybeDefault :: (GenExpType a ~ a, GenExp a) => a -> Selector (Maybe a) a
maybeDefault a = selector $ const $ applyE (flip' <>$ maybe' <>$ id') $ expr a
selector :: (Version -> ExpG (i -> o)) -> Selector i o
selector = Selector
data Query s a = forall i. Typeable i => Query (Selector s i) (i -> a)
instance Functor (Query s) where
fmap f (Query s x) = Query s $ f . x
instance Applicative (Query s) where
pure = Query (selector $ const $ const' <>$ tuple0) . const
Query f getF <*> Query a getA = Query (zipSelector f a) $ \(fv, av) -> getF fv $ getA av
query :: Typeable a => Selector s a -> Query s a
query = flip Query id
fmapQ :: (Functor f, Typeable1 f) => Query s a -> Query (f s) (f a)
fmapQ (Query s f) = Query (fmapS s) (fmap f)
on :: Selector i o -> Query o r -> Query i r
on s (Query sq f) = Query (sq . s) f
getRunDirectory :: IO FilePath
getRunDirectory = getTemporaryDirectory >>= go 0
where go :: Integer -> FilePath -> IO FilePath
go !c dir = do
let cdir = dir </> "dynamic-cabal" <.> show c
res <- E.try $ createDirectory cdir
case res of
Left e | isAlreadyExistsError e -> go (c + 1) dir
| otherwise -> E.throwIO e
Right () -> return cdir
getCabalVersion :: FilePath -> IO Version
getCabalVersion setupConfig = do
versionString <- dropWhile (not . flip elem ['0'..'9']) . (!! 7) . words . head . lines <$> readFile setupConfig
case filter (null . snd) $ readP_to_S parseVersion versionString of
[(v,_)] -> return v
_ -> E.throwIO $ userError "Couldn't parse version"
data LeftoverTempDir e = LeftoverTempDir FilePath e deriving Typeable
instance Show e => Show (LeftoverTempDir e) where
show (LeftoverTempDir dir e) = "Left over temporary directory not removed: " ++ dir ++ "\n" ++ show e
instance E.Exception e => E.Exception (LeftoverTempDir e)
withTempWorkingDir :: IO a -> IO a
withTempWorkingDir act = do
pwd <- getCurrentDirectory
tmp <- getRunDirectory
setCurrentDirectory tmp
res <- act `E.catch` \(E.SomeException e) -> setCurrentDirectory pwd >> E.throwIO (LeftoverTempDir tmp e)
setCurrentDirectory pwd
res <$ removeDirectoryRecursive tmp
generateSource :: Selector LocalBuildInfo o -> String -> FilePath -> Version -> IO String
generateSource (Selector s) modName setupConfig version =
return $ flip generateModule modName $ do
getLBI <- addDecl (Ident "getLBI") $
applyE fmap' (read' <>. unlines' <>. applyE drop' 1 <>. lines' :: ExpG (String -> LocalBuildInfo))
<>$ applyE readFile' (expr setupConfig)
result <- addDecl (Ident "result") $ applyE fmap' (s version) <>$ expr getLBI
return $ Just [exportFun result]
runQuery :: Query LocalBuildInfo a -> FilePath -> IO a
runQuery (Query s post) setupConfig = do
setupConfig' <- canonicalizePath setupConfig
version <- getCabalVersion setupConfig'
src<- generateSource s "DynamicCabalQuery" setupConfig' version
runRawQuery' src setupConfig post
runRawQuery :: Typeable a => String -> FilePath -> IO a
runRawQuery s setupConfig = runRawQuery' s setupConfig id
runRawQuery' :: Typeable i => String -> FilePath -> (i -> a) -> IO a
runRawQuery' s setupConfig post = do
setupConfig' <- canonicalizePath setupConfig
withTempWorkingDir $ do
version <- getCabalVersion setupConfig'
writeFile "DynamicCabalQuery.hs" s
GHC.runGhc (Just GHC.Paths.libdir) $ do
dflags <- GHC.getSessionDynFlags
void $ GHC.setSessionDynFlags $ dflags
{ GHC.ghcLink = GHC.LinkInMemory
, GHC.hscTarget = GHC.HscInterpreted
, GHC.packageFlags = [DynFlags.ExposePackage $ "Cabal-" ++ showVersion version]
, GHC.ctxtStkDepth = 1000
}
dflags' <- GHC.getSessionDynFlags
GHC.defaultCleanupHandler dflags' $ do
target <- GHC.guessTarget "DynamicCabalQuery.hs" Nothing
GHC.setTargets [target]
void $ GHC.load GHC.LoadAllTargets
GHC.setContext [GHC.IIDecl $ GHC.simpleImportDecl $ GHC.mkModuleName "DynamicCabalQuery"]
GHC.dynCompileExpr "result" >>= maybe (fail "dynamic-cabal: runQuery: Result expression has wrong type") (MonadUtils.liftIO . fmap post) . fromDynamic