module Language.Haskell.BuildWrapper.API where
import Distribution.Simple.LocalBuildInfo (localPkgDescr)
import Distribution.Package (packageId)
import Distribution.Text (display)
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 qualified Data.HashMap.Lazy as HM
import qualified Data.Map as DM
import Data.List (sortBy)
import Prelude hiding (readFile, writeFile)
import qualified Data.Vector as V
import System.IO.UTF8
import Control.Monad.State
import Language.Haskell.Exts.Annotated hiding (String)
import Language.Preprocessor.Cpphs
import Data.Maybe
import System.Directory
import System.FilePath
import GHC (RenamedSource, TypecheckedSource, TypecheckedModule(..), Ghc, ms_mod, pm_mod_summary, moduleName)
import Data.Aeson
import Outputable (showSDoc,ppr)
import Data.Foldable (foldrM)
synchronize :: Bool
-> BuildWrapper(OpResult ([FilePath],[FilePath]))
synchronize force =do
cf<-gets cabalFile
(fileList,ns)<-getFilesToCopy
let fullFileList=takeFileName cf :
"Setup.hs":
"Setup.lhs":
fileList
m1<-mapM (copyFromMain force) fullFileList
del<-deleteGhosts fullFileList
return ((catMaybes m1,del), 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
generateUsage :: Bool
-> String
-> BuildWrapper(OpResult (Maybe [FilePath]))
generateUsage returnAll ccn=
withCabal Source (\lbi -> do
cbis<-getAllFiles lbi
cf<-gets cabalFile
temp<-getFullTempDir
let dir=takeDirectory cf
let pkg=T.pack $ display $ packageId $ localPkgDescr lbi
allMps<-mapM (\cbi->do
let
mps1=map (\(m,f)->(f,moduleToString $ fromJust m)) $ filter (isJust . fst) $ cbiModulePaths cbi
mps<-filterM (\(f,_)->do
fullSrc<-getFullSrc f
fullTgt<-getTargetPath f
let fullUsage=getUsageFile fullTgt
liftIO $ isSourceMoreRecent fullSrc fullUsage
) $ filter (\(f,_)->fitForUsage f
)
mps1
opts<-fileGhcOptions (lbi,cbi)
modules<-liftIO $ do
cd<-getCurrentDirectory
setCurrentDirectory dir
(mods,_)<-BwGHC.withASTNotes (getModule pkg) (temp </>) dir (MultipleFile mps) opts
setCurrentDirectory cd
return mods
mapM_ (generate pkg) modules
return $ if returnAll then mps1 else mps
) $ filter (\cbi->cabalComponentName (cbiComponent cbi) == ccn) cbis
return $ map fst $ concat allMps
)
where
fitForUsage :: FilePath -> Bool
fitForUsage f
| takeDirectory f == "." && takeBaseName f == "Setup"=False
| otherwise=let ext=takeExtension f
in ext `elem` [".hs",".lhs"]
getModule :: T.Text
-> FilePath
-> TypecheckedModule
-> Ghc(FilePath,T.Text,RenamedSource,[Usage])
getModule pkg f tm=do
let rs@(_,imps,mexps,_)=fromJust $ tm_renamed_source tm
(ius,aliasMap)<-foldrM (BwGHC.ghcImportToUsage pkg) ([],DM.empty) imps
let modu=T.pack $ showSDoc $ ppr $ moduleName $ ms_mod $ pm_mod_summary $ tm_parsed_module tm
eus<-mapM (BwGHC.ghcExportToUsage pkg modu aliasMap) (fromMaybe [] mexps)
return (f,modu,rs,ius ++ concat eus)
generate :: T.Text
-> (FilePath,T.Text,RenamedSource,[Usage]) -> BuildWrapper()
generate pkg (fp,modu,(hsg,_,_,_),ius)
| modu=="Main" && ccn=="" = return ()
| otherwise = do
tgt<-getTargetPath fp
let v = dataToJSON hsg
let vals=extractUsages v
(mast,_)<-getAST fp
case mast of
Just (ParseOk ast)->do
let ods=getHSEOutline ast
let val=reconcile pkg vals ods ius
let (es,is)=getHSEImportExport ast
let modLoc=maybe Null toJSON (getModuleLocation ast)
let valWithModule=Array $ V.fromList [toJSON pkg,toJSON modu,modLoc,val,toJSON $ OutlineResult ods es is]
liftIO $ setUsageInfo tgt valWithModule
return ()
_ -> return ()
return ()
reconcile :: T.Text
-> [Value] -> [OutlineDef] -> [Usage] -> Value
reconcile pkg vals ods ius=let
mapOds=foldr mapOutline DM.empty ods
in foldr usageToJSON (object [])
(ius ++ concatMap (ghcValToUsage pkg mapOds) vals)
mapOutline :: OutlineDef -> DM.Map Int [OutlineDef] -> DM.Map Int [OutlineDef]
mapOutline od m=let
ifs=odLoc od
lins=[(iflLine $ ifsStart ifs) .. (iflLine $ ifsEnd ifs)]
m2=foldr (addOutline od) m lins
in foldr mapOutline m2 (odChildren od)
addOutline :: OutlineDef -> Int -> DM.Map Int [OutlineDef] -> DM.Map Int [OutlineDef]
addOutline od l m=let
mods=DM.lookup l m
newOds=case mods of
Just ods->od:ods
Nothing->[od]
in DM.insert l newOds m
usageToJSON :: Usage -> Value -> Value
usageToJSON u v@(Object pkgs) | Just pkg<-usagePackage u v=
let
(Object mods) = HM.lookupDefault (object []) pkg pkgs
(Object types)= HM.lookupDefault (object []) (usModule u) mods
typeKey=if usType u
then "types"
else "vars"
(Object names)= HM.lookupDefault (object []) typeKey types
nameKey=usName u
(Array lins)= HM.lookupDefault (Array V.empty) nameKey names
lineV= usLoc u
objectV=object ["s" .= usSection u, "d" .= usDef u, "l" .= lineV]
lins2=if objectV `V.elem` lins
then lins
else V.cons objectV lins
names2=HM.insert nameKey (Array lins2) names
types2=HM.insert typeKey (Object names2) types
mods2=HM.insert (usModule u) (Object types2) mods
in Object $ HM.insert pkg (Object mods2) pkgs
usageToJSON _ a=a
usagePackage :: Usage -> Value -> Maybe T.Text
usagePackage u (Object pkgs)=case usPackage u of
Just p->Just p
Nothing->let
modu=usModule u
matchingpkgs=HM.foldrWithKey (listPkgs modu) [] pkgs
in listToMaybe matchingpkgs
usagePackage _ _=Nothing
listPkgs :: T.Text -> T.Text -> Value -> [T.Text] -> [T.Text]
listPkgs modu k (Object mods) l=if HM.member modu mods then k : l else l
listPkgs _ _ _ l=l
ghcValToUsage :: T.Text -> DM.Map Int [OutlineDef] -> Value -> [Usage]
ghcValToUsage pkg mapOds (Object m) |
Just (String s)<-HM.lookup "Name" m,
Just (String mo)<-HM.lookup "Module" m,
not $ T.null mo,
Just (String p)<-HM.lookup "Package" m,
Just (String ht)<-HM.lookup "HType" m,
Just arr<-HM.lookup "Pos" m,
Success ifs <- fromJSON arr= let
mods=DM.lookup (iflLine $ ifsStart ifs) mapOds
(section,def)=getSection mods s ifs
in [Usage (Just (if p=="main" then pkg else p)) mo s section (ht=="t") arr def]
ghcValToUsage _ _ _=[]
getSection :: Maybe [OutlineDef] -> T.Text -> InFileSpan -> (T.Text,Bool)
getSection (Just ods) objName ifs =let
matchods=filter (\od-> ifsOverlap (odLoc od) ifs) ods
bestods=sortBy (\od1 od2->let
l1=iflLine $ ifsStart $ odLoc od1
l2=iflLine $ ifsStart $ odLoc od2
in case compare l2 l1 of
EQ -> let
c1=iflColumn $ ifsStart $ odLoc od1
c2=iflColumn $ ifsStart $ odLoc od2
in compare c2 c1
a-> a
) matchods
in case bestods of
(x:_)->let
def=odName x == objName &&
((iflColumn (ifsStart $ odLoc x) == iflColumn (ifsStart ifs))
|| (
(Data `elem` odType x)
&& (iflColumn (ifsStart $ odLoc x) + 5==iflColumn (ifsStart ifs))
)
|| (
(Type `elem` odType x)
&& (iflColumn (ifsStart $ odLoc x) + 5 == iflColumn (ifsStart ifs))
))
in (odName x,def)
_->("",False)
getSection _ _ _=("",False)
build1 :: FilePath
-> BuildWrapper (OpResult (Maybe [NameDef]))
build1 fp=withGHCAST' fp BwGHC.getGhcNameDefsInScope
preproc :: BuildFlags
-> FilePath
-> IO String
preproc bf tgt= do
inputOrig<-readFile tgt
let epo=parseOptions $ bfPreproc 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
fullFp=(takeDirectory src) </> fp
modName=listToMaybe $ mapMaybe fst (filter (\ (_, f) -> f == fullFp) $ cbiModulePaths $ snd cbi)
cppo=fileCppOptions (snd cbi) ++ unlitF
modS=fmap moduleToString modName
return (BuildFlags opts2 cppo modS,bwns)
Nothing -> return (BuildFlags [] unlitF Nothing,[])
liftIO $ storeBuildFlagsInfo tgt ret
return ret
where unlitF=let
lit=".lhs" == takeExtension fp
in ("-D__GLASGOW_HASKELL__=" ++ show (__GLASGOW_HASKELL__ :: Int)) : ["--unlit" | lit]
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 (bfAst 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 (\a b c d->do
r<- f a b c d
return (Just r,[]))
withGHCAST' :: FilePath
-> (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
tgt<-getTargetPath fp
let usageFile=getUsageFile tgt
usageStale<-liftIO $ isSourceMoreRecent tgt usageFile
mods<-if not usageStale
then do
mv<-liftIO $ getUsageInfo tgt
return $ case mv of
(Array arr) | V.length arr==5->let
(Success r)= fromJSON (arr V.! 4)
in (Just r)
_->Nothing
else return Nothing
case mods of
Just ods-> return (ods,[])
_ -> 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 (mkEmptySpan 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