diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,32 @@ +Copyright 2011, JP Moresmau +Copyright 2008, Thiago Arrais +Copyright 2008, Thomas Schilling +Copyright 2008, Simon Marlow +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +- Redistributions of source code must retain the above copyright notice, +this list of conditions and the following disclaimer. + +- Redistributions in binary form must reproduce the above copyright notice, +this list of conditions and the following disclaimer in the documentation +and/or other materials provided with the distribution. + +- Neither name of the author nor the names of its contributors may be +used to endorse or promote products derived from this software without +specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE AUTHOR(S) AND THE CONTRIBUTORS "AS +IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE UNIVERSITY +COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE FOR +ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE +GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER +IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR +OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF +ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,4 @@ +#!/usr/bin/env runhaskell +import Distribution.Simple +main :: IO () +main = defaultMain diff --git a/buildwrapper.cabal b/buildwrapper.cabal new file mode 100644 --- /dev/null +++ b/buildwrapper.cabal @@ -0,0 +1,46 @@ +name: buildwrapper +version: 0.1 +cabal-version: >= 1.8 +build-type: Simple +license: BSD3 +license-file: LICENSE +synopsis: A library and an executable that provide an easy API for a Haskell IDE +description: Buildwrapper is an alternative to scion. + It provides services to configure, build and give information on source files to help IDEs manage Haskell projects. + You can use buildwrapper to build project and retrieve errors, get outline for each module source, get the type of something inside a source file, get lexer tokens, etc. + Buildwrapper is used in the EclipseFP project (Eclipse plugins for Haskell development) +category: Development +stability: beta +maintainer: JP Moresmau +author: JP Moresmau , based on the work of Thomas Schilling and others +homepage: https://github.com/JPMoresmau/BuildWrapper + +library + hs-source-dirs: src + build-depends: base < 5 , filepath, mtl, directory, Cabal, process, regex-tdfa, ghc, ghc-paths, syb, ghc-syb-utils, + text, containers, vector, haskell-src-exts, cpphs, old-time, aeson + ghc-options: -Wall -fno-warn-unused-do-bind + exposed-modules: Language.Haskell.BuildWrapper.API,Language.Haskell.BuildWrapper.Base,Language.Haskell.BuildWrapper.Cabal + extensions: CPP + other-modules: Language.Haskell.BuildWrapper.GHC, Language.Haskell.BuildWrapper.Src, Language.Haskell.BuildWrapper.Find, Language.Haskell.BuildWrapper.Packages + +executable buildwrapper + hs-source-dirs: src-exe + main-is: Main.hs + build-depends: base < 5, buildwrapper, cmdargs, filepath, Cabal, directory, mtl, ghc, cpphs,haskell-src-exts, old-time, ghc-syb-utils, ghc-paths + ,vector, containers, syb, process, regex-tdfa, text, aeson, bytestring + ghc-options: -Wall -fno-warn-unused-do-bind + other-modules: Language.Haskell.BuildWrapper.CMD + +test-suite buildwrapper-test + type: exitcode-stdio-1.0 + hs-source-dirs: test + build-depends: base < 5, buildwrapper, HUnit, mtl, filepath, directory, Cabal, old-time, aeson, text, process, bytestring, attoparsec, test-framework, test-framework-hunit + main-is: Main.hs + ghc-options: -Wall -fno-warn-unused-do-bind + x-uses-tf: true + other-modules: Language.Haskell.BuildWrapper.APITest, Language.Haskell.BuildWrapper.Tests, Language.Haskell.BuildWrapper.CMDTests + +source-repository head + type: git + location: git://github.com/JPMoresmau/BuildWrapper.git diff --git a/src-exe/Language/Haskell/BuildWrapper/CMD.hs b/src-exe/Language/Haskell/BuildWrapper/CMD.hs new file mode 100644 --- /dev/null +++ b/src-exe/Language/Haskell/BuildWrapper/CMD.hs @@ -0,0 +1,99 @@ +{-# LANGUAGE DeriveDataTypeable,OverloadedStrings #-} +-- | +-- Module : Language.Haskell.BuildWrapper.CMD +-- Author : JP Moresmau +-- Copyright : (c) JP Moresmau 2011 +-- License : BSD3 +-- +-- Maintainer : jpmoresmau@gmail.com +-- Stability : beta +-- Portability : portable +-- +-- CmdArgs configuration for executable option handling +module Language.Haskell.BuildWrapper.CMD where + +import Language.Haskell.BuildWrapper.API +import Language.Haskell.BuildWrapper.Base +import Control.Monad.State +import System.Console.CmdArgs hiding (Verbosity(..)) + +import Data.Aeson +import qualified Data.ByteString.Lazy as BS + + +type CabalFile = FilePath +type CabalPath = FilePath +type TempFolder = FilePath + +data BWCmd=Synchronize {tempFolder::TempFolder, cabalPath::CabalPath, cabalFile::CabalFile, cabalFlags::String, force::Bool} + | Synchronize1 {tempFolder::TempFolder, cabalPath::CabalPath, cabalFile::CabalFile, cabalFlags::String, force::Bool, file:: FilePath} + | Write {tempFolder::TempFolder, cabalPath::CabalPath, cabalFile::CabalFile, cabalFlags::String, file:: FilePath, contents::String} + | Configure {tempFolder::TempFolder, cabalPath::CabalPath, cabalFile::CabalFile, cabalFlags::String, verbosity::Verbosity,cabalTarget::WhichCabal} + | Build {tempFolder::TempFolder, cabalPath::CabalPath, cabalFile::CabalFile, cabalFlags::String, verbosity::Verbosity,output::Bool,cabalTarget::WhichCabal} + | Build1 {tempFolder::TempFolder, cabalPath::CabalPath, cabalFile::CabalFile, cabalFlags::String, file:: FilePath} + | Outline {tempFolder::TempFolder, cabalPath::CabalPath, cabalFile::CabalFile, cabalFlags::String, file:: FilePath} + | TokenTypes {tempFolder::TempFolder, cabalPath::CabalPath, cabalFile::CabalFile, cabalFlags::String, file:: FilePath} + | Occurrences {tempFolder::TempFolder, cabalPath::CabalPath, cabalFile::CabalFile, cabalFlags::String, file:: FilePath,token::String} + | ThingAtPoint {tempFolder::TempFolder, cabalPath::CabalPath, cabalFile::CabalFile, cabalFlags::String, file:: FilePath, line::Int, column::Int, qualify::Bool, typed::Bool} + | NamesInScope {tempFolder::TempFolder, cabalPath::CabalPath, cabalFile::CabalFile, cabalFlags::String, file:: FilePath} + | Dependencies {tempFolder::TempFolder, cabalPath::CabalPath, cabalFile::CabalFile, cabalFlags::String} + | Components {tempFolder::TempFolder, cabalPath::CabalPath, cabalFile::CabalFile, cabalFlags::String} + deriving (Show,Read,Data,Typeable) + + +tf=".dist-buildwrapper" &= typDir &= help "temporary folder, relative to cabal file folder" +cp="cabal" &= typFile &= help "location of cabal executable" +cf=def &= typFile &= help "cabal file" +fp=def &= typFile &= help "relative path of file to process" +ff=def &= help "overwrite newer file" +uf=def &= help "user cabal flags" + +v=Normal &= help "verbosity" +wc=Target &= help "which cabal file to use: original or temporary" + +msynchronize = Synchronize tf cp cf uf ff +msynchronize1 = Synchronize1 tf cp cf uf ff fp +mconfigure = Configure tf cp cf uf v wc +mwrite= Write tf cp cf uf fp (def &= help "file contents") +mbuild = Build tf cp cf uf v (def &= help "output compilation and linking result") wc +mbuild1 = Build1 tf cp cf uf fp +moutline = Outline tf cp cf uf fp +mtokenTypes= TokenTypes tf cp cf uf fp +moccurrences=Occurrences tf cp cf uf fp (def &= help "text to search occurrences of" &= name "token") +mthingAtPoint=ThingAtPoint tf cp cf uf fp + (def &= help "line" &= name "line") + (def &= help "column" &= name "column") + (def &= help "qualify results") + (def &= help "type results") +mnamesInScope=NamesInScope tf cp cf uf fp +mdependencies=Dependencies tf cp cf uf +mcomponents=Components tf cp cf uf + +cmdMain = (cmdArgs $ + modes [msynchronize, msynchronize1, mconfigure,mwrite,mbuild,mbuild1, moutline, mtokenTypes,moccurrences,mthingAtPoint,mnamesInScope,mdependencies,mcomponents] + &= helpArg [explicit, name "help", name "h"] + &= help "buildwrapper executable" + &= program "buildwrapper" + ) + >>= handle + where + handle ::BWCmd -> IO () + handle (Synchronize tf cp cf uf ff )=run tf cp cf uf (synchronize ff) + handle (Synchronize1 tf cp cf uf ff fp)=run tf cp cf uf (synchronize1 ff fp) + handle (Write tf cp cf uf fp s)=run tf cp cf uf (write fp s) + handle (Configure tf cp cf uf v wc)=runV v tf cp cf uf (configure wc) + handle (Build tf cp cf uf v output wc)=runV v tf cp cf uf (build output wc) + handle (Build1 tf cp cf uf fp)=runV v tf cp cf uf (build1 fp) + handle (Outline tf cp cf uf fp)=run tf cp cf uf (getOutline fp) + handle (TokenTypes tf cp cf uf fp)=run tf cp cf uf (getTokenTypes fp) + handle (Occurrences tf cp cf uf fp token)=run tf cp cf uf (getOccurrences fp token) + handle (ThingAtPoint tf cp cf uf fp line column qual typed)=run tf cp cf uf (getThingAtPoint fp line column qual typed) + handle (NamesInScope tf cp cf uf fp)=run tf cp cf uf (getNamesInScope fp) + handle (Dependencies tf cp cf uf)=run tf cp cf uf getCabalDependencies + handle (Components tf cp cf uf)=run tf cp cf uf getCabalComponents + run:: (ToJSON a) => FilePath -> FilePath -> FilePath -> String -> StateT BuildWrapperState IO a -> IO () + run = runV Normal + runV:: (ToJSON a) => Verbosity -> FilePath -> FilePath -> FilePath -> String -> StateT BuildWrapperState IO a -> IO () + runV v tf cp cf uf f=(evalStateT f (BuildWrapperState tf cp cf v uf)) + >>= BS.putStrLn . BS.append "build-wrapper-json:" . encode + diff --git a/src-exe/Main.hs b/src-exe/Main.hs new file mode 100644 --- /dev/null +++ b/src-exe/Main.hs @@ -0,0 +1,17 @@ +-- | +-- Module : Main +-- Author : JP Moresmau +-- Copyright : (c) JP Moresmau 2011 +-- License : BSD3 +-- +-- Maintainer : jpmoresmau@gmail.com +-- Stability : beta +-- Portability : portable +-- +-- Executable entry point +module Main where + +import Language.Haskell.BuildWrapper.CMD + +main::IO() +main = cmdMain diff --git a/src/Language/Haskell/BuildWrapper/API.hs b/src/Language/Haskell/BuildWrapper/API.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/BuildWrapper/API.hs @@ -0,0 +1,218 @@ +{-# LANGUAGE CPP, ScopedTypeVariables #-} +-- | +-- Module : Language.Haskell.BuildWrapper.API +-- Author : JP Moresmau +-- Copyright : (c) JP Moresmau 2011 +-- License : BSD3 +-- +-- Maintainer : jpmoresmau@gmail.com +-- Stability : beta +-- Portability : portable +-- +-- API entry point, with all exposed methods +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.Src + +import qualified Data.Text as T + +import Control.Monad.State +import Language.Haskell.Exts.Annotated +import Language.Preprocessor.Cpphs +import Data.Maybe +import System.FilePath +--import System.Time +import GHC (TypecheckedSource) + +synchronize :: Bool -> BuildWrapper(OpResult [FilePath]) +synchronize force =do + cf<-gets cabalFile + m<-copyFromMain force $ takeFileName cf + (fileList,ns)<-getFilesToCopy + --liftIO $ putStrLn ("filelist:" ++ (show fileList)) + --let fileList=case motherFiles of + -- Nothing ->[] + -- Just fps->fps + 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 $ putStrLn ("contents:"++s) + liftIO $ writeFile real s + +configure :: WhichCabal -> BuildWrapper (OpResult Bool) +configure which= do + --synchronize + (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) + +-- (bool,bwns)<-configure +-- if bool +-- then do +-- (ret,bwns2)<-cabalBuild +-- return (ret,(bwns++bwns2)) +-- else +-- return (bool,bwns) + +-- ppContents :: String -> String +-- ppContents = unlines . (map f) . lines +-- where f ('#':_) = "" +-- f x = x + +preproc :: CabalBuildInfo -> FilePath -> IO String +preproc cbi tgt= do + inputOrig<-readFile tgt + let cppo=fileCppOptions cbi ++ ["-D__GLASGOW_HASKELL__=" ++ show (__GLASGOW_HASKELL__::Int)] + --putStrLn $ "cppo=" ++ (show cppo) + if not $ null cppo + then do + let epo=parseOptions cppo + case epo of + Right opts2->liftIO $ runCpphs opts2 tgt inputOrig + Left _->return inputOrig + else return inputOrig + + +getAST :: FilePath -> BuildWrapper (OpResult (Maybe (ParseResult (Module SrcSpanInfo, [Comment])))) +getAST fp = do + (mcbi,bwns)<-getBuildInfo fp + case mcbi of + Just(cbi)->do + let (_,opts)=cabalExtensions $ snd cbi + tgt<-getTargetPath fp + --let modS=moduleToString modName + input<-liftIO $ preproc (snd cbi) tgt + pr<- liftIO $ getHSEAST input opts + --let json=makeObj [("parse" , (showJSON $ pr))] + return (Just pr,bwns) + Nothing-> do + -- cf<-gets cabalFile + tgt<-getTargetPath fp + -- let dir=(takeDirectory cf) + --liftIO $ putStrLn "not in cabal" + input<-liftIO $ readFile tgt -- (dir fp) + pr<- liftIO $ getHSEAST input knownExtensionNames + --let json=makeObj [("parse" , (showJSON $ pr))] + return (Just pr,[]) + +getGHCAST :: FilePath -> BuildWrapper (OpResult (Maybe TypecheckedSource)) +getGHCAST fp = do + (mcbi,bwns)<-getBuildInfo fp + case mcbi of + Just(cbi)->do + let (modName,opts)=cabalExtensions $ snd cbi + (_,opts2)<-fileGhcOptions cbi + tgt<-getTargetPath fp + temp<-getFullTempDir + let modS=moduleToString modName + (pr,bwns2)<- liftIO $ BwGHC.getAST tgt temp modS (opts++opts2) + return (pr,bwns2) + Nothing-> return (Nothing,bwns) + +withGHCAST :: FilePath -> (FilePath -> FilePath -> String -> [String] -> IO a) -> BuildWrapper (OpResult (Maybe a)) +withGHCAST fp f= do + (mcbi,bwns)<-getBuildInfo fp + case mcbi of + Just(cbi)->do + let (modName,opts)=cabalExtensions $ snd cbi + (_,opts2)<-fileGhcOptions cbi + tgt<-getTargetPath fp + temp<-getFullTempDir + let modS=moduleToString modName + pr<- liftIO $ f tgt temp modS (opts++opts2) + return (Just pr,bwns) + Nothing-> return (Nothing,bwns) + +getOutline :: FilePath -> BuildWrapper (OpResult [OutlineDef]) +getOutline fp=do + (mast,bwns)<-getAST fp + --liftIO $ putStrLn $ show mast + case mast of + Just (ParseOk ast)->do + return (getHSEOutline ast,bwns) + Just (ParseFailed loc err)->return ([],(BWNote BWError err (BWLocation fp (srcLine loc) (srcColumn loc))):bwns) + _ -> return ([],bwns) + +getTokenTypes :: FilePath -> BuildWrapper (OpResult [TokenDef]) +getTokenTypes fp=do +-- c1<-liftIO $ getClockTime +-- (mcbi,bwns)<-getBuildInfo fp +-- case mcbi of +-- Just(cbi)->do +-- let (_,opts)=cabalExtensions $ snd cbi +-- tgt<-getTargetPath fp +-- ett<-liftIO $ do +-- input<-readFile tgt +-- putStrLn $ show $ length input +-- ett2<-BwGHC.tokenTypesArbitrary tgt input (".lhs" == (takeExtension fp)) opts +-- c2<-getClockTime +-- putStrLn ("getTokenTypes: " ++ (show $ tdPicosec $ diffClockTimes c2 c1)) +-- return ett2 +-- case ett of +-- Right tt->return (tt,bwns) +-- Left bw -> return ([],bw:bwns) +-- Nothing-> do + tgt<-getTargetPath fp + ett<-liftIO $ do + --let dir=takeDirectory cf + --liftIO $ putStrLn "not in cabal" + input<-readFile tgt --(dir fp) + ett2<-BwGHC.tokenTypesArbitrary tgt input (".lhs" == (takeExtension fp)) knownExtensionNames + --case ett2 of + -- Right tt-> putStrLn ("getTokenTypes: " ++ (show $ length tt)) + -- Left _->return() + --c2<-getClockTime + --putStrLn ("getTokenTypes: " ++ (show $ (\x->div x 1000000000) $ tdPicosec $ diffClockTimes c2 c1) ++"ms") + return ett2 + case ett of + Right tt->return (tt,[]) -- bwns + Left bw -> return ([],bw:[]) -- bwns + + +getOccurrences :: FilePath -> String -> BuildWrapper (OpResult [TokenDef]) +getOccurrences fp query=do + (mcbi,bwns)<-getBuildInfo fp + case mcbi of + Just(cbi)->do + let (_,opts)=cabalExtensions $ snd cbi + 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,bwns) + Left bw -> return ([],bw:bwns) + Nothing-> return ([],bwns) + +getThingAtPoint :: FilePath -> Int -> Int -> Bool -> Bool -> BuildWrapper (OpResult (Maybe String)) +getThingAtPoint fp line col qual typed=withGHCAST fp $ BwGHC.getThingAtPoint line col qual typed + +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 diff --git a/src/Language/Haskell/BuildWrapper/Base.hs b/src/Language/Haskell/BuildWrapper/Base.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/BuildWrapper/Base.hs @@ -0,0 +1,301 @@ +{-# LANGUAGE DeriveDataTypeable,OverloadedStrings,PatternGuards #-} +-- | +-- Module : Language.Haskell.BuildWrapper.GHC +-- Author : JP Moresmau +-- Copyright : (c) JP Moresmau 2011 +-- License : BSD3 +-- +-- Maintainer : jpmoresmau@gmail.com +-- Stability : beta +-- Portability : portable +-- +-- Data types, State Monad, utility functions +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.Map as M +import qualified Data.Vector as V + +import System.Directory +import System.FilePath + +type BuildWrapper=StateT BuildWrapperState IO + +data BuildWrapperState=BuildWrapperState{ + tempFolder::String, + cabalPath::FilePath, + cabalFile::FilePath, + verbosity::Verbosity, + cabalFlags::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) + +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 + 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))=toJSON $ map toJSON [sr,sc,er,ec] + +instance FromJSON InFileSpan where + parseJSON (Array v) | + 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) + 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] + } + deriving (Show,Read,Eq,Ord) + +instance ToJSON OutlineDef where + toJSON (OutlineDef n tps l c)= object ["n" .= n , "t" .= map toJSON tps, "l" .= l, "c" .= map toJSON c] + +instance FromJSON OutlineDef where + parseJSON (Object v) =OutlineDef <$> + v .: "n" <*> + v .: "t" <*> + v .: "l" <*> + v .: "c" + 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.assocs o, + Success v0 <- fromJSON b=return $ TokenDef a v0 + parseJSON _= mzero +--withCabal :: (GenericPackageDescription -> BuildWrapper a) -> BuildWrapper (Either BWNote a) +--withCabal f =do +-- cf<-gets cabalFile +-- pr<-parseCabal +-- case pr of +-- ParseOk _ a ->(liftM Right) $ f a +-- ParseFailed p->return $ Left $ peErrorToBWNote (takeFileName cf) p +-- +--parseCabal :: BuildWrapper(ParseResult GenericPackageDescription) +--parseCabal = do +-- cf<-gets cabalFile +-- return $ parsePackageDescription cf + +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 + +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 $ copyFileFull fullSrc fullTgt + return $ Just src + else return Nothing + else return Nothing + +copyFileFull :: FilePath -> FilePath -> IO() +copyFileFull src tgt=do + --createDirectoryIfMissing True (takeDirectory tgt) + --putStrLn tgt + copyFile src tgt + +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_exposedModules::[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 + +-- | http://book.realworldhaskell.org/read/io-case-study-a-library-for-searching-the-filesystem.html +getRecursiveContents :: FilePath -> IO [FilePath] +getRecursiveContents topdir = do + names <- getDirectoryContents topdir + let properNames = filter (`notElem` [".", ".."]) names + paths <- forM properNames $ \name -> do + let path = topdir name + isDirectory <- doesDirectoryExist path + if isDirectory + then getRecursiveContents path + else return [path] + return (concat paths) diff --git a/src/Language/Haskell/BuildWrapper/Cabal.hs b/src/Language/Haskell/BuildWrapper/Cabal.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/BuildWrapper/Cabal.hs @@ -0,0 +1,543 @@ +{-# LANGUAGE PatternGuards,ScopedTypeVariables #-} +-- | +-- Module : Language.Haskell.BuildWrapper.Cabal +-- Author : JP Moresmau +-- Copyright : (c) JP Moresmau 2011 +-- License : BSD3 +-- +-- Maintainer : jpmoresmau@gmail.com +-- Stability : beta +-- Portability : portable +-- +-- Cabal operations: configure, build, retrieve information from build info, parse errors and warnings +module Language.Haskell.BuildWrapper.Cabal where + +import Language.Haskell.BuildWrapper.Base +import Language.Haskell.BuildWrapper.Packages + +import Control.Monad.State + + +import Data.Char +import Data.Function (on) +import Data.List +import Data.Maybe +import qualified Data.Map as DM + +import Exception (ghandle) + +import Distribution.ModuleName +import Distribution.PackageDescription ( otherModules,library,executables,testSuites,Library,hsSourceDirs,libBuildInfo,Executable(..),exeName,modulePath,buildInfo,TestSuite(..),testName,TestSuiteInterface(..),testInterface,testBuildInfo,BuildInfo,cppOptions,defaultExtensions,otherExtensions,oldExtensions ) +import Distribution.Simple.GHC +import Distribution.Simple.LocalBuildInfo + +import qualified Distribution.PackageDescription as PD +import Distribution.Package +import Distribution.InstalledPackageInfo as IPI +import Distribution.Version +import Distribution.Text (display) + + +import qualified Distribution.Simple.Configure as DSC +import qualified Distribution.Verbosity as V +import Text.Regex.TDFA + +import System.Directory +import System.Exit +import System.FilePath +import System.Process +--import System.Time + + + +getFilesToCopy :: BuildWrapper(OpResult [FilePath]) +getFilesToCopy =do + (mfps,bwns)<-withCabal Source getAllFiles + return $ case mfps of + Just fps->(nub $ concatMap (\(_,_,_,_,ls)->map snd ls) fps,bwns) + Nothing ->([],bwns); + + +--maybe (return []) (\f->concat $ (map (\(_,_,ls)->ls)) f) getAllFiles + +{--withCabal True (\gpd->do + let pd=localPkgDescr gpd + let libs=maybe [] extractFromLib $ library pd + let exes=concatMap extractFromExe $ executables pd + let tests=concatMap extractFromTest $ testSuites pd + return (libs ++ exes ++ tests) + ) + where + extractFromLib :: Library -> [FilePath] + extractFromLib l=let + modules=(exposedModules l) ++ (otherModules $ libBuildInfo l) + in copyModules modules (hsSourceDirs $ libBuildInfo l) + extractFromExe :: Executable -> [FilePath] + extractFromExe e=let + modules= (otherModules $ buildInfo e) + hsd=hsSourceDirs $ buildInfo e + in (copyFiles [modulePath e] hsd)++ (copyModules modules hsd) + extractFromTest :: TestSuite -> [FilePath] + extractFromTest e =let + modules= (otherModules $ testBuildInfo e) + hsd=hsSourceDirs $ testBuildInfo e + extras=case testInterface e of + (TestSuiteExeV10 _ mp)->(copyFiles [mp] hsd) + (TestSuiteLibV09 _ mn)->copyModules [mn] hsd + _->[] + in extras++ (copyModules modules hsd) + copyModules :: [ModuleName] -> [FilePath] -> [FilePath] + copyModules mods=copyFiles (concatMap (\m->[(toFilePath m) <.> "hs",(toFilePath m) <.> "lhs"]) mods) + copyFiles :: [FilePath] -> [FilePath] -> [FilePath] + copyFiles mods dirs=[d m | m<-mods, d<-dirs] + --} + +cabalV :: BuildWrapper (V.Verbosity) +cabalV =do + v<-gets verbosity + return $ toCabalV v + where + toCabalV Silent =V.silent + toCabalV Normal =V.normal + toCabalV Verbose =V.verbose + toCabalV Deafening =V.deafening + +cabalBuild :: Bool -> WhichCabal -> BuildWrapper (OpResult BuildResult) +cabalBuild output srcOrTgt= do + (mr,n)<-withCabal srcOrTgt (\_->do + cf<-getCabalFile srcOrTgt + cp<-gets cabalPath + v<-cabalV + dist_dir<-getDistDir + + let args=[ + "build", + "--verbose="++(show $ fromEnum v), + "--builddir="++dist_dir + + ] ++ (if output + then [] + else ["--ghc-option=-c"]) + + liftIO $ do + cd<-getCurrentDirectory + setCurrentDirectory (takeDirectory cf) + -- c1<-getClockTime + -- f<-readFile ((takeDirectory cf) "src" "A.hs") + -- putStrLn "cabal build start" + (ex,out,err)<-readProcessWithExitCode cp args "" + putStrLn err + --putStrLn ("build out:" ++ out) + let fps=catMaybes $ map getBuiltPath $ lines out + -- c2<-getClockTime + -- putStrLn ("cabal build end" ++ (timeDiffToString $ diffClockTimes c2 c1)) + let ret=parseBuildMessages err + setCurrentDirectory cd + return (ex==ExitSuccess,ret,fps) + ) + return $ case mr of + Nothing -> ((BuildResult False []),n) + Just (r,n2,fps) -> ((BuildResult r fps),n++n2) + +cabalConfigure :: WhichCabal-> BuildWrapper (OpResult (Maybe LocalBuildInfo)) +cabalConfigure srcOrTgt= do + cf<-getCabalFile srcOrTgt + cp<-gets cabalPath + ok<-liftIO $ doesFileExist cf + if ok + then + do + v<-cabalV + dist_dir<-getDistDir + uf<-gets cabalFlags + let args=[ + "configure", + "--verbose="++(show $ fromEnum v), + "--user", + "--enable-tests", + "--builddir="++dist_dir, + "--flags="++uf + ] + {--(_,Just hOut,Just hErr)<-liftIO $ createProcess + ((proc cp args){ + cwd = Just $takeDirectory cf, + std_out = CreatePipe, + std_err = CreatePipe + })--} + liftIO $ do + cd<-getCurrentDirectory + setCurrentDirectory (takeDirectory cf) + --c1<-getClockTime + --c<-readFile cf + --putStrLn dist_dir + --putStrLn (takeDirectory cf) + --putStrLn (show $ fromEnum v) + --putStrLn "cabal configure start" + (ex,_,err)<-readProcessWithExitCode cp args "" + --c2<-getClockTime + --putStrLn ("cabal configure end: " ++ (timeDiffToString $ diffClockTimes c2 c1)) + putStrLn err + let msgs=(parseCabalMessages (takeFileName cf) (takeFileName cp) err) -- ++ (parseCabalMessages (takeFileName cf) out) + --putStrLn ("msgs:"++(show $ length msgs)) + ret<-case ex of + ExitSuccess -> do + lbi<-DSC.getPersistBuildConfig dist_dir + return (Just lbi,msgs) + ExitFailure _ -> return $ (Nothing,msgs) + setCurrentDirectory cd + return ret + else return (Nothing,[]) + {-- + v<-gets cabalVerbosity + gen_pkg_descr <- liftIO $ readPackageDescription v cf + dist_dir<-getDistDir + let prog_conf =defaultProgramConfiguration + let user_flags = [] --getSessionSelector userFlags + let config_flags = + (defaultConfigFlags prog_conf) + { configDistPref = Flag dist_dir + , configVerbosity = Flag v + , configUserInstall = Flag True + , configTests = Flag True + -- , configConfigurationsFlags = map (\(n,v)->(FlagName n,v)) user_flags + } + lbi<-liftIO $ handle (\(e :: IOError) -> return $ Left $ BWNote BWError "Cannot configure:" (show e) (BWLocation cf 1 1)) $ do + lbi <- liftIO $ DSC.configure (gen_pkg_descr, (Nothing, [])) + config_flags + liftIO $ DSC.writePersistBuildConfig dist_dir lbi + liftIO $ initialBuildSteps dist_dir (localPkgDescr lbi) lbi v + knownSuffixHandlers + return $ Right lbi + liftIO $ setCurrentDirectory cd + return lbi --} + -- cabal configure --buildir dist_dir -v=verbosity --user --enable-tests + +getCabalFile :: WhichCabal -> BuildWrapper FilePath +getCabalFile Source= gets cabalFile +getCabalFile Target= gets cabalFile + >>=return . takeFileName + >>=getTargetPath + +cabalInit :: WhichCabal -> BuildWrapper (OpResult (Maybe LocalBuildInfo)) +cabalInit srcOrTgt= do + cabal_file<-getCabalFile srcOrTgt + dist_dir<-getDistDir + let setup_config = DSC.localBuildInfoFile dist_dir + conf'd <- liftIO $ doesFileExist setup_config + if not conf'd + then do + liftIO $ putStrLn "configuring because setup_config not present" + cabalConfigure srcOrTgt + else do + cabal_time <- liftIO $ getModificationTime cabal_file + conf_time <- liftIO $ getModificationTime setup_config + if cabal_time > conf_time + then do + liftIO $ putStrLn "configuring because setup_config too old" + cabalConfigure srcOrTgt + else do + mb_lbi <- liftIO $ DSC.maybeGetPersistBuildConfig dist_dir + case mb_lbi of + Nothing -> do + liftIO $ putStrLn "configuring because persist build config not present" + cabalConfigure srcOrTgt + Just _lbi -> do + return $ (Just _lbi,[]) + + +withCabal :: WhichCabal -> (LocalBuildInfo -> BuildWrapper (a))-> BuildWrapper (OpResult (Maybe a)) +withCabal srcOrTgt f=do + (mlbi,notes)<-cabalInit srcOrTgt + case mlbi of + Nothing-> do + --liftIO $ putStrLn (show err) + return $ (Nothing,notes) + Just lbi ->do + r<-(f lbi) + return (Just r, notes) + + +parseCabalMessages :: FilePath -> FilePath -> String -> [BWNote] +parseCabalMessages cf cabalExe s=let + (m,ls)=foldl parseCabalLine (Nothing,[]) $ lines s + in nub $ case m of + Nothing -> ls + Just (bwn,msgs)->ls++[makeNote bwn msgs] + where + parseCabalLine :: (Maybe (BWNote,[String]),[BWNote]) -> String ->(Maybe (BWNote,[String]),[BWNote]) + parseCabalLine (currentNote,ls) l + | isPrefixOf "Error:" l=(Just (BWNote BWError "" (BWLocation cf 1 1),[dropWhile isSpace $ drop 6 l]),addCurrent currentNote ls) + | isPrefixOf "Warning:" l=let + msg=(dropWhile isSpace $ drop 8 l) + msg2=if isPrefixOf cf msg + then dropWhile isSpace $ drop ((length cf) + 1) msg + else msg + in (Just (BWNote BWWarning "" (BWLocation cf (extractLine msg2) 1),[msg2]),addCurrent currentNote ls) + | isPrefixOf (cabalExe++":") l= + let + s2=(dropWhile isSpace $ drop ((length cabalExe)+1) l) + in if isPrefixOf "At least the following" s2 + then (Just $ (BWNote BWError "" (BWLocation cf 1 1),[s2]),addCurrent currentNote ls) + else + let + (loc,rest)=span (/= ':') s2 + (realloc,line,msg)=if null rest + then ("","0",s2) + else + let tr=tail rest + (line',msg')=span (/= ':') tr + in if null msg' + then (loc,"0",tr) + else (loc,line',tail msg') + in (Just (BWNote BWError "" (BWLocation realloc (read line) 1),[msg]),addCurrent currentNote ls) + | Just (jcn,msgs)<-currentNote= + if (not $ null l) + then (Just (jcn,l:msgs),ls) + else (Nothing,ls++[makeNote jcn msgs]) + | otherwise =(Nothing,ls) + addCurrent Nothing xs=xs + addCurrent (Just (n,msgs)) xs=xs++[makeNote n msgs] + extractLine el=let + (_,_,_,ls)=el =~ "\\(line ([0-9]*)\\)" :: (String,String,String,[String]) + in if null ls + then 0 + else (read $ head ls) + + +parseBuildMessages :: String -> [BWNote] +parseBuildMessages s=let + (m,ls)=foldl parseBuildLine (Nothing,[]) $ lines s + in ((nub $ case m of + Nothing -> ls + Just (bwn,msgs)->ls++[makeNote bwn msgs])) + where + parseBuildLine :: (Maybe (BWNote,[String]),[BWNote]) -> String ->(Maybe (BWNote,[String]),[BWNote]) + parseBuildLine (currentNote,ls) l + | Just (jcn,msgs)<-currentNote= + if (not $ null l) + then (Just (jcn,l:msgs),ls) + else (Nothing,ls++[makeNote jcn msgs]) + -- | Just fp<-getBuiltPath l=(currentNote,ls,fp:fps) + | Just n<-extractLocation l=(Just (n,[bwn_title n]),ls) + | otherwise =(Nothing,ls) + extractLocation el=let + (_,_,aft,ls)=el =~ "(.+):([0-9]+):([0-9]+):" :: (String,String,String,[String]) + in case ls of + (loc:line:col:[])-> (Just $ BWNote BWError (dropWhile isSpace aft) (BWLocation loc (read line) (read col))) + _ -> Nothing + +makeNote :: BWNote -> [String] ->BWNote +makeNote bwn msgs=let + title=dropWhile isSpace $ unlines $ reverse msgs + in if isPrefixOf "Warning:" title + then bwn{bwn_title=dropWhile isSpace $ drop 8 title,bwn_status=BWWarning} + else bwn{bwn_title=title} + +getBuiltPath :: String -> Maybe FilePath +getBuiltPath line=let + (_,_,_,ls)=line =~ "\\[[0-9]+ of [0-9]+\\] Compiling .+\\( (.+), (.+)\\)" :: (String,String,String,[String]) + in case ls of + (src:_:[])->Just src + _ -> Nothing + +type CabalBuildInfo=(BuildInfo,ComponentLocalBuildInfo,FilePath,Bool,[(ModuleName,FilePath)]) + +getBuildInfo :: FilePath -> BuildWrapper (OpResult (Maybe (LocalBuildInfo,CabalBuildInfo))) +getBuildInfo fp=do + (mmr,bwns)<-go getReferencedFiles + case mmr of + Nothing-> do + (mmr2,bwns2)<-go getAllFiles + return $ case mmr2 of + Nothing-> (Nothing,bwns) + Just a-> (a,bwns2) + Just a->return $ (a,bwns) + where go f=withCabal Source (\lbi->do + fps<-f lbi + --liftIO $ mapM_ (\(_,_,_,ls)->mapM_ (putStrLn . snd) ls) fps + let ok=filter (\(_,_,_,_,ls)->not $ null ls ) $ + map (\(n1,n2,n3,n4,ls)->(n1,n2,n3,n4,filter (\(_,b)->b==fp) ls) ) + fps + return $ if null ok + then Nothing + else Just $ (lbi,head ok)) + +fileGhcOptions :: (LocalBuildInfo,CabalBuildInfo) -> BuildWrapper(ModuleName,[String]) +fileGhcOptions (lbi,(bi,clbi,fp,isLib,ls))=do + dist_dir<-getDistDir + let inplace=dist_dir "package.conf.inplace" + inplaceExist<-liftIO $ doesFileExist inplace + let pkg=if isLib + then ["-package-name", display $ packageId $ localPkgDescr lbi ] + else if inplaceExist + then ["-package-conf",inplace] + else [] + return (fst $ head ls,pkg++(ghcOptions lbi bi clbi fp)) + + + + -- libraries, executables, test suite: BuildInfo + all relevant modules + -- find if modules included correspond to a component + -- what about generated modules? + + -- libraryConfig :: Maybe ComponentLocalBuildInfo executableConfigs :: [(String, ComponentLocalBuildInfo)] testSuiteConfigs :: [(String, ComponentLocalBuildInfo)] + + -- ghcOptions :: LocalBuildInfo -> BuildInfo -> ComponentLocalBuildInfo + -- -> FilePath -> [String] + -- ghcOptions lbi bi clbi odir + +fileCppOptions :: CabalBuildInfo -> [String] +fileCppOptions (bi,_,_,_,_)=cppOptions bi + +cabalExtensions :: CabalBuildInfo -> (ModuleName,[String]) +cabalExtensions (bi,_,_,_,ls)=(fst $ head ls,map show $ ((otherExtensions bi) ++ (defaultExtensions bi) ++ (oldExtensions bi))) + +getAllFiles :: LocalBuildInfo -> BuildWrapper [CabalBuildInfo] +getAllFiles lbi= do + let pd=localPkgDescr lbi + let libs=maybe [] extractFromLib $ library pd + let exes=map extractFromExe $ executables pd + let tests=map extractFromTest $ testSuites pd + mapM (\(a,b,c,isLib,d)->do + mf<-copyAll d + return (a,b,c,isLib,mf)) (libs ++ exes ++ tests) + where + extractFromLib :: Library -> [(BuildInfo,ComponentLocalBuildInfo,FilePath,Bool,[FilePath])] + extractFromLib l=let + lib=libBuildInfo l + in [(lib,fromJust $ libraryConfig lbi,buildDir lbi,True,(hsSourceDirs lib))] + extractFromExe :: Executable -> (BuildInfo,ComponentLocalBuildInfo,FilePath,Bool,[FilePath]) + extractFromExe e@Executable{exeName=exeName'}=let + ebi=buildInfo e + targetDir = buildDir lbi exeName' + exeDir = targetDir (exeName' ++ "-tmp") + hsd=hsSourceDirs ebi + in (ebi,fromJust $ lookup exeName' $ executableConfigs lbi,exeDir,False, hsd) + extractFromTest :: TestSuite -> (BuildInfo,ComponentLocalBuildInfo,FilePath,Bool,[FilePath]) + extractFromTest t@TestSuite {testName=testName'} =let + tbi=testBuildInfo t + targetDir = buildDir lbi testName' + testDir = targetDir (testName' ++ "-tmp") + hsd=hsSourceDirs tbi + in (tbi,fromJust $ lookup testName' $ testSuiteConfigs lbi,testDir,False,hsd) + copyAll :: [FilePath] -> BuildWrapper [(ModuleName,FilePath)] + copyAll fps= do +-- cf<-gets cabalFile +-- let dir=(takeDirectory cf) +-- ffps<-mapM getFullSrc fps +-- allF<-liftIO $ mapM getRecursiveContents ffps +-- liftIO $ putStrLn ("allF:" ++ (show allF)) +-- return $ map (\f->(fromString $ fileToModule f,f)) $ map (\f->makeRelative dir f) $ concat allF + allF<-mapM copyAll' fps + return $ concat allF + copyAll' :: FilePath -> BuildWrapper [(ModuleName,FilePath)] + copyAll' fp=do + cf<-gets cabalFile + let dir=(takeDirectory cf) + fullFP<-getFullSrc fp + allF<-liftIO $ getRecursiveContents fullFP + return $ map (\f->(fromString $ fileToModule $ makeRelative fullFP f,makeRelative dir f)) allF + +getReferencedFiles :: LocalBuildInfo -> BuildWrapper [CabalBuildInfo] +getReferencedFiles lbi= do + let pd=localPkgDescr lbi + let libs=maybe [] extractFromLib $ library pd + let exes=map extractFromExe $ executables pd + let tests=map extractFromTest $ testSuites pd + return (libs ++ exes ++ tests) + where + extractFromLib :: Library -> [CabalBuildInfo] + extractFromLib l=let + lib=libBuildInfo l + modules=(PD.exposedModules l) ++ (otherModules lib) + in [(lib,fromJust $ libraryConfig lbi,buildDir lbi,True,(copyModules modules (hsSourceDirs lib)))] + extractFromExe :: Executable ->CabalBuildInfo + extractFromExe e@Executable{exeName=exeName'}=let + ebi=buildInfo e + targetDir = buildDir lbi exeName' + exeDir = targetDir (exeName' ++ "-tmp") + modules= (otherModules ebi) + hsd=hsSourceDirs ebi + in (ebi,fromJust $ lookup exeName' $ executableConfigs lbi,exeDir,False, copyFiles [modulePath e] hsd++ (copyModules modules hsd) ) + extractFromTest :: TestSuite -> CabalBuildInfo + extractFromTest t@TestSuite {testName=testName'} =let + tbi=testBuildInfo t + targetDir = buildDir lbi testName' + testDir = targetDir (testName' ++ "-tmp") + modules= (otherModules tbi ) + hsd=hsSourceDirs tbi + extras=case testInterface t of + (TestSuiteExeV10 _ mp)->(copyFiles [mp] hsd) + (TestSuiteLibV09 _ mn)->copyModules [mn] hsd + _->[] + in (tbi,fromJust $ lookup testName' $ testSuiteConfigs lbi,testDir,False,extras++ (copyModules modules hsd) ) + copyModules :: [ModuleName] -> [FilePath] -> [(ModuleName,FilePath)] + copyModules mods=copyFiles (concatMap (\m->[(toFilePath m) <.> "hs",((toFilePath m) <.> "lhs")]) mods) + copyFiles :: [FilePath] -> [FilePath] -> [(ModuleName,FilePath)] + copyFiles mods dirs=[(fromString $ fileToModule m,d m) | m<-mods, d<-dirs] + +moduleToString :: ModuleName -> String +moduleToString = concat . intersperse ['.'] . components + +cabalComponents :: BuildWrapper (OpResult [CabalComponent]) +cabalComponents = do + (rs,ns)<-withCabal Source (return . cabalComponentsFromDescription . localPkgDescr) + return (fromMaybe [] rs,ns) + +cabalDependencies :: BuildWrapper (OpResult [(FilePath,[CabalPackage])]) +cabalDependencies = do + (rs,ns)<-withCabal Source (\lbi-> do + liftIO $ ghandle (\(e :: IOError) -> do + putStrLn $ show e + return []) $ do + pkgs<-liftIO $ getPkgInfos + return $ dependencies (localPkgDescr lbi) pkgs + ) + return (fromMaybe [] rs,ns) + + +dependencies :: PD.PackageDescription -> [(FilePath,[InstalledPackageInfo])] -> [(FilePath,[CabalPackage])] +dependencies pd pkgs=let + pkgsMap=foldr buildPkgMap DM.empty pkgs -- build the map of package by name with ordered version (more recent first) + allC= cabalComponentsFromDescription pd + gdeps=PD.buildDepends pd + cpkgs=concat $ DM.elems $ DM.map (\ipis->getDep allC ipis gdeps []) pkgsMap + in DM.assocs $ DM.fromListWith (++) $ ((map (\(a,b)->(a,[b])) cpkgs) ++ (map (\(a,_)->(a,[])) pkgs)) + where + buildPkgMap :: (FilePath,[InstalledPackageInfo]) -> DM.Map String [(FilePath,InstalledPackageInfo)] -> DM.Map String [(FilePath,InstalledPackageInfo)] + buildPkgMap (fp,ipis) m=foldr (\i dm->let + key=display $ pkgName $ sourcePackageId i + vals=DM.lookup key dm + newvals=case vals of + Nothing->[(fp,i)] + Just l->sortBy (flip (compare `on` (pkgVersion . sourcePackageId . snd))) ((fp,i):l) + in DM.insert key newvals dm + ) m ipis + getDep :: [CabalComponent] -> [(FilePath,InstalledPackageInfo)] -> [Dependency]-> [(FilePath,CabalPackage)] -> [(FilePath,CabalPackage)] + getDep _ [] _ acc= acc + getDep allC ((fp,InstalledPackageInfo{sourcePackageId=i,exposed=e,IPI.exposedModules=ems}):xs) deps acc= let + (ds,deps2)=partition (\(Dependency n v)->((pkgName i)==n) && withinRange (pkgVersion i) v) deps -- find if version is referenced, remove the referencing component so that it doesn't match an older version + cps=if null ds then [] else allC + mns=map display ems + in getDep allC xs deps2 ((fp,CabalPackage (display $ pkgName i) (display $ pkgVersion i) e cps mns): acc) -- build CabalPackage structure + + --DM.map (sortBy (flip (compare `on` (pkgVersion . sourcePackageId . snd)))) $ DM.fromListWith (++) (map (\i->((display $ pkgName $ sourcePackageId i),[i]) ) ipis) --concatenates all version and sort them, most recent first + +cabalComponentsFromDescription :: PD.PackageDescription -> [CabalComponent] +cabalComponentsFromDescription pd= + (if isJust (PD.library pd) then [CCLibrary (PD.buildable $ PD.libBuildInfo $ fromJust (PD.library pd))] else []) ++ + [ CCExecutable (PD.exeName e) (PD.buildable $ PD.buildInfo e) + | e <- PD.executables pd ] + ++ [ CCTestSuite (PD.testName e) (PD.buildable $ PD.testBuildInfo e) + | e <- PD.testSuites pd ] + + +--class ToBWNote a where +-- toBWNote :: a -> BWNote + +--peErrorToBWNote :: FilePath -> PError -> BWNote +--peErrorToBWNote cf (AmbigousParse t ln)= BWNote BWError "AmbigousParse" t (BWLocation cf ln 1) +--peErrorToBWNote cf (NoParse t ln) = BWNote BWError "NoParse" t (BWLocation cf ln 1) +--peErrorToBWNote cf (TabsError ln) = BWNote BWError "TabsError" "" (BWLocation cf ln 1) +--peErrorToBWNote cf (FromString t mln) = BWNote BWError "FromString" t (BWLocation cf (fromMaybe 1 mln) 1) + diff --git a/src/Language/Haskell/BuildWrapper/Find.hs b/src/Language/Haskell/BuildWrapper/Find.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/BuildWrapper/Find.hs @@ -0,0 +1,699 @@ +{-# LANGUAGE UndecidableInstances, FunctionalDependencies, FlexibleContexts #-} +{-# LANGUAGE TypeSynonymInstances, MultiParamTypeClasses #-} +{-# LANGUAGE PatternGuards, FlexibleInstances, CPP #-} +-- | +-- Module : Language.Haskell.BuildWrapper.Find +-- Copyright : (c) Thomas Schilling 2008, JP Moresmau 2011 +-- License : BSD-style +-- +-- Maintainer : jpmoresmau@gmail.com +-- Stability : beta +-- Portability : portable +-- +-- Find things in a syntax tree. +-- +module Language.Haskell.BuildWrapper.Find + ( findHsThing, SearchResult(..), SearchResults, Search + , PosTree(..), PosForest, deepestLeaf, pathToDeepest, searchBindBag + , surrounds, overlaps, haddockType, prettyResult, qualifiedResult, typeOf, start, end +#ifdef SCION_DEBUG + , prop_invCmpOverlap +#endif + ) +where + +import GHC +import Outputable +import Name hiding (varName) + +import BasicTypes ( IPName(..) ) +import Bag +import Var ( varName,varType ) + +#if __GLASGOW_HASKELL__ < 702 +import TypeRep ( Type(..), PredType(..) ) +#else +import TypeRep ( Type(..), Pred(..) ) +#endif + +import Data.Monoid ( mempty, mappend, mconcat ) +import Data.Foldable as F ( maximumBy ) +import Data.Ord ( comparing ) +import qualified Data.Set as S + +------------------------------------------------------------------------------ + + +isRecStmt :: StmtLR idL idR -> Bool + +#if __GLASGOW_HASKELL__ < 611 + +isRecStmt (RecStmt _ _ _ _ _) = True +isRecStmt _ = False + +#else + +isRecStmt (RecStmt _ _ _ _ _ _ _ _) = True +isRecStmt _ = False + +#endif + +-- | Pretty-print a search result. +prettyResult :: OutputableBndr id => SearchResult id -> SDoc +prettyResult (FoundId i) = ppr i +prettyResult (FoundName n) = ppr n +prettyResult (FoundCon _ c) = ppr c +prettyResult r = ppr r + +-- | Pretty-print a search result as qualified name +qualifiedResult :: OutputableBndr id => SearchResult id -> SDoc +qualifiedResult (FoundId i) = qualifiedName $ getName i +qualifiedResult (FoundName n) = qualifiedName n +qualifiedResult (FoundCon _ c) = qualifiedName $ getName c +qualifiedResult r = ppr r + +qualifiedName :: Name -> SDoc +qualifiedName n = maybe empty (\x-> (ppr x) <> dot) (nameModule_maybe n) <> (ppr n) + +typeOf :: (SearchResult Id, [SearchResult Id]) -> Maybe Type +typeOf (FoundId ident, path) = + let -- Unwrap a HsWrapper and its associated type + unwrap WpHole t = t + unwrap (WpCompose w1 w2) t = unwrap w1 (unwrap w2 t) + unwrap (WpCast _) t = t -- XXX: really? + unwrap (WpTyApp t') t = AppTy t t' + unwrap (WpTyLam tv) t = ForAllTy tv t + -- do something else with coercion/dict vars? +#if __GLASGOW_HASKELL__ < 700 + unwrap (WpApp v) t = AppTy t (TyVarTy v) + unwrap (WpLam v) t = ForAllTy v t +#else + -- unwrap (WpEvApp v) t = AppTy t (TyVarTy v) + unwrap (WpEvLam v) t = ForAllTy v t + unwrap (WpEvApp _) t = t +#endif + unwrap (WpLet _) t = t +#ifdef WPINLINE + unwrap WpInline t = t +#endif + in case path of + FoundExpr _ (HsVar _) : FoundExpr _ (HsWrap wr _) : _ -> + Just $ reduce_type $ unwrap wr (varType ident) + _ -> Just (varType ident) + +-- All other search results produce no type information +typeOf _ = Nothing + +-- | Reduce a top-level type application if possible. That is, we perform the +-- following simplification step: +-- @ +-- (forall v . t) t' ==> t [t'/v] +-- @ +-- where @[t'/v]@ is the substitution of @t'@ for @v@. +-- +reduce_type :: Type -> Type +reduce_type (AppTy (ForAllTy tv b) t) = + reduce_type (subst_type tv t b) +reduce_type t = t + +subst_type :: TyVar -> Type -> Type -> Type +subst_type v t' t0 = go t0 + where + go t = case t of + TyVarTy tv + | tv == v -> t' + | otherwise -> t + AppTy t1 t2 -> AppTy (go t1) (go t2) + TyConApp c ts -> TyConApp c (map go ts) + FunTy t1 t2 -> FunTy (go t1) (go t2) + ForAllTy v' bt + | v == v' -> t + | otherwise -> ForAllTy v' (go bt) + PredTy pt -> PredTy (go_pt pt) + + -- XXX: this is probably not right + go_pt (ClassP c ts) = ClassP c (map go ts) + go_pt (IParam i t) = IParam i (go t) + go_pt (EqPred t1 t2) = EqPred (go t1) (go t2) + +data PosTree a = Node { val :: a, children :: PosForest a } + deriving (Eq, Ord) +type PosForest a = S.Set (PosTree a) + +-- | Lookup all the things in a certain region. +findHsThing :: Search id a => (SrcSpan -> Bool) -> a -> SearchResults id +findHsThing p a = search p noSrcSpan a + +deepestLeaf :: Ord a => PosTree a -> a +deepestLeaf t = snd $ go (0::Int) t + where + go n (Node x xs) + | S.null xs = (n,x) + | otherwise = maximumBy (comparing fst) (S.map (go (n+1)) xs) + +-- | Returns the deepest leaf, together with the path to this leaf. For +-- example, for the following tree with root @A@: +-- +-- @ +-- A -+- B --- C +-- '- D --- E --- F +-- @ +-- +-- this function will return: +-- +-- @ +-- (F, [E, D, A]) +-- @ +-- +-- If @F@ were missing the result is either @(C, [B,A])@ or @(E, [D,A])@. +-- +pathToDeepest :: Ord a => PosForest a -> Maybe (a, [a]) +pathToDeepest forest + | S.null forest = Nothing + | otherwise = Just $ ptl3 $ go_many (0::Int) [] forest + where + go n path (Node x xs) + | S.null xs = (n, x, path) + | otherwise = go_many (n+1) (x:path) xs + go_many n path xs = + maximumBy (comparing fst3) (S.map (go n path) xs) + fst3 (x,_,_) = x + ptl3 (_,x,y) = (x,y) + +haddockType :: SearchResult a -> String +haddockType (FoundName n) + | isValOcc (nameOccName n)="v" + | otherwise= "t" +haddockType (FoundId i) + | isValOcc (nameOccName (Var.varName i))="v" + | otherwise= "t" +haddockType _="t" + +data SearchResult id + = FoundBind SrcSpan (HsBind id) + | FoundPat SrcSpan (Pat id) + | FoundType SrcSpan (HsType id) + | FoundExpr SrcSpan (HsExpr id) + | FoundStmt SrcSpan (Stmt id) + | FoundId Id + | FoundName Name + | FoundCon SrcSpan DataCon + | FoundLit SrcSpan HsLit + +resLoc :: SearchResult id -> SrcSpan +resLoc (FoundId i) = nameSrcSpan (varName i) +resLoc (FoundName n) = nameSrcSpan n +resLoc (FoundBind s _) = s +resLoc (FoundPat s _) = s +resLoc (FoundType s _) = s +resLoc (FoundExpr s _) = s +resLoc (FoundStmt s _) = s +resLoc (FoundCon s _) = s +resLoc (FoundLit s _) = s + +instance Eq (SearchResult id) where + a == b = resLoc a == resLoc b -- TODO: sufficient? + +instance Ord (SearchResult id) where + compare a b = compare (resLoc a) (resLoc b) + +type SearchResults id = PosForest (SearchResult id) + +-- | Given two good SrcSpans (see 'SrcLoc.isGoodSrcSpan'), returns 'EQ' if the +-- spans overlap or, if not, the relative ordering of both. +cmpOverlap :: SrcSpan -> SrcSpan -> Ordering +cmpOverlap sp1 sp2 + | not (isGoodSrcSpan sp1) = LT + | not (isGoodSrcSpan sp2) = GT + | end1 < start2 = LT + | end2 < start1 = GT + | otherwise = EQ + where + -- At this point we assume that both spans are good. We also ignore the + -- file names since faststrings seem to be rather unreliable. + start1 = start sp1 + end1 = end sp1 + start2 = start sp2 + end2 = end sp2 + +start, end :: SrcSpan -> (Int,Int) +#if __GLASGOW_HASKELL__ < 702 +start ss= (srcSpanStartLine ss, srcSpanStartCol ss) +end ss= (srcSpanEndLine ss, srcSpanEndCol ss) +#else +start (RealSrcSpan ss)= (srcSpanStartLine ss, srcSpanStartCol ss) +start (UnhelpfulSpan _)=error "UnhelpfulSpan in cmpOverlap start" +end (RealSrcSpan ss)= (srcSpanEndLine ss, srcSpanEndCol ss) +end (UnhelpfulSpan _)=error "UnhelpfulSpan in cmpOverlap start" +#endif + +surrounds :: SrcSpan -> SrcSpan -> Bool +surrounds outer inner = start1 <= start2 && end2 <= end1 + where + start1 = srcSpanStart outer + end1 = srcSpanEnd outer + start2 = srcSpanStart inner + end2 = srcSpanEnd inner + +overlaps :: SrcSpan -> SrcSpan -> Bool +overlaps sp1 sp2 = cmpOverlap sp1 sp2 == EQ + + +#ifdef SCION_DEBUG + +prop_invCmpOverlap :: SrcSpan -> SrcSpan -> Bool +prop_invCmpOverlap s1 s2 = + case cmpOverlap s1 s2 of + LT -> cmpOverlap s2 s1 == GT + EQ -> cmpOverlap s2 s1 == EQ + GT -> cmpOverlap s2 s1 == LT + +-- prop_sane : if overlap -> there is some point which is in both spans + +#endif + + +------------------------------------------------------------------------------ + +instance (OutputableBndr id, Outputable id) + => Outputable (SearchResult id) where + ppr (FoundBind s b) = text "bind:" <+> ppr s $$ nest 4 (ppr b) + ppr (FoundPat s b) = text "pat: " <+> ppr s $$ nest 4 (ppr b) + ppr (FoundType s t) = text "type:" <+> ppr s $$ nest 4 (ppr t) + ppr (FoundExpr s e) = text "expr:" <+> ppr s $$ nest 4 (ppr e) + ppr (FoundStmt s t) = text "stmt:" <+> ppr s $$ nest 4 (ppr t) + ppr (FoundId i) = text "id: " <+> ppr i + ppr (FoundName n) = text "name:" <+> ppr n + ppr (FoundCon s c) = text "con: " <+> ppr s $$ nest 4 (ppr c) + ppr (FoundLit s l) = text "lit: " <+> ppr s $$ nest 4 (ppr l) + +instance Outputable a => Outputable (PosTree a) where + ppr (Node v cs) = ppr v $$ nest 2 (vcat (map ppr (S.toList cs))) + +class Search id a | a -> id where + search :: (SrcSpan -> Bool) -> SrcSpan -> a -> SearchResults id + +only :: SearchResult id -> SearchResults id +only r = S.singleton (Node r S.empty) + +above :: SearchResult id -> SearchResults id -> SearchResults id +above r rest = S.singleton (Node r rest) + +instance Search id Id where + search _ _ i = only (FoundId i) + +instance Search Name Name where + search _ _ i = only (FoundName i) + +instance Search id DataCon where + search _ s d = only (FoundCon s d) + +instance Search id HsLit where + search _ s l = only (FoundLit s l) + +instance Search id id => Search id (IPName id) where + search p s (IPName i) = search p s i + +--instance Search id id => Search id (Located (HsBindLR id id)) where +-- search p s (L _ a@AbsBinds{})= search p s a +-- search p _ (L s a) +-- | p s = search p s a +-- | otherwise = mempty + +-- at least in GHC7 if you have a AbsBind with a type signature the SrcSpan of the AbsBind covers only the type signature... +searchBindBag :: Search id id => (SrcSpan -> Bool) -> SrcSpan -> Bag (Located (HsBindLR id id)) -> SearchResults id +searchBindBag p s bs = mconcat $ fmap (searchBinds p s) (bagToList bs) + +searchBinds :: Search id id => (SrcSpan -> Bool) -> SrcSpan -> (Located (HsBindLR id id)) -> SearchResults id +searchBinds p s (L _ a@AbsBinds{})= search p s a -- ignore location of the absbinds +searchBinds p _ (L s a) + | p s = search p s a + | otherwise = mempty + +instance Search id a => Search id (Located a) where + search p _ (L s a) + | p s = search p s a + | otherwise = mempty + +instance Search id a => Search id (Bag a) where + search p s bs = mconcat $ fmap (search p s) (bagToList bs) + +instance Search id a => Search id [a] where + search p s bs = mconcat $ fmap (search p s) bs + +instance Search id a => Search id (Maybe a) where + search _ _ Nothing = mempty + search p s (Just a) = search p s a + +instance (Search id id) => Search id (HsGroup id) where + search p s grp = + search p s (hs_valds grp) + -- TODO + +instance (Search id id) => Search id (HsBindLR id id) where + search p s b = FoundBind s b `above` search_inside + where + search_inside = + case b of + FunBind { fun_id = i, fun_matches = ms } -> + search p s i `mappend` search p s ms + AbsBinds { abs_binds = bs } -> searchBindBag p s bs + PatBind { pat_lhs = lhs, pat_rhs = rhs } -> + search p s lhs `mappend` search p s rhs + VarBind { var_rhs = rhs } -> search p s rhs + + +instance (Search id id) => Search id (MatchGroup id) where + search p s (MatchGroup ms _) = search p s ms + +instance (Search id id) => Search id (Match id) where + search p s (Match pats tysig rhss) = + search p s pats `mappend` search p s tysig `mappend` search p s rhss + +instance (Search id id) => Search id (Pat id) where + search p s pat0 = FoundPat s pat0 `above` search_inside + where + search_inside = + case pat0 of + VarPat i -> search p s i +#if __GLASGOW_HASKELL__ < 702 + VarPatOut i _ -> search p s i + TypePat t -> search p s t +#endif + LitPat pat -> search p s pat + LazyPat pat -> search p s pat + AsPat i pat -> search p s i `mappend` search p s pat + ParPat pat -> search p s pat + BangPat pat -> search p s pat + ListPat ps _ -> search p s ps + TuplePat ps _ _ -> search p s ps + PArrPat ps _ -> search p s ps + ConPatIn i d -> search p s i `mappend` search p s d + ConPatOut c _ _ _ d _ -> search p s c `mappend` search p s d + ViewPat e pt _ -> search p s e `mappend` search p s pt + SigPatIn pt t -> search p s pt `mappend` search p s t + SigPatOut pt _ -> search p s pt + NPlusKPat n _ _ _ -> search p s n + QuasiQuotePat qq -> search p s qq + CoPat _ pt _ -> search p s pt + _ -> mempty + +-- type HsConPatDetails id = HsConDetails (LPat id) (HsRecFields id (LPat id)) +instance (Search id arg, Search id rec) => Search id (HsConDetails arg rec) where + search p s (PrefixCon args) = search p s args + search p s (RecCon rec) = search p s rec + search p s (InfixCon a1 a2) = search p s a1 `mappend` search p s a2 + +--instance (Search id id) => Search id (HsModule id) where +-- search p s m =search p s (hsmodDecls m) + +instance Search Name (RenamedSource) where + search p s (b,_,_,_) = search p s b + +instance (Search id id) => Search id (HsType id) where + search _ s t = only (FoundType s t) + +instance (Search id id) => Search id (GRHSs id) where + search p s (GRHSs rhss local_binds) = + search p s rhss `mappend` search p s local_binds + +instance (Search id id) => Search id (GRHS id) where + search p s (GRHS _guards rhs) = + -- guards look like statements, but we should probably treat them + -- differently + search p s _guards `mappend` search p s rhs + +instance (Search id id) => Search id (HsExpr id) where + search p s e0 = FoundExpr s e0 `above` search_inside + where + search_inside = + case e0 of + HsVar i -> search p s i + HsIPVar i -> search p s i + HsLit l -> search p s l + ExprWithTySigOut e _t -> search p s e --`mappend` search p s t + HsBracketOut _b _ -> mempty -- search p s b + HsLam mg -> search p s mg + HsApp l r -> search p s l `mappend` search p s r + OpApp l o _ r -> search p s l `mappend` search p s o + `mappend` search p s r + NegApp e n -> search p s e `mappend` search p s n + HsPar e -> search p s e + SectionL e o -> search p s e `mappend` search p s o + SectionR o e -> search p s o `mappend` search p s e + HsCase e mg -> search p s e `mappend` search p s mg +#if __GLASGOW_HASKELL__ < 700 + HsIf c t e -> search p s c `mappend` search p s t + `mappend` search p s e +#else + HsIf _ c t e -> search p s c `mappend` search p s t + `mappend` search p s e +#endif + HsLet bs e -> search p s bs `mappend` search p s e +#if __GLASGOW_HASKELL__ < 702 + HsDo _ ss e _ -> search p s ss `mappend` search p s e +#else + HsDo _ ss _ -> search p s ss +#endif + ExplicitList _ es -> search p s es + ExplicitPArr _ es -> search p s es + ExplicitTuple es _ -> search p s es + RecordCon _ _ bs -> search p s bs + RecordUpd es bs _ _ _ -> search p s es `mappend` search p s bs + ExprWithTySig e t -> search p s e `mappend` search p s t + --ExprWithTySigOut e t -> mempty + ArithSeq _ i -> search p s i + PArrSeq _ i -> search p s i + HsSCC _ e -> search p s e + HsCoreAnn _ e -> search p s e + HsBracket b -> search p s b + --HsBracketOut b _ -> search p s b -- + HsSpliceE sp -> search p s sp + HsQuasiQuoteE _ -> mempty + HsProc pat ct -> search p s pat `mappend` search p s ct + HsArrApp f arg _ _ _ -> search p s f `mappend` search p s arg + HsArrForm e _ cmds -> search p s e `mappend` search p s cmds + HsTick _ _ e -> search p s e + HsBinTick _ _ e -> search p s e + HsTickPragma _ e -> search p s e + HsWrap _ e -> search p s e + _ -> mempty + +#if __GLASGOW_HASKELL__ > 610 +instance (Search id id) => Search id (HsTupArg id) where + search p s (Present e) = search p s e + search _ _ _ = mempty +#endif + +instance (Search id id) => Search id (HsLocalBindsLR id id) where + search p s (HsValBinds val_binds) = search p s val_binds + search _ _ _ = mempty + +instance (Search id id) => Search id (HsValBindsLR id id) where + search p s (ValBindsOut rec_binds _) = + mconcat $ fmap (searchBindBag p s . snd) rec_binds + search _ _ _ = mempty + +instance (Search id id) => Search id (HsCmdTop id) where + search p s (HsCmdTop c _ _ _) = search p s c + +instance (Search id id) => Search id (StmtLR id id) where + search p s st + | isRecStmt st = search_inside -- see Note [SearchRecStmt] + | otherwise = FoundStmt s st `above` search_inside + where + search_inside = + case st of + BindStmt pat e _ _ -> search p s pat `mappend` search p s e +#if __GLASGOW_HASKELL__ < 702 + ExprStmt e _ _ -> search p s e + ParStmt ss -> search p s (concatMap fst ss) +#else + ExprStmt e _ _ _ -> search p s e + ParStmt ss _ _ _ -> search p s (concatMap fst ss) +#endif + LetStmt bs -> search p s bs + +#if __GLASGOW_HASKELL__ < 700 + TransformStmt (ss,_) f e -> search p s ss `mappend` search p s f + `mappend` search p s e + GroupStmt (ss, _) g -> search p s ss `mappend` search p s g +#elif __GLASGOW_HASKELL__ < 702 + TransformStmt ss _ f e -> search p s ss `mappend` search p s f + `mappend` search p s e + GroupStmt ss _ g gg -> search p s ss `mappend` search p s g + `mappend` either (search p s) (const mempty) gg +#else + LastStmt e _ -> search p s e + TransStmt _ ss _ f e _ _ _-> search p s ss `mappend` search p s f + `mappend` search p s e +#endif + RecStmt{recS_stmts=sts} -> search p s sts + +-- +-- Note [SearchRecStmt] +-- -------------------- +-- +-- We only return children of a RecStmt but not the RecStmt itself, even +-- though a RecStmt may occur in the source code (under very rare +-- circumstances). The reasons are: +-- +-- * We have no way of knowing whether the RecStmt actually occured in the +-- source code. We could add a flag in GHC, but its probably not +-- worthwhile due to the other reason. +-- +-- * GHC may move things out of the recursive group if it detects that these +-- things are in fact not recursive at all. Source locations are +-- preserved, so this is fine. +-- + +#if __GLASGOW_HASKELL__ < 700 +instance (Search id id) => Search id (GroupByClause id) where + search p s (GroupByNothing f) = search p s f + search p s (GroupBySomething using_f e) = + either (search p s) (const mempty) using_f `mappend` search p s e +#endif + +instance (Search id id) => Search id (ArithSeqInfo id) where + search p s (From e) = search p s e + search p s (FromThen e1 e2) = search p s e1 `mappend` search p s e2 + search p s (FromTo e1 e2) = search p s e1 `mappend` search p s e2 + search p s (FromThenTo e1 e2 e3) = + search p s e1 `mappend` search p s e2 `mappend` search p s e3 + +-- type HsRecordBinds id = HsRecFields id (LHsExpr id) +instance Search id e => Search id (HsRecFields id e) where + search p s (HsRecFields flds _) = search p s flds + +instance Search id e => Search id (HsRecField id e) where + search p s (HsRecField _lid a _) = search p s a + +instance (Search id id) => Search id (HsBracket id) where + search p s (ExpBr e) = search p s e + search p s (PatBr q) = search p s q +#if __GLASGOW_HASKELL__ < 700 + search p s (DecBr g) = search p s g +#else + search p s (DecBrL g) = search p s g + search p s (DecBrG g) = search p s g +#endif + search p s (TypBr t) = search p s t + search _ _ (VarBr _) = mempty + +instance (Search id id) => Search id (HsSplice id) where + search p s (HsSplice _ e) = search p s e + +#if __GLASGOW_HASKELL__ >= 700 +instance (Search id id) => Search id ([id], [id]) where + search p s (a, b) = search p s a `mappend` search p s b + +instance (Search id id) => Search id (HsDecl id) where + search p s (TyClD e) = search p s e + search p s (InstD e) = search p s e + search p s (DerivD e) = search p s e + search p s (ValD e) = search p s e + search p s (SigD e) = search p s e + search p s (DefD e) = search p s e + search p s (ForD e) = search p s e + search p s (WarningD e) = search p s e + search p s (AnnD e) = search p s e + search p s (RuleD e) = search p s e + search p s (SpliceD e) = search p s e + search p s (DocD e) = search p s e + search p s (QuasiQuoteD e) = search p s e + +instance (Search id id) => Search id (TyClDecl id) where + search p s (ForeignType n _) = search p s n + search p s (TyFamily _ n ns _) = search p s n `mappend` search p s ns + search p s (TyData _ ct n v pt _ c d) = search p s ct `mappend` search p s n + `mappend` search p s v + `mappend` search p s pt + `mappend` search p s c + `mappend` search p s d + search p s (TySynonym n v pt r) = search p s n `mappend` search p s v + `mappend` search p s pt + `mappend` search p s r + search p s (ClassDecl ct n v fd sg m tt dc) = search p s ct `mappend` search p s n + `mappend` search p s v + `mappend` search p s fd + `mappend` search p s sg + `mappend` searchBindBag p s m + `mappend` search p s tt + `mappend` search p s dc + +instance (Search id id) => Search id (InstDecl id) where + search p s (InstDecl t b sg dc) = search p s t `mappend` searchBindBag p s b + `mappend` search p s sg + `mappend` search p s dc + +instance (Search id id) => Search id (DerivDecl id) where + search p s (DerivDecl t) = search p s t + +instance (Search id id) => Search id (Sig id) where + search p s (TypeSig n t) = search p s n `mappend` search p s t + search p s (IdSig i) = search p s i + search p s (FixSig n) = search p s n + search p s (InlineSig n _) = search p s n + search p s (SpecSig n t _) = search p s n `mappend` search p s t + search p s (SpecInstSig t) = search p s t + +instance (Search id id) => Search id (FixitySig id) where + search p s (FixitySig n _) = search p s n + +instance (Search id id) => Search id (DefaultDecl id) where + search p s (DefaultDecl n) = search p s n + +instance (Search id id) => Search id (ForeignDecl id) where + search p s (ForeignImport n t _) = search p s n `mappend` search p s t + search p s (ForeignExport n t _) = search p s n `mappend` search p s t + +instance (Search id id) => Search id (WarnDecl id) where + search p s (Warning n _) = search p s n + +instance (Search id id) => Search id (AnnDecl id) where + search p s (HsAnnotation pr n) = search p s pr `mappend` search p s n + +instance (Search id id) => Search id (AnnProvenance id) where + search p s (ValueAnnProvenance n) = search p s n + search p s (TypeAnnProvenance n) = search p s n + search _ _ (ModuleAnnProvenance) = mempty + +instance (Search id id) => Search id (RuleDecl id) where + search p s (HsRule _ _ bn e1 _ e2 _) = search p s bn `mappend` search p s e1 + `mappend` search p s e2 + +instance (Search id id) => Search id (RuleBndr id) where + search p s (RuleBndr n) = search p s n + search p s (RuleBndrSig n t) = search p s n `mappend` search p s t + +instance (Search id id) => Search id (SpliceDecl id) where + search p s (SpliceDecl n _) = search p s n + +instance (Search id id) => Search id DocDecl where + search _ _ _ = mempty + +instance (Search id id) => Search id (HsQuasiQuote id) where + search _ _ _ = mempty + +instance (Search id id) => Search id (ConDecl id) where + search p s (ConDecl n _ qv ct dt res _ _) = search p s n `mappend` search p s qv + `mappend` search p s ct + `mappend` search p s dt + `mappend` search p s res + +instance (Search id id) => Search id (ConDeclField id) where + search p s (ConDeclField n t _) = search p s n `mappend` search p s t + +instance (Search id id) => Search id (HsPred id) where + search p s (HsClassP n t) = search p s n `mappend` search p s t + search p s (HsEqualP n1 n2) = search p s n1 `mappend` search p s n2 + search p s (HsIParam i n) = search p s i `mappend` search p s n + +instance (Search id id) => Search id (HsTyVarBndr id) where + search p s (UserTyVar n _) = search p s n + search p s (KindedTyVar n _) = search p s n + +instance (Search id id) => Search id (ResType id) where + search _ _ (ResTyH98) = mempty + search p s (ResTyGADT n) = search p s n +#endif diff --git a/src/Language/Haskell/BuildWrapper/GHC.hs b/src/Language/Haskell/BuildWrapper/GHC.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/BuildWrapper/GHC.hs @@ -0,0 +1,1056 @@ +{-# LANGUAGE CPP, OverloadedStrings, TypeSynonymInstances,StandaloneDeriving,DeriveDataTypeable,ScopedTypeVariables, MultiParamTypeClasses, PatternGuards #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +-- | +-- Module : Language.Haskell.BuildWrapper.GHC +-- Author : JP Moresmau +-- Copyright : (c) JP Moresmau 2011 +-- License : BSD3 +-- +-- Maintainer : jpmoresmau@gmail.com +-- Stability : beta +-- Portability : portable +-- +-- Load relevant module in the GHC AST and get GHC messages and thing at point info. +module Language.Haskell.BuildWrapper.GHC where +import Language.Haskell.BuildWrapper.Base hiding (Target) +import Language.Haskell.BuildWrapper.Find + + +-- import Text.JSON +-- import Data.DeriveTH +-- import Data.Derive.JSON +import Data.Char +import Data.Generics hiding (Fixity, typeOf) +import Data.Maybe +import Data.Monoid + +import Data.IORef +import qualified Data.List as List +import Data.Ord (comparing) +import qualified Data.Text as T + +import DynFlags +import ErrUtils ( ErrMsg(..), WarnMsg, mkPlainErrMsg,Messages,ErrorMessages,WarningMessages, Message ) +import GHC +import SrcLoc +import GHC.Paths ( libdir ) +import HscTypes ( srcErrorMessages, SourceError) +import Outputable +import FastString (FastString,unpackFS,concatFS,fsLit,mkFastString) +import Lexer +import PprTyThing ( pprTypeForUser ) +import Bag + +#if __GLASGOW_HASKELL__ >= 610 +import StringBuffer +#endif + +import System.FilePath +--import System.Time + +import qualified MonadUtils as GMU + +getAST :: FilePath -> FilePath -> String -> [String] -> IO (OpResult (Maybe TypecheckedSource)) +getAST =withASTNotes (\t -> do + return $ tm_typechecked_source t + ) + +withAST :: (TypecheckedModule -> Ghc a) -> FilePath -> FilePath -> String -> [String] -> IO (Maybe a) +withAST f fp base_dir mod options= do + (a,_)<-withASTNotes f fp base_dir mod options + return a + + +withASTNotes :: (TypecheckedModule -> Ghc a) -> FilePath -> FilePath -> String -> [String] -> IO (OpResult (Maybe a)) +withASTNotes f fp base_dir mod options=do + let lflags=map noLoc options + (_leftovers, _) <- parseStaticFlags lflags + runGhc (Just libdir) $ do + flg <- getSessionDynFlags + (flg', _, _) <- parseDynamicFlags flg _leftovers + ref <- GMU.liftIO $ newIORef [] + setSessionDynFlags flg' { hscTarget = HscNothing, ghcLink = NoLink , ghcMode = OneShot, log_action = logAction ref } + -- $ dopt_set (flg' { ghcLink = NoLink , ghcMode = CompManager }) Opt_ForceRecomp + addTarget Target { targetId = TargetFile fp Nothing, targetAllowObjCode = True, targetContents = Nothing } + --c1<-GMU.liftIO getClockTime + let modName=mkModuleName mod + -- loadWithLogger (logWarnErr ref) + res<- load (LoadUpTo modName) -- LoadAllTargets + `gcatch` (\(e :: SourceError) -> handle_error ref e) + --(warns, errs) <- GMU.liftIO $ readIORef ref + --let notes = ghcMessagesToNotes base_dir (warns, errs) + notes <- GMU.liftIO $ readIORef ref + --c2<-GMU.liftIO getClockTime + --GMU.liftIO $ putStrLn ("load all targets: " ++ (timeDiffToString $ diffClockTimes c2 c1)) + case res of + Succeeded -> do + modSum <- getModSummary $ modName + p <- parseModule modSum + --return $ showSDocDump $ ppr $ pm_mod_summary p + t <- typecheckModule p + d <- desugarModule t -- to get warnings + l <- loadModule d + --c3<-GMU.liftIO getClockTime + setContext [ms_mod modSum] [] + --GMU.liftIO $ putStrLn ("parse, typecheck load: " ++ (timeDiffToString $ diffClockTimes c3 c2)) + a<-f (dm_typechecked_module l) +#if __GLASGOW_HASKELL__ < 702 + warns <- getWarnings + return $ (Just a,notes++ (reverse $ ghcMessagesToNotes base_dir (warns, emptyBag))) +#else + notes2 <- GMU.liftIO $ readIORef ref + return $ (Just a,notes2) +#endif + Failed -> return $ (Nothing,notes) + where +-- logWarnErr :: GhcMonad m => IORef [BWNote] -> Maybe SourceError -> m () +-- logWarnErr ref err = do +-- let errs = case err of +-- Nothing -> mempty +-- Just exc -> srcErrorMessages exc +-- warns <- getWarnings +-- clearWarnings +-- add_warn_err ref warns errs + + add_warn_err :: GhcMonad m => IORef [BWNote] -> WarningMessages -> ErrorMessages -> m() + add_warn_err ref warns errs = do + let notes = ghcMessagesToNotes base_dir (warns, errs) + GMU.liftIO $ modifyIORef ref $ + \ns -> ( ns ++ notes) + + handle_error :: GhcMonad m => IORef [BWNote] -> SourceError -> m SuccessFlag + handle_error ref e = do + let errs = srcErrorMessages e + add_warn_err ref emptyBag errs +-- warns <- getWarnings +-- add_warn_err ref warns errs +-- clearWarnings + return Failed + + logAction :: IORef [BWNote] -> Severity -> SrcSpan -> PprStyle -> Message -> IO () + logAction ref s loc ppr msg + | (Just status)<-bwSeverity s=do + let n=BWNote { bwn_location = ghcSpanToBWLocation base_dir loc + , bwn_status = status + , bwn_title = removeStatus status $ showSDocForUser (qualName ppr,qualModule ppr) msg + } + modifyIORef ref $ \ns -> ( ns ++ [n]) + | otherwise=do + return () + + bwSeverity :: Severity -> Maybe BWNoteStatus + bwSeverity SevWarning = Just BWWarning + bwSeverity SevError = Just BWError + bwSeverity SevFatal = Just BWError + bwSeverity _ = Nothing + + --f $ tm_typechecked_source t + --return $ showSDocDump $ ppr $ pm_parsed_source p + --return $ showSDocDump $ ppr $ tm_typechecked_source t + --return $ makeObj [("parse" , (showJSON $ tm_typechecked_source t))] + --return r + +-- | Convert 'GHC.Messages' to '[BWNote]'. +-- +-- This will mix warnings and errors, but you can split them back up +-- by filtering the '[BWNote]' based on the 'bw_status'. +ghcMessagesToNotes :: FilePath -> Messages -> [BWNote] +ghcMessagesToNotes base_dir (warns, errs) = + (map_bag2ms (ghcWarnMsgToNote base_dir) warns) ++ + (map_bag2ms (ghcErrMsgToNote base_dir) errs) + where + map_bag2ms f = map f . Bag.bagToList + + +getGhcNamesInScope :: FilePath -> FilePath -> String -> [String] -> IO [String] +getGhcNamesInScope f base_dir mod options=do + names<-withAST (\_->do + --c1<-GMU.liftIO getClockTime + names<-getNamesInScope + --c2<-GMU.liftIO getClockTime + --GMU.liftIO $ putStrLn ("getNamesInScope: " ++ (timeDiffToString $ diffClockTimes c2 c1)) + return $ map (showSDocDump . ppr ) names) f base_dir mod options + return $ fromMaybe[] names + +getThingAtPoint :: Int -> Int -> Bool -> Bool -> FilePath -> FilePath -> String -> [String] -> IO String +getThingAtPoint line col qual typed fp base_dir mod options= do + t<-withAST (\tcm->do + let loc = srcLocSpan $ mkSrcLoc (fsLit fp) line (scionColToGhcCol col) + uq<-unqualifiedForModule tcm + let f=(if typed then (doThingAtPointTyped $ typecheckedSource tcm) else (doThingAtPointUntyped $ renamedSource tcm)) + --tap<- doThingAtPoint loc qual typed tcm (if typed then (typecheckedSource tcm) else (renamedSource tcm)) + let tap=f loc qual tcm uq + --(if typed then (doThingAtPointTyped $ typecheckedSource tcm) + -- else doThingAtPointTyped (renamedSource tcm) loc qual tcm + return tap) fp base_dir mod options + return $ fromMaybe "" t + where + doThingAtPointTyped :: TypecheckedSource -> SrcSpan -> Bool -> TypecheckedModule -> PrintUnqualified -> String + doThingAtPointTyped src loc qual tcm uq=let + in_range = overlaps loc + r = searchBindBag in_range noSrcSpan src + unqual = if qual + then alwaysQualify + else uq + --liftIO $ putStrLn $ showData TypeChecker 2 src + in case pathToDeepest r of + Nothing -> "no info" + Just (x,xs) -> + case typeOf (x,xs) of + Just t -> + showSDocForUser unqual + (prettyResult x <+> dcolon <+> + pprTypeForUser True t) + _ -> showSDocForUser unqual (prettyResult x) --(Just (showSDocDebug (ppr x $$ ppr xs ))) + doThingAtPointUntyped :: (Search id a, OutputableBndr id) => a -> SrcSpan -> Bool -> TypecheckedModule -> PrintUnqualified -> String + doThingAtPointUntyped src loc qual tcm uq=let + in_range = overlaps loc + r = findHsThing in_range src + unqual = if qual + then neverQualify + else uq + in case pathToDeepest r of + Nothing -> "no info" + Just (x,_) -> + if qual + then showSDocForUser unqual ((qualifiedResult x) <+> (text $ haddockType x)) + else showSDocForUser unqual ((prettyResult x) <+> (text $ haddockType x)) + +unqualifiedForModule :: TypecheckedMod m => m -> Ghc PrintUnqualified +unqualifiedForModule tcm =fromMaybe alwaysQualify `fmap` mkPrintUnqualifiedForModule (moduleInfo tcm) + +--data S a=S String +-- +--instance Show (S a) where +-- show (S s)=s +-- +--data TestLoc=TestLoc Int Int +-- deriving (Show,Data,Typeable) +--data Test=Test [TestLoc] +-- deriving (Show,Data,Typeable) +-- +--test1=Test [TestLoc 3 4,TestLoc 2 14,TestLoc 3 16] +-- +--getThingAtPoint :: TypecheckedSource -> Int -> Int -> [String] +--getThingAtPoint ts line col= everything (++) ([] `mkQ` (\x -> p x )) test1 +-- -- synthesize [] toS (mkQ Nothing toS) test1 +-- where +-- p :: TestLoc -> [String] +-- p t@(TestLoc a b)= if a==line || b==col +-- then [show t] +-- else [] +-- + +--getThingAtPoint :: TypecheckedSource -> Int -> Int -> [String] +--getThingAtPoint ts line col= maybeToList $ something (mkQ Nothing toS) test1 +-- where +-- toS :: TestLoc -> Maybe String +-- toS t@(TestLoc a b)=if a==line || b==col +-- then Just $ show t +-- else Nothing + + +--getThingAtPoint :: TypecheckedSource -> Int -> Int -> [String] +--getThingAtPoint ts line col=map show ((listify (mkQ False (isJust . toS)) test1)::[TestLoc]) +-- -- maybeToList $ something (mkQ Nothing toS) test1 +-- where +-- toS :: TestLoc -> Maybe String +-- toS t@(TestLoc a b)=if a==line || b==col +-- then Just $ show t +-- else Nothing + +--newtype C a = C a deriving (Data,Typeable) +-- +----getThingAtPoint :: TypecheckedSource -> Int -> Int -> [String] +-- +--coerce :: a -> C a +--coerce = unsafeCoerce +--uncoerce :: C a -> a +--uncoerce = unsafeCoerce +-- +--fmapData :: forall t a b. (Typeable a, Data (t (C a)), Data (t a)) => +-- (a -> b) -> t a -> t b +--fmapData f input = uc . everything (++) ([] `mkQ` (\(x::C a) -> [coerce (f (uncoerce x))])) +-- $ (coerce input) +-- where uc = unsafeCoerce +-- +--getThingAtPoint :: TypecheckedSource -> Int -> Int -> [String] +--getThingAtPoint ts line col= --map unLoc $ filter (\(L _ o)->not $ null o) $ fmapData overlap (bagToList ts) +-- map unLoc $ filter (\(L _ o)->not $ null o) $ everything (++) ([] `mkQ` overlap) (bagToList ts) +-- where +-- --overlap :: forall b1 . (Outputable b1, Typeable b1) =>Located b1 -> Located String +-- overlap :: Located (HsBindLR Id Id) -> [Located String] +-- overlap (L loc o)= let +-- st=srcSpanStart loc +-- en=srcSpanEnd loc +-- in if (isGoodSrcLoc st) && (isGoodSrcLoc en) && ((srcLocLine st) <= line) && ((srcLocCol st) <=col) && ((srcLocLine en) >= line) && ((srcLocCol en) >=col) +-- then [L loc $ showSDocDump $ ppr o] +-- else [] +-- +-- [showData TypeChecker 4 ts] + + +--getThingAtPoint :: TypecheckedSource -> Int -> Int -> [String] +--getThingAtPoint ts line col= map pr lf +-- --maybeToList $ something (mkQ Nothing toS) ts -- listify (mkQ False overlap) ts +-- where +-- lf :: forall b1 . (Outputable b1, Typeable b1) => [Located b1] +-- lf=listify (mkQ False overlap) ts +-- --find :: (Outputable a,Typeable a) => TypecheckedSource -> [Located a] +-- --find = listify $ overlap +-- toS :: forall b1 . (Outputable b1, Typeable b1) =>Located b1 -> Maybe String +-- toS l= if overlap l +-- then Just $ pr l +-- else Nothing +-- pr :: forall b1 . (Outputable b1) => Located b1 -> String +-- pr=showSDocDump . ppr . unLoc +-- --showData TypeChecker 4 +-- overlap :: forall b1 . (Outputable b1, Typeable b1) =>Located b1 -> Bool +-- overlap (a::Located b1)= let +-- (L loc _)=a +-- st=srcSpanStart loc +-- en=srcSpanEnd loc +-- in (isGoodSrcLoc st) && (isGoodSrcLoc en) && ((srcLocLine st) <= line) && ((srcLocCol st) <=col) && ((srcLocLine en) >= line) && ((srcLocCol en) >=col) +-- -- overlap _ =False +-- +-- + +ghcSpanToLocation :: FilePath -- ^ Base directory + -> GHC.SrcSpan + -> InFileSpan +ghcSpanToLocation baseDir sp + | GHC.isGoodSrcSpan sp =let + (stl,stc)=start sp + (enl,enc)=end sp + in mkFileSpan + stl + (ghcColToScionCol stc) + (enl) + (ghcColToScionCol enc) + | otherwise = mkFileSpan 0 0 0 0 + + + +ghcSpanToBWLocation :: FilePath -- ^ Base directory + -> GHC.SrcSpan + -> BWLocation +ghcSpanToBWLocation baseDir sp + | GHC.isGoodSrcSpan sp = + let (stl,stc)=start sp + in BWLocation (makeRelative baseDir $ foldr f [] $ normalise $ unpackFS (sfile sp)) + stl + (ghcColToScionCol $stc) + | otherwise = BWLocation "" 1 1 + where + f c (x:xs) + | c=='\\' && x=='\\'=x:xs -- WHY do we get two slashed after the drive sometimes? + | otherwise=c:x:xs + f c s=c:s +#if __GLASGOW_HASKELL__ < 702 + sfile ss= GHC.srcSpanFile ss +#else + sfile (RealSrcSpan ss)= GHC.srcSpanFile ss +#endif + +ghcColToScionCol :: Int -> Int +#if __GLASGOW_HASKELL__ < 700 +ghcColToScionCol c=c+1 -- GHC 6.x starts at 0 for columns +#else +ghcColToScionCol c=c -- GHC 7 starts at 1 for columns +#endif + +scionColToGhcCol :: Int -> Int +#if __GLASGOW_HASKELL__ < 700 +scionColToGhcCol c=c-1 -- GHC 6.x starts at 0 for columns +#else +scionColToGhcCol c=c -- GHC 7 starts at 1 for columns +#endif + +-- | Get a stream of tokens generated by the GHC lexer from the current document +ghctokensArbitrary :: FilePath -- ^ The file path to the document + -> String -- ^ The document's contents + -> [String] -- ^ The options + -> IO (Either BWNote [Located Token]) +ghctokensArbitrary base_dir contents options= do +#if __GLASGOW_HASKELL__ < 702 + sb <- stringToStringBuffer contents +#else + let sb=stringToStringBuffer contents +#endif + let lflags=map noLoc options + (_leftovers, _) <- parseStaticFlags lflags + runGhc (Just libdir) $ do + flg <- getSessionDynFlags + (flg', _, _) <- parseDynamicFlags flg _leftovers + +#if __GLASGOW_HASKELL__ >= 700 + let dflags1 = List.foldl' xopt_set flg' lexerFlags +#else + let dflags1 = List.foldl' dopt_set flg' lexerFlags +#endif + let prTS = lexTokenStream sb lexLoc dflags1 + case prTS of + POk _ toks -> return $ Right $ (filter ofInterest toks) + PFailed loc msg -> return $ Left $ ghcErrMsgToNote base_dir $ mkPlainErrMsg loc msg + +#if __GLASGOW_HASKELL__ < 702 +lexLoc :: SrcLoc +lexLoc = mkSrcLoc (mkFastString "") 1 (scionColToGhcCol 1) +#else +lexLoc :: RealSrcLoc +lexLoc = mkRealSrcLoc (mkFastString "") 1 (scionColToGhcCol 1) +#endif + + +#if __GLASGOW_HASKELL__ >= 700 +lexerFlags :: [ExtensionFlag] +#else +lexerFlags :: [DynFlag] +#endif +lexerFlags = + [ Opt_ForeignFunctionInterface + , Opt_Arrows +#if __GLASGOW_HASKELL__ < 702 + , Opt_PArr +#else + , Opt_ParallelArrays +#endif + , Opt_TemplateHaskell + , Opt_QuasiQuotes + , Opt_ImplicitParams + , Opt_BangPatterns + , Opt_TypeFamilies +#if __GLASGOW_HASKELL__ < 700 + , Opt_Haddock +#endif + , Opt_MagicHash + , Opt_KindSignatures + , Opt_RecursiveDo + , Opt_UnicodeSyntax + , Opt_UnboxedTuples + , Opt_StandaloneDeriving + , Opt_TransformListComp +#if __GLASGOW_HASKELL__ < 702 + , Opt_NewQualifiedOperators +#endif +#if GHC_VERSION > 611 + , Opt_ExplicitForAll -- 6.12 + , Opt_DoRec -- 6.12 +#endif + ] + +-- | Filter tokens whose span appears legitimate (start line is less than end line, start column is +-- less than end column.) +ofInterest :: Located Token -> Bool +ofInterest (L span _) = + let (sl,sc) = start span + (el,ec) = end span + in (sl < el) || (sc < ec) + +--toInteractive :: Location -> Location +--toInteractive l = +-- let (_, sl1, sc1, el1, ec1) = viewLoc l +-- in mkLocation interactive sl1 sc1 el1 ec1 + +-- | Convert a GHC token to an interactive token (abbreviated token type) +tokenToType :: FilePath -> Located Token -> TokenDef +tokenToType base_dir (L sp t) = TokenDef (tokenType t) (ghcSpanToLocation base_dir sp) + +-- | Generate the interactive token list used by EclipseFP for syntax highlighting +tokenTypesArbitrary :: FilePath -> String -> Bool -> [String] -> IO (Either BWNote [TokenDef]) +tokenTypesArbitrary projectRoot contents literate options = generateTokens projectRoot contents literate options convertTokens id + where + convertTokens = map (tokenToType projectRoot) + +-- | Extract occurrences based on lexing +occurrences :: FilePath -- ^ Project root or base directory for absolute path conversion + -> String -- ^ Contents to be parsed + -> T.Text -- ^ Token value to find + -> Bool -- ^ Literate source flag (True = literate, False = ordinary) + -> [String] -- ^ Options + -> IO (Either BWNote [TokenDef]) +occurrences projectRoot contents query literate options = + let + qualif = isJust $ T.find (=='.') query + -- Get the list of tokens matching the query for relevant token types + tokensMatching :: [TokenDef] -> [TokenDef] + tokensMatching = filter matchingVal + matchingVal :: TokenDef -> Bool + matchingVal (TokenDef v _)=query==v + mkTokenDef (L sp t)=TokenDef (tokenValue qualif t) (ghcSpanToLocation projectRoot sp) + in generateTokens projectRoot contents literate options (map mkTokenDef) tokensMatching + +-- | Parse the current document, generating a TokenDef list, filtered by a function +generateTokens :: FilePath -- ^ The project's root directory + -> String -- ^ The current document contents, to be parsed + -> Bool -- ^ Literate Haskell flag + -> [String] -- ^ The options + -> ([Located Token] -> [TokenDef]) -- ^ Transform function from GHC tokens to TokenDefs + -> ([TokenDef] -> a) -- ^ The TokenDef filter function + -> IO (Either BWNote a) +generateTokens projectRoot contents literate options xform filterFunc = + let (ppTs, ppC) = preprocessSource contents literate + in ghctokensArbitrary projectRoot ppC options + >>= (\result -> + case result of + Right toks -> + let filterResult = filterFunc $ List.sortBy (comparing td_loc) (ppTs ++ (xform toks)) + --liftIO $ putStrLn $ show tokenList + in return $ Right filterResult + Left n -> return $ Left n + ) + +-- | Preprocess some source, returning the literate and Haskell source as tuple. +--preprocessSource :: String -> Bool -> ([TokenDef],String) +--preprocessSource contents literate= +-- let +-- (ts1,s2)=if literate then ppSF contents ppSLit else ([],contents) +-- (ts2,s3)=ppSF s2 ppSCpp +-- in (ts1++ts2,s3) +-- where +-- ppSF contents2 p= let +-- linesWithCount=zip (lines contents2) [1..] +-- (ts,nc,_)= List.foldl' p (Seq.empty,Seq.empty,False) linesWithCount +-- in (F.toList ts, F.concatMap (++ "\n") nc) +-- ppSCpp :: (Seq.Seq TokenDef,Seq.Seq String,Bool) -> (String,Int) -> (Seq.Seq TokenDef,Seq.Seq String,Bool) +-- ppSCpp (ts2,l2,f) (l,c) +-- | f = addPPToken "PP" (l,c) (ts2,l2,'\\' == (last l)) +-- | ('#':_)<-l =addPPToken "PP" (l,c) (ts2,l2,'\\' == (last l)) +-- | ("{-# " `List.isPrefixOf` l)=addPPToken "D" (l,c) (ts2,l2,False) +-- | otherwise =(ts2,l2 Seq.|> l,False) +-- ppSLit :: (Seq.Seq TokenDef,Seq.Seq String,Bool) -> (String,Int) -> (Seq.Seq TokenDef,Seq.Seq String,Bool) +-- ppSLit (ts2,l2,f) (l,c) +-- | "\\begin{code}" `List.isPrefixOf` l=addPPToken "DL" ("\\begin{code}",c) (ts2,l2,True) +-- | "\\end{code}" `List.isPrefixOf` l=addPPToken "DL" ("\\end{code}",c) (ts2,l2,False) +-- | f = (ts2,l2 Seq.|> l,True) +-- | ('>':lCode)<-l=(ts2,l2 Seq.|> (' ':lCode ),f) +-- | otherwise =addPPToken "DL" (l,c) (ts2,l2,f) +-- addPPToken :: T.Text -> (String,Int) -> (Seq.Seq TokenDef,Seq.Seq String,Bool) -> (Seq.Seq TokenDef,Seq.Seq String,Bool) +-- addPPToken name (l,c) (ts2,l2,f) =(ts2 Seq.|> (TokenDef name (mkFileSpan c 1 c ((length l)+1))),l2 Seq.|> "",f) + +preprocessSource :: String -> Bool -> ([TokenDef],String) +preprocessSource contents literate= + let + (ts1,s2)=if literate then ppSF contents ppSLit else ([],contents) + (ts2,s3)=ppSF s2 ppSCpp + in (ts1++ts2,s3) + where + ppSF contents2 p= let + linesWithCount=zip (lines contents2) [1..] + (ts,nc,_)= List.foldl' p ([],[],False) linesWithCount + in (reverse ts, unlines $ reverse nc) + ppSCpp :: ([TokenDef],[String],Bool) -> (String,Int) -> ([TokenDef],[String],Bool) + ppSCpp (ts2,l2,f) (l,c) + | f = addPPToken "PP" (l,c) (ts2,l2,'\\' == (last l)) + | ('#':_)<-l =addPPToken "PP" (l,c) (ts2,l2,'\\' == (last l)) + | ("{-# " `List.isPrefixOf` l)=addPPToken "D" (l,c) (ts2,l2,False) + | otherwise =(ts2,l:l2,False) + ppSLit :: ([TokenDef],[String],Bool) -> (String,Int) -> ([TokenDef],[String],Bool) + ppSLit (ts2,l2,f) (l,c) + | "\\begin{code}" `List.isPrefixOf` l=addPPToken "DL" ("\\begin{code}",c) (ts2,l2,True) + | "\\end{code}" `List.isPrefixOf` l=addPPToken "DL" ("\\end{code}",c) (ts2,l2,False) + | f = (ts2,l:l2,True) + | ('>':lCode)<-l=(ts2, (' ':lCode ):l2,f) + | otherwise =addPPToken "DL" (l,c) (ts2,l2,f) + addPPToken :: T.Text -> (String,Int) -> ([TokenDef],[String],Bool) -> ([TokenDef],[String],Bool) + addPPToken name (l,c) (ts2,l2,f) =((TokenDef name (mkFileSpan c 1 c ((length l)+1))):ts2 ,"":l2,f) + + +ghcErrMsgToNote :: FilePath -> ErrMsg -> BWNote +ghcErrMsgToNote = ghcMsgToNote BWError + +ghcWarnMsgToNote :: FilePath -> WarnMsg -> BWNote +ghcWarnMsgToNote = ghcMsgToNote BWWarning + +-- Note that we don *not* include the extra info, since that information is +-- only useful in the case where we don not show the error location directly +-- in the source. +ghcMsgToNote :: BWNoteStatus -> FilePath -> ErrMsg -> BWNote +ghcMsgToNote note_kind base_dir msg = + BWNote { bwn_location = ghcSpanToBWLocation base_dir loc + , bwn_status = note_kind + , bwn_title = removeStatus note_kind $ show_msg (errMsgShortDoc msg) + } + where + loc | (s:_) <- errMsgSpans msg = s + | otherwise = GHC.noSrcSpan + unqual = errMsgContext msg + show_msg = showSDocForUser unqual + +removeStatus :: BWNoteStatus -> String -> String +removeStatus BWWarning s + | List.isPrefixOf "Warning:" s = List.dropWhile isSpace $ drop 8 s + | otherwise = s +removeStatus BWError s + | List.isPrefixOf "Error:" s = List.dropWhile isSpace $ drop 6 s + | otherwise = s + +#if CABAL_VERSION == 106 +deriving instance Typeable StringBuffer +deriving instance Data StringBuffer +#endif + +mkUnqualTokenValue :: FastString + -> T.Text +mkUnqualTokenValue = T.pack . unpackFS + + +mkQualifiedTokenValue :: FastString + -> FastString + -> T.Text +mkQualifiedTokenValue q a = (T.pack . unpackFS . concatFS) [q, dotFS, a] + +-- | Make a token definition from its source location and Lexer.hs token type. +mkTokenDef :: FilePath -> Located Token -> TokenDef +mkTokenDef base_dir (L sp t) = TokenDef (mkTokenName t) (ghcSpanToLocation base_dir sp) + +mkTokenName :: Token -> T.Text +mkTokenName = T.pack . showConstr . toConstr + +deriving instance Typeable Token +deriving instance Data Token + +#if CABAL_VERSION == 106 +deriving instance Typeable StringBuffer +deriving instance Data StringBuffer +#endif + + +tokenType :: Token -> T.Text +tokenType ITas = "K" -- Haskell keywords +tokenType ITcase = "K" +tokenType ITclass = "K" +tokenType ITdata = "K" +tokenType ITdefault = "K" +tokenType ITderiving = "K" +tokenType ITdo = "K" +tokenType ITelse = "K" +tokenType IThiding = "K" +tokenType ITif = "K" +tokenType ITimport = "K" +tokenType ITin = "K" +tokenType ITinfix = "K" +tokenType ITinfixl = "K" +tokenType ITinfixr = "K" +tokenType ITinstance = "K" +tokenType ITlet = "K" +tokenType ITmodule = "K" +tokenType ITnewtype = "K" +tokenType ITof = "K" +tokenType ITqualified = "K" +tokenType ITthen = "K" +tokenType ITtype = "K" +tokenType ITwhere = "K" +tokenType ITscc = "K" -- ToDo: remove (we use {-# SCC "..." #-} now) + +tokenType ITforall = "EK" -- GHC extension keywords +tokenType ITforeign = "EK" +tokenType ITexport= "EK" +tokenType ITlabel= "EK" +tokenType ITdynamic= "EK" +tokenType ITsafe= "EK" +#if __GLASGOW_HASKELL__ < 702 +tokenType ITthreadsafe= "EK" +#endif +tokenType ITunsafe= "EK" +tokenType ITstdcallconv= "EK" +tokenType ITccallconv= "EK" +#if __GLASGOW_HASKELL__ >= 612 +tokenType ITprimcallconv= "EK" +#endif +tokenType ITmdo= "EK" +tokenType ITfamily= "EK" +tokenType ITgroup= "EK" +tokenType ITby= "EK" +tokenType ITusing= "EK" + + -- Pragmas +tokenType (ITinline_prag {})="P" -- True <=> INLINE, False <=> NOINLINE +#if __GLASGOW_HASKELL__ >= 612 && __GLASGOW_HASKELL__ < 700 +tokenType (ITinline_conlike_prag {})="P" -- same +#endif +tokenType ITspec_prag="P" -- SPECIALISE +tokenType (ITspec_inline_prag {})="P" -- SPECIALISE INLINE (or NOINLINE) +tokenType ITsource_prag="P" +tokenType ITrules_prag="P" +tokenType ITwarning_prag="P" +tokenType ITdeprecated_prag="P" +tokenType ITline_prag="P" +tokenType ITscc_prag="P" +tokenType ITgenerated_prag="P" +tokenType ITcore_prag="P" -- hdaume: core annotations +tokenType ITunpack_prag="P" +#if __GLASGOW_HASKELL__ >= 612 +tokenType ITann_prag="P" +#endif +tokenType ITclose_prag="P" +tokenType (IToptions_prag {})="P" +tokenType (ITinclude_prag {})="P" +tokenType ITlanguage_prag="P" + +tokenType ITdotdot="S" -- reserved symbols +tokenType ITcolon="S" +tokenType ITdcolon="S" +tokenType ITequal="S" +tokenType ITlam="S" +tokenType ITvbar="S" +tokenType ITlarrow="S" +tokenType ITrarrow="S" +tokenType ITat="S" +tokenType ITtilde="S" +tokenType ITdarrow="S" +tokenType ITminus="S" +tokenType ITbang="S" +tokenType ITstar="S" +tokenType ITdot="S" + +tokenType ITbiglam="ES" -- GHC-extension symbols + +tokenType ITocurly="SS" -- special symbols +tokenType ITccurly="SS" +tokenType ITocurlybar="SS" -- "{|", for type applications +tokenType ITccurlybar="SS" -- "|}", for type applications +tokenType ITvocurly="SS" +tokenType ITvccurly="SS" +tokenType ITobrack="SS" +tokenType ITopabrack="SS" -- [:, for parallel arrays with -XParr +tokenType ITcpabrack="SS" -- :], for parallel arrays with -XParr +tokenType ITcbrack="SS" +tokenType IToparen="SS" +tokenType ITcparen="SS" +tokenType IToubxparen="SS" +tokenType ITcubxparen="SS" +tokenType ITsemi="SS" +tokenType ITcomma="SS" +tokenType ITunderscore="SS" +tokenType ITbackquote="SS" + +tokenType (ITvarid {})="IV" -- identifiers +tokenType (ITconid {})="IC" +tokenType (ITvarsym {})="IV" +tokenType (ITconsym {})="IC" +tokenType (ITqvarid {})="IV" +tokenType (ITqconid {})="IC" +tokenType (ITqvarsym {})="IV" +tokenType (ITqconsym {})="IC" +tokenType (ITprefixqvarsym {})="IV" +tokenType (ITprefixqconsym {})="IC" + +tokenType (ITdupipvarid {})="EI" -- GHC extension: implicit param: ?x + +tokenType (ITchar {})="LC" +tokenType (ITstring {})="LS" +tokenType (ITinteger {})="LI" +tokenType (ITrational {})="LR" + +tokenType (ITprimchar {})="LC" +tokenType (ITprimstring {})="LS" +tokenType (ITprimint {})="LI" +tokenType (ITprimword {})="LW" +tokenType (ITprimfloat {})="LF" +tokenType (ITprimdouble {})="LD" + + -- Template Haskell extension tokens +tokenType ITopenExpQuote="TH" -- [| or [e| +tokenType ITopenPatQuote="TH" -- [p| +tokenType ITopenDecQuote="TH" -- [d| +tokenType ITopenTypQuote="TH" -- [t| +tokenType ITcloseQuote="TH" --tokenType ] +tokenType (ITidEscape {})="TH" -- $x +tokenType ITparenEscape="TH" -- $( +tokenType ITvarQuote="TH" -- ' +tokenType ITtyQuote="TH" -- '' +tokenType (ITquasiQuote {})="TH" -- [:...|...|] + + -- Arrow notation extension +tokenType ITproc="A" +tokenType ITrec="A" +tokenType IToparenbar="A" -- (| +tokenType ITcparenbar="A" --tokenType ) +tokenType ITlarrowtail="A" -- -< +tokenType ITrarrowtail="A" -- >- +tokenType ITLarrowtail="A" -- -<< +tokenType ITRarrowtail="A" -- >>- + +#if __GLASGOW_HASKELL__ <= 611 +tokenType ITdotnet="SS" -- ?? +tokenType (ITpragma _) = "SS" -- ?? +#endif + +tokenType (ITunknown {})="" -- Used when the lexer can't make sense of it +tokenType ITeof="" -- end of file token + + -- Documentation annotations +tokenType (ITdocCommentNext {})="D" -- something beginning '-- |' +tokenType (ITdocCommentPrev {})="D" -- something beginning '-- ^' +tokenType (ITdocCommentNamed {})="D" -- something beginning '-- $' +tokenType (ITdocSection {})="D" -- a section heading +tokenType (ITdocOptions {})="D" -- doc options (prune, ignore-exports, etc) +tokenType (ITdocOptionsOld {})="D" -- doc options declared "-- # ..."-style +tokenType (ITlineComment {})="D" -- comment starting by "--" +tokenType (ITblockComment {})="D" -- comment in {- -} + + -- 7.2 new token types +#if __GLASGOW_HASKELL__ >= 702 +tokenType (ITinterruptible {})="EK" +tokenType (ITvect_prag {})="P" +tokenType (ITvect_scalar_prag {})="P" +tokenType (ITnovect_prag {})="P" +#endif + +dotFS :: FastString +dotFS = fsLit "." + +tokenValue :: Bool -> Token -> T.Text +tokenValue _ t | elem (tokenType t) ["K","EK"] = T.drop 2 $ mkTokenName t +tokenValue _ (ITvarid a) = mkUnqualTokenValue a +tokenValue _ (ITconid a) = mkUnqualTokenValue a +tokenValue _ (ITvarsym a) = mkUnqualTokenValue a +tokenValue _ (ITconsym a) = mkUnqualTokenValue a +tokenValue False (ITqvarid (_,a)) = mkUnqualTokenValue a +tokenValue True (ITqvarid (q,a)) = mkQualifiedTokenValue q a +tokenValue False(ITqconid (_,a)) = mkUnqualTokenValue a +tokenValue True (ITqconid (q,a)) = mkQualifiedTokenValue q a +tokenValue False (ITqvarsym (_,a)) = mkUnqualTokenValue a +tokenValue True (ITqvarsym (q,a)) = mkQualifiedTokenValue q a +tokenValue False (ITqconsym (_,a)) = mkUnqualTokenValue a +tokenValue True (ITqconsym (q,a)) = mkQualifiedTokenValue q a +tokenValue False (ITprefixqvarsym (_,a)) = mkUnqualTokenValue a +tokenValue True (ITprefixqvarsym (q,a)) = mkQualifiedTokenValue q a +tokenValue False (ITprefixqconsym (_,a)) = mkUnqualTokenValue a +tokenValue True (ITprefixqconsym (q,a)) = mkQualifiedTokenValue q a +tokenValue _ _= "" + +instance Monoid (Bag a) where + mempty = emptyBag + mappend = unionBags + mconcat = unionManyBags + +--instance JSON SrcLoc +-- where showJSON src +-- | isGoodSrcLoc src =makeObj [((unpackFS $ srcLocFile src) , (JSArray [showJSON $ srcLocLine src,showJSON $ srcLocCol src])) ] +-- | otherwise = JSNull +-- +--instance JSON SrcSpan +-- where showJSON src +-- | isGoodSrcSpan src=makeObj [((unpackFS $ srcSpanFile src) , (JSArray [showJSON $ srcSpanStartLine src,showJSON $ srcSpanStartCol src,showJSON $ srcSpanEndLine src,showJSON $ srcSpanEndCol src])) ] +-- | otherwise = JSNull +-- +--instance JSON FastString +-- where showJSON=JSString . toJSString . unpackFS +-- +--instance JSON ModuleName +-- where showJSON=JSString . toJSString . moduleNameString +-- +--instance JSON OccName +-- where showJSON=JSString . toJSString . showSDocDump . ppr +-- +--instance JSON Type +-- where showJSON =JSString . toJSString . showSDocDump . ppr +-- +--instance JSON DataCon +-- where showJSON=JSString . toJSString . showSDocDump . ppr +-- +--instance JSON Unique +-- where showJSON=JSString . toJSString . showSDocDump . ppr +-- +--instance JSON Name +-- where showJSON=JSString . toJSString . showSDocDump . ppr +-- +--instance JSON EvBindsVar +-- where showJSON=JSString . toJSString . showSDocDump . ppr +-- +--instance JSON PackageId +-- where showJSON=JSString . toJSString . showSDocDump . ppr +-- +--instance (JSON a)=> JSON (Bag a) +-- where showJSON=JSArray . map showJSON . bagToList +-- +--instance (JSON a)=> JSON (UniqSet a) +-- where showJSON=JSArray . map showJSON . uniqSetToList +-- +--instance JSON Rational +-- where showJSON=JSRational False +-- +--instance JSON Var +-- where showJSON v=makeObj [("Name",showJSON $ Var.varName v),("Unique",showJSON $ varUnique v),("Type",showJSON $ varType v)] +-- +--instance JSON RdrName +-- where +-- showJSON (Unqual on) = JSArray [showJSON on] +-- showJSON (Qual mn on) = JSArray [showJSON mn,showJSON on] +-- +--instance(JSON a)=> JSON (Located a) +-- where showJSON (L s o)=case showJSON o of +-- JSObject o->let +-- ass=fromJSObject o +-- in JSObject $ toJSObject (("Loc",(showJSON s)):ass) +-- JSNull -> JSNull +-- v->makeObj [("Loc",(showJSON s)),("Object" ,v)] +-- +-- $( derive makeJSON ''HsModule ) +-- $( derive makeJSON ''ImportDecl ) +-- $( derive makeJSON ''HsDocString ) +-- $( derive makeJSON ''HsDecl) +-- $( derive makeJSON ''WarningTxt) +-- +-- +-- $( derive makeJSON ''InstDecl ) +---- $( derive makeJSON ''HsBind ) +-- $( derive makeJSON ''HsBindLR ) +-- $( derive makeJSON ''DefaultDecl ) +-- $( derive makeJSON ''WarnDecl ) +-- $( derive makeJSON ''RuleDecl ) +-- $( derive makeJSON ''DocDecl ) +-- $( derive makeJSON ''HsQuasiQuote ) +-- $( derive makeJSON ''SpliceDecl ) +-- $( derive makeJSON ''AnnDecl ) +-- $( derive makeJSON ''ForeignDecl ) +-- $( derive makeJSON ''Sig ) +-- $( derive makeJSON ''DerivDecl ) +-- $( derive makeJSON ''TyClDecl ) +-- +-- $( derive makeJSON ''NewOrData ) +-- $( derive makeJSON ''HsTyVarBndr ) +-- $( derive makeJSON ''HsPred ) +-- $( derive makeJSON ''HsType ) +-- $( derive makeJSON ''ConDecl ) +-- $( derive makeJSON ''FamilyFlavour ) +-- $( derive makeJSON ''ResType ) +-- $( derive makeJSON ''HsConDetails ) +-- $( derive makeJSON ''HsExplicitFlag ) +-- $( derive makeJSON ''ConDeclField ) +-- $( derive makeJSON ''Boxity ) +-- $( derive makeJSON ''HsSplice ) +-- $( derive makeJSON ''HsBang ) +-- $( derive makeJSON ''IPName ) +-- $( derive makeJSON ''HsExpr ) +-- +-- $( derive makeJSON ''HsLit) +-- $( derive makeJSON ''MatchGroup) +-- $( derive makeJSON ''HsStmtContext) +-- $( derive makeJSON ''HsBracket) +-- $( derive makeJSON ''Pat) +-- $( derive makeJSON ''HsWrapper) +-- $( derive makeJSON ''HsCmdTop) +-- $( derive makeJSON ''Fixity) +-- $( derive makeJSON ''HsArrAppType) +-- $( derive makeJSON ''ArithSeqInfo) +-- $( derive makeJSON ''HsRecFields ) +-- $( derive makeJSON ''HsRecField ) +-- $( derive makeJSON ''StmtLR ) +-- $( derive makeJSON ''HsLocalBindsLR ) +-- $( derive makeJSON ''HsTupArg ) +-- $( derive makeJSON ''HsOverLit ) +-- $( derive makeJSON ''OverLitVal ) +-- $( derive makeJSON ''HsValBindsLR ) +-- $( derive makeJSON ''HsIPBinds ) +-- $( derive makeJSON ''IPBind ) +-- $( derive makeJSON ''FixitySig ) +-- $( derive makeJSON ''InlinePragma ) +-- $( derive makeJSON ''Match ) +-- $( derive makeJSON ''Activation ) +-- $( derive makeJSON ''RuleMatchInfo ) +-- $( derive makeJSON ''InlineSpec ) +-- $( derive makeJSON ''RecFlag ) +-- $( derive makeJSON ''GRHSs ) +-- $( derive makeJSON ''GRHS ) +-- $( derive makeJSON ''FixityDirection ) +-- $( derive makeJSON ''EvTerm ) +-- $( derive makeJSON ''TcEvBinds ) +-- $( derive makeJSON ''ForeignExport ) +-- $( derive makeJSON ''ForeignImport ) +-- $( derive makeJSON ''HsMatchContext ) +-- $( derive makeJSON ''HsGroup ) +-- $( derive makeJSON ''CExportSpec ) +-- $( derive makeJSON ''CImportSpec ) +-- $( derive makeJSON ''CCallConv ) +-- $( derive makeJSON ''CCallTarget ) +-- $( derive makeJSON ''EvBind ) +-- $( derive makeJSON ''Safety ) +-- $( derive makeJSON ''AnnProvenance ) +-- $( derive makeJSON ''RuleBndr ) +-- $( derive makeJSON ''TcSpecPrags ) +-- $( derive makeJSON ''TcSpecPrag ) +-- +--instance (JSON a)=> JSON (IE a) +-- where +-- showJSON= showJSON . ieName +-- +-- {-- +-- p <- parseModule modSum +-- t <- typecheckModule p +-- d <- desugarModule t +-- l <- loadModule d +-- n <- getNamesInScope +-- c <- return $ coreModule d +-- +-- g <- getModuleGraph +-- mapM showModule g +-- return $ (parsedSource d,"/n-----/n", typecheckedSource d) +-- --} +-- +--{-- +--instance ToJSON SrcLoc +-- where toJSON src +-- | isGoodSrcLoc src =object [(pack $ unpackFS $ srcLocFile src) .= (Array $ fromList [toJSON $ srcLocLine src,toJSON $ srcLocCol src]) ] +-- | otherwise = Null +-- +--instance ToJSON SrcSpan +-- where toJSON src +-- | isGoodSrcSpan src=object [(pack $ unpackFS $ srcSpanFile src) .= (Array $ fromList [toJSON $ srcSpanStartLine src,toJSON $ srcSpanStartCol src,toJSON $ srcSpanEndLine src,toJSON $ srcSpanEndCol src]) ] +-- | otherwise = Null +-- +--instance(ToJSON a)=> ToJSON (Located a) +-- where toJSON (L s o)=case toJSON o of +-- Object o->Object (M.insert "Loc" (toJSON s) o) +-- Null -> Null +-- v->object ["Loc" .= (toJSON s),"Object" .= v] +-- +--instance (ToJSON a, OutputableBndr a)=> ToJSON (HsModule a) +-- where toJSON hsm=object ["ModName" .= (toJSON $ hsmodName hsm), +-- "Exports" .= (toJSON $ hsmodExports hsm), +-- "Imports" .= (toJSON $ hsmodImports hsm), +-- "Decls" .= (toJSON $ hsmodDecls hsm) +-- ] +-- +--instance ToJSON FastString +-- where toJSON=toJSON . pack . unpackFS +-- +--instance ToJSON ModuleName +-- where toJSON=toJSON . moduleNameString +-- +--instance ToJSON OccName +-- where toJSON=toJSON . showSDocDump . ppr +-- +--instance ToJSON RdrName +-- where +-- toJSON (Unqual on) = Array $ fromList [toJSON on] +-- toJSON (Qual mn on) = Array $ fromList [toJSON mn,toJSON on] +-- +--instance (ToJSON a)=> ToJSON (IE a) +-- where +-- toJSON= toJSON . ieName --} +-- {--toJSON (IEVar name)= object ["IEVar" .= toJSON name] +-- toJSON (IEThingAbs name)=object ["IEThingAbs" .= toJSON name] +-- toJSON (IEThingAll name)= object ["IEThingAll" .= toJSON name] +-- toJSON (IEThingWith name ns)= object ["IEVar" .= toJSON name] +-- toJSON (IEModuleContents mn)= object ["IEModuleContents" .= toJSON name] +-- toJSON (IEGroup i hds)= object ["IEVar" .= toJSON hds] +-- toJSON (IEDoc hds)= object ["IEDoc" .= toJSON hds] +-- toJSON (IEDocNamed s)= object ["IEDocNamed" .= toJSON s] --} +--{-- +--instance (ToJSON a)=> ToJSON (ImportDecl a) +-- where +-- toJSON imd=object ["ModName" .= toJSON (ideclName imd), +-- "PackageQualified" .= toJSON (ideclPkgQual imd), +-- "Source" .= toJSON (ideclSource imd), +-- "Qualified" .= toJSON (ideclQualified imd), +-- "As" .= toJSON (ideclAs imd), +-- "Hiding" .= toJSON (ideclHiding imd) +-- ] +-- +--instance (ToJSON a, OutputableBndr a)=> ToJSON (HsDecl a) +-- where toJSON =toJSON . showSDocDump . ppr +-- +-- --} diff --git a/src/Language/Haskell/BuildWrapper/Packages.hs b/src/Language/Haskell/BuildWrapper/Packages.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/BuildWrapper/Packages.hs @@ -0,0 +1,201 @@ +{-# LANGUAGE CPP #-} +-- | +-- Module : Language.Haskell.BuildWrapper.Packages +-- Author : Thiago Arrais +-- Copyright : (c) Thiago Arrais 2009 +-- License : BSD3 +-- Url : http://stackoverflow.com/questions/1522104/how-to-programmatically-retrieve-ghc-package-information +-- +-- Maintainer : jpmoresmau@gmail.com +-- Stability : beta +-- Portability : portable +-- +-- Packages from packages databases (global, user). +module Language.Haskell.BuildWrapper.Packages ( getPkgInfos ) where + + +import Prelude hiding (Maybe) +import qualified Config +import qualified System.Info +import Data.List +import Data.Maybe +import Control.Monad +import Distribution.InstalledPackageInfo +import Distribution.Text +import System.Directory +import System.Environment (getEnv) +import System.FilePath +import System.IO +import System.IO.Error + +import GHC.Paths + +import qualified Control.Exception as Exception + +-- This was borrowed from the ghc-pkg source: +type InstalledPackageInfoString = InstalledPackageInfo_ String + +-- | Types of cabal package databases +data CabalPkgDBType = + PkgDirectory FilePath + | PkgFile FilePath + +type InstalledPackagesList = [(FilePath, [InstalledPackageInfo])] + +-- | Fetch the installed package info from the global and user package.conf +-- databases, mimicking the functionality of ghc-pkg. + +getPkgInfos :: IO InstalledPackagesList +getPkgInfos = + let + -- | Test for package database's presence in a given directory + -- NB: The directory is returned for later scanning by listConf, + -- which parses the actual package database file(s). + lookForPackageDBIn :: FilePath -> IO (Maybe InstalledPackagesList) + lookForPackageDBIn dir = + let + path_dir = dir "package.conf.d" + path_file = dir "package.conf" + in do + exists_dir <- doesDirectoryExist path_dir + if exists_dir + then do + pkgs <- readContents (PkgDirectory path_dir) + return $ Just pkgs + else do + exists_file <- doesFileExist path_file + if exists_file + then do + pkgs <- readContents (PkgFile path_file) + return $ Just pkgs + else return Nothing + + currentArch :: String + currentArch = System.Info.arch + + currentOS :: String + currentOS = System.Info.os + + ghcVersion :: String + ghcVersion = Config.cProjectVersion + in do + -- Get the global package configuration database: + global_conf <- do + r <- lookForPackageDBIn getLibDir + case r of + Nothing -> ioError $ userError ("Can't find package database in " ++ getLibDir) + Just pkgs -> return $ pkgs + + -- Get the user package configuration database + e_appdir <- try $ getAppUserDataDirectory "ghc" + user_conf <- do + case e_appdir of + Left _ -> return [] + Right appdir -> do + let subdir = currentArch ++ '-':currentOS ++ '-':ghcVersion + dir = appdir subdir + r <- lookForPackageDBIn dir + case r of + Nothing -> return [] + Just pkgs -> return pkgs + + -- Process GHC_PACKAGE_PATH, if present: + e_pkg_path <- try (getEnv "GHC_PACKAGE_PATH") + env_stack <- do + case e_pkg_path of + Left _ -> return [] + Right path -> do + pkgs <- mapM readContents [(PkgDirectory pkg) | pkg <- splitSearchPath path] + return $ concat pkgs + + -- Send back the combined installed packages list: + return (env_stack ++ user_conf ++ global_conf) + +-- | Read the contents of the given directory, searching for ".conf" files, and parse the +-- package contents. Returns a singleton list (directory, [installed packages]) + +readContents :: CabalPkgDBType -- ^ The package database + -> IO [(FilePath, [InstalledPackageInfo])] -- ^ Installed packages + +readContents pkgdb = + let + -- | List package configuration files that might live in the given directory + listConf :: FilePath -> IO [FilePath] + listConf dbdir = do + conf_dir_exists <- doesDirectoryExist dbdir + if conf_dir_exists + then do + files <- getDirectoryContents dbdir + return [ dbdir file | file <- files, isSuffixOf ".conf" file] + else return [] + + -- | Read a file, ensuring that UTF8 coding is used for GCH >= 6.12 + readUTF8File :: FilePath -> IO String + readUTF8File file = do + h <- openFile file ReadMode +#if __GLASGOW_HASKELL__ >= 612 + -- fix the encoding to UTF-8 + hSetEncoding h utf8 + catch (hGetContents h) (\err->do + putStrLn $ ioeGetErrorString err + hClose h + h' <- openFile file ReadMode + hSetEncoding h' localeEncoding + hGetContents h' + ) +#else + hGetContents h +#endif + + + -- | This function was lifted directly from ghc-pkg. Its sole purpose is + -- parsing an input package description string and producing an + -- InstalledPackageInfo structure. + convertPackageInfoIn :: InstalledPackageInfoString -> InstalledPackageInfo + convertPackageInfoIn + (pkgconf@(InstalledPackageInfo { exposedModules = e, + hiddenModules = h })) = + pkgconf{ exposedModules = map convert e, + hiddenModules = map convert h } + where convert = fromJust . simpleParse + + -- | Utility function that just flips the arguments to Control.Exception.catch + catchError :: IO a -> (String -> IO a) -> IO a + catchError io handler = io `Exception.catch` handler' + where handler' (Exception.ErrorCall err) = handler err + + -- | Slightly different approach in Cabal 1.8 series, with the package.conf.d + -- directories, where individual package configuration files are association + -- pairs. + pkgInfoReader :: FilePath + -> IO [InstalledPackageInfo] + pkgInfoReader f = + catch ( + do + pkgStr <- readUTF8File f + let pkgInfo = parseInstalledPackageInfo pkgStr + case pkgInfo of + ParseOk _ info -> return [info] + ParseFailed err -> do + putStrLn (show err) + return [emptyInstalledPackageInfo] + ) (\_->return [emptyInstalledPackageInfo]) + + in case pkgdb of + (PkgDirectory pkgdbDir) -> do + confs <- listConf pkgdbDir + pkgInfoList <- mapM pkgInfoReader confs + return [(pkgdbDir, join pkgInfoList)] + + (PkgFile dbFile) -> do + pkgStr <- readUTF8File dbFile + let pkgs = map convertPackageInfoIn $ read pkgStr + pkgInfoList <- + Exception.evaluate pkgs + `catchError` + (\e-> ioError $ userError $ "parsing " ++ dbFile ++ ": " ++ (show e)) + return [(takeDirectory dbFile, pkgInfoList)] + +-- GHC.Path sets libdir for us... +getLibDir :: String +getLibDir = libdir diff --git a/src/Language/Haskell/BuildWrapper/Src.hs b/src/Language/Haskell/BuildWrapper/Src.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/BuildWrapper/Src.hs @@ -0,0 +1,199 @@ +{-# LANGUAGE TypeSynonymInstances,OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +-- | +-- Module : Language.Haskell.BuildWrapper.Src +-- Author : JP Moresmau +-- Copyright : (c) JP Moresmau 2011 +-- License : BSD3 +-- +-- Maintainer : jpmoresmau@gmail.com +-- Stability : beta +-- Portability : portable +-- +-- Use haskell-src-exts to get a module outline +module Language.Haskell.BuildWrapper.Src where + +import Language.Haskell.BuildWrapper.Base + +import Language.Haskell.Exts.Annotated + + +import qualified Data.Text as T +--import Text.JSON +--import Data.DeriveTH +--import Data.Derive.JSON + +getHSEAST :: String -> [String] -> IO (ParseResult (Module SrcSpanInfo, [Comment])) +getHSEAST input options=do + let exts=map classifyExtension options + -- putStrLn $ show exts + let mode=defaultParseMode {extensions=exts,ignoreLinePragmas=False,ignoreLanguagePragmas=False} + return $ parseFileContentsWithComments mode input + --return $ makeObj [("parse" , (showJSON $ pr))] + +getHSEOutline :: (Module SrcSpanInfo, [Comment]) -> [OutlineDef] +getHSEOutline (Module _ _ _ _ decls,comments)=concat $ map declOutline decls + where + declOutline :: Decl SrcSpanInfo -> [OutlineDef] + declOutline (DataFamDecl l _ h _) = [OutlineDef (headDecl h) [Data,Family] (makeSpan l) []] + declOutline (DataInsDecl l _ t cons _) = [OutlineDef (typeDecl t) [Data,Instance] (makeSpan l) (map qualConDeclOutline cons)] + --declOutline (GDataInsDecl l _ t cons _) = [OutlineDef (typeDecl t) [Data,Instance] (makeSpan l) (map qualConDeclOutline cons)] + declOutline (DataDecl l _ _ h cons _) = [OutlineDef (headDecl h) [Data] (makeSpan l) (map qualConDeclOutline cons)] + --declOutline (GDataDecl l _ _ h cons _) = [OutlineDef (headDecl h) [Data] (makeSpan l) (map qualConDeclOutline cons)] + declOutline (TypeFamDecl l h _) = [OutlineDef (headDecl h) [Type,Family] (makeSpan l) []] + declOutline (TypeInsDecl l t1 _) = [OutlineDef ((typeDecl t1) ) [Type,Instance] (makeSpan l) []] -- ++ " "++(typeDecl t2) + declOutline (TypeDecl l h _) = [OutlineDef (headDecl h) [Type] (makeSpan l) []] + declOutline (ClassDecl l _ h _ cdecls) = [OutlineDef (headDecl h) [Class] (makeSpan l) (maybe [] (concatMap classDecl) cdecls)] + declOutline (FunBind l matches) = [OutlineDef (matchDecl $ head matches) [Function] (makeSpan l) []] + declOutline (PatBind l (PVar _ n) _ _ _)=[OutlineDef (nameDecl n) [Function] (makeSpan l) []] + declOutline (InstDecl l _ h idecls)=[OutlineDef (iheadDecl h) [Instance] (makeSpan l) (maybe [] (concatMap instDecl) idecls)] + declOutline _ = [] + qualConDeclOutline :: QualConDecl SrcSpanInfo-> OutlineDef + qualConDeclOutline (QualConDecl l _ _ con)=let + (n,defs)=conDecl con + in OutlineDef n [Constructor] (makeSpan l) defs + declOutlineInClass :: Decl SrcSpanInfo -> [OutlineDef] + declOutlineInClass (TypeSig l ns _)=map (\n->OutlineDef (nameDecl n) [Function] (makeSpan l) []) ns + declOutlineInClass o=declOutline o + headDecl :: DeclHead a -> T.Text + headDecl (DHead _ n _)=nameDecl n + headDecl (DHInfix _ _ n _)=nameDecl n + headDecl (DHParen _ h)=headDecl h + nameDecl :: Name a -> T.Text + nameDecl (Ident _ s)=T.pack s + nameDecl (Symbol _ s)=T.pack s + typeDecl :: Type a -> T.Text + typeDecl (TyForall _ _ _ t)=typeDecl t + typeDecl (TyVar _ n )=nameDecl n + typeDecl (TyCon _ qn )=qnameDecl qn + typeDecl (TyList _ t )=T.concat ["[",(typeDecl t),"]"] + typeDecl (TyParen _ t )=typeDecl t + typeDecl (TyApp _ t1 t2)=T.concat [(typeDecl t1) , " ",(typeDecl t2)] + typeDecl _ = "" + qnameDecl :: QName a -> T.Text + qnameDecl (Qual _ _ n)=nameDecl n + qnameDecl (UnQual _ n)=nameDecl n + qnameDecl _ ="" + matchDecl :: Match a -> T.Text + matchDecl (Match _ n _ _ _)=nameDecl n + matchDecl (InfixMatch _ _ n _ _ _)=nameDecl n + iheadDecl :: InstHead a -> T.Text + iheadDecl (IHead _ qn ts)= T.concat [(qnameDecl qn) , " " , (T.intercalate " " (map typeDecl ts))] + iheadDecl (IHInfix _ t1 qn t2)= T.concat [(typeDecl t1), " ", (qnameDecl qn) , " " , (typeDecl t2)] + iheadDecl (IHParen _ i)=iheadDecl i + conDecl :: ConDecl SrcSpanInfo -> (T.Text,[OutlineDef]) + conDecl (ConDecl _ n _)=(nameDecl n,[]) + conDecl (InfixConDecl _ _ n _)=(nameDecl n,[]) + conDecl (RecDecl _ n fields)=(nameDecl n,concatMap fieldDecl fields) + fieldDecl :: FieldDecl SrcSpanInfo -> [OutlineDef] + fieldDecl (FieldDecl l ns _)=map (\n->OutlineDef (nameDecl n) [Field] (makeSpan l) []) ns + classDecl :: ClassDecl SrcSpanInfo -> [OutlineDef] + classDecl (ClsDecl _ d) = declOutlineInClass d + classDecl _ = [] + instDecl :: InstDecl SrcSpanInfo -> [OutlineDef] + instDecl (InsDecl _ d) = declOutlineInClass d + instDecl _ = [] + +getHSEOutline _ = [] + + +makeSpan :: SrcSpanInfo -> InFileSpan +makeSpan si=let + sis=srcInfoSpan si + (sl,sc)=srcSpanStart sis + (el,ec)=srcSpanEnd sis + in InFileSpan (InFileLoc sl sc) (InFileLoc el ec) + +knownExtensionNames :: [String] +knownExtensionNames = map show knownExtensions + + +-- $( derive makeJSON ''ParseResult ) +-- $( derive makeJSON ''Module ) +-- $( derive makeJSON ''ModuleHead ) +-- $( derive makeJSON ''ExportSpecList ) +---- $( derive makeJSON ''SrcLoc ) +-- +--instance JSON SrcLoc +-- where showJSON src = JSArray [showJSON $ srcLine src,showJSON $ srcColumn src] +-- +-- $( derive makeJSON ''ModulePragma ) +-- $( derive makeJSON ''WarningText ) +-- $( derive makeJSON ''ExportSpec ) +-- $( derive makeJSON ''ImportDecl ) +-- $( derive makeJSON ''ImportSpecList ) +-- $( derive makeJSON ''ImportSpec ) +-- $( derive makeJSON ''Decl ) +-- $( derive makeJSON ''DeclHead ) +-- $( derive makeJSON ''Deriving ) +-- $( derive makeJSON ''Context ) +-- $( derive makeJSON ''InstHead ) +-- $( derive makeJSON ''ModuleName ) +-- $( derive makeJSON ''Tool ) +-- $( derive makeJSON ''CName ) +-- $( derive makeJSON ''Name ) +-- $( derive makeJSON ''DataOrNew ) +-- $( derive makeJSON ''QualConDecl ) +-- $( derive makeJSON ''Kind ) +-- $( derive makeJSON ''TyVarBind ) +-- $( derive makeJSON ''Asst ) +-- $( derive makeJSON ''ConDecl ) +-- $( derive makeJSON ''FieldDecl ) +-- $( derive makeJSON ''QName ) +-- $( derive makeJSON ''Type ) +-- $( derive makeJSON ''IPName ) +-- $( derive makeJSON ''BangType ) +-- $( derive makeJSON ''SpecialCon ) +-- $( derive makeJSON ''Boxed ) +-- $( derive makeJSON ''FunDep ) +-- $( derive makeJSON ''ClassDecl ) +-- $( derive makeJSON ''GadtDecl ) +-- $( derive makeJSON ''InstDecl ) +-- $( derive makeJSON ''Match ) +-- $( derive makeJSON ''Rhs ) +-- $( derive makeJSON ''Binds ) +-- $( derive makeJSON ''Exp ) +-- $( derive makeJSON ''GuardedRhs ) +-- $( derive makeJSON ''IPBind ) +-- $( derive makeJSON ''Splice ) +-- $( derive makeJSON ''Literal ) +-- $( derive makeJSON ''Pat ) +-- $( derive makeJSON ''XName ) +-- $( derive makeJSON ''Alt ) +-- $( derive makeJSON ''QOp ) +-- $( derive makeJSON ''XAttr ) +-- $( derive makeJSON ''Bracket ) +-- $( derive makeJSON ''QualStmt ) +-- $( derive makeJSON ''Stmt ) +-- $( derive makeJSON ''FieldUpdate ) +-- $( derive makeJSON ''RPat ) +-- $( derive makeJSON ''RPatOp ) +-- $( derive makeJSON ''GuardedAlts ) +-- $( derive makeJSON ''PXAttr ) +-- $( derive makeJSON ''PatField ) +-- $( derive makeJSON ''GuardedAlt ) +-- $( derive makeJSON ''Activation ) +-- $( derive makeJSON ''Annotation ) +-- $( derive makeJSON ''Rule ) +-- $( derive makeJSON ''CallConv ) +-- $( derive makeJSON ''RuleVar ) +-- $( derive makeJSON ''Safety ) +-- $( derive makeJSON ''Op ) +-- $( derive makeJSON ''Assoc ) +-- $( derive makeJSON ''Comment ) +-- $( derive makeJSON ''SrcSpan ) +-- $( derive makeJSON ''SrcSpanInfo ) +-- +--instance JSON Rational +-- where showJSON=JSRational False + + + + + + + + + + + diff --git a/test/Language/Haskell/BuildWrapper/APITest.hs b/test/Language/Haskell/BuildWrapper/APITest.hs new file mode 100644 --- /dev/null +++ b/test/Language/Haskell/BuildWrapper/APITest.hs @@ -0,0 +1,51 @@ +{-# LANGUAGE OverloadedStrings #-} +-- | +-- Module : Language.Haskell.BuildWrapper.APITest +-- Author : JP Moresmau +-- Copyright : (c) JP Moresmau 2011 +-- License : BSD3 +-- +-- Maintainer : jpmoresmau@gmail.com +-- Stability : beta +-- Portability : portable +-- +-- Direct tests on the API code +module Language.Haskell.BuildWrapper.APITest where + +import qualified Language.Haskell.BuildWrapper.Cabal as Cabal + +import Test.HUnit + + +unitTests :: [Test] +unitTests=[testGetBuiltPath] + +--apiTests::Test +--apiTests=TestList $ map (\f->f DirectAPI) tests +-- +--data DirectAPI=DirectAPI +-- +--instance APIFacade DirectAPI where +-- synchronize _ r= runAPI r API.synchronize +-- synchronize1 _ r= runAPI r . API.synchronize1 +-- write _ r fp s= runAPI r $ API.write fp s +-- configure _ r= runAPI r . API.configure +-- build _ r= runAPI r . API.build +-- getOutline _ r= runAPI r . API.getOutline +-- getTokenTypes _ r= runAPI r . API.getTokenTypes +-- getOccurrences _ r fp s= runAPI r $ API.getOccurrences fp s +-- getThingAtPoint _ r fp l c q t= runAPI r $ API.getThingAtPoint fp l c q t +-- getNamesInScope _ r= runAPI r . API.getNamesInScope +-- getCabalDependencies _ r= runAPI r . API.getCabalDependencies +-- getCabalComponents _ r= runAPI r . API.getCabalComponents +-- +--runAPI:: FilePath -> StateT BuildWrapperState IO a -> IO a +--runAPI root f= do +-- evalStateT f (BuildWrapperState ".dist-buildwrapper" "cabal" (testCabalFile root) Normal "") + +testGetBuiltPath :: Test +testGetBuiltPath = TestLabel "testGetBuiltPath" (TestCase (do + assertEqual "backslash path" (Just "src\\Language\\Haskell\\BuildWrapper\\Cabal.hs") $ Cabal.getBuiltPath "[4 of 7] Compiling Language.Haskell.BuildWrapper.Cabal ( src\\Language\\Haskell\\BuildWrapper\\Cabal.hs, dist\\build\\Language\\Haskell\\BuildWrapper\\Cabal.o )" + assertEqual "forward slash path" (Just "src/Language/Haskell/BuildWrapper/Cabal.hs") $ Cabal.getBuiltPath "[4 of 7] Compiling Language.Haskell.BuildWrapper.Cabal ( src/Language/Haskell/BuildWrapper/Cabal.hs, dist/build/Language/Haskell/BuildWrapper/Cabal.o )" + assertEqual "no path" Nothing $ Cabal.getBuiltPath "something else" + )) diff --git a/test/Language/Haskell/BuildWrapper/CMDTests.hs b/test/Language/Haskell/BuildWrapper/CMDTests.hs new file mode 100644 --- /dev/null +++ b/test/Language/Haskell/BuildWrapper/CMDTests.hs @@ -0,0 +1,65 @@ +-- | +-- Module : Language.Haskell.BuildWrapper.CMDTests +-- Author : JP Moresmau +-- Copyright : (c) JP Moresmau 2011 +-- License : BSD3 +-- +-- Maintainer : jpmoresmau@gmail.com +-- Stability : beta +-- Portability : portable +-- +-- Testing via the executable interface +module Language.Haskell.BuildWrapper.CMDTests where + +import Language.Haskell.BuildWrapper.Tests +import Test.HUnit + +import Data.Attoparsec +import Data.Aeson +import Data.Aeson.Parser +import qualified Data.ByteString.Char8 as BS +import Data.List +import System.Exit +import System.Process + +cmdTests::[Test] +cmdTests= map (\f->f CMDAPI) tests + +data CMDAPI=CMDAPI + +instance APIFacade CMDAPI where + synchronize _ r ff= runAPI r "synchronize" ["--force="++(show ff)] + synchronize1 _ r ff fp= runAPI r "synchronize1" ["--force="++(show ff),"--file="++fp] + write _ r fp s= runAPI r "write" ["--file="++fp,"--contents="++s] + configure _ r t= runAPI r "configure" ["--cabaltarget="++(show t)] + build _ r b wc= runAPI r "build" ["--output="++(show b),"--cabaltarget="++(show wc)] + build1 _ r fp= runAPI r "build1" ["--file="++fp] + getOutline _ r fp= runAPI r "outline" ["--file="++fp] + getTokenTypes _ r fp= runAPI r "tokentypes" ["--file="++fp] + getOccurrences _ r fp s= runAPI r "occurrences" ["--file="++fp,"--token="++s] + getThingAtPoint _ r fp l c q t= runAPI r "thingatpoint" ["--file="++fp,"--line="++(show l),"--column="++(show c),"--qualify="++(show q),"--typed="++(show t)] + getNamesInScope _ r fp= runAPI r "namesinscope" ["--file="++fp] + getCabalDependencies _ r= runAPI r "dependencies" [] + getCabalComponents _ r= runAPI r "components" [] + +runAPI:: (FromJSON a,Show a) => FilePath -> String -> [String] -> IO a +runAPI root command args= do + let fullargs=[command,"--tempfolder=.dist-buildwrapper","--cabalpath=cabal","--cabalfile="++(testCabalFile root)] ++ args + (ex,out,err)<-readProcessWithExitCode ".dist-buildwrapper/dist/build/buildwrapper/buildwrapper" fullargs "" + putStrLn ("out:"++out) + putStrLn ("err:"++err) + assertEqual ("returned error: "++show fullargs++"\n:"++show err) ExitSuccess ex + let res=map (drop $ length "build-wrapper-json:") $ filter (isPrefixOf "build-wrapper-json:") $ lines out + assertEqual ("no json: "++show fullargs++"\n:"++show out) 1 (length res) + let r=parse value $ BS.pack (head res) + case r of + Done _ js->do + let r1= fromJSON js + case r1 of + Success fin->return fin + a->do + assertFailure (show a) + error "" + a->do + assertFailure (show a) + error "" diff --git a/test/Language/Haskell/BuildWrapper/Tests.hs b/test/Language/Haskell/BuildWrapper/Tests.hs new file mode 100644 --- /dev/null +++ b/test/Language/Haskell/BuildWrapper/Tests.hs @@ -0,0 +1,817 @@ +{-# LANGUAGE OverloadedStrings #-} +-- | +-- Module : Language.Haskell.BuildWrapper.Tests +-- Author : JP Moresmau +-- Copyright : (c) JP Moresmau 2011 +-- License : BSD3 +-- +-- Maintainer : jpmoresmau@gmail.com +-- Stability : beta +-- Portability : portable +-- +-- Abstract tests of the behavior +module Language.Haskell.BuildWrapper.Tests where + +import Language.Haskell.BuildWrapper.Base + +import Data.Maybe +import Data.Aeson +import Data.Char + +import Test.HUnit + +import System.Directory +import System.FilePath +import System.Info + +import Control.Monad + +--import System.Time + +tests :: (APIFacade a)=> [(a -> Test)] +tests= [ + testSynchronizeAll, + testConfigureWarnings , testConfigureErrors , + testBuildErrors , + testBuildWarnings, + testBuildOutput, + testModuleNotInCabal, + testOutline, + testOutlinePreproc, + testPreviewTokenTypes, + testThingAtPoint, + testNamesInScope, + testInPlaceReference, + testCabalComponents, + testCabalDependencies + ] + +class APIFacade a where + synchronize :: a -> FilePath -> Bool -> IO (OpResult [FilePath]) + synchronize1 :: a -> FilePath -> Bool -> FilePath -> IO (Maybe FilePath) + write :: a -> FilePath -> FilePath -> String -> IO () + configure :: a -> FilePath -> WhichCabal -> IO (OpResult Bool) + build :: a -> FilePath -> Bool -> WhichCabal -> IO (OpResult BuildResult) + build1 :: a -> FilePath -> FilePath -> IO (OpResult Bool) + getOutline :: a -> FilePath -> FilePath -> IO (OpResult [OutlineDef]) + getTokenTypes :: a -> FilePath -> FilePath -> IO (OpResult [TokenDef]) + getOccurrences :: a -> FilePath -> FilePath -> String -> IO (OpResult [TokenDef]) + getThingAtPoint :: a -> FilePath -> FilePath -> Int -> Int -> Bool -> Bool -> IO (OpResult (Maybe String)) + getNamesInScope :: a -> FilePath -> FilePath-> IO (OpResult (Maybe [String])) + getCabalDependencies :: a -> FilePath -> IO (OpResult [(FilePath,[CabalPackage])]) + getCabalComponents :: a -> FilePath -> IO (OpResult [CabalComponent]) + +testSynchronizeAll :: (APIFacade a)=> a -> Test +testSynchronizeAll api= TestLabel "testSynchronizeAll" (TestCase ( do + root<-createTestProject + (fps,_)<-synchronize api root False + assertBool "no file path on creation" (not $ null fps) + assertEqual "no cabal file" (testProjectName <.> ".cabal") (head fps) + assertBool "no A" (elem ("src" "A.hs") fps) + assertBool "no C" (elem ("src" "B" "C.hs") fps) + assertBool "no Main" (elem ("src" "Main.hs") fps) + assertBool "no D" (elem ("src" "B" "D.hs") fps) + assertBool "no Main test" (elem ("test" "Main.hs") fps) + assertBool "no TestA" (elem ("test" "TestA.hs") fps) + )) + +testConfigureErrors :: (APIFacade a)=> a -> Test +testConfigureErrors api= TestLabel "testConfigureErrors" (TestCase ( do + root<-createTestProject + (boolNoCabal,nsNoCabal)<- configure api root Target + assertBool "configure returned true on no cabal" (not boolNoCabal) + assertEqual "errors or warnings on no cabal (should be ignored)" 0 (length nsNoCabal) + -- assertEqual ("wrong error on no cabal") (BWNote BWError "No cabal file found.\nPlease create a package description file .cabal\n" (BWLocation "" 0 1)) (head nsNoCabal) + + synchronize api root False + (boolOK,nsOK)<-configure api root Target + assertBool ("configure returned false") boolOK + assertBool ("errors or warnings:"++show nsOK) (null nsOK) + let cf=testCabalFile root + let cfn=takeFileName cf + writeFile cf $ unlines ["version:0.1", + "build-type: Simple"] + synchronize api root False + (bool1,nsErrors1)<-configure api root Target + assertBool ("bool1 returned true") (not bool1) + assertEqual "no errors on no name" 2 (length nsErrors1) + let (nsError1:nsError2:[])=nsErrors1 + assertEqual "not proper error 1" (BWNote BWError "No 'name' field.\n" (BWLocation cfn 1 1)) nsError1 + assertEqual "not proper error 2" (BWNote BWError "No executables and no library found. Nothing to do.\n" (BWLocation cfn 1 1)) nsError2 + writeFile cf $ unlines ["name: 4 P1", + "version:0.1", + "build-type: Simple"] + synchronize api root False + (bool2,nsErrors2)<-configure api root Target + assertBool ("bool2 returned true") (not bool2) + assertEqual "no errors on invalid name" 1 (length nsErrors2) + let (nsError3:[])=nsErrors2 + assertEqual "not proper error 3" (BWNote BWError "Parse of field 'name' failed.\n" (BWLocation cfn 1 1)) nsError3 + writeFile cf $ unlines ["name: "++testProjectName, + "version:0.1", + "cabal-version: >= 1.8", + "build-type: Simple", + "", + "library", + " hs-source-dirs: src", + " exposed-modules: A", + " other-modules: B.C", + " build-depends: base, toto"] + synchronize api root False + (bool3,nsErrors3)<-configure api root Target + assertBool ("bool3 returned true") (not bool3) + assertEqual "no errors on unknown dependency" 1 (length nsErrors3) + let (nsError4:[])=nsErrors3 + assertEqual "not proper error 4" (BWNote BWError "At least the following dependencies are missing:\ntoto -any\n" (BWLocation cfn 1 1)) nsError4 + + writeFile cf $ unlines ["name: "++testProjectName, + "version:0.1", + "cabal-version: >= 1.8", + "build-type: Simple", + "", + "library", + " hs-source-dirs: src", + " exposed-modules: A", + " other-modules: B.C", + " build-depends: base, toto, titi"] + synchronize api root False + (bool4,nsErrors4)<-configure api root Target + assertBool ("bool4 returned true") (not bool4) + assertEqual "no errors on unknown dependencies" 1 (length nsErrors4) + let (nsError5:[])=nsErrors4 + assertEqual "not proper error 5" (BWNote BWError "At least the following dependencies are missing:\ntiti -any, toto -any\n" (BWLocation cfn 1 1)) nsError5 + (BuildResult bool4b _,nsErrors4b)<-build api root False Source + assertBool ("bool4b returned true") (not bool4b) + assertEqual "no errors on unknown dependencies" 1 (length nsErrors4b) + let (nsError5b:[])=nsErrors4b + assertEqual "not proper error 5b" (BWNote BWError "At least the following dependencies are missing:\ntiti -any, toto -any\n" (BWLocation cfn 1 1)) nsError5b + writeFile cf $ unlines ["name: "++testProjectName, + "version:0.1", + "cabal-version: >= 1.8", + "build-type: Simple", + "", + "executable BWTest", + " hs-source-dirs: src", + " other-modules: B.D", + " build-depends: base"] + synchronize api root False + (bool5,nsErrors5)<-configure api root Target + assertBool ("bool5 returned true") (not bool5) + assertEqual "no errors on no main" 1 (length nsErrors5) + let (nsError6:[])=nsErrors5 + assertEqual "not proper error 6" (BWNote BWError "No 'Main-Is' field found for executable BWTest\n" (BWLocation cfn 1 1)) nsError6 + + )) + +testConfigureWarnings :: (APIFacade a)=> a -> Test +testConfigureWarnings api = TestLabel "testConfigureWarnings" (TestCase ( do + root<-createTestProject + synchronize api root False + let cf=testCabalFile root + let cfn=takeFileName cf + writeFile cf $ unlines ["name: "++testProjectName, + "version:0.1", + "cabal-version: >= 1.8", + "build-type: Simple", + "field1: toto", + "", + "library", + " hs-source-dirs: src", + " exposed-modules: A", + " other-modules: B.C", + " build-depends: base"] + synchronize api root False + (bool1,ns1)<- configure api root Target + assertBool ("returned false 1 "++ (show ns1)) bool1 + assertEqual ("didn't return 1 warning") 1 (length ns1) + let (nsWarning1:[])=ns1 + assertEqual "not proper warning 1" (BWNote BWWarning "Unknown fields: field1 (line 5)\nFields allowed in this section:\nname, version, cabal-version, build-type, license, license-file,\ncopyright, maintainer, build-depends, stability, homepage,\npackage-url, bug-reports, synopsis, description, category, author,\ntested-with, data-files, data-dir, extra-source-files,\nextra-tmp-files\n" (BWLocation cfn 5 1)) nsWarning1 + writeFile cf $ unlines ["name: "++testProjectName, + "version:0.1", + "build-type: Simple", + "", + "library", + " hs-source-dirs: src", + " exposed-modules: A", + " other-modules: B.C", + " build-depends: base"] + synchronize api root False + (bool2,ns2)<- configure api root Target + assertBool ("returned false 2 "++ (show ns2)) bool2 + assertEqual ("didn't return 1 warning") 1 (length ns2) + let (nsWarning2:[])=ns2 + assertEqual "not proper warning 2" (BWNote BWWarning "A package using section syntax must specify at least\n'cabal-version: >= 1.2'.\n" (BWLocation cfn 0 1)) nsWarning2 + writeFile cf $ unlines ["name: "++testProjectName, + "version:0.1", + "cabal-version: >= 1.2", + "", + "library", + " hs-source-dirs: src", + " exposed-modules: A", + " other-modules: B.C", + " build-depends: base"] + writeFile ((takeDirectory cf) "Setup.hs") $ unlines ["import Distribution.Simple", + "main = defaultMain"] + synchronize api root False + (bool3,ns3)<- configure api root Target + assertBool ("returned false 3 "++ (show ns3)) bool3 + assertEqual ("didn't return 1 warning") 1 (length ns3) + let (nsWarning3:[])=ns3 + assertEqual "not proper warning 3" (BWNote BWWarning "No 'build-type' specified. If you do not need a custom Setup.hs or\n./configure script then use 'build-type: Simple'.\n" (BWLocation cfn 0 1)) nsWarning3 + + )) + +testBuildErrors :: (APIFacade a)=> a -> Test +testBuildErrors api = TestLabel "testBuildErrors" (TestCase ( do + root<-createTestProject + synchronize api root False + (boolOKc,nsOKc)<-configure api root Target + assertBool ("returned false on configure") boolOKc + assertBool ("errors or warnings on configure:"++show nsOKc) (null nsOKc) + (BuildResult boolOK _,nsOK)<-build api root False Source + assertBool ("returned false on build") boolOK + assertBool ("errors or warnings on build:"++show nsOK) (null nsOK) + --let srcF=root "src" + let rel="src""A.hs" + -- write source file + writeFile (root rel) $ unlines ["module A where","import toto","fA=undefined"] + --mf1<-runAPI root $ synchronize1 rel False + --assertBool ("mf1 not just") (isJust mf1) + (BuildResult bool1 _,nsErrors1)<-build api root False Source + assertBool ("returned true on bool1") (not bool1) + assertBool ("no errors or warnings on nsErrors") (not $ null nsErrors1) + -- assertBool ("no rel in fps1: "++(show fps1)) (elem rel fps1) + let (nsError1:[])=nsErrors1 + assertEqualNotesWithoutSpaces "not proper error 1" (BWNote BWError "parse error on input `toto'\n" (BWLocation rel 2 8)) nsError1 + -- write file and synchronize + writeFile (root "src""A.hs")$ unlines ["module A where","import Toto","fA=undefined"] + mf2<-synchronize1 api root True rel + assertBool ("mf2 not just") (isJust mf2) + (BuildResult bool2 _,nsErrors2)<-build api root False Source + assertBool ("returned true on bool2") (not bool2) + assertBool ("no errors or warnings on nsErrors2") (not $ null nsErrors2) + -- assertBool ("no rel in fps2: "++(show fps2)) (elem rel fps1) + let (nsError2:[])=nsErrors2 + assertEqualNotesWithoutSpaces "not proper error 2" (BWNote BWError "Could not find module `Toto':\n Use -v to see a list of the files searched for.\n" (BWLocation rel 2 8)) nsError2 + (bool3,nsErrors3)<-build1 api root ("src""A.hs") + assertBool ("returned true on bool3") (not bool3) + assertBool ("no errors or warnings on nsErrors3") (not $ null nsErrors3) + -- assertBool ("no rel in fps2: "++(show fps2)) (elem rel fps1) + let (nsError3:[])=nsErrors3 + assertEqualNotesWithoutSpaces "not proper error 3" (BWNote BWError "Could not find module `Toto':\n Use -v to see a list of the files searched for." (BWLocation rel 2 8)) nsError3 + + )) + +testBuildWarnings :: (APIFacade a)=> a -> Test +testBuildWarnings api = TestLabel "testBuildWarnings" (TestCase ( do + root<-createTestProject + synchronize api root False + --let cf=testCabalFile root + writeFile (root (testProjectName <.> ".cabal")) $ unlines ["name: "++testProjectName, + "version:0.1", + "cabal-version: >= 1.8", + "build-type: Simple", + "", + "library", + " hs-source-dirs: src", + " exposed-modules: A", + " build-depends: base", + " ghc-options: -Wall"] + --let srcF=root "src" + (boolOK,nsOK)<-configure api root Source + assertBool ("returned false") boolOK + assertBool ("errors or warnings:"++show nsOK) (null nsOK) + let rel="src""A.hs" + writeFile (root rel) $ unlines ["module A where","import Data.List","fA=undefined"] + mf2<-synchronize1 api root True rel + assertBool ("mf2 not just") (isJust mf2) + (BuildResult bool1 fps1,nsErrors1)<-build api root False Source + assertBool ("returned false on bool1") bool1 + assertBool ("no errors or warnings on nsErrors1") (not $ null nsErrors1) + assertBool ("no rel in fps1: "++(show fps1)) (elem rel fps1) + let (nsError1:nsError2:[])=nsErrors1 + assertEqualNotesWithoutSpaces "not proper error 1" (BWNote BWWarning "The import of `Data.List' is redundant\n except perhaps to import instances from `Data.List'\n To import instances alone, use: import Data.List()\n" (BWLocation rel 2 1)) nsError1 + assertEqualNotesWithoutSpaces "not proper error 2" (BWNote BWWarning "Top-level binding with no type signature:\n fA :: forall a. a\n" (BWLocation rel 3 1)) nsError2 + (bool3,nsErrors3)<-build1 api root rel + assertBool ("returned false on bool3") bool3 + assertBool ("no errors or warnings on nsErrors3") (not $ null nsErrors3) + let (nsError3:nsError4:[])=nsErrors3 + assertEqualNotesWithoutSpaces "not proper error 3" (BWNote BWWarning "The import of `Data.List' is redundant\n except perhaps to import instances from `Data.List'\n To import instances alone, use: import Data.List()" (BWLocation rel 2 1)) nsError3 + assertEqualNotesWithoutSpaces "not proper error 4" (BWNote BWWarning "Top-level binding with no type signature:\n fA :: forall a. a" (BWLocation rel 3 1)) nsError4 + + )) + +testBuildOutput :: (APIFacade a)=> a -> Test +testBuildOutput api = TestLabel "testBuildOutput" (TestCase ( do + root<-createTestProject + synchronize api root False + build api root True Source + let exeN=case os of + "mingw32"->(addExtension testProjectName "exe") + _->testProjectName + let exeF=root ".dist-buildwrapper" "dist" "build" testProjectName exeN + exeE1<-doesFileExist exeF + assertBool ("exe does not exist on build output: "++exeF) exeE1 + removeFile exeF + exeE2<-doesFileExist exeF + assertBool ("exe does still exist after deletion: "++exeF) (not exeE2) + build api root False Source + exeE3<-doesFileExist exeF + assertBool ("exe exists after build no output: "++exeF) (not exeE3) + )) + +testModuleNotInCabal :: (APIFacade a)=> a -> Test +testModuleNotInCabal api = TestLabel "testModuleNotInCabal" (TestCase ( do + root<-createTestProject + synchronize api root False + let rel="src""A.hs" + writeFile (root rel) $ unlines ["module A where","import Auto","fA=undefined"] + let rel2="src""Auto.hs" + putStrLn (root rel2) + writeFile (root rel2) $ unlines ["module Auto where","fAuto=undefined"] + (fps,ns)<-synchronize api root False + putStrLn $ show fps + putStrLn $ show ns + (BuildResult bool1 _,nsErrors1)<-build api root True Source + putStrLn $ show nsErrors1 + assertBool ("returned false on bool1") bool1 + assertBool ("errors or warnings on nsErrors1") (null nsErrors1) + (bool2, nsErrors2)<-build1 api root rel + assertBool ("returned false on bool2: "++(show nsErrors2)) bool2 + assertBool ("errors or warnings on nsErrors2: "++(show nsErrors2)) (null nsErrors2) + + )) + +--testAST :: Test +--testAST = TestLabel "testAST" (TestCase ( do +-- root<-createTestProject +-- runAPI root synchronize False +-- (boolOKc,nsOKc)<-runAPI root $ configure Target +-- assertBool ("returned false on configure") boolOKc +-- assertBool ("errors or warnings on configure:"++show nsOKc) (null nsOKc) +-- +-- (boolOK,nsOK)<-runAPI root $ build False +-- assertBool ("returned false on build") boolOK +-- assertBool ("errors or warnings on build:"++show nsOK) (null nsOK) +-- (mast,nsOK2)<-runAPI root $ getAST ("src" "A.hs") +-- assertBool ("errors or warnings on getAST:"++show nsOK2) (null nsOK2) +-- case mast of +-- Just ast->do +-- let json=makeObj [("parse" , (showJSON $ ast))] +-- putStrLn $ show $ encode json +-- Nothing -> assertFailure "no ast" +-- )) + +testOutline :: (APIFacade a)=> a -> Test +testOutline api= TestLabel "testOutline" (TestCase ( do + root<-createTestProject + synchronize api root False + let rel="src""A.hs" + -- use api to write temp file + write api root rel $ unlines [ + "{-# LANGUAGE RankNTypes, TypeSynonymInstances, TypeFamilies #-}", + "", + "module Module1 where", + "", + "import Data.Char", + "", + "-- Declare a list-like data family", + "data family XList a", + "", + "-- Declare a list-like instance for Char", + "data instance XList Char = XCons !Char !(XList Char) | XNil", + "", + "type family Elem c", + "", + "type instance Elem [e] = e", + "", + "testfunc1 :: [Char]", + "testfunc1=reverse \"test\"", + "", + "testfunc1bis :: String -> [Char]", + "testfunc1bis []=\"nothing\"", + "testfunc1bis s=reverse s", + "", + "testMethod :: forall a. (Num a) => a -> a -> a", + "testMethod a b=", + " let e=a + (fromIntegral $ length testfunc1)", + " in e * 2", + "", + "class ToString a where", + " toString :: a -> String", + "", + "instance ToString String where", + " toString = id", + "", + "type Str=String", + "", + "data Type1=MkType1_1 Int", + " | MkType1_2 {", + " mkt2_s :: String,", + " mkt2_i :: Int", + " }" ] + (defs,nsErrors1)<-getOutline api root rel + assertBool ("errors or warnings on getOutline:"++show nsErrors1) (null nsErrors1) + let expected=[ + OutlineDef "XList" [Data,Family] (InFileSpan (InFileLoc 8 1)(InFileLoc 8 20)) [] + ,OutlineDef "XList Char" [Data,Instance] (InFileSpan (InFileLoc 11 1)(InFileLoc 11 60)) [ + OutlineDef "XCons" [Constructor] (InFileSpan (InFileLoc 11 28)(InFileLoc 11 53)) [] + ,OutlineDef "XNil" [Constructor] (InFileSpan (InFileLoc 11 56)(InFileLoc 11 60)) [] + ] + ,OutlineDef "Elem" [Type,Family] (InFileSpan (InFileLoc 13 1)(InFileLoc 13 19)) [] + ,OutlineDef "Elem [e]" [Type,Instance] (InFileSpan (InFileLoc 15 1)(InFileLoc 15 27)) [] + ,OutlineDef "testfunc1" [Function] (InFileSpan (InFileLoc 18 1)(InFileLoc 18 25)) [] + ,OutlineDef "testfunc1bis" [Function] (InFileSpan (InFileLoc 21 1)(InFileLoc 22 25)) [] + ,OutlineDef "testMethod" [Function] (InFileSpan (InFileLoc 25 1)(InFileLoc 27 13)) [] + ,OutlineDef "ToString" [Class] (InFileSpan (InFileLoc 29 1)(InFileLoc 32 0)) [ + OutlineDef "toString" [Function] (InFileSpan (InFileLoc 30 5)(InFileLoc 30 28)) [] + ] + ,OutlineDef "ToString String" [Instance] (InFileSpan (InFileLoc 32 1)(InFileLoc 35 0)) [ + OutlineDef "toString" [Function] (InFileSpan (InFileLoc 33 5)(InFileLoc 33 18)) [] + ] + ,OutlineDef "Str" [Type] (InFileSpan (InFileLoc 35 1)(InFileLoc 35 16)) [] + ,OutlineDef "Type1" [Data] (InFileSpan (InFileLoc 37 1)(InFileLoc 41 10)) [ + OutlineDef "MkType1_1" [Constructor] (InFileSpan (InFileLoc 37 12)(InFileLoc 37 25)) [] + ,OutlineDef "MkType1_2" [Constructor] (InFileSpan (InFileLoc 38 7)(InFileLoc 41 10)) [ + OutlineDef "mkt2_s" [Field] (InFileSpan (InFileLoc 39 9)(InFileLoc 39 25)) [] + ,OutlineDef "mkt2_i" [Field] (InFileSpan (InFileLoc 40 9)(InFileLoc 40 22)) [] + + ] + + ] + ] + assertEqual "length" (length expected) (length defs) + mapM_ (\(e,c)->assertEqual "outline" e c) (zip expected defs) + )) + +testOutlinePreproc :: (APIFacade a)=> a -> Test +testOutlinePreproc api= TestLabel "testOutlinePreproc" (TestCase ( do + root<-createTestProject + synchronize api root False + let rel="src""A.hs" + write api root (testProjectName <.> ".cabal") $ unlines ["name: "++testProjectName, + "version:0.1", + "cabal-version: >= 1.8", + "build-type: Simple", + "", + "library", + " hs-source-dirs: src", + " exposed-modules: A", + " build-depends: base", + " extensions: CPP", + " ghc-options: -Wall", + " cpp-options: -DCABAL_VERSION=112"] + configure api root Target + -- use api to write temp file + write api root rel $ unlines [ + "{-# LANGUAGE CPP #-}", + "", + "module Module1 where", + "", + "#if CABAL_VERSION > 110", + "testfunc1=reverse \"test\"", + "#endif", + "" + ] + (defs1,nsErrors1)<-getOutline api root rel + assertBool ("errors or warnings on getOutlinePreproc 1:"++show nsErrors1) (null nsErrors1) + let expected1=[ + OutlineDef "testfunc1" [Function] (InFileSpan (InFileLoc 6 1)(InFileLoc 6 25)) [] + ] + assertEqual "length of expected1" (length expected1) (length defs1) + mapM_ (\(e,c)->assertEqual "outline" e c) (zip expected1 defs1) + write api root rel $ unlines [ + "{-# LANGUAGE CPP #-}", + "", + "module Module1 where", + "", + "data Name", + " = Ident String -- ^ /varid/ or /conid/.", + " | Symbol String -- ^ /varsym/ or /consym/", + "#ifdef __GLASGOW_HASKELL__", + " deriving (Eq,Ord,Show,Typeable,Data)", + "#else", + " deriving (Eq,Ord,Show)", + "#endif", + "" + ] + (defs2,nsErrors2)<-getOutline api root rel + assertBool ("errors or warnings on getOutlinePreproc:"++show nsErrors2) (null nsErrors2) + let expected2=[ + OutlineDef "Name" [Data] (InFileSpan (InFileLoc 5 1)(InFileLoc 9 38)) [ + OutlineDef "Ident" [Constructor] (InFileSpan (InFileLoc 6 6)(InFileLoc 6 18)) [], + OutlineDef "Symbol" [Constructor] (InFileSpan (InFileLoc 7 6)(InFileLoc 7 19)) [] + ] + ] + assertEqual "length of expected2" (length expected2) (length defs2) + mapM_ (\(e,c)->assertEqual "outline" e c) (zip expected2 defs2) + write api root rel $ unlines [ + "{-# LANGUAGE CPP #-}", + "", + "module Module1 where", + "", + "#ifdef __GLASGOW_HASKELL__", + "testfunc1=reverse \"test\"", + "#else", + "testfunc2=reverse \"test\"", + "#endif", + "" + ] + (defs3,nsErrors3)<-getOutline api root rel + assertBool ("errors or warnings on getOutlinePreproc 3:"++show nsErrors3) (null nsErrors3) + let expected3=[ + OutlineDef "testfunc1" [Function] (InFileSpan (InFileLoc 6 1)(InFileLoc 6 25)) [] + ] + assertEqual "length of expected3" (length expected3) (length defs3) + mapM_ (\(e,c)->assertEqual "outline" e c) (zip expected3 defs3) + )) + +testPreviewTokenTypes :: (APIFacade a)=> a -> Test +testPreviewTokenTypes api= TestLabel "testPreviewTokenTypes" (TestCase ( do + root<-createTestProject + synchronize api root False + configure api root Target + let rel="src""Main.hs" + write api root rel $ unlines [ + "{-# LANGUAGE TemplateHaskell,CPP #-}", + "-- a comment", + "module Main where", + "", + "main :: IO (Int)", + "main = do" , + " putStr ('h':\"ello Prefs!\")", + " return (2 + 2)", + "", + "#if USE_TH", + "$( derive makeTypeable ''Extension )", + "#endif", + "" + ] + (tts,nsErrors1)<-getTokenTypes api root rel + assertBool ("errors or warnings on getTokenTypes:"++show nsErrors1) (null nsErrors1) + let expectedS="[{\"D\":[1,1,1,37]},{\"D\":[2,1,2,13]},{\"K\":[3,1,3,7]},{\"IC\":[3,8,3,12]},{\"K\":[3,13,3,18]},{\"IV\":[5,1,5,5]},{\"S\":[5,6,5,8]},{\"IC\":[5,9,5,11]},{\"SS\":[5,12,5,13]},{\"IC\":[5,13,5,16]},{\"SS\":[5,16,5,17]},{\"IV\":[6,1,6,5]},{\"S\":[6,6,6,7]},{\"K\":[6,8,6,10]},{\"IV\":[7,9,7,15]},{\"SS\":[7,16,7,17]},{\"LC\":[7,17,7,20]},{\"S\":[7,20,7,21]},{\"LS\":[7,21,7,34]},{\"SS\":[7,34,7,35]},{\"IV\":[8,9,8,15]},{\"SS\":[8,16,8,17]},{\"LI\":[8,17,8,18]},{\"IV\":[8,19,8,20]},{\"LI\":[8,21,8,22]},{\"SS\":[8,22,8,23]},{\"PP\":[10,1,10,11]},{\"TH\":[11,1,11,3]},{\"IV\":[11,4,11,10]},{\"IV\":[11,11,11,23]},{\"TH\":[11,24,11,26]},{\"IC\":[11,26,11,35]},{\"SS\":[11,36,11,37]},{\"PP\":[12,1,12,7]}]" + assertEqual "" expectedS (encode $ toJSON tts) + )) + +testThingAtPoint :: (APIFacade a)=> a -> Test +testThingAtPoint api= TestLabel "testThingAtPoint" (TestCase ( do + root<-createTestProject + synchronize api root False + configure api root Target + let rel="src""Main.hs" + write api root rel $ unlines [ + "module Main where", + "main=return $ map id \"toto\"" + ] + (tap1,nsErrors1)<-getThingAtPoint api root rel 2 16 True True + assertBool ("errors or warnings on getThingAtPoint1:"++show nsErrors1) (null nsErrors1) + assertEqual "not just typed qualified" (Just "GHC.Base.map :: forall a b.\n (a -> b) -> [a] -> [b] GHC.Types.Char GHC.Types.Char") tap1 + (tap2,nsErrors2)<-getThingAtPoint api root rel 2 16 False True + assertBool ("errors or warnings on getThingAtPoint2:"++show nsErrors2) (null nsErrors2) + assertEqual "not just typed unqualified" (Just "map :: forall a b. (a -> b) -> [a] -> [b] Char Char") tap2 + (tap3,nsErrors3)<-getThingAtPoint api root rel 2 16 True False + assertBool ("errors or warnings on getThingAtPoint3:"++show nsErrors3) (null nsErrors3) + assertEqual "not just untyped qualified" (Just "GHC.Base.map v") tap3 + + (tap4,nsErrors4)<-getThingAtPoint api root rel 2 16 False False + assertBool ("errors or warnings on getThingAtPoint4:"++show nsErrors4) (null nsErrors4) + assertEqual "not just untyped unqualified" (Just "map v") tap4 + + )) + +testNamesInScope :: (APIFacade a)=> a -> Test +testNamesInScope api= TestLabel "testNamesInScope" (TestCase ( do + root<-createTestProject + synchronize api root False + configure api root Source + let rel="src""Main.hs" + writeFile (root rel) $ unlines [ + "module Main where", + "import B.D", + "main=return $ map id \"toto\"" + ] + build api root True Source + synchronize api root False + --c1<-getClockTime + (mtts,nsErrors1)<-getNamesInScope api root rel + --c2<-getClockTime + --putStrLn ("testNamesInScope: " ++ (timeDiffToString $ diffClockTimes c2 c1)) + assertBool ("errors or warnings on getNamesInScope:"++show nsErrors1) (null nsErrors1) + assertBool "getNamesInScope not just" (isJust mtts) + let tts=fromJust mtts + assertBool "does not contain Main.main" (elem "Main.main" tts) + assertBool "does not contain B.D.fD" (elem "B.D.fD" tts) + assertBool "does not contain GHC.Types.Char" (elem "GHC.Types.Char" tts) + )) + +testInPlaceReference :: (APIFacade a)=> a -> Test +testInPlaceReference api= TestLabel "testInPlaceReference" (TestCase ( do + root<-createTestProject + synchronize api root False + writeFile (root (testProjectName <.> ".cabal")) $ unlines ["name: "++testProjectName, + "version:0.1", + "cabal-version: >= 1.8", + "build-type: Simple", + "", + "library", + " hs-source-dirs: src", + " exposed-modules: A,B.C", + " build-depends: base", + "", + "executable BWTest", + " hs-source-dirs: src", + " main-is: Main.hs", + " other-modules: B.D", + " build-depends: base, BWTest", + "", + "test-suite BWTest-test", + " type: exitcode-stdio-1.0", + " hs-source-dirs: test", + " main-is: Main.hs", + " other-modules: TestA", + " build-depends: base, BWTest", + "" + ] + let rel="src""Main.hs" + writeFile (root rel) $ unlines [ + "module Main where", + "import B.C", + "main=return $ map id \"toto\"" + ] + let rel3="test""TestA.hs" + writeFile (root rel3) $ unlines ["module TestA where","import A","fTA=undefined"] + let rel2="src""A.hs" + writeFile (root rel2) $ unlines ["module A where","import B.C","fA=undefined"] + (boolOKc,nsOKc)<-configure api root Source + assertBool ("returned false on configure:"++show nsOKc) boolOKc + assertBool ("errors or warnings on configure:"++show nsOKc) (null nsOKc) + (BuildResult boolOK _,nsOK)<-build api root True Source + assertBool ("returned false on build") boolOK + assertBool ("errors or warnings on build:"++show nsOK) (null nsOK) + synchronize api root True + (mtts,nsErrors1)<-getNamesInScope api root rel + assertBool ("errors or warnings on getNamesInScope in place:"++show nsErrors1) (null nsErrors1) + assertBool "getNamesInScope in place not just" (isJust mtts) + let tts=fromJust mtts + assertBool "getNamesInScope in place 1 does not contain Main.main" (elem "Main.main" tts) + assertBool "getNamesInScope in place 1 does not contain B.C.fC" (elem "B.C.fC" tts) + (tap1,nsErrorsTap1)<-getThingAtPoint api root rel 3 16 True True + assertBool ("errors or warnings on getThingAtPoint1 in place:"++show nsErrorsTap1) (null nsErrorsTap1) + assertEqual "not just typed qualified" (Just "GHC.Base.map :: forall a b.\n (a -> b) -> [a] -> [b] GHC.Types.Char GHC.Types.Char") tap1 + (mtts2,nsErrors2)<-getNamesInScope api root rel2 + assertBool ("errors or warnings on getNamesInScope in place 2:"++show nsErrors2) (null nsErrors2) + assertBool "getNamesInScope in place 2 not just" (isJust mtts2) + let tts2=fromJust mtts2 + assertBool "getNamesInScope in place 2 does not contain A.fA" (elem "A.fA" tts2) + assertBool "getNamesInScope in place 2 does not contain B.C.fC" (elem "B.C.fC" tts2) + + (mtts3,nsErrors3)<-getNamesInScope api root rel3 + assertBool ("errors or warnings on getNamesInScope in place 3:"++show nsErrors3) (null nsErrors3) + assertBool "getNamesInScope in place 3 not just" (isJust mtts3) + let tts3=fromJust mtts3 + assertBool "getNamesInScope in place 3 does not contain A.fA" (elem "A.fA" tts3) + )) + +testCabalComponents :: (APIFacade a)=> a -> Test +testCabalComponents api= TestLabel "testCabalComponents" (TestCase ( do + root<-createTestProject + synchronize api root False + (cps,nsOK)<-getCabalComponents api root + assertBool ("errors or warnings on getCabalComponents:"++show nsOK) (null nsOK) + assertEqual "not three components" 3 (length cps) + let (l:ex:ts:[])=cps + assertEqual "not library true" (CCLibrary True) l + assertEqual "not executable true" (CCExecutable "BWTest" True) ex + assertEqual "not test suite true" (CCTestSuite "BWTest-test" True) ts + let cf=testCabalFile root + writeFile cf $ unlines ["name: "++testProjectName, + "version:0.1", + "cabal-version: >= 1.8", + "build-type: Simple", + "", + "library", + " hs-source-dirs: src", + " exposed-modules: A", + " other-modules: B.C", + " build-depends: base", + " buildable: False", + "", + "executable BWTest", + " hs-source-dirs: src", + " main-is: Main.hs", + " other-modules: B.D", + " build-depends: base", + " buildable: False", + "", + "test-suite BWTest-test", + " type: exitcode-stdio-1.0", + " hs-source-dirs: test", + " main-is: Main.hs", + " other-modules: TestA", + " build-depends: base", + " buildable: False", + "" + ] + configure api root Source + (cps2,nsOK2)<-getCabalComponents api root + assertBool ("errors or warnings on getCabalComponents:"++show nsOK2) (null nsOK2) + assertEqual "not three components" 3 (length cps2) + let (l2:ex2:ts2:[])=cps2 + assertEqual "not library false" (CCLibrary False) l2 + assertEqual "not executable false" (CCExecutable "BWTest" False) ex2 + assertEqual "not test suite false" (CCTestSuite "BWTest-test" False) ts2 + )) + +testCabalDependencies :: (APIFacade a)=> a -> Test +testCabalDependencies api= TestLabel "testCabalDependencies" (TestCase ( do + root<-createTestProject + synchronize api root False + (cps,nsOK)<-getCabalDependencies api root + assertBool ("errors or warnings on getCabalDependencies:"++show nsOK) (null nsOK) + assertEqual "not two databases" 2 (length cps) + let (_:(_,pkgs):[])=cps + let base=filter (\pkg->(cp_name pkg)=="base") pkgs + assertEqual "not 1 base" 1 (length base) + let (l:ex:ts:[])=cp_dependent $ head base + assertEqual "not library true" (CCLibrary True) l + assertEqual "not executable true" (CCExecutable "BWTest" True) ex + assertEqual "not test suite true" (CCTestSuite "BWTest-test" True) ts + )) + +testProjectName :: String +testProjectName="BWTest" + +testCabalContents :: String +testCabalContents = unlines ["name: "++testProjectName, + "version:0.1", + "cabal-version: >= 1.8", + "build-type: Simple", + "", + "library", + " hs-source-dirs: src", + " exposed-modules: A", + " other-modules: B.C", + " build-depends: base", + "", + "executable BWTest", + " hs-source-dirs: src", + " main-is: Main.hs", + " other-modules: B.D", + " build-depends: base", + "", + "test-suite BWTest-test", + " type: exitcode-stdio-1.0", + " hs-source-dirs: test", + " main-is: Main.hs", + " other-modules: TestA", + " build-depends: base", + "" + ] + +testCabalFile :: FilePath -> FilePath +testCabalFile root =root (testProjectName <.> ".cabal") + +testAContents :: String +testAContents=unlines ["module A where","fA=undefined"] +testCContents :: String +testCContents=unlines ["module B.C where","fC=undefined"] +testDContents :: String +testDContents=unlines ["module B.D where","fD=undefined"] +testMainContents :: String +testMainContents=unlines ["module Main where","main=undefined"] +testMainTestContents :: String +testMainTestContents=unlines ["module Main where","main=undefined"] +testTestAContents :: String +testTestAContents=unlines ["module TestA where","fTA=undefined"] + +createTestProject :: IO(FilePath) +createTestProject = do + temp<-getTemporaryDirectory + let root=temp testProjectName + ex<-(doesDirectoryExist root) + when ex (removeDirectoryRecursive root) + createDirectory root + writeFile (testCabalFile root) testCabalContents + let srcF=root "src" + createDirectory srcF + writeFile (srcF "A.hs") testAContents + let b=srcF "B" + createDirectory b + writeFile (b "C.hs") testCContents + writeFile (b "D.hs") testDContents + writeFile (srcF "Main.hs") testMainContents + let testF=root "test" + createDirectory testF + writeFile (testF "Main.hs") testMainTestContents + writeFile (testF "TestA.hs") testTestAContents + return root + +removeSpaces :: String -> String +removeSpaces = (filter (/=':')) . (filter (not . isSpace)) + +assertEqualNotesWithoutSpaces :: String -> BWNote -> BWNote -> IO() +assertEqualNotesWithoutSpaces msg n1 n2=do + let + n1'=n1{bwn_title=removeSpaces $ bwn_title n1} + n2'=n1{bwn_title=removeSpaces $ bwn_title n2} + assertEqual msg n1' n2' diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,46 @@ +-- | +-- Module : Main +-- Author : JP Moresmau +-- Copyright : (c) JP Moresmau 2011 +-- License : BSD3 +-- +-- Maintainer : jpmoresmau@gmail.com +-- Stability : beta +-- Portability : portable +-- +-- Testing exe entry point +-- TODO replace with test-framework +module Main where + +import Language.Haskell.BuildWrapper.APITest +import Language.Haskell.BuildWrapper.CMDTests + +import Test.Framework (defaultMain, testGroup) +import Test.Framework.Providers.HUnit + +main = defaultMain tests + +tests = [testGroup "Unit Tests" (concatMap (hUnitTestToTests) unitTests), + testGroup "Command Tests" (concatMap (hUnitTestToTests) cmdTests)] + +--import Language.Haskell.BuildWrapper.APITest +--import Language.Haskell.BuildWrapper.CMDTests +-- +--import Control.Monad +--import Data.Monoid +-- +--import System.Exit (exitFailure) +--import Test.HUnit +-- +--main :: IO() +--main = do +-- unit<-mapM runTestTT [unitTests] +-- cmd<-mapM runTestTT [cmdTests] +-- --let cmd=[] +-- let allCounts=mconcat (unit ++ cmd) +-- when ((errors allCounts)>0 || (failures allCounts)>0) exitFailure +-- +-- +--instance Monoid Counts where +-- mempty =Counts 0 0 0 0 +-- mappend (Counts a b c d) (Counts a' b' c' d')=Counts (a+a') (b+b') (c+c') (d+d')