module Language.Haskell.BuildWrapper.Base where
import Control.Applicative
import Control.Monad
import Control.Monad.State
import Control.Exception (bracket)
import Control.Concurrent.Async (Concurrently (..))
import qualified Data.ByteString as BS
import Data.Conduit (($=),($$))
import qualified Data.Conduit.List as CL
import Data.Conduit.Process (Inherited (..), proc,
streamingProcess,
waitForStreamingProcess)
import System.Exit (ExitCode)
import Data.Data
import Data.Aeson
import qualified Data.Text as T
import qualified Data.HashMap.Lazy as M
import qualified Data.Vector as V
import qualified Data.Set as S
import System.Directory
import System.FilePath
import Data.List (isPrefixOf)
import Data.Maybe (catMaybes)
import System.IO.UTF8 (hPutStr,hGetContents)
import Data.ByteString.UTF8 (toString)
import System.IO (IOMode, openBinaryFile, IOMode(..), Handle, hClose, hFlush, stdout)
import Control.DeepSeq (rnf, NFData)
type BuildWrapper=StateT BuildWrapperState IO
data BuildWrapperState=BuildWrapperState{
tempFolder::String
,cabalPath::FilePath
,cabalFile::FilePath
,verbosity::Verbosity
,cabalFlags::String
,cabalOpts::[String]
,logCabalArgs :: Bool
}
data BWNoteStatus=BWError | BWWarning
deriving (Show,Read,Eq)
instance ToJSON BWNoteStatus where
toJSON = toJSON . drop 2 . show
instance FromJSON BWNoteStatus where
parseJSON (String t) =return $ readObj "BWNoteStatus" $ T.unpack $ T.append "BW" t
parseJSON _= mzero
readObj :: Read a=> String -> String -> a
readObj msg s=let parses=reads s
in if null parses
then error (msg ++ ": " ++ s ++ ".")
else fst $ head parses
data BWLocation=BWLocation {
bwlSrc::FilePath
,bwlLine::Int
,bwlCol::Int
,bwlEndLine::Int
,bwlEndCol::Int
}
deriving (Show,Read,Eq)
instance NFData BWLocation
where rnf (BWLocation src sl sc el ec)=rnf src `seq` rnf sl `seq` rnf sc `seq` rnf el `seq` rnf ec
mkEmptySpan :: FilePath -> Int -> Int -> BWLocation
mkEmptySpan src line col = BWLocation src line col line col
instance ToJSON BWLocation where
toJSON (BWLocation s l c el ec)=object ["f" .= s, "l" .= l , "c" .= c, "el" .= el , "ec" .= ec]
instance FromJSON BWLocation where
parseJSON (Object v) =BWLocation <$>
v .: "f" <*>
v .: "l" <*>
v .: "c" <*>
v .: "el" <*>
v .: "ec"
parseJSON _= mzero
data BWNote=BWNote {
bwnStatus :: BWNoteStatus
,bwnTitle :: String
,bwnLocation :: BWLocation
}
deriving (Show,Read,Eq)
instance NFData BWNote
where rnf (BWNote _ t l)=rnf t `seq` rnf l
isBWNoteError :: BWNote -> Bool
isBWNoteError bw=bwnStatus bw == BWError
instance ToJSON BWNote where
toJSON (BWNote s t l)= object ["s" .= s, "t" .= t, "l" .= l]
instance FromJSON BWNote where
parseJSON (Object v) =BWNote <$>
v .: "s" <*>
v .: "t" <*>
v .: "l"
parseJSON _= mzero
type OpResult a=(a,[BWNote])
data BuildResult=BuildResult Bool [FilePath]
deriving (Show,Read,Eq)
instance ToJSON BuildResult where
toJSON (BuildResult b fps)= object ["r" .= b, "fps" .= map toJSON fps]
instance FromJSON BuildResult where
parseJSON (Object v) =BuildResult <$>
v .: "r" <*>
v .: "fps"
parseJSON _= mzero
data WhichCabal=
Source
| Target
deriving (Show,Read,Eq,Enum,Data,Typeable)
data OutlineDefType =
Class |
Data |
Family |
Function |
Pattern |
Syn |
Type |
Instance |
Field |
Constructor |
Splice
deriving (Show,Read,Eq,Ord,Enum)
instance ToJSON OutlineDefType where
toJSON = toJSON . show
instance FromJSON OutlineDefType where
parseJSON (String s) =return $ readObj "OutlineDefType" $ T.unpack s
parseJSON _= mzero
data InFileLoc=InFileLoc {iflLine::Int
,iflColumn::Int
}
deriving (Show,Read,Eq,Ord)
data InFileSpan=InFileSpan {ifsStart::InFileLoc
,ifsEnd::InFileLoc
}
deriving (Show,Read,Eq,Ord)
ifsOverlap :: InFileSpan -> InFileSpan -> Bool
ifsOverlap ifs1 ifs2 = iflOverlap ifs1 $ ifsStart ifs2
iflOverlap :: InFileSpan -> InFileLoc -> Bool
iflOverlap ifs1 ifs2 =let
l11=iflLine $ ifsStart ifs1
l12=iflLine $ ifsEnd ifs1
c11=iflColumn $ ifsStart ifs1
c12=iflColumn $ ifsEnd ifs1
l21=iflLine ifs2
c21=iflColumn ifs2
in (l11<l21 || (l11==l21 && c11<=c21)) && (l12>l21 || (l12==l21 && c12>=c21))
instance ToJSON InFileSpan where
toJSON (InFileSpan (InFileLoc sr sc) (InFileLoc er ec))
| sr==er = if ec==sc+1
then toJSON $ map toJSON [sr,sc]
else toJSON $ map toJSON [sr,sc,ec]
| otherwise = toJSON $ map toJSON [sr,sc,er,ec]
instance FromJSON InFileSpan where
parseJSON (Array v) =do
let
l=V.length v
case l of
2->do
let
Success v0 = fromJSON (v V.! 0)
Success v1 = fromJSON (v V.! 1)
return $ InFileSpan (InFileLoc v0 v1) (InFileLoc v0 (v1+1))
3->do
let
Success v0 = fromJSON (v V.! 0)
Success v1 = fromJSON (v V.! 1)
Success v2 = fromJSON (v V.! 2)
return $ InFileSpan (InFileLoc v0 v1) (InFileLoc v0 v2)
4->do
let
Success v0 = fromJSON (v V.! 0)
Success v1 = fromJSON (v V.! 1)
Success v2 = fromJSON (v V.! 2)
Success v3 = fromJSON (v V.! 3)
return $ InFileSpan (InFileLoc v0 v1) (InFileLoc v2 v3)
_ -> mzero
parseJSON _= mzero
mkFileSpan :: Int
-> Int
-> Int
-> Int
-> InFileSpan
mkFileSpan sr sc er ec=InFileSpan (InFileLoc sr sc) (InFileLoc er ec)
data NameDef = NameDef
{ ndName :: T.Text
, ndType :: [OutlineDefType]
, ndSignature :: Maybe T.Text
}
deriving (Show,Read,Eq,Ord)
instance ToJSON NameDef where
toJSON (NameDef n tps ts)= object ["n" .= n , "t" .= map toJSON tps,"s" .= ts]
instance FromJSON NameDef where
parseJSON (Object v) =NameDef <$>
v .: "n" <*>
v .: "t" <*>
v .:? "s"
parseJSON _= mzero
data OutlineDef = OutlineDef
{ odName :: T.Text
,odType :: [OutlineDefType]
,odLoc :: InFileSpan
,odChildren :: [OutlineDef]
,odSignature :: Maybe T.Text
,odComment :: Maybe T.Text
,odStartLineComment :: Maybe Int
}
deriving (Show,Read,Eq,Ord)
mkOutlineDef :: T.Text
-> [OutlineDefType]
-> InFileSpan
-> OutlineDef
mkOutlineDef n t l= mkOutlineDefWithChildren n t l []
mkOutlineDefWithChildren :: T.Text
-> [OutlineDefType]
-> InFileSpan
-> [OutlineDef]
-> OutlineDef
mkOutlineDefWithChildren n t l c= OutlineDef n t l c Nothing Nothing Nothing
instance ToJSON OutlineDef where
toJSON (OutlineDef n tps l c ts d sl)= object ["n" .= n , "t" .= map toJSON tps, "l" .= l, "c" .= map toJSON c, "s" .= ts, "d" .= d, "sl" .= sl]
instance FromJSON OutlineDef where
parseJSON (Object v) =OutlineDef <$>
v .: "n" <*>
v .: "t" <*>
v .: "l" <*>
v .: "c" <*>
v .:? "s" <*>
v .:? "d" <*>
v .:? "sl"
parseJSON _= mzero
data TokenDef = TokenDef {
tdName :: T.Text
,tdLoc :: InFileSpan
}
deriving (Show,Eq)
instance ToJSON TokenDef where
toJSON (TokenDef n s)=
object [n .= s]
instance FromJSON TokenDef where
parseJSON (Object o) |
((a,b):[])<-M.toList o,
Success v0 <- fromJSON b=return $ TokenDef a v0
parseJSON _= mzero
data ImportExportType = IEVar
| IEAbs
| IEThingAll
| IEThingWith
| IEModule
deriving (Show,Read,Eq,Ord,Enum)
instance ToJSON ImportExportType where
toJSON = toJSON . show
instance FromJSON ImportExportType where
parseJSON (String s) =return $ readObj "ImportExportType" $ T.unpack s
parseJSON _= mzero
data ExportDef = ExportDef {
eName :: T.Text
,eType :: ImportExportType
,eLoc :: InFileSpan
,eChildren :: [T.Text]
} deriving (Show,Eq)
instance ToJSON ExportDef where
toJSON (ExportDef n t l c)= object ["n" .= n , "t" .= t, "l" .= l, "c" .= map toJSON c]
instance FromJSON ExportDef where
parseJSON (Object v) =ExportDef <$>
v .: "n" <*>
v .: "t" <*>
v .: "l" <*>
v .: "c"
parseJSON _= mzero
data ImportSpecDef = ImportSpecDef {
isName :: T.Text
,isType :: ImportExportType
,isLoc :: InFileSpan
,isChildren :: [T.Text]
} deriving (Show,Eq)
instance ToJSON ImportSpecDef where
toJSON (ImportSpecDef n t l c)= object ["n" .= n , "t" .= t, "l" .= l, "c" .= map toJSON c]
instance FromJSON ImportSpecDef where
parseJSON (Object v) =ImportSpecDef <$>
v .: "n" <*>
v .: "t" <*>
v .: "l" <*>
v .: "c"
parseJSON _= mzero
data ImportDef = ImportDef {
iModule :: T.Text
,iPackage :: Maybe T.Text
,iLoc :: InFileSpan
,iQualified :: Bool
,iHiding :: Bool
,iAlias :: T.Text
,iChildren :: Maybe [ImportSpecDef]
} deriving (Show,Eq)
instance ToJSON ImportDef where
toJSON (ImportDef m p l q h a c)= object ["m" .= m , "p" .= p, "l" .= l, "q" .= q, "h" .= h, "a" .= a, "c" .= c]
instance FromJSON ImportDef where
parseJSON (Object v) =ImportDef <$>
v .: "m" <*>
v .:? "p" <*>
v .: "l" <*>
v .: "q" <*>
v .: "h" <*>
v .: "a" <*>
v .:? "c"
parseJSON _= mzero
data OutlineResult = OutlineResult {
orOutline :: [OutlineDef]
,orExports :: [ExportDef]
,orImports :: [ImportDef]
}
deriving (Show,Eq)
instance ToJSON OutlineResult where
toJSON (OutlineResult o e i)= object ["o" .= map toJSON o,"e" .= map toJSON e,"i" .= map toJSON i]
instance FromJSON OutlineResult where
parseJSON (Object v) =OutlineResult <$>
v .: "o" <*>
v .: "e" <*>
v .: "i"
parseJSON _= mzero
data BuildFlags = BuildFlags {
bfAst :: [String]
,bfPreproc :: [String]
,bfModName :: Maybe String
,bfComponent :: Maybe String
}
deriving (Show,Read,Eq,Data,Typeable)
instance ToJSON BuildFlags where
toJSON (BuildFlags ast preproc modName comp)= object ["a" .= map toJSON ast, "p" .= map toJSON preproc, "m" .= toJSON modName, "c" .= toJSON comp]
instance FromJSON BuildFlags where
parseJSON (Object v)=BuildFlags <$>
v .: "a" <*>
v .: "p" <*>
v .:? "m" <*>
v .:? "c"
parseJSON _= mzero
data ThingAtPoint = ThingAtPoint {
tapName :: String,
tapModule :: Maybe String,
tapType :: Maybe String,
tapQType :: Maybe String,
tapHType :: Maybe String,
tapGType :: Maybe String
}
deriving (Show,Read,Eq,Data,Typeable)
instance ToJSON ThingAtPoint where
toJSON (ThingAtPoint name modu stype qtype htype gtype)=object ["Name" .= name, "Module" .= modu, "Type" .= stype, "QType" .= qtype, "HType" .= htype, "GType" .= gtype]
instance FromJSON ThingAtPoint where
parseJSON (Object v)=ThingAtPoint <$>
v .: "Name" <*>
v .:? "Module" <*>
v .:? "Type" <*>
v .:? "QType" <*>
v .:? "HType" <*>
v .:? "GType"
parseJSON _= mzero
getFullTempDir :: BuildWrapper FilePath
getFullTempDir = do
cf<-gets cabalFile
temp<-gets tempFolder
let dir=takeDirectory cf
return (dir </> temp)
getDistDir :: BuildWrapper FilePath
getDistDir = do
temp<-getFullTempDir
return (temp </> "dist")
getTargetPath :: FilePath
-> BuildWrapper FilePath
getTargetPath src=do
temp<-getFullTempDir
liftIO $ getTargetPath' src temp
getTargetPath' :: FilePath
-> FilePath
-> IO FilePath
getTargetPath' src temp=do
let path=temp </> src
createDirectoryIfMissing True (takeDirectory path)
return path
canonicalizeFullPath :: FilePath
-> BuildWrapper FilePath
canonicalizeFullPath fp =do
full<-getFullSrc fp
ex<-liftIO $ doesFileExist full
if ex
then liftIO $ canonicalizePath full
else return full
getFullSrc :: FilePath
-> BuildWrapper FilePath
getFullSrc src=do
cf<-gets cabalFile
let dir=takeDirectory cf
return (dir </> src)
copyFromMain :: Bool
-> FilePath
-> BuildWrapper(Maybe FilePath)
copyFromMain force src=do
fullSrc<-getFullSrc src
fullTgt<-getTargetPath src
exSrc<-liftIO $ doesFileExist fullSrc
if exSrc
then do
moreRecent<-liftIO $ isSourceMoreRecent fullSrc fullTgt
if force || moreRecent
then do
liftIO $ copyFile fullSrc fullTgt
return $ Just src
else return Nothing
else return Nothing
isSourceMoreRecent :: FilePath -> FilePath -> IO Bool
isSourceMoreRecent fullSrc fullTgt=do
ex<-doesFileExist fullTgt
if not ex
then return True
else
do modSrc <- getModificationTime fullSrc
modTgt <- getModificationTime fullTgt
return (modSrc >= modTgt)
fileToModule :: FilePath -> String
fileToModule fp=map rep (dropExtension fp)
where rep '/' = '.'
rep '\\' = '.'
rep a = a
data Verbosity = Silent | Normal | Verbose | Deafening
deriving (Show, Read, Eq, Ord, Enum, Bounded,Data,Typeable)
data CabalComponent
= CCLibrary
{ ccBuildable :: Bool
}
| CCExecutable
{ ccExeName :: String
, ccBuildable :: Bool
}
| CCTestSuite
{ ccTestName :: String
, ccBuildable :: Bool
}
| CCBenchmark
{ ccBenchName :: String
, ccBuildable :: Bool
}
deriving (Eq, Show, Read,Ord)
instance ToJSON CabalComponent where
toJSON (CCLibrary b)= object ["Library" .= b]
toJSON (CCExecutable e b)= object ["Executable" .= b,"e" .= e]
toJSON (CCTestSuite t b)= object ["TestSuite" .= b,"t" .= t]
toJSON (CCBenchmark t b)= object ["Benchmark" .= b,"b" .= t]
instance FromJSON CabalComponent where
parseJSON (Object v)
| Just b <- M.lookup "Library" v =CCLibrary <$> parseJSON b
| Just b <- M.lookup "Executable" v =CCExecutable <$> v .: "e" <*> parseJSON b
| Just b <- M.lookup "TestSuite" v =CCTestSuite <$> v .: "t" <*> parseJSON b
| Just b <- M.lookup "Benchmark" v =CCBenchmark <$> v .: "b" <*> parseJSON b
| otherwise = mzero
parseJSON _= mzero
cabalComponentName :: CabalComponent -> String
cabalComponentName CCLibrary{}=""
cabalComponentName CCExecutable{ccExeName}=ccExeName
cabalComponentName CCTestSuite{ccTestName}=ccTestName
cabalComponentName CCBenchmark{ccBenchName}=ccBenchName
data CabalPackage=CabalPackage {
cpName::String
,cpVersion::String
,cpExposed::Bool
,cpDependent::[CabalComponent]
,cpModules::[String]
}
deriving (Eq, Show)
instance ToJSON CabalPackage where
toJSON (CabalPackage n v e d em)=object ["n" .= n,"v" .= v, "e" .= e, "d" .= map toJSON d, "m" .= map toJSON em]
instance FromJSON CabalPackage where
parseJSON (Object v) =CabalPackage <$>
v .: "n" <*>
v .: "v" <*>
v .: "e" <*>
v .: "d" <*>
v .: "m"
parseJSON _= mzero
data ImportClean = ImportClean {
icSpan :: InFileSpan,
icText :: T.Text
}
deriving (Show,Read,Eq,Ord)
instance ToJSON ImportClean where
toJSON (ImportClean sp txt)=object ["l" .= sp, "t" .= txt]
instance FromJSON ImportClean where
parseJSON (Object v)=ImportClean <$>
v .: "l" <*>
v .: "t"
parseJSON _=mzero
data LoadContents = SingleFile {
lmFile :: FilePath
,lmModule :: String
}
| MultipleFile {
lmFiles :: [(FilePath,String)]
}
deriving (Show,Read)
getLoadFiles :: LoadContents -> [(FilePath,String)]
getLoadFiles SingleFile{lmFile=f,lmModule=m}=[(f,m)]
getLoadFiles MultipleFile{lmFiles=fs}=fs
getRecursiveContents :: FilePath -> IO [FilePath]
getRecursiveContents topdir = do
ex<-doesDirectoryExist topdir
if ex
then do
names <- getDirectoryContents topdir
let properNames = filter (not . isPrefixOf ".") names
paths <- forM properNames $ \name -> do
let path = topdir </> name
isDirectory <- doesDirectoryExist path
if isDirectory
then getRecursiveContents path
else return [path]
return (concat paths)
else return []
getRecursiveContentsHidden :: FilePath -> IO [FilePath]
getRecursiveContentsHidden topdir = do
ex<-doesDirectoryExist topdir
if ex
then do
names <- getDirectoryContents topdir
let properNames = filter (not . flip elem [".",".."]) names
paths <- forM properNames $ \name -> do
let path = topdir </> name
isDirectory <- doesDirectoryExist path
if isDirectory
then getRecursiveContentsHidden path
else return [path]
return (concat paths)
else return []
deleteGhosts :: [FilePath] -> BuildWrapper [FilePath]
deleteGhosts copied=do
root<-getFullSrc ""
temp<-getFullTempDir
fs<-liftIO $ getRecursiveContents temp
let copiedS=S.fromList copied
del<-liftIO $ mapM (deleteIfGhost root temp copiedS) fs
return $ catMaybes del
where
deleteIfGhost :: FilePath -> FilePath -> S.Set FilePath -> FilePath -> IO (Maybe FilePath)
deleteIfGhost rt tmp cs f=do
let rel=makeRelative tmp f
let cabalDist="dist"
let cabalDevDist="cabal-dev"
if cabalDist `isPrefixOf` rel || cabalDevDist `isPrefixOf` rel || S.member rel cs
then return Nothing
else do
let fullSrc=rt </> rel
ex<-doesFileExist fullSrc
if ex
then return Nothing
else do
removeFile (tmp </> f)
return $ Just rel
deleteTemp :: BuildWrapper()
deleteTemp = do
temp<-getFullTempDir
liftIO $ removeDirectoryRecursive temp
deleteGenerated :: BuildWrapper()
deleteGenerated = do
temp<-getFullTempDir
fs<-liftIO $ getRecursiveContentsHidden temp
liftIO $ mapM_ deleteIfGenerated fs
where
deleteIfGenerated :: FilePath -> IO()
deleteIfGenerated f=do
let del=case takeExtension f of
".bwinfo"->True
".bwusage"->True
_->False
when del (removeFile f)
fromJustDebug :: String -> Maybe a -> a
fromJustDebug s Nothing=error ("fromJust:" ++ s)
fromJustDebug _ (Just a)=a
removeBaseDir :: FilePath -> String -> String
removeBaseDir base_dir = loop
where
loop [] = []
loop str =
let (prefix, rest) = splitAt n str
in
if base_dir_sep == prefix
then loop rest
else head str : loop (tail str)
n = length base_dir_sep
base_dir_sep=base_dir ++ [pathSeparator]
nubOrd :: Ord a => [a] -> [a]
nubOrd=S.toList . S.fromList
formatJSON :: String -> String
formatJSON s1=snd $ foldl f (0,"") s1
where
f :: (Int,String) -> Char -> (Int,String)
f (i,s) '['=(i + 4, s ++ "\n" ++ map (const ' ') [0 .. i] ++ "[")
f (i,s) ']' =(i 4, s ++ "\n" ++ map (const ' ') [0 .. i] ++ "]")
f (i,s) c =(i,s++[c])
data Usage = Usage {
usPackage::Maybe T.Text,
usModule::T.Text,
usName::T.Text,
usSection::T.Text,
usType::Bool,
usLoc::Value,
usDef::Bool
}
deriving (Show,Eq)
readFile :: FilePath -> IO String
readFile n = do
inFile<- openBinaryFile n ReadMode
contents <- hGetContents inFile
rnf contents `seq` hClose inFile
return contents
writeFile :: FilePath -> String -> IO ()
writeFile n s = withBinaryFile n WriteMode (`hPutStr` s)
withBinaryFile :: FilePath -> IOMode -> (Handle -> IO a) -> IO a
withBinaryFile n m = bracket (openBinaryFile n m) hClose
data EvalResult = EvalResult {
erType :: Maybe String
,erResult :: Maybe String
,erError :: Maybe String
} deriving (Show,Read,Eq,Ord)
instance NFData EvalResult
where rnf (EvalResult t r e)=rnf t `seq` rnf r `seq` rnf e
instance ToJSON EvalResult where
toJSON (EvalResult mt mr me)=object ["t" .= mt, "r" .= mr, "e" .= me]
instance FromJSON EvalResult where
parseJSON (Object v)=EvalResult <$>
v .: "t" <*>
v .: "r" <*>
v .: "e"
parseJSON _=mzero
splitString :: Eq a => [a] -> [a] -> ([a],[a])
splitString prf str=go str []
where
go [] a=(reverse a,[])
go s@(x:xs) a=
if prf `isPrefixOf` s
then (reverse a,s)
else go xs (x:a)
runAndPrint :: FilePath -> [String] -> IO (ExitCode,String,String)
runAndPrint prog args = do
(Inherited,outP,errP,cph) <- streamingProcess (proc prog args)
let
bsw bs = do
BS.putStr bs
hFlush stdout
return bs
output = outP $$ CL.mapM bsw $= CL.consume
err = errP $$ CL.mapM bsw $= CL.consume
(outb,errb,ec) <- runConcurrently $ (,,)
<$> Concurrently output
<*> Concurrently err
<*> Concurrently (waitForStreamingProcess cph)
return (ec,toString $ BS.concat outb,toString $ BS.concat errb)