module Language.Haskell.BuildWrapper.Base where
import Control.Applicative
import Control.Monad
import Control.Monad.State
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 System.Directory
import System.FilePath
import Data.List (isPrefixOf)
type BuildWrapper=StateT BuildWrapperState IO
data BuildWrapperState=BuildWrapperState{
tempFolder::String
,cabalPath::FilePath
,cabalFile::FilePath
,verbosity::Verbosity
,cabalFlags::String
,cabalOpts::[String]
}
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 $ read $ T.unpack $ T.append "BW" t
parseJSON _= mzero
data BWLocation=BWLocation {
bwl_src::FilePath
,bwl_line::Int
,bwl_col::Int
}
deriving (Show,Read,Eq)
instance ToJSON BWLocation where
toJSON (BWLocation s l c)=object ["f" .= s, "l" .= l , "c" .= c]
instance FromJSON BWLocation where
parseJSON (Object v) =BWLocation <$>
v .: "f" <*>
v .: "l" <*>
v .: "c"
parseJSON _= mzero
data BWNote=BWNote {
bwn_status :: BWNoteStatus
,bwn_title :: String
,bwn_location :: BWLocation
}
deriving (Show,Read,Eq)
isBWNoteError :: BWNote -> Bool
isBWNoteError bw=(bwn_status 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 $ read $ T.unpack s
parseJSON _= mzero
data InFileLoc=InFileLoc {ifl_line::Int
,ifl_column::Int
}
deriving (Show,Read,Eq,Ord)
data InFileSpan=InFileSpan {ifs_start::InFileLoc
,ifs_end::InFileLoc
}
deriving (Show,Read,Eq,Ord)
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 OutlineDef = OutlineDef
{ od_name :: T.Text
,od_type :: [OutlineDefType]
,od_loc :: InFileSpan
,od_children :: [OutlineDef]
,od_signature :: Maybe T.Text
,od_comment :: 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 {
td_name :: T.Text
,td_loc :: 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 $ read $ T.unpack s
parseJSON _= mzero
data ExportDef = ExportDef {
e_name :: T.Text
,e_type :: ImportExportType
,e_loc :: InFileSpan
,e_children :: [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 {
is_name :: T.Text
,is_type :: ImportExportType
,is_loc :: InFileSpan
,is_children :: [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 {
i_module :: T.Text
,i_loc :: InFileSpan
,i_qualified :: Bool
,i_hiding :: Bool
,i_alias :: T.Text
,i_children :: Maybe [ImportSpecDef]
} deriving (Show,Eq)
instance ToJSON ImportDef where
toJSON (ImportDef m l q h a c)= object ["m" .= m , "l" .= l, "q" .= q, "h" .= h, "a" .= a, "c" .= c]
instance FromJSON ImportDef where
parseJSON (Object v) =ImportDef <$>
v .: "m" <*>
v .: "l" <*>
v .: "q" <*>
v .: "h" <*>
v .: "a" <*>
v .: "c"
parseJSON _= mzero
data OutlineResult = OutlineResult {
or_outline :: [OutlineDef]
,or_exports :: [ExportDef]
,or_imports :: [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 {
bf_ast :: [String]
,bf_preproc :: [String]
,bf_modName :: Maybe String
}
deriving (Show,Read,Eq,Data,Typeable)
instance ToJSON BuildFlags where
toJSON (BuildFlags ast preproc modName)= object ["a" .= map toJSON ast, "p" .= map toJSON preproc, "m" .= toJSON modName]
instance FromJSON BuildFlags where
parseJSON (Object v)=BuildFlags <$>
v .: "a" <*>
v .: "p" <*>
v .: "m"
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
exSrc<-liftIO $ doesFileExist fullSrc
if exSrc
then do
fullTgt<-getTargetPath src
ex<-liftIO $ doesFileExist fullTgt
shouldCopy<- if force || not ex
then return True
else
do modSrc <- liftIO $ getModificationTime fullSrc
modTgt <- liftIO $ getModificationTime fullTgt
return (modSrc >= modTgt)
if shouldCopy
then do
liftIO $ copyFile fullSrc fullTgt
return $ Just src
else return Nothing
else return Nothing
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
{ cc_buildable :: Bool
}
| CCExecutable
{ cc_exe_name :: String
, cc_buildable :: Bool
}
| CCTestSuite
{ cc_test_name :: String
, cc_buildable :: Bool
}
deriving (Eq, Show)
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
data CabalPackage=CabalPackage {
cp_name::String
,cp_version::String
,cp_exposed::Bool
,cp_dependent::[CabalComponent]
,cp_modules::[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
getRecursiveContents :: FilePath -> IO [FilePath]
getRecursiveContents topdir = 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)
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]