module Language.Haskell.BuildWrapper.API where
import Language.Haskell.BuildWrapper.Base
import Language.Haskell.BuildWrapper.Cabal
import qualified Language.Haskell.BuildWrapper.GHC as BwGHC
import Language.Haskell.BuildWrapper.GHCStorage
import Language.Haskell.BuildWrapper.Src
import qualified Data.Text as T
import Prelude hiding (readFile, writeFile)
import System.IO.UTF8
import Control.Monad.State
import Language.Haskell.Exts.Annotated
import Language.Preprocessor.Cpphs
import Data.Maybe
import System.Directory
import System.FilePath
import GHC (TypecheckedSource)
synchronize :: Bool
-> BuildWrapper(OpResult [FilePath])
synchronize force =do
cf<-gets cabalFile
m<-copyFromMain force $ takeFileName cf
(fileList,ns)<-getFilesToCopy
m1<-mapM (copyFromMain force)(
"Setup.hs":
"Setup.lhs":
fileList)
return (catMaybes (m : m1), ns)
synchronize1 :: Bool
-> FilePath
-> BuildWrapper(Maybe FilePath)
synchronize1 force fp = do
m1<-mapM (copyFromMain force) [fp]
return $ head m1
write :: FilePath
-> String
-> BuildWrapper()
write fp s= do
real<-getTargetPath fp
liftIO $ writeFile real s
configure :: WhichCabal
-> BuildWrapper (OpResult Bool)
configure which= do
(mlbi,msgs)<-cabalConfigure which
return (isJust mlbi,msgs)
build :: Bool
-> WhichCabal
-> BuildWrapper (OpResult BuildResult)
build = cabalBuild
build1 :: FilePath
-> BuildWrapper (OpResult Bool)
build1 fp=do
(mtm,msgs)<-getGHCAST fp
return (isJust mtm,msgs)
preproc :: BuildFlags
-> FilePath
-> IO String
preproc bf tgt= do
inputOrig<-readFile tgt
let epo=parseOptions $ bf_preproc bf
case epo of
Right opts2->runCpphs opts2 tgt inputOrig
Left _->return inputOrig
getBuildFlags :: FilePath
-> BuildWrapper (OpResult BuildFlags)
getBuildFlags fp=do
tgt<-getTargetPath fp
src<-getCabalFile Source
modSrc<-liftIO $ getModificationTime src
mbf<-liftIO $ readBuildFlagsInfo tgt modSrc
case mbf of
Just bf-> return bf
Nothing -> do
(mcbi,bwns)<-getBuildInfo fp
ret<-case mcbi of
Just cbi->do
(_,opts2)<-fileGhcOptions cbi
let
(modName,opts)=cabalExtensions $ snd cbi
lit=".lhs" == takeExtension fp
cppo=fileCppOptions (snd cbi) ++ ["-D__GLASGOW_HASKELL__=" ++ show (__GLASGOW_HASKELL__ :: Int)] ++ ["--unlit" | lit]
modS=moduleToString modName
return (BuildFlags (opts ++ opts2) cppo (Just modS),bwns)
Nothing -> return (BuildFlags knownExtensionNames [] Nothing,[])
liftIO $ storeBuildFlagsInfo tgt ret
return ret
getAST :: FilePath
-> BuildWrapper (OpResult (Maybe (ParseResult (Module SrcSpanInfo, [Comment]))))
getAST fp=do
(bf,ns)<-getBuildFlags fp
tgt<-getTargetPath fp
input<-liftIO $ preproc bf tgt
pr<- liftIO $ getHSEAST input (bf_ast bf)
return (Just pr,ns)
getGHCAST :: FilePath
-> BuildWrapper (OpResult (Maybe TypecheckedSource))
getGHCAST fp = withGHCAST' fp (\_->BwGHC.getAST)
withGHCAST :: FilePath
-> (FilePath
-> FilePath
-> String
-> [String]
-> IO a)
-> BuildWrapper (OpResult (Maybe a))
withGHCAST fp f=withGHCAST' fp (\n a b c d->do
r<- f a b c d
return (Just r,n))
withGHCAST' :: FilePath
-> ([BWNote]
-> FilePath
-> FilePath
-> String
-> [String]
-> IO (OpResult (Maybe a))) -> BuildWrapper (OpResult (Maybe a))
withGHCAST' fp f= do
(bf,ns)<-getBuildFlags fp
case bf of
(BuildFlags opts _ (Just modS))-> do
tgt<-getTargetPath fp
temp<-getFullTempDir
liftIO $ do
cd<-getCurrentDirectory
setCurrentDirectory temp
(pr,bwns2)<- f [] tgt temp modS opts
setCurrentDirectory cd
return (pr,ns ++ bwns2)
_ -> return (Nothing,ns)
getOutline :: FilePath
-> BuildWrapper (OpResult OutlineResult)
getOutline fp=do
(mast,bwns)<-getAST fp
case mast of
Just (ParseOk ast)->do
let ods=getHSEOutline ast
let (es,is)=getHSEImportExport ast
return (OutlineResult ods es is,bwns)
Just (ParseFailed failLoc err)->return (OutlineResult [] [] [],BWNote BWError err (BWLocation fp (srcLine failLoc) (srcColumn failLoc)) :bwns)
_ -> return (OutlineResult [] [] [],bwns)
getTokenTypes :: FilePath
-> BuildWrapper (OpResult [TokenDef])
getTokenTypes fp=do
tgt<-getTargetPath fp
ett<-liftIO $ do
input<-readFile tgt
BwGHC.tokenTypesArbitrary tgt input (".lhs" == takeExtension fp) knownExtensionNames
case ett of
Right tt->return (tt,[])
Left bw -> return ([],[bw])
getOccurrences :: FilePath
-> String
-> BuildWrapper (OpResult [TokenDef])
getOccurrences fp query=do
(BuildFlags opts _ _, _)<-getBuildFlags fp
tgt<-getTargetPath fp
input<-liftIO $ readFile tgt
ett<-liftIO $ BwGHC.occurrences tgt input (T.pack query) (".lhs" == takeExtension fp) opts
case ett of
Right tt->return (tt,[])
Left bw -> return ([],[bw])
getThingAtPoint :: FilePath
-> Int
-> Int
-> BuildWrapper (OpResult (Maybe ThingAtPoint))
getThingAtPoint fp line col=do
mm<-withGHCAST fp $ BwGHC.getThingAtPointJSON line col
return $ case mm of
(Just m,ns)->(m,ns)
(Nothing,ns)-> (Nothing,ns)
getNamesInScope :: FilePath-> BuildWrapper (OpResult (Maybe [String]))
getNamesInScope fp=withGHCAST fp BwGHC.getGhcNamesInScope
getCabalDependencies :: BuildWrapper (OpResult [(FilePath,[CabalPackage])])
getCabalDependencies = cabalDependencies
getCabalComponents :: BuildWrapper (OpResult [CabalComponent])
getCabalComponents = cabalComponents