module Language.Haskell.BuildWrapper.Base where
import Control.Applicative
import Control.Monad
import Control.Monad.State
import Control.Exception (bracket)
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 System.IO (IOMode, openBinaryFile, IOMode(..), Handle, hClose)
import Control.DeepSeq (rnf)
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)
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)
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
}
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
instance ToJSON OutlineDef where
toJSON (OutlineDef n tps l c ts d)= object ["n" .= n , "t" .= map toJSON tps, "l" .= l, "c" .= map toJSON c, "s" .= ts, "d" .= d]
instance FromJSON OutlineDef where
parseJSON (Object v) =OutlineDef <$>
v .: "n" <*>
v .: "t" <*>
v .: "l" <*>
v .: "c" <*>
v .:? "s" <*>
v .:? "d"
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
let path=temp </> src
liftIO $ 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
}
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]
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
| otherwise = mzero
parseJSON _= mzero
cabalComponentName :: CabalComponent -> String
cabalComponentName CCLibrary{}=""
cabalComponentName CCExecutable{ccExeName}=ccExeName
cabalComponentName CCTestSuite{ccTestName}=ccTestName
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)]
}
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 (\ h -> hPutStr h s)
withBinaryFile :: FilePath -> IOMode -> (Handle -> IO a) -> IO a
withBinaryFile n m f = bracket (openBinaryFile n m) hClose f