diff --git a/leksah-server.cabal b/leksah-server.cabal --- a/leksah-server.cabal +++ b/leksah-server.cabal @@ -1,5 +1,5 @@ name: leksah-server -version: 0.13.1.1 +version: 0.14.0.0 cabal-version: >= 1.10.2 build-type: Simple license: GPL @@ -36,10 +36,11 @@ binary-shared >=0.8 && <0.9, bytestring >=0.9.0.1 && <0.11, containers >=0.2.0.0 && <0.6, executable-path >=0.0.3 && <0.1, directory >=1.0.0.2 && <1.3, filepath >=1.1.0.1 && <1.4, ghc >=7.0.4 && <7.9, - ltk >=0.13.1.0 && <0.14, parsec >=2.1.0.1 && <3.2, + ltk >=0.14.0.0 && <0.15, parsec >=2.1.0.1 && <3.2, pretty >=1.0.1.0 && <1.2, time >=1.1 && <1.5, deepseq >=1.1 && <1.4, - hslogger >= 1.0.7 && <1.3, network >=2.2 && <3.0, conduit >= 1.0.8 && <1.1, - attoparsec-conduit >=1.0.1.2 && <1.1, attoparsec >=0.10.0.3 && <0.12, + hslogger >= 1.0.7 && <1.3, network >=2.2 && <3.0, conduit >= 1.0.8 && <1.2, + conduit-extra >=1.0.0.1 && <1.2, resourcet, + attoparsec-conduit >=1.0.1.2 && <1.2, attoparsec >=0.10.0.3 && <0.13, transformers >=0.2.2.0 && <0.4, strict >=0.3.2 && <0.4, text >=0.11.3.1 && <1.2 if (impl(ghc >= 7.8)) build-depends: haddock >= 2.7.2 && <2.15 @@ -99,10 +100,11 @@ binary-shared >=0.8 && <0.9, bytestring >=0.9.0.1 && <0.11, containers >=0.2.0.0 && <0.6, executable-path >=0.0.3 && <0.1, directory >=1.0.0.2 && <1.3, filepath >=1.1.0.1 && <1.6, ghc >=7.0.4 && <7.9, - ltk >=0.13.1.0 && <0.14, parsec >=2.1.0.1 && <3.2, + ltk >=0.14.0.0 && <0.15, parsec >=2.1.0.1 && <3.2, pretty >=1.0.1.0 && <1.2, time >=1.1 && <1.5, deepseq >=1.1 && <1.4, - hslogger >= 1.0.7 && <1.3, network >=2.2 && <3.0, conduit >= 1.0.8 && <1.1, - attoparsec-conduit >=1.0.1.2 && <1.1, attoparsec >=0.10.0.3 && <0.12, + hslogger >= 1.0.7 && <1.3, network >=2.2 && <3.0, conduit >= 1.0.8 && <1.2, + conduit-extra >=1.0.0.1 && <1.2, resourcet, + attoparsec-conduit >=1.0.1.2 && <1.2, attoparsec >=0.10.0.3 && <0.13, transformers >=0.2.2.0 && <0.4, strict >=0.3.2 && <0.4, text >=0.11.3.1 && <1.2 if (impl(ghc >= 7.8)) build-depends: haddock >= 2.7.2 && <2.15 @@ -173,8 +175,9 @@ ghc-prof-options: -auto-all -prof -- ghc-shared-options: -auto-all -prof build-depends: base >= 4.0.0.0 && <4.8, hslogger >= 1.0.7 && <1.3, deepseq >=1.1 && <1.4, - bytestring >=0.9.0.1 && <0.11, conduit >= 1.0.8 && <1.1, - attoparsec-conduit >=1.0.1.2 && <1.1, attoparsec >=0.10.0.3 && <0.12, + bytestring >=0.9.0.1 && <0.11, conduit >= 1.0.8 && <1.2, + conduit-extra >=1.0.0.1 && <1.2, resourcet, + attoparsec-conduit >=1.0.1.2 && <1.2, attoparsec >=0.10.0.3 && <0.13, transformers >=0.2.2.0 && <0.4, text >=0.11.3.1 && <1.2 if (impl(ghc >= 7.2)) @@ -196,8 +199,9 @@ hs-source-dirs: tests main-is: TestTool.hs build-depends: base >= 4.0.0.0 && <4.8, hslogger >= 1.0.7 && <1.3, - leksah-server == 0.13.1.1, - HUnit >=1.2 && <1.3, transformers >=0.2.2.0 && <0.4, conduit >= 1.0.8 && <1.1 + leksah-server == 0.14.0.0, + HUnit >=1.2 && <1.3, transformers >=0.2.2.0 && <0.4, conduit >= 1.0.8 && <1.2, + conduit-extra >=1.0.0.1 && <1.2, resourcet if (impl(ghc >= 7.2)) build-depends: process >= 1.1 && <1.3 diff --git a/src/IDE/Core/CTypes.hs b/src/IDE/Core/CTypes.hs --- a/src/IDE/Core/CTypes.hs +++ b/src/IDE/Core/CTypes.hs @@ -1,5 +1,9 @@ -{-# OPTIONS_GHC -XFlexibleInstances -XDeriveDataTypeable -XExistentialQuantification - -XMultiParamTypeClasses -XFlexibleContexts -fno-warn-orphans #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} ----------------------------------------------------------------------------- -- -- Module : IDE.Core.CTypes @@ -83,12 +87,17 @@ import Distribution.Text (simpleParse, display) import qualified Data.ByteString.Char8 as BS (unpack, empty) import qualified Data.Map as Map (lookup,keysSet,splitLookup, insertWith,empty,elems,union) -import Text.PrettyPrint as PP import Text.PrinterParser import Data.Char (isAlpha) import Control.DeepSeq (NFData(..)) import PackageConfig (PackageConfig) import qualified Distribution.InstalledPackageInfo as IPI +import Data.Text (Text) +import Data.Monoid ((<>)) +import Text.PrettyPrint (fsep, Doc, (<+>), empty, text) +import qualified Text.PrettyPrint as PP + (text, comma, punctuate, parens) +import qualified Data.Text as T (pack, tail, span, unpack) #if !MIN_VERSION_ghc(7,7,0) import Distribution.Package(PackageName(..)) #endif @@ -97,9 +106,9 @@ -- | Information about the system, extraced from .hi and source files -- -leksahVersion, configDirName :: String -leksahVersion = "0.13" -configDirName = ".leksah-" ++ leksahVersion +leksahVersion, configDirName :: FilePath +leksahVersion = "0.14" +configDirName = ".leksah-" <> leksahVersion metadataVersion :: Integer metadataVersion = 7 @@ -119,13 +128,13 @@ wcRebuild :: Bool, wcPackage :: PackageIdentifier, wcPath :: FilePath, - wcModList :: [(String,FilePath)]} + wcModList :: [(Text,FilePath)]} | ParseHeaderCommand { hcFilePath :: FilePath} deriving (Eq,Ord,Show,Read) data ServerAnswer = ServerOK - | ServerFailed String + | ServerFailed Text | ServerHeader (Either [ImportDecl] Int) deriving (Eq,Ord,Show,Read) @@ -134,15 +143,15 @@ data GenScope = forall alpha. SymbolTable alpha => GenScopeC (PackScope alpha) class SymbolTable alpha where - symLookup :: String -> alpha -> [Descr] - symbols :: alpha -> Set String - symSplitLookup :: String -> alpha -> (alpha , Maybe [Descr], alpha) - symInsert :: String -> [Descr] -> alpha -> alpha + symLookup :: Text -> alpha -> [Descr] + symbols :: alpha -> Set Text + symSplitLookup :: Text -> alpha -> (alpha , Maybe [Descr], alpha) + symInsert :: Text -> [Descr] -> alpha -> alpha symEmpty :: alpha symElems :: alpha -> [[Descr]] symUnion :: alpha -> alpha -> alpha -instance SymbolTable (Map String [Descr]) where +instance SymbolTable (Map Text [Descr]) where symLookup str smap = case str `Map.lookup` smap of Just dl -> dl Nothing -> [] @@ -166,7 +175,7 @@ newtype Present alpha = Present alpha instance Show (Present PackageDescr) where - show (Present pd) = (packageIdentifierToString . pdPackage) pd + show (Present pd) = T.unpack $ (packageIdentifierToString . pdPackage) pd instance Eq PackageDescr where (== ) a b = pdPackage a == pdPackage b @@ -177,7 +186,7 @@ data ModuleDescr = ModuleDescr { mdModuleId :: PackModule , mdMbSourcePath :: (Maybe FilePath) -- unqualified - , mdReferences :: (Map ModuleName (Set String)) -- imports + , mdReferences :: (Map ModuleName (Set Text)) -- imports , mdIdDescriptions :: [Descr] } deriving (Show,Typeable) @@ -197,7 +206,7 @@ deriving (Show,Read,Typeable,Eq,Ord) data RealDescr = RealDescr { - dscName' :: String + dscName' :: Text , dscMbTypeStr' :: Maybe ByteString , dscMbModu' :: Maybe PackModule , dscMbLocation' :: Maybe Location @@ -218,7 +227,7 @@ isReexported (Reexported _) = True isReexported _ = False -dscName :: Descr -> String +dscName :: Descr -> Text dscName (Reexported d) = dscName (dsrDescr d) dscName (Real d) = dscName' d @@ -259,9 +268,9 @@ | DataDescr [SimpleDescr] [SimpleDescr] -- ^ first constructors, then fields | TypeDescr | NewtypeDescr SimpleDescr (Maybe SimpleDescr) -- ^ first constructors, then maybe field - | ClassDescr [String] [SimpleDescr] -- ^ first super, then methods + | ClassDescr [Text] [SimpleDescr] -- ^ first super, then methods | MethodDescr Descr -- ^ classDescr - | InstanceDescr [String] -- ^ binds + | InstanceDescr [Text] -- ^ binds | KeywordDescr | ExtensionDescr | ModNameDescr @@ -278,7 +287,7 @@ getDefault = Variable data SimpleDescr = SimpleDescr { - sdName :: String, + sdName :: Text, sdType :: Maybe ByteString, sdLocation :: Maybe Location, sdComment :: Maybe ByteString, @@ -306,27 +315,27 @@ deriving (Eq, Ord,Read,Show,Typeable) instance Show (Present PackModule) where - showsPrec _ (Present pd) = showString ((packageIdentifierToString . pack) pd) . showChar ':' + showsPrec _ (Present pd) = showString (T.unpack $ (packageIdentifierToString . pack) pd) . showChar ':' . showString (display (modu pd)) -parsePackModule :: String -> PackModule -parsePackModule str = let (pack',mod') = span (\c -> c /= ':') str +parsePackModule :: Text -> PackModule +parsePackModule str = let (pack',mod') = T.span (\c -> c /= ':') str in case packageIdentifierFromString $ pack' of - Nothing -> perror $ "Types>>parsePackModule: Can't parse package:" ++ str - Just pi'-> case simpleParse $ tail mod' of - Nothing -> perror $ - "Types>>parsePackModule: Can't parse module:" ++ str + Nothing -> perror . T.unpack $ "Types>>parsePackModule: Can't parse package:" <> str + Just pi'-> case simpleParse . T.unpack $ T.tail mod' of + Nothing -> perror . T.unpack $ + "Types>>parsePackModule: Can't parse module:" <> str Just mn -> (PM pi' mn) where perror s = error $ "cannot parse PackModule from " ++ s -showPackModule :: PackModule -> String -showPackModule = show. Present +showPackModule :: PackModule -> Text +showPackModule = T.pack . show . Present -packageIdentifierToString :: PackageIdentifier -> String -packageIdentifierToString = display +packageIdentifierToString :: PackageIdentifier -> Text +packageIdentifierToString = T.pack . display -packageIdentifierFromString :: String -> Maybe PackageIdentifier -packageIdentifierFromString = simpleParse +packageIdentifierFromString :: Text -> Maybe PackageIdentifier +packageIdentifierFromString = simpleParse . T.unpack instance Show (Present Descr) where showsPrec _ (Present descr) = case dscMbComment descr of @@ -338,7 +347,7 @@ c com = showString $ unlines $ map (\(i,l) -> if i == 0 then "-- | " ++ l else "-- " ++ l) $ zip [0 .. length nelines - 1] nelines - where nelines = nonEmptyLines (BS.unpack com) + where nelines = nonEmptyLines $ BS.unpack com t = case dscMbTypeStr descr of Just ti -> showString $ BS.unpack ti Nothing -> id @@ -371,7 +380,7 @@ -- | A portion of the source, spanning one or more lines and zero or more columns. data SrcSpan = SrcSpan - { srcSpanFilename :: String + { srcSpanFilename :: FilePath , srcSpanStartLine :: Int , srcSpanStartColumn :: Int , srcSpanEndLine :: Int @@ -380,8 +389,9 @@ deriving (Eq,Ord,Show) data Location = Location { - locationSLine :: Int -, locationSCol :: Int + locationFile :: FilePath +, locationSLine :: Int +, locationSCol :: Int , locationELine :: Int , locationECol :: Int } deriving (Show,Eq,Ord,Read,Typeable) @@ -404,11 +414,11 @@ -- | An import declaration. data ImportDecl = ImportDecl { importLoc :: Location - , importModule :: String -- ^ name of the module imported. + , importModule :: Text -- ^ name of the module imported. , importQualified :: Bool -- ^ imported @qualified@? , importSrc :: Bool -- ^ imported with @{-\# SOURCE \#-}@? - , importPkg :: Maybe String -- ^ imported with explicit package name - , importAs :: Maybe String -- ^ optional alias name in an @as@ clause. + , importPkg :: Maybe Text -- ^ imported with explicit package name + , importAs :: Maybe Text -- ^ optional alias name in an @as@ clause. , importSpecs :: Maybe ImportSpecList -- ^ optional list of import specifications. } @@ -446,18 +456,18 @@ -- | An import specification, representing a single explicit item imported -- (or hidden) from a module. data ImportSpec - = IVar String -- ^ variable - | IAbs String -- ^ @T@: + = IVar Text -- ^ variable + | IAbs Text -- ^ @T@: -- the name of a class, datatype or type synonym. - | IThingAll String -- ^ @T(..)@: + | IThingAll Text -- ^ @T(..)@: -- a class imported with all of its methods, or -- a datatype imported with all of its constructors. - | IThingWith String [String] -- ^ @T(C_1,...,C_n)@: + | IThingWith Text [Text] -- ^ @T(C_1,...,C_n)@: -- a class imported with some of its methods, or -- a datatype imported with some of its constructors. deriving (Eq,Ord,Read,Show) -newtype VName = VName String +newtype VName = VName Text instance Pretty ImportSpec where pretty (IVar name) = pretty (VName name) @@ -467,7 +477,7 @@ pretty name <> (parenList (map (pretty.VName) nameList)) instance Pretty VName where - pretty (VName str) = if isOperator str then PP.parens (PP.text str) else (PP.text str) + pretty (VName t) = let str = T.unpack t in if isOperator str then PP.parens (PP.text str) else PP.text str isOperator :: String -> Bool isOperator ('(':_) = False -- (), (,) etc diff --git a/src/IDE/Core/Serializable.hs b/src/IDE/Core/Serializable.hs --- a/src/IDE/Core/Serializable.hs +++ b/src/IDE/Core/Serializable.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE RecordWildCards #-} {-# OPTIONS_GHC -XScopedTypeVariables -XStandaloneDeriving @@ -32,7 +33,12 @@ import Distribution.ModuleName (ModuleName) import IDE.Core.CTypes +import Control.Applicative ((<$>)) +import Data.Text (Text) +import qualified Data.Text as T (pack, unpack) +#if !MIN_VERSION_ghc(7,7,0) import Data.Typeable (Typeable) +#endif #if !MIN_VERSION_ghc(7,7,0) deriving instance Typeable PackageIdentifier @@ -41,6 +47,12 @@ #endif ----------------------------------------------------------- +instance BinaryShared Text where + put = put . T.unpack + get = T.pack <$> get + putShared x = putShared (x . T.pack) . T.unpack + getShared x = T.pack <$> getShared (T.unpack <$> x) + instance BinaryShared PackModule where put = putShared (\ (PM pack' modu') -> do (put pack') @@ -221,16 +233,18 @@ return (SimpleDescr sdName' sdType' sdLocation' sdComment' sdExported') instance BinaryShared Location where - put (Location locationSLine' locationSCol' locationELine' locationECol') - = do put locationSLine' - put locationSCol' - put locationELine' - put locationECol' - get = do locationSLine' <- get - locationSCol' <- get - locationELine' <- get - locationECol' <- get - return (Location locationSLine' locationSCol' locationELine' locationECol') + put Location{..} + = do put locationFile + put locationSLine + put locationSCol + put locationELine + put locationECol + get = do locationFile <- get + locationSLine <- get + locationSCol <- get + locationELine <- get + locationECol <- get + return Location{..} instance BinaryShared ModuleName where diff --git a/src/IDE/HeaderParser.hs b/src/IDE/HeaderParser.hs --- a/src/IDE/HeaderParser.hs +++ b/src/IDE/HeaderParser.hs @@ -37,6 +37,8 @@ import IDE.Utils.FileUtils (figureOutHaddockOpts) import Control.Monad.IO.Class (MonadIO(..)) import System.IO.Strict (readFile) +import qualified Data.Text as T (pack) +import Control.Applicative ((<$>)) #if !MIN_VERSION_ghc(7,6,0) showSDoc :: DynFlags -> O.SDoc -> String @@ -73,11 +75,11 @@ transformImport dflags (L srcSpan importDecl) = ImportDecl { importLoc = srcSpanToLocation srcSpan, - importModule = modName, + importModule = T.pack modName, importQualified = ideclQualified importDecl, importSrc = ideclSource importDecl, - importPkg = pkgQual, - importAs = impAs, + importPkg = T.pack <$> pkgQual, + importAs = T.pack <$> impAs, importSpecs = specs} where modName = moduleNameString $ unLoc $ ideclName importDecl @@ -93,20 +95,20 @@ transformEntity :: DynFlags -> LIE RdrName -> Maybe ImportSpec #if MIN_VERSION_ghc(7,2,0) -transformEntity dflags (L _ (IEVar name)) = Just (IVar (showSDoc dflags (pprPrefixOcc name))) +transformEntity dflags (L _ (IEVar name)) = Just (IVar (T.pack $ showSDoc dflags (pprPrefixOcc name))) #else -transformEntity dflags (L _ (IEVar name)) = Just (IVar (showSDoc dflags (pprHsVar name))) +transformEntity dflags (L _ (IEVar name)) = Just (IVar (T.pack $ showSDoc dflags (pprHsVar name))) #endif -transformEntity dflags (L _ (IEThingAbs name)) = Just (IAbs (showRdrName dflags name)) -transformEntity dflags (L _ (IEThingAll name)) = Just (IThingAll (showRdrName dflags name)) -transformEntity dflags (L _ (IEThingWith name list)) = Just (IThingWith (showRdrName dflags name) - (map (showRdrName dflags) list)) +transformEntity dflags (L _ (IEThingAbs name)) = Just (IAbs (T.pack $ showRdrName dflags name)) +transformEntity dflags (L _ (IEThingAll name)) = Just (IThingAll (T.pack $ showRdrName dflags name)) +transformEntity dflags (L _ (IEThingWith name list)) = Just (IThingWith (T.pack $ showRdrName dflags name) + (map (T.pack . showRdrName dflags) list)) transformEntity _ _ = Nothing #if MIN_VERSION_ghc(7,2,0) srcSpanToLocation :: SrcSpan -> Location srcSpanToLocation (RealSrcSpan span') - = Location (srcSpanStartLine span') (srcSpanStartCol span') + = Location (unpackFS $ srcSpanFile span') (srcSpanStartLine span') (srcSpanStartCol span') (srcSpanEndLine span') (srcSpanEndCol span') srcSpanToLocation _ = error "srcSpanToLocation: unhelpful span" @@ -122,7 +124,7 @@ srcSpanToLocation span' | not (isGoodSrcSpan span') = error "srcSpanToLocation: unhelpful span" srcSpanToLocation span' - = Location (srcSpanStartLine span') (srcSpanStartCol span') + = Location (unpackFS $ srcSpanFile span') (srcSpanStartLine span') (srcSpanStartCol span') (srcSpanEndLine span') (srcSpanEndCol span') srcSpanStartLine' :: SrcSpan -> Int diff --git a/src/IDE/Metainfo/Collector.hs b/src/IDE/Metainfo/Collector.hs --- a/src/IDE/Metainfo/Collector.hs +++ b/src/IDE/Metainfo/Collector.hs @@ -1,4 +1,6 @@ -{-# OPTIONS_GHC -XScopedTypeVariables -fno-warn-type-defaults #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-type-defaults #-} ----------------------------------------------------------------------------- -- -- Module : Main @@ -40,7 +42,6 @@ import Data.Time import Control.Exception (catch, SomeException) -import MyMissing(trim) import System.Log import System.Log.Logger(updateGlobalLogger,rootLoggerName,addHandler,debugM,infoM,errorM, setLevel) @@ -61,6 +62,10 @@ doesDirectoryExist) import IDE.Metainfo.SourceCollectorH (PackageCollectStats(..)) import Control.Monad.IO.Class (MonadIO(..)) +import qualified Data.Text as T (strip, pack, unpack) +import Data.Text (Text) +import Control.Applicative ((<$>)) +import Data.Monoid ((<>)) -- -------------------------------------------------------------------- -- Command line options @@ -69,7 +74,7 @@ data Flag = CollectSystem - | ServerCommand (Maybe String) + | ServerCommand (Maybe Text) --modifiers | Rebuild | Sources @@ -78,8 +83,8 @@ | VersionF | Help | Debug - | Verbosity String - | LogFile String + | Verbosity Text + | LogFile Text | Forever | EndWithLast deriving (Show,Eq) @@ -90,7 +95,7 @@ -- main functions Option ['s'] ["system"] (NoArg CollectSystem) "Collects new information for installed packages" - , Option ['r'] ["server"] (OptArg ServerCommand "Maybe Port") + , Option ['r'] ["server"] (OptArg (ServerCommand . (T.pack <$>)) "Maybe Port") "Start as server." , Option ['b'] ["rebuild"] (NoArg Rebuild) "Modifier for -s and -p: Rebuild metadata" @@ -102,9 +107,9 @@ "Display command line options" , Option ['d'] ["debug"] (NoArg Debug) "Write ascii pack files" - , Option ['e'] ["verbosity"] (ReqArg Verbosity "Verbosity") + , Option ['e'] ["verbosity"] (ReqArg (Verbosity . T.pack) "Verbosity") "One of DEBUG, INFO, NOTICE, WARNING, ERROR, CRITICAL, ALERT, EMERGENCY" - , Option ['l'] ["logfile"] (ReqArg LogFile "LogFile") + , Option ['l'] ["logfile"] (ReqArg (LogFile . T.pack) "LogFile") "File path for logging messages" , Option ['f'] ["forever"] (NoArg Forever) "Don't end the server when last connection ends" @@ -142,7 +147,7 @@ _ -> Nothing) o let verbosity = case verbosity' of [] -> INFO - h:_ -> read h + h:_ -> read $ T.unpack h let logFile' = catMaybes $ map (\x -> case x of LogFile s -> Just s @@ -152,7 +157,7 @@ h:_ -> Just h updateGlobalLogger rootLoggerName (\ l -> setLevel verbosity l) when (isJust logFile) $ do - handler' <- fileHandler (fromJust logFile) verbosity + handler' <- fileHandler (T.unpack $ fromJust logFile) verbosity updateGlobalLogger rootLoggerName (\ l -> addHandler handler' l) infoM "leksah-server" $ "***server start" debugM "leksah-server" $ "args: " ++ show args @@ -195,7 +200,7 @@ waitFor running return () (Just ps:_) -> do - let port = read ps + let port = read $ T.unpack ps running <- serveOne Nothing (server (PortNum (fromIntegral port)) newPrefs connRef threadId localServerAddr) waitFor running @@ -239,7 +244,7 @@ hPutStrLn h (show ServerOK) hFlush h) (\ (e :: SomeException) -> do - hPutStrLn h (show (ServerFailed (show e))) + hPutStrLn h (show (ServerFailed (T.pack $ show e))) hFlush h) WorkspaceCommand rebuild package path modList -> catch (do @@ -247,7 +252,7 @@ hPutStrLn h (show ServerOK) hFlush h) (\ (e :: SomeException) -> do - hPutStrLn h (show (ServerFailed (show e))) + hPutStrLn h (show (ServerFailed (T.pack $ show e))) hFlush h) ParseHeaderCommand filePath -> catch (do @@ -255,7 +260,7 @@ hPutStrLn h (show res) hFlush h) (\ (e :: SomeException) -> do - hPutStrLn h (show (ServerFailed (show e))) + hPutStrLn h (show (ServerFailed (T.pack $ show e))) hFlush h) doCommands' prefs connRef threadId (h,n,p) @@ -294,9 +299,9 @@ appendFile reportPath (report time) where report time = "\n++++++++++++++++++++++++++++++\n" ++ show time ++ "\n++++++++++++++++++++++++++++++\n" - ++ header' time ++ summary ++ details + ++ header' time ++ summary ++ T.unpack details header' _time = "\nLeksah system metadata collection " - summary = "\nSuccess with = " ++ packs ++ + summary = "\nSuccess with = " ++ T.unpack packs ++ "\nPackages total = " ++ show packagesTotal ++ "\nPackages with source = " ++ show packagesWithSource ++ "\nPackages retreived = " ++ show packagesRetreived ++ @@ -311,9 +316,9 @@ percentageWithSource = (fromIntegral modulesWithSource) * 100.0 / (fromIntegral modulesTotal') details = foldr detail "" (filter (isJust . mbError) stats) - detail stat string = string ++ "\n" ++ packageString stat ++ " " ++ trim (fromJust (mbError stat)) - packs = foldr (\stat string -> string ++ packageString stat ++ " ") + detail stat string = string <> "\n" <> packageString stat <> " " <> (T.strip . fromJust $ mbError stat) + packs = foldr (\stat string -> string <> packageString stat <> " ") "" (take 10 (filter withSource stats)) - ++ if packagesWithSource > 10 then "..." else "" + <> if packagesWithSource > 10 then "..." else "" diff --git a/src/IDE/Metainfo/InterfaceCollector.hs b/src/IDE/Metainfo/InterfaceCollector.hs --- a/src/IDE/Metainfo/InterfaceCollector.hs +++ b/src/IDE/Metainfo/InterfaceCollector.hs @@ -47,12 +47,7 @@ import FastString import Name import PrelNames -#if MIN_VERSION_ghc(6,12,1) import PackageConfig (PackageConfig, mkPackageId) -#else -import PackageConfig - (PackageConfig, mkPackageId) -#endif import TcRnTypes import Data.Char (isSpace) import qualified Data.Map as Map @@ -70,11 +65,13 @@ import TcRnMonad (initTcRnIf) import IDE.Utils.GHCUtils import Control.DeepSeq(deepseq) +import Data.Text (Text) +import qualified Data.Text as T (pack) #if !MIN_VERSION_ghc(7,6,0) -showSDoc :: DynFlags -> SDoc -> String +showSDoc :: DynFlags -> SDoc -> Text showSDoc _ = O.showSDoc -showSDocUnqual :: DynFlags -> SDoc -> String +showSDocUnqual :: DynFlags -> SDoc -> Text showSDocUnqual _ = O.showSDocUnqual #endif @@ -147,7 +144,7 @@ -> ModuleDescr extractExportedDescrR dflags pid hidden iface = let mid = (fromJust . simpleParse . moduleNameString . moduleName) (mi_module iface) - exportedNames = Set.fromList + exportedNames = Set.fromList . map T.pack #if MIN_VERSION_Cabal(1,11,0) $ map (occNameString . nameOccName) $ concatMap availNames @@ -157,7 +154,7 @@ $ concatMap availNames $ concatMap snd (mi_exports iface) #endif - exportedDecls = filter (\ ifdecl -> (occNameString $ifName ifdecl) + exportedDecls = filter (\ ifdecl -> (T.pack . occNameString $ ifName ifdecl) `Set.member` exportedNames) (map snd (mi_decls iface)) ownDecls = concatMap (extractIdentifierDescr dflags pid [mid]) exportedDecls @@ -181,8 +178,8 @@ then [] else let descr = RealDescr{ - dscName' = unpackFS $occNameFS (ifName decl) - , dscMbTypeStr' = Just (BS.pack $ unlines $ nonEmptyLines $ filterExtras $ showSDocUnqual dflags $ppr decl) + dscName' = T.pack . unpackFS . occNameFS $ ifName decl + , dscMbTypeStr' = Just . BS.pack . unlines . nonEmptyLines . filterExtras . showSDocUnqual dflags $ ppr decl , dscMbModu' = Just (PM package (last modules)) , dscMbLocation' = Nothing , dscMbComment' = Nothing @@ -246,7 +243,7 @@ #endif extractConstructors :: DynFlags -> OccName -> [IfaceConDecl] -> [SimpleDescr] -extractConstructors dflags name decls = map (\decl -> SimpleDescr (unpackFS $occNameFS (ifConOcc decl)) +extractConstructors dflags name decls = map (\decl -> SimpleDescr (T.pack . unpackFS $occNameFS (ifConOcc decl)) (Just (BS.pack $ filterExtras $ showSDocUnqual dflags $ pprIfaceForAllPart (ifConUnivTvs decl ++ ifConExTvs decl) (eq_ctxt decl ++ ifConCtxt decl) (pp_tau decl))) @@ -272,15 +269,15 @@ extractType :: DynFlags -> IfaceType -> Maybe ByteString extractType dflags it = Just ((BS.pack . filterExtras . showSDocUnqual dflags . ppr) it) -extractFieldNames :: OccName -> String -extractFieldNames occName' = unpackFS $occNameFS occName' +extractFieldNames :: OccName -> Text +extractFieldNames occName' = T.pack . unpackFS $occNameFS occName' extractClassOp :: DynFlags -> IfaceClassOp -> SimpleDescr -extractClassOp dflags (IfaceClassOp occName' _dm ty) = SimpleDescr (unpackFS $occNameFS occName') +extractClassOp dflags (IfaceClassOp occName' _dm ty) = SimpleDescr (T.pack . unpackFS $occNameFS occName') (Just (BS.pack $ showSDocUnqual dflags (ppr ty))) Nothing Nothing True -extractSuperClassNames :: [IfacePredType] -> [String] +extractSuperClassNames :: [IfacePredType] -> [Text] extractSuperClassNames l = catMaybes $ map extractSuperClassName l where #if !MIN_VERSION_ghc(7,3,0) @@ -299,12 +296,12 @@ -> [Descr] extractInstances dflags pm ifaceInst = let className = showSDocUnqual dflags $ ppr $ ifInstCls ifaceInst - dataNames = map (\iftc -> showSDocUnqual dflags $ ppr iftc) + dataNames = map (\iftc -> T.pack . showSDocUnqual dflags $ ppr iftc) $ map fromJust $ filter isJust $ ifInstTys ifaceInst in [Real (RealDescr - { dscName' = className + { dscName' = T.pack className , dscMbTypeStr' = Nothing , dscMbModu' = Just pm , dscMbLocation' = Nothing @@ -313,13 +310,13 @@ , dscExported' = False})] -extractUsages :: DynFlags -> Usage -> Maybe (ModuleName, Set String) +extractUsages :: DynFlags -> Usage -> Maybe (ModuleName, Set Text) extractUsages _ (UsagePackageModule {usg_mod = usg_mod'}) = let name = (fromJust . simpleParse . moduleNameString) (moduleName usg_mod') in Just (name, Set.fromList []) extractUsages dflags (UsageHomeModule {usg_mod_name = usg_mod_name', usg_entities = usg_entities'}) = let name = (fromJust . simpleParse . moduleNameString) usg_mod_name' - ids = map (showSDocUnqual dflags . ppr . fst) usg_entities' + ids = map (T.pack . showSDocUnqual dflags . ppr . fst) usg_entities' in Just (name, Set.fromList ids) #if MIN_VERSION_ghc(7,4,0) extractUsages _ (UsageFile _ _) = Nothing diff --git a/src/IDE/Metainfo/PackageCollector.hs b/src/IDE/Metainfo/PackageCollector.hs --- a/src/IDE/Metainfo/PackageCollector.hs +++ b/src/IDE/Metainfo/PackageCollector.hs @@ -1,4 +1,5 @@ -{-# OPTIONS_GHC -XScopedTypeVariables -fno-warn-type-defaults #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings #-} ----------------------------------------------------------------------------- -- -- Module : IDE.Metainfo.PackageCollector @@ -58,6 +59,9 @@ import Control.Monad.IO.Class (MonadIO, MonadIO(..)) import qualified Control.Exception as E (SomeException, catch) import IDE.Utils.Tool (runTool') +import Data.Monoid ((<>)) +import qualified Data.Text as T (unpack) +import Data.Text (Text) collectPackage :: Bool -> Prefs -> Int -> (PackageConfig,Int) -> IO PackageCollectStats collectPackage writeAscii prefs numPackages (packageConfig, packageIndex) = do @@ -77,11 +81,11 @@ success <- retrieve packageName if success then do - debugM "leksah-server" $ "collectPackage: retreived = " ++ packageName + debugM "leksah-server" . T.unpack $ "collectPackage: retreived = " <> packageName liftIO $ writePackagePath (dropFileName fpSource) packageName return (stat {withSource=True, retrieved= True, mbError=Nothing}) else do - debugM "leksah-server" $ "collectPackage: Can't retreive = " ++ packageName + debugM "leksah-server" . T.unpack $ "collectPackage: Can't retreive = " <> packageName runCabalConfigure fpSource packageDescrHi <- collectPackageFromHI packageConfig mbPackageDescrPair <- packageFromSource fpSource packageConfig @@ -104,7 +108,7 @@ success <- retrieve packageName if success then do - debugM "leksah-server" $ "collectPackage: retreived = " ++ packageName + debugM "leksah-server" . T.unpack $ "collectPackage: retreived = " <> packageName liftIO $ writePackagePath (dropFileName fpSource) packageName return (stat {withSource=True, retrieved= True, mbError=Nothing}) else do @@ -123,13 +127,13 @@ writeExtractedPackage False packageDescrHi return bstat{modulesTotal = Just (length (pdModules packageDescrHi))} where - retrieve :: String -> IO Bool + retrieve :: Text -> IO Bool retrieve packString = do collectorPath <- liftIO $ getCollectorPath setCurrentDirectory collectorPath - let fullUrl = retrieveURL prefs ++ "/metadata-" ++ leksahVersion ++ "/" ++ packString ++ leksahMetadataSystemFileExtension - filePath = collectorPath packString <.> leksahMetadataSystemFileExtension - debugM "leksah-server" $ "collectPackage: before retreiving = " ++ fullUrl + let fullUrl = T.unpack (retrieveURL prefs) <> "/metadata-" <> leksahVersion <> "/" <> T.unpack packString <> leksahMetadataSystemFileExtension + filePath = collectorPath T.unpack packString <.> leksahMetadataSystemFileExtension + debugM "leksah-server" $ "collectPackage: before retreiving = " <> fullUrl #if defined(USE_LIBCURL) E.catch (do (code, string) <- curlGetString_ fullUrl [] @@ -143,7 +147,7 @@ #endif (\(e :: SomeException) -> debugM "leksah-server" $ "collectPackage: Error when calling wget " ++ show e) - debugM "leksah-server" $ "collectPackage: after retreiving = " ++ packString -- ++ " result = " ++ res + debugM "leksah-server" . T.unpack $ "collectPackage: after retreiving = " <> packString -- ++ " result = " ++ res exist <- doesFileExist filePath return exist writeMerged packageDescrS packageDescrHi fpSource packageName = do @@ -161,16 +165,16 @@ writeExtractedPackage :: MonadIO m => Bool -> PackageDescr -> m () writeExtractedPackage writeAscii pd = do collectorPath <- liftIO $ getCollectorPath - let filePath = collectorPath packageIdentifierToString (pdPackage pd) <.> + let filePath = collectorPath T.unpack (packageIdentifierToString $ pdPackage pd) <.> leksahMetadataSystemFileExtension if writeAscii then liftIO $ writeFile (filePath ++ "dpg") (show pd) else liftIO $ encodeFileSer filePath (metadataVersion, pd) -writePackagePath :: MonadIO m => FilePath -> String -> m () +writePackagePath :: MonadIO m => FilePath -> Text -> m () writePackagePath fp packageName = do collectorPath <- liftIO $ getCollectorPath - let filePath = collectorPath packageName <.> leksahMetadataPathFileExtension + let filePath = collectorPath T.unpack packageName <.> leksahMetadataPathFileExtension liftIO $ writeFile filePath fp --------------Merging of .hi and .hs parsing / parsing and typechecking results @@ -205,7 +209,7 @@ mergeDescrs :: [Descr] -> [Descr] -> [Descr] mergeDescrs hiList srcList = concatMap mergeIt allNames where - mergeIt :: String -> [Descr] + mergeIt :: Text -> [Descr] mergeIt pm = case (Map.lookup pm hiDict, Map.lookup pm srcDict) of (Just mdhi, Nothing) -> mdhi (Nothing, Just mdsrc) -> mdsrc @@ -271,7 +275,7 @@ mergeSimpleDescrs :: [SimpleDescr] -> [SimpleDescr] -> [SimpleDescr] mergeSimpleDescrs hiList srcList = map mergeIt allNames where - mergeIt :: String -> SimpleDescr + mergeIt :: Text -> SimpleDescr mergeIt pm = case mergeMbDescr (Map.lookup pm hiDict) (Map.lookup pm srcDict) of Just mdhi -> mdhi Nothing -> error "Collector>>mergeSimpleDescrs: impossible" diff --git a/src/IDE/Metainfo/SourceCollectorH.hs b/src/IDE/Metainfo/SourceCollectorH.hs --- a/src/IDE/Metainfo/SourceCollectorH.hs +++ b/src/IDE/Metainfo/SourceCollectorH.hs @@ -1,4 +1,5 @@ -{-# OPTIONS_GHC -XScopedTypeVariables -XBangPatterns #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings #-} ----------------------------------------------------------------------------- -- -- Module : IDE.Metainfo.SourceCollectorH @@ -24,7 +25,7 @@ import IDE.Core.CTypes (getThisPackage, PackageDescr(..), TypeDescr(..), RealDescr(..), Descr(..), ModuleDescr(..), PackModule(..), SimpleDescr(..), - packageIdentifierToString) + packageIdentifierToString, Location(..), RealDescr(..)) #ifdef MIN_VERSION_haddock_leksah import Haddock.Types @@ -40,20 +41,14 @@ #else import InstEnv (Instance(..)) #endif -import MyMissing +import MyMissing (forceJust) import Data.Map (Map) import qualified Data.Map as Map (empty) -import Data.List (nub) +import Data.List (nub, isSuffixOf) import qualified Data.ByteString.Char8 as BS (pack) -#if MIN_VERSION_ghc(6,12,1) import IDE.Metainfo.WorkspaceCollector (srcSpanToLocation, uncommentDecl, uncommentData, printHsDoc, sortByLoc) -#else -import IDE.Metainfo.WorkspaceCollector - (srcSpanToLocation, uncommentDecl, uncommentData, sortByLoc) -#endif - import PackageConfig (PackageConfig) import Distribution.Verbosity (verbose) import qualified Distribution.InstalledPackageInfo as IPI @@ -61,7 +56,7 @@ import IDE.Metainfo.SourceDB (sourceForPackage, getSourcesMap) import MonadUtils (liftIO) import System.Directory (setCurrentDirectory, doesDirectoryExist,createDirectory) -import System.FilePath ((<.>), dropFileName, ()) +import System.FilePath ((<.>), dropFileName, (), splitDirectories, dropExtension) import Data.Maybe(mapMaybe) import IDE.Utils.GHCUtils (inGhcIO) import qualified Control.Exception as NewException (SomeException, catch) @@ -70,17 +65,21 @@ import IDE.Utils.FileUtils (figureOutGhcOpts, myCanonicalizePath) import Distribution.Package(PackageIdentifier) import GHC hiding(Id,Failed,Succeeded,ModuleName) +import Distribution.ModuleName (components) import System.Log.Logger (warningM, debugM) import Control.DeepSeq (deepseq) import Data.ByteString.Char8 (ByteString) #if MIN_VERSION_ghc(7,6,0) -import Outputable hiding(trace) +import Outputable hiding(trace, (<>)) #else -import Outputable hiding(trace, showSDoc, showSDocUnqual) +import Outputable hiding(trace, (<>), showSDoc, showSDocUnqual) import qualified Outputable as O #endif import GHC.Show(showSpace) import Name +import Data.Text (Text) +import qualified Data.Text as T (unpack, pack) +import Data.Monoid ((<>)) #ifdef MIN_VERSION_haddock_leksah #else @@ -93,16 +92,12 @@ isEmptyDoc DocEmpty = True isEmptyDoc _ = False -#if MIN_VERSION_ghc(6,12,1) type MyLDocDecl = LDocDecl -#else -type MyLDocDecl = LDocDecl Name -#endif #if !MIN_VERSION_ghc(7,6,0) -showSDoc :: DynFlags -> SDoc -> String +showSDoc :: DynFlags -> SDoc -> Text showSDoc _ = O.showSDoc -showSDocUnqual :: DynFlags -> SDoc -> String +showSDocUnqual :: DynFlags -> SDoc -> Text showSDocUnqual _ = O.showSDocUnqual #endif @@ -110,13 +105,13 @@ show' dflags = showSDoc dflags . ppr data PackageCollectStats = PackageCollectStats { - packageString :: String, + packageString :: Text, modulesTotal :: Maybe Int, withSource :: Bool, retrieved :: Bool, - mbError :: Maybe String} + mbError :: Maybe Text} -findSourceForPackage :: Prefs -> PackageConfig -> IO (Either String FilePath) +findSourceForPackage :: Prefs -> PackageConfig -> IO (Either Text FilePath) findSourceForPackage prefs packageConfig = do sourceMap <- liftIO $ getSourcesMap prefs case sourceForPackage (getThisPackage packageConfig) sourceMap of @@ -130,12 +125,13 @@ unless exists $ createDirectory fpUnpack setCurrentDirectory fpUnpack runTool' "cabal" (["unpack",packageName]) Nothing - success <- doesDirectoryExist (fpUnpack packageName) + success <- doesDirectoryExist (fpUnpack packageName') if not success then return (Left "Failed to download and unpack source") - else return (Right (fpUnpack packageName takeWhile (/= '-') packageName <.> "cabal")) + else return (Right (fpUnpack packageName' takeWhile (/= '-') packageName' <.> "cabal")) where packageName = packageIdentifierToString (getThisPackage packageConfig) + packageName' = T.unpack packageName packageFromSource :: FilePath -> PackageConfig -> IO (Maybe PackageDescr, PackageCollectStats) @@ -151,7 +147,7 @@ handler (e :: NewException.SomeException) = do warningM "leksah-server" ("Ghc failed to process: " ++ show e) return (Nothing, PackageCollectStats packageName Nothing False False - (Just ("Ghc failed to process: " ++ show e))) + (Just ("Ghc failed to process: " <> T.pack (show e)))) inner ghcFlags = inGhcIO ghcFlags [Opt_Haddock] $ \ dflags -> do #if MIN_VERSION_haddock(2,8,0) (interfaces,_) <- processModules verbose (exportedMods ++ hiddenMods) [] [] @@ -183,9 +179,17 @@ , mdReferences = imports , mdIdDescriptions = descrs} where - filepath = ifaceOrigFilename interface + -- ifaceOrigFilename points at the hs output file (not chs file) + -- So if possible we look up one of the things in the module and + -- get the file it is located in. + filepath = head $ + [locationFile loc | Real RealDescr{dscMbLocation' = Just loc, + dscMbModu' = Just dscMod} <- descrs, dscMod == PM pid modName, + filenameMatchesModule (locationFile loc)] + ++ [ifaceOrigFilename interface] modName = forceJust ((simpleParse . moduleNameString . moduleName . ifaceMod) interface) "Can't parse module name" + filenameMatchesModule fn = components modName `isSuffixOf` splitDirectories (dropExtension fn) descrs = extractDescrs dflags (PM pid modName) (ifaceDeclMap interface) (ifaceExportItems interface) (ifaceInstances interface) [] --(ifaceLocals interface) @@ -202,7 +206,6 @@ #if MIN_VERSION_ghc(7,4,1) type DeclInfo = [LHsDecl Name] #endif -#if MIN_VERSION_ghc(6,12,1) #if MIN_VERSION_ghc(7,6,0) extractDescrs :: DynFlags -> PackModule -> Map Name DeclInfo -> [ExportItem Name] -> [ClsInst] -> [Name] -> [Descr] #else @@ -218,18 +221,6 @@ toDeclInfo (ExportGroup _ _ _) = Nothing toDeclInfo (ExportDoc _) = Nothing toDeclInfo (ExportModule _) = Nothing -#else -extractDescrs :: DynFlags -> PackModule -> Map Name DeclInfo -> [ExportItem Name] -> [Instance] -> [Name] -> [Descr] -extractDescrs dflags pm _ifaceDeclMap ifaceExportItems' ifaceInstances' _ifaceLocals = - transformToDescrs dflags pm exportedDeclInfo ++ map (toDescrInst dflags pm) ifaceInstances' - where - exportedDeclInfo = mapMaybe toDeclInfo ifaceExportItems' - toDeclInfo (ExportDecl decl mbDoc subDocs _) = Just(decl,mbDoc,subDocs) - toDeclInfo (ExportNoDecl _ _) = Nothing - toDeclInfo (ExportGroup _ _ _) = Nothing - toDeclInfo (ExportDoc _) = Nothing - toDeclInfo (ExportModule _) = Nothing -#endif transformToDescrs :: DynFlags -> PackModule -> [(LHsDecl Name, Maybe NDoc, [(Name, Maybe NDoc)])] -> [Descr] transformToDescrs dflags pm = concatMap transformToDescr @@ -240,8 +231,8 @@ transformToDescr ((L loc (SigD (TypeSig name typ))), mbComment,_subCommentList) = #endif [Real $ RealDescr { - dscName' = getOccString (unLoc name) - , dscMbTypeStr' = Just (BS.pack (showSDocUnqual dflags $ppr typ)) + dscName' = T.pack . getOccString $ unLoc name + , dscMbTypeStr' = Just . BS.pack . showSDocUnqual dflags $ ppr typ , dscMbModu' = Just pm , dscMbLocation' = srcSpanToLocation loc , dscMbComment' = toComment dflags mbComment [] @@ -253,8 +244,8 @@ #if MIN_VERSION_ghc(7,6,0) transformToDescr ((L loc (TyClD typ@(ForeignType {tcdLName = lid}))), mbComment,_sigList) = [Real $ RealDescr { - dscName' = getOccString (unLoc lid) - , dscMbTypeStr' = Just (BS.pack (showSDocUnqual dflags $ppr typ)) + dscName' = T.pack . getOccString $ unLoc lid + , dscMbTypeStr' = Just . BS.pack . showSDocUnqual dflags $ ppr typ , dscMbModu' = Just pm , dscMbLocation' = srcSpanToLocation loc , dscMbComment' = toComment dflags mbComment [] @@ -267,8 +258,8 @@ transformToDescr ((L loc (TyClD typ@(TyFamily {tcdLName = lid}))), mbComment,_sigList) = #endif [Real $ RealDescr { - dscName' = getOccString (unLoc lid) - , dscMbTypeStr' = Just (BS.pack (showSDocUnqual dflags $ppr typ)) + dscName' = T.pack . getOccString $ unLoc lid + , dscMbTypeStr' = Just . BS.pack . showSDocUnqual dflags $ ppr typ , dscMbModu' = Just pm , dscMbLocation' = srcSpanToLocation loc , dscMbComment' = toComment dflags mbComment [] @@ -284,8 +275,8 @@ transformToDescr ((L loc (TyClD typ@(TySynonym lid _ _ _ ))), mbComment, _subCommentList) = #endif [Real $ RealDescr { - dscName' = getOccString (unLoc lid) - , dscMbTypeStr' = Just (BS.pack (showSDocUnqual dflags $ppr typ)) + dscName' = T.pack . getOccString $ unLoc lid + , dscMbTypeStr' = Just . BS.pack . showSDocUnqual dflags $ ppr typ , dscMbModu' = Just pm , dscMbLocation' = srcSpanToLocation loc , dscMbComment' = toComment dflags mbComment [] @@ -300,8 +291,8 @@ transformToDescr ((L loc (TyClD typ@(TyData DataType _ lid _ _ _ lConDecl tcdDerivs'))), mbComment,_subCommentList) = #endif [Real $ RealDescr { - dscName' = name - , dscMbTypeStr' = Just (BS.pack (showSDocUnqual dflags $ppr (uncommentData typ))) + dscName' = T.pack name + , dscMbTypeStr' = Just . BS.pack . showSDocUnqual dflags . ppr $ uncommentData typ , dscMbModu' = Just pm , dscMbLocation' = srcSpanToLocation loc , dscMbComment' = toComment dflags mbComment [] @@ -319,7 +310,7 @@ transformToDescr ((L loc (TyClD typ@(TyData NewType _ tcdLName' _ _ _ lConDecl tcdDerivs'))), mbComment,_subCommentList) = [Real $ RealDescr { dscName' = name - , dscMbTypeStr' = Just (BS.pack (showSDocUnqual dflags $ppr (uncommentData typ))) + , dscMbTypeStr' = Just . BS.pack . showSDocUnqual dflags . ppr $ uncommentData typ , dscMbModu' = Just pm , dscMbLocation' = srcSpanToLocation loc , dscMbComment' = toComment dflags mbComment [] @@ -339,8 +330,8 @@ transformToDescr ((L loc (TyClD cl@(ClassDecl{tcdLName=tcdLName', tcdSigs=tcdSigs', tcdDocs=docs}))), mbComment,_subCommentList) = [Real $ RealDescr { - dscName' = getOccString (unLoc tcdLName') - , dscMbTypeStr' = Just (BS.pack (showSDocUnqual dflags $ppr cl{tcdMeths = emptyLHsBinds})) + dscName' = T.pack . getOccString $ unLoc tcdLName' + , dscMbTypeStr' = Just . BS.pack . showSDocUnqual dflags $ ppr cl{tcdMeths = emptyLHsBinds} , dscMbModu' = Just pm , dscMbLocation' = srcSpanToLocation loc , dscMbComment' = toComment dflags mbComment [] @@ -360,12 +351,12 @@ toDescrInst dflags pm inst@(Instance is_cls' _is_tcs _is_tvs is_tys' _is_dfun _is_flag) = #endif Real $ RealDescr { - dscName' = getOccString is_cls' - , dscMbTypeStr' = Just (BS.pack (showSDocUnqual dflags $ppr inst)) + dscName' = T.pack $ getOccString is_cls' + , dscMbTypeStr' = Just . BS.pack . showSDocUnqual dflags $ ppr inst , dscMbModu' = Just pm , dscMbLocation' = srcSpanToLocation (getSrcSpan inst) , dscMbComment' = Nothing - , dscTypeHint' = InstanceDescr (map (showSDocUnqual dflags . ppr) is_tys') + , dscTypeHint' = InstanceDescr (map (T.pack . showSDocUnqual dflags . ppr) is_tys') , dscExported' = True} extractMethods :: DynFlags -> [LSig Name] -> [MyLDocDecl] -> [SimpleDescr] @@ -380,8 +371,8 @@ extractMethod dflags ((L loc (SigD ts@(TypeSig name _typ))), mbDoc) = #endif Just $ SimpleDescr - (getOccString (unLoc name)) - (Just (BS.pack (showSDocUnqual dflags $ ppr ts))) + (T.pack . getOccString $ unLoc name) + (Just . BS.pack . showSDocUnqual dflags $ ppr ts) (srcSpanToLocation loc) (toComment dflags mbDoc []) True @@ -390,12 +381,12 @@ extractConstructor :: DynFlags -> LConDecl Name -> SimpleDescr extractConstructor dflags decl@(L loc (ConDecl {con_name = name, con_doc = doc})) = SimpleDescr - (getOccString (unLoc name)) - (Just (BS.pack (showSDocUnqual dflags $ppr (uncommentDecl decl)))) + (T.pack . getOccString $ unLoc name) + (Just . BS.pack . showSDocUnqual dflags . ppr $uncommentDecl decl) (srcSpanToLocation loc) (case doc of Nothing -> Nothing - Just (L _ d) -> Just (BS.pack (printHsDoc d))) + Just (L _ d) -> Just . BS.pack . T.unpack $ printHsDoc d) True extractRecordFields :: DynFlags -> LConDecl Name -> [SimpleDescr] @@ -404,18 +395,18 @@ where extractRecordFields' _field@(ConDeclField (L loc name) typ doc) = SimpleDescr - (getOccString name) + (T.pack $ getOccString name) (Just (BS.pack (showSDocUnqual dflags $ ppr typ))) (srcSpanToLocation loc) (case doc of Nothing -> Nothing - Just (L _ d) -> Just (BS.pack (printHsDoc d))) + Just (L _ d) -> Just . BS.pack . T.unpack $ printHsDoc d) True extractRecordFields _ _ = [] toComment :: DynFlags -> Maybe NDoc -> [NDoc] -> Maybe ByteString -toComment dflags (Just c) _ = Just (BS.pack (printHsDoc' dflags c)) -toComment dflags Nothing (c:_) = Just (BS.pack (printHsDoc' dflags c)) +toComment dflags (Just c) _ = Just . BS.pack . T.unpack $ printHsDoc' dflags c +toComment dflags Nothing (c:_) = Just . BS.pack . T.unpack $ printHsDoc' dflags c toComment _ Nothing [] = Nothing @@ -427,8 +418,8 @@ = addLocationAndComment (l,st) (unLoc lid) loc mbComment' [Class] [] --} -printHsDoc' :: DynFlags -> HsDoc Name -> String -printHsDoc' dflags d = show (PPDoc dflags d) +printHsDoc' :: DynFlags -> HsDoc Name -> Text +printHsDoc' dflags d = T.pack . show $ PPDoc dflags d data PPDoc alpha = PPDoc DynFlags (HsDoc alpha) diff --git a/src/IDE/Metainfo/SourceDB.hs b/src/IDE/Metainfo/SourceDB.hs --- a/src/IDE/Metainfo/SourceDB.hs +++ b/src/IDE/Metainfo/SourceDB.hs @@ -1,4 +1,4 @@ - +{-# LANGUAGE OverloadedStrings #-} ----------------------------------------------------------------------------- -- -- Module : IDE.Metainfo.SourceDB @@ -62,6 +62,10 @@ import System.FilePath (takeDirectory, (), takeFileName) import System.Directory (doesDirectoryExist) +import Data.Text (Text) +import qualified Data.Text as T (unpack, pack) +import Control.Applicative ((<$>)) +import Data.Monoid ((<>)) -- --------------------------------------------------------------------- -- Function to map packages to file paths @@ -106,16 +110,16 @@ filePath <- getConfigFilePathForSave standardSourcesFilename writeFile filePath (PP.render (showSourceForPackageDB pdToFiles)) -showSourceForPackageDB :: Map String [FilePath] -> PP.Doc +showSourceForPackageDB :: Map Text [FilePath] -> PP.Doc showSourceForPackageDB aMap = PP.vcat (map showIt (Map.toList aMap)) where - showIt :: (String,[FilePath]) -> PP.Doc + showIt :: (Text,[FilePath]) -> PP.Doc showIt (pd,list) = (foldl' (\l n -> l PP.$$ (PP.text $ show n)) label list) PP.<> PP.char '\n' - where label = PP.text pd PP.<> PP.colon + where label = PP.text (T.unpack pd) PP.<> PP.colon -- Strict version -parseFromFile :: Parser a -> String -> IO (Either ParseError a) +parseFromFile :: Parser a -> FilePath -> IO (Either ParseError a) parseFromFile p f = do input <- S.readFile f return $ parse p f input @@ -155,8 +159,8 @@ whiteSpace :: CharParser st () whiteSpace = P.whiteSpace lexer -symbol :: String -> CharParser st String -symbol = P.symbol lexer +symbol :: Text -> CharParser st Text +symbol = (T.pack <$>) . P.symbol lexer . T.unpack sourceForPackageParser :: CharParser () (Map PackageIdentifier [FilePath]) sourceForPackageParser = do @@ -181,7 +185,7 @@ whiteSpace str <- many (noneOf ":") char ':' - return (packageIdentifierFromString str)) + return (packageIdentifierFromString (T.pack str))) "packageDescriptionParser" filePathParser :: CharParser () FilePath @@ -193,7 +197,7 @@ return (str)) "filePathParser" -parseCabal :: FilePath -> IO (Maybe String) +parseCabal :: FilePath -> IO (Maybe Text) parseCabal fn = do --putStrLn $ "Now parsing minimal " ++ fn res <- parseFromFile cabalMinimalParser fn @@ -202,39 +206,39 @@ errorM "leksah-server" $"Error reading cabal file " ++ show fn ++ " " ++ show pe return Nothing Right r -> do - debugM "leksah-server" r + debugM "leksah-server" (T.unpack r) return (Just r) -cabalMinimalParser :: CharParser () String +cabalMinimalParser :: CharParser () Text cabalMinimalParser = do r1 <- cabalMinimalP r2 <- cabalMinimalP case r1 of Left v -> do case r2 of - Right n -> return (n ++ "-" ++ v) + Right n -> return (n <> "-" <> v) Left _ -> unexpected "Illegal cabal" Right n -> do case r2 of - Left v -> return (n ++ "-" ++ v) + Left v -> return (n <> "-" <> v) Right _ -> unexpected "Illegal cabal" -cabalMinimalP :: CharParser () (Either String String) +cabalMinimalP :: CharParser () (Either Text Text) cabalMinimalP = do try $(symbol "name:" <|> symbol "Name:") whiteSpace name <- (many $noneOf " \n") (many $noneOf "\n") char '\n' - return (Right name) + return . Right $ T.pack name <|> do try $(symbol "version:" <|> symbol "Version:") whiteSpace versionString <- (many $noneOf " \n") (many $noneOf "\n") char '\n' - return (Left versionString) + return . Left $ T.pack versionString <|> do many $noneOf "\n" char '\n' diff --git a/src/IDE/Metainfo/WorkspaceCollector.hs b/src/IDE/Metainfo/WorkspaceCollector.hs --- a/src/IDE/Metainfo/WorkspaceCollector.hs +++ b/src/IDE/Metainfo/WorkspaceCollector.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE ScopedTypeVariables, PatternGuards #-} +{-# LANGUAGE ScopedTypeVariables, PatternGuards, OverloadedStrings #-} ----------------------------------------------------------------------------- -- -- Module : IDE.Metainfo.WorkspaceCollector @@ -36,9 +36,9 @@ import HscTypes hiding (liftIO) #endif #if MIN_VERSION_ghc(7,6,0) -import Outputable hiding(trace) +import Outputable hiding(trace, (<>)) #else -import Outputable hiding(trace, showSDoc, showSDocUnqual) +import Outputable hiding(trace, (<>), showSDoc, showSDocUnqual) import qualified Outputable as O #endif import ErrUtils @@ -57,7 +57,7 @@ import Data.ByteString.Char8 (ByteString) import DriverPipeline (preprocess) import StringBuffer(hGetStringBuffer) -import Data.List(partition,sortBy,nub,find,intercalate) +import Data.List(partition,sortBy,nub,find) import Data.Ord(comparing) import GHC.Exception #if !MIN_VERSION_ghc(7,6,0) @@ -74,55 +74,46 @@ import PrelNames import System.Log.Logger import Control.DeepSeq (deepseq) -#if MIN_VERSION_ghc(6,12,1) import FastString(mkFastString,appendFS,nullFS,unpackFS) import Control.Monad.IO.Class (MonadIO, MonadIO(..)) import Control.Monad (when) -#else -import GHC.Show(showSpace) -#endif import Control.Exception as E +import Control.Applicative ((<$>), (<|>)) +import Debug.Trace (trace) +import Data.Text (Text) +import qualified Data.Text as T (intercalate, words, unpack, pack) +import Data.Monoid ((<>)) type NDecl = LHsDecl RdrName myDocEmpty :: NDoc myDocAppend :: NDoc -> NDoc -> NDoc isEmptyDoc :: NDoc -> Bool -#if MIN_VERSION_ghc(6,12,1) type NDoc = HsDocString type MyLDocDecl = LDocDecl myDocEmpty=HsDocString(mkFastString "") myDocAppend (HsDocString l) (HsDocString r) = HsDocString (appendFS l r) isEmptyDoc (HsDocString fs) = nullFS fs -#else -type NDoc = HsDoc RdrName -type MyLDocDecl = LDocDecl RdrName -myDocEmpty = DocEmpty -myDocAppend = docAppend -isEmptyDoc DocEmpty = True -isEmptyDoc _ = False - -#endif type NSig = Located (Sig RdrName) #if !MIN_VERSION_ghc(7,6,0) -showSDoc :: DynFlags -> SDoc -> String +showSDoc :: DynFlags -> SDoc -> Text showSDoc _ = O.showSDoc -showSDocUnqual :: DynFlags -> SDoc -> String +showSDocUnqual :: DynFlags -> SDoc -> Text showSDocUnqual _ = O.showSDocUnqual #endif -showRdrName :: DynFlags -> RdrName -> String -showRdrName dflags r = showSDoc dflags (ppr r) +showRdrName :: DynFlags -> RdrName -> Text +showRdrName dflags r = T.pack . showSDoc dflags $ ppr r -- | Test -collectWorkspace :: PackageIdentifier -> [(String,FilePath)] -> Bool -> Bool -> FilePath -> IO() +collectWorkspace :: PackageIdentifier -> [(Text,FilePath)] -> Bool -> Bool -> FilePath -> IO() collectWorkspace packId moduleList forceRebuild writeAscii dir = do debugM "leksah-server" $ "collectWorkspace called with modules " ++ show moduleList ++ " in folder " ++ dir collectorPath <- liftIO $ getCollectorPath - let packageCollectorPath = collectorPath packageIdentifierToString packId + let packageCollectorPath = collectorPath T.unpack (packageIdentifierToString packId) when forceRebuild $ do exists <- doesDirectoryExist packageCollectorPath when exists $ removeDirectoryRecursive packageCollectorPath @@ -136,12 +127,12 @@ mapM_ (collectModule packageCollectorPath writeAscii packId opts1) moduleList debugM "leksah-server" $ "after collect modules" -collectModule :: FilePath -> Bool -> PackageIdentifier -> [String] -> (String,FilePath) -> IO() +collectModule :: FilePath -> Bool -> PackageIdentifier -> [Text] -> (Text,FilePath) -> IO() collectModule collectorPackagePath writeAscii packId opts (modId,sourcePath) = do existCollectorFile <- doesFileExist collectorModulePath existSourceFile <- doesFileExist sourcePath case mbModuleName of - Nothing -> errorM "leksah-server" ("Can't parse module name " ++ modId) + Nothing -> errorM "leksah-server" (T.unpack $ "Can't parse module name " <> modId) Just moduleName' -> if existSourceFile then do @@ -156,11 +147,11 @@ else return () else errorM "leksah-server" ("source file not found " ++ sourcePath) where - collectorModulePath = collectorPackagePath modId <.> leksahMetadataWorkspaceFileExtension - mbModuleName = simpleParse modId + collectorModulePath = collectorPackagePath T.unpack modId <.> leksahMetadataWorkspaceFileExtension + mbModuleName = simpleParse $ T.unpack modId -collectModule' :: FilePath -> FilePath -> Bool -> PackageIdentifier -> [String] -> ModuleName -> IO() +collectModule' :: FilePath -> FilePath -> Bool -> PackageIdentifier -> [Text] -> ModuleName -> IO() collectModule' sourcePath destPath writeAscii packId opts moduleName' = gcatch ( inGhcIO (opts++["-cpp"]) [Opt_Haddock] $ \ dynFlags -> do session <- getSession @@ -218,12 +209,15 @@ extractModDescr :: DynFlags -> PackageIdentifier -> ModuleName -> FilePath -> HsModule RdrName -> ModuleDescr extractModDescr dflags packId moduleName' sourcePath hsMod = ModuleDescr { mdModuleId = PM packId moduleName' - , mdMbSourcePath = Just sourcePath + , mdMbSourcePath = trace ("extractModDescr " ++ (show . modFile $ hsmodName hsMod)) $ modFile $ hsmodName hsMod , mdReferences = Map.empty -- imports , mdIdDescriptions = descrs'} where descrs = extractDescrs dflags (PM packId moduleName') (hsmodDecls hsMod) descrs' = fixExports dflags (hsmodExports hsMod) descrs + modFile (Just (L loc _)) = + (locationFile <$> srcSpanToLocation loc) <|> Just sourcePath + modFile _ = Just sourcePath ----------------------------------------------------------------------------------- -- Add exported hint @@ -562,13 +556,13 @@ ClsInstD t -> ppr t DataFamInstD t -> ppr t TyFamInstD t -> ppr t - (instn,nameI,other) = case words (showSDocUnqual dflags typp) of + (instn,nameI,other) = case T.words . T.pack $ showSDocUnqual dflags typp of instn':nameI':tl -> (instn',nameI',takeWhile (/= "where") tl) _ -> ("","",[]) in [Real $ RealDescr { - dscName' = instn ++ " " ++ nameI - , dscMbTypeStr' = Just (BS.pack (instn ++ " " ++ nameI ++ " " ++ (intercalate " " other))) + dscName' = instn <> " " <> nameI + , dscMbTypeStr' = Just (BS.pack . T.unpack $ instn <> " " <> nameI <> " " <> (T.intercalate " " other)) , dscMbModu' = Just pm , dscMbLocation' = srcSpanToLocation loc , dscMbComment' = toComment mbComment [] @@ -649,18 +643,18 @@ Just d -> dscMbTypeStr d} addType _ d = d -extractDeriving :: OutputableBndr alpha => DynFlags -> PackModule -> String -> LHsType alpha -> Descr +extractDeriving :: OutputableBndr alpha => DynFlags -> PackModule -> Text -> LHsType alpha -> Descr extractDeriving dflags pm name (L loc typ) = Real $ RealDescr { dscName' = className - , dscMbTypeStr' = Just (BS.pack ("instance " ++ (className ++ " " ++ name))) + , dscMbTypeStr' = Just (BS.pack . T.unpack $ "instance " <> className <> " " <> name) , dscMbModu' = Just pm , dscMbLocation' = srcSpanToLocation loc , dscMbComment' = toComment (Nothing :: Maybe NDoc) [] - , dscTypeHint' = InstanceDescr (words name) + , dscTypeHint' = InstanceDescr (T.words name) , dscExported' = True} where - className = showSDocUnqual dflags $ ppr typ + className = T.pack . showSDocUnqual dflags $ ppr typ extractMethods :: DynFlags -> [LSig RdrName] -> [MyLDocDecl] -> [SimpleDescr] extractMethods dflags sigs docs = @@ -674,8 +668,8 @@ extractMethod dflags ((L loc (SigD ts@(TypeSig name _typ))), mbDoc) = #endif Just $ SimpleDescr - ((showSDoc dflags . ppr) (unLoc name)) - (Just (BS.pack (showSDocUnqual dflags $ ppr ts))) + (T.pack . showSDoc dflags . ppr $ unLoc name) + (Just . BS.pack . showSDocUnqual dflags $ ppr ts) (srcSpanToLocation loc) (toComment mbDoc []) True @@ -684,12 +678,12 @@ extractConstructor :: DynFlags -> Located (ConDecl RdrName) -> SimpleDescr extractConstructor dflags decl@(L loc (ConDecl {con_name = name, con_doc = doc})) = SimpleDescr - ((showSDoc dflags . ppr) (unLoc name)) - (Just (BS.pack (showSDocUnqual dflags $ppr (uncommentDecl decl)))) + (T.pack . showSDoc dflags . ppr $ unLoc name) + (Just . BS.pack . showSDocUnqual dflags . ppr $ uncommentDecl decl) (srcSpanToLocation loc) (case doc of Nothing -> Nothing - Just (L _ d) -> Just (BS.pack (printHsDoc d))) + Just (L _ d) -> Just . BS.pack . T.unpack $ printHsDoc d) True extractRecordFields :: DynFlags -> Located (ConDecl RdrName) -> [SimpleDescr] @@ -698,12 +692,12 @@ where extractRecordFields' _field@(ConDeclField (L loc name) typ doc) = SimpleDescr - ((showSDoc dflags . ppr) name) - (Just (BS.pack (showSDocUnqual dflags $ ppr typ))) + (T.pack . showSDoc dflags $ ppr name) + (Just . BS.pack . showSDocUnqual dflags $ ppr typ) (srcSpanToLocation loc) (case doc of Nothing -> Nothing - Just (L _ d) -> Just (BS.pack (printHsDoc d))) + Just (L _ d) -> Just . BS.pack . T.unpack $ printHsDoc d) True extractRecordFields _ _ = [] @@ -719,20 +713,20 @@ srcSpanToLocation :: SrcSpan -> Maybe Location #if MIN_VERSION_ghc(7,2,0) srcSpanToLocation (RealSrcSpan span') - = Just (Location (srcSpanStartLine span') (srcSpanStartCol span') + = Just (Location (unpackFS $ srcSpanFile span') (srcSpanStartLine span') (srcSpanStartCol span') (srcSpanEndLine span') (srcSpanEndCol span')) srcSpanToLocation _ = Nothing #else srcSpanToLocation span' | not (isGoodSrcSpan span') = Nothing srcSpanToLocation span' - = Just (Location (srcSpanStartLine span') (srcSpanStartCol span') + = Just (Location (unpackFS $ srcSpanFile span') (srcSpanStartLine span') (srcSpanStartCol span') (srcSpanEndLine span') (srcSpanEndCol span')) #endif toComment :: Maybe (NDoc) -> [NDoc] -> Maybe ByteString -toComment (Just c) _ = Just (BS.pack (printHsDoc c)) -toComment Nothing (c:_) = Just (BS.pack (printHsDoc c)) +toComment (Just c) _ = Just . BS.pack . T.unpack $ printHsDoc c +toComment Nothing (c:_) = Just . BS.pack . T.unpack $ printHsDoc c toComment Nothing [] = Nothing @@ -743,42 +737,9 @@ collectParseInfoForDecl (l,st) ((Just (L loc (TyClD (ClassDecl _ lid _ _ _ _ _ _ )))), mbComment') = addLocationAndComment (l,st) (unLoc lid) loc mbComment' [Class] [] --} -#if MIN_VERSION_ghc(6,12,1) -printHsDoc :: NDoc -> String -printHsDoc (HsDocString fs) = unpackFS fs - -#else -printHsDoc :: NDoc -> String -printHsDoc d = show (PPDoc d) - --- Okay, I need to reconstruct the document comments, but for now: ---instance Outputable (DocDecl name) where --- ppr _ = text "<**>" - - -newtype PPDoc alpha = PPDoc (HsDoc alpha) +printHsDoc :: NDoc -> Text +printHsDoc (HsDocString fs) = T.pack $ unpackFS fs -instance Outputable alpha => Show (PPDoc alpha) where - showsPrec _ (PPDoc DocEmpty) = id - showsPrec _ (PPDoc (DocAppend l r)) = shows (PPDoc l) . shows (PPDoc r) - showsPrec _ (PPDoc (DocString str)) = showString str - showsPrec _ (PPDoc (DocParagraph d)) = shows (PPDoc d) . showChar '\n' - showsPrec _ (PPDoc (DocIdentifier l)) = foldr (\i _f -> showChar '\'' . - ((showString . showSDoc . ppr) i) . showChar '\'') id l - showsPrec _ (PPDoc (DocModule str)) = showChar '"' . showString str . showChar '"' - showsPrec _ (PPDoc (DocEmphasis doc)) = showChar '/' . shows (PPDoc doc) . showChar '/' - showsPrec _ (PPDoc (DocMonospaced doc)) = showChar '@' . shows (PPDoc doc) . showChar '@' - showsPrec _ (PPDoc (DocUnorderedList l)) = - foldr (\s r -> showString "* " . shows (PPDoc s) . showChar '\n' . r) id l - showsPrec _ (PPDoc (DocOrderedList l)) = - foldr (\(i,n) _f -> shows n . showSpace . shows (PPDoc i)) id (zip l [1 .. length l]) - showsPrec _ (PPDoc (DocDefList li)) = - foldr (\(l,r) f -> showString "[@" . shows (PPDoc l) . showString "[@ " . shows (PPDoc r) . f) id li - showsPrec _ (PPDoc (DocCodeBlock doc)) = showChar '@' . shows (PPDoc doc) . showChar '@' - showsPrec _ (PPDoc (DocURL str)) = showChar '<' . showString str . showChar '>' - showsPrec _ (PPDoc (DocAName str)) = showChar '#' . showString str . showChar '#' - showsPrec _ (PPDoc _) = id -#endif --------------------------------------------------------------------------------- -- Now the interface file stuff diff --git a/src/IDE/StrippedPrefs.hs b/src/IDE/StrippedPrefs.hs --- a/src/IDE/StrippedPrefs.hs +++ b/src/IDE/StrippedPrefs.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE OverloadedStrings #-} ----------------------------------------------------------------------------- -- -- Module : IDE.StrippedPrefs @@ -31,6 +32,7 @@ import System.Directory (getHomeDirectory) import Control.Monad (liftM) import IDE.Core.CTypes (RetrieveStrategy(..)) +import Data.Text (Text) -- -- | Preferences is a data structure to hold configuration data @@ -38,7 +40,7 @@ data Prefs = Prefs { sourceDirectories :: [FilePath] , unpackDirectory :: Maybe FilePath - , retrieveURL :: String + , retrieveURL :: Text , retrieveStrategy :: RetrieveStrategy , serverPort :: Int , endWithLastConn :: Bool diff --git a/src/IDE/Utils/FileUtils.hs b/src/IDE/Utils/FileUtils.hs --- a/src/IDE/Utils/FileUtils.hs +++ b/src/IDE/Utils/FileUtils.hs @@ -1,5 +1,6 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE OverloadedStrings #-} -{-# OPTIONS_GHC -XScopedTypeVariables -XBangPatterns #-} ----------------------------------------------------------------------------- -- -- Module : IDE.Utils.FileUtils @@ -85,16 +86,17 @@ import Control.Exception as E (SomeException, catch) import System.IO.Strict (readFile) import qualified Data.Text as T - (map, stripPrefix, isSuffixOf, take, length, unpack, init, last, - words) + (pack, map, stripPrefix, isSuffixOf, take, length, unpack, init, + last, words) import Data.Monoid ((<>)) import Control.Applicative ((<$>)) +import Data.Text (Text) -haskellSrcExts :: [String] +haskellSrcExts :: [FilePath] haskellSrcExts = ["hs","lhs","chs","hs.pp","lhs.pp","chs.pp","hsc"] -- | canonicalizePath without crashing -myCanonicalizePath :: String -> IO String +myCanonicalizePath :: FilePath -> IO FilePath myCanonicalizePath fp = do exists <- doesFileExist fp if exists @@ -111,7 +113,7 @@ in res findSourceFile :: [FilePath] - -> [String] + -> [FilePath] -> ModuleName -> IO (Maybe FilePath) findSourceFile directories exts modId = @@ -122,7 +124,7 @@ in find' allPossibles findSourceFile' :: [FilePath] - -> String + -> FilePath -> IO (Maybe FilePath) findSourceFile' directories modulePath = let allPathes = map (\ d -> d modulePath) directories @@ -160,13 +162,13 @@ then return (Just filePath) else return Nothing -hasSavedConfigFile :: String -> IO Bool +hasSavedConfigFile :: FilePath -> IO Bool hasSavedConfigFile fn = do savedConfigFile <- getConfigFilePathForSave fn doesFileExist savedConfigFile -getConfigFilePathForLoad :: String -> Maybe FilePath -> FilePath -> IO FilePath +getConfigFilePathForLoad :: FilePath -> Maybe FilePath -> FilePath -> IO FilePath getConfigFilePathForLoad fn mbFilePath dataDir = do mbCd <- case mbFilePath of Just p -> return (Just p) @@ -184,7 +186,7 @@ then return (dataDir "data" fn) else error $"Config file not found: " ++ fn -getConfigFilePathForSave :: String -> IO FilePath +getConfigFilePathForSave :: FilePath -> IO FilePath getConfigFilePathForSave fn = do cd <- getConfigDir return (cd fn) @@ -206,7 +208,7 @@ let mbModuleNames = catMaybes $ map (\n -> case n of Nothing -> Nothing - Just s -> simpleParse s) + Just s -> simpleParse $ T.unpack s) mbModuleStrs otherModules <- mapM allModules dirs return (mbModuleNames ++ concat otherModules) @@ -222,7 +224,7 @@ allHaskellSourceFiles :: FilePath -> IO [FilePath] allHaskellSourceFiles = allFilesWithExtensions [".hs",".lhs"] True [] -allFilesWithExtensions :: [String] -> Bool -> [FilePath] -> FilePath -> IO [FilePath] +allFilesWithExtensions :: [FilePath] -> Bool -> [FilePath] -> FilePath -> IO [FilePath] allFilesWithExtensions extensions recurseFurther collecting filePath = E.catch (do exists <- doesDirectoryExist filePath if exists @@ -243,7 +245,7 @@ $ \ (_ :: SomeException) -> return collecting -moduleNameFromFilePath :: FilePath -> IO (Maybe String) +moduleNameFromFilePath :: FilePath -> IO (Maybe Text) moduleNameFromFilePath fp = E.catch (do exists <- doesFileExist fp if exists @@ -253,7 +255,7 @@ else return Nothing) $ \ (_ :: SomeException) -> return Nothing -moduleNameFromFilePath' :: FilePath -> String -> IO (Maybe String) +moduleNameFromFilePath' :: FilePath -> FilePath -> IO (Maybe Text) moduleNameFromFilePath' fp str = do let unlitRes = if takeExtension fp == ".lhs" then unlit fp str @@ -278,10 +280,10 @@ whiteSpace :: CharParser st () whiteSpace = P.whiteSpace lexer -symbol :: String -> CharParser st String -symbol = P.symbol lexer +symbol :: Text -> CharParser st Text +symbol = (T.pack <$>) . P.symbol lexer . T.unpack -moduleNameParser :: CharParser () String +moduleNameParser :: CharParser () Text moduleNameParser = do whiteSpace many skipPreproc @@ -300,18 +302,19 @@ return ()) "preproc" -mident :: GenParser Char st String +mident :: GenParser Char st Text mident = do{ c <- P.identStart haskellDef ; cs <- many (alphaNum <|> oneOf "_'.") - ; return (c:cs) + ; return (T.pack (c:cs)) } "midentifier" -findKnownPackages :: FilePath -> IO (Set String) +findKnownPackages :: FilePath -> IO (Set Text) findKnownPackages filePath = E.catch (do paths <- getDirectoryContents filePath - let nameList = map dropExtension $filter (\s -> leksahMetadataSystemFileExtension `isSuffixOf` s) paths + let nameList = map (T.pack . dropExtension) $ + filter (\s -> leksahMetadataSystemFileExtension `isSuffixOf` s) paths return (Set.fromList nameList)) $ \ (_ :: SomeException) -> return (Set.empty) @@ -427,20 +430,20 @@ replaceSpace ' ' = '-' replaceSpace c = c -figureOutHaddockOpts :: IO [String] +figureOutHaddockOpts :: IO [Text] figureOutHaddockOpts = do (!output,_) <- runTool' "cabal" (["haddock","--with-haddock=leksahecho","--executables"]) Nothing let opts = concatMap (words . T.unpack . toolline) output let res = filterOptGhc opts debugM "leksah-server" ("figureOutHaddockOpts " ++ show res) - return res + return $ map T.pack res where filterOptGhc [] = [] filterOptGhc (s:r) = case stripPrefix "--optghc=" s of Nothing -> filterOptGhc r Just s' -> s' : filterOptGhc r -figureOutGhcOpts :: IO [String] +figureOutGhcOpts :: IO [Text] figureOutGhcOpts = do debugM "leksah-server" "figureOutGhcOpts" (!output,_) <- runTool' "cabal" ["build","--with-ghc=leksahecho"] Nothing @@ -448,7 +451,7 @@ options:_ -> words options _ -> [] debugM "leksah-server" $ ("figureOutGhcOpts " ++ show res) - return res + return $ map T.pack res where findMake [] = Nothing findMake line@(_:xs) = diff --git a/src/IDE/Utils/GHCUtils.hs b/src/IDE/Utils/GHCUtils.hs --- a/src/IDE/Utils/GHCUtils.hs +++ b/src/IDE/Utils/GHCUtils.hs @@ -1,4 +1,6 @@ -{-# OPTIONS_GHC -XCPP -fno-warn-orphans #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} ----------------------------------------------------------------------------- -- -- Module : IDE.Utils.GHCUtils @@ -43,18 +45,24 @@ import qualified Parser as P (parseModule,parseHeader) import HscStats (ppSourceStats) #if MIN_VERSION_ghc(7,2,0) +#if !MIN_VERSION_ghc(7,7,0) import GhcMonad (Ghc(..)) +#endif import SrcLoc (mkRealSrcLoc) #else import HscTypes (Ghc(..)) #endif import IDE.Utils.FileUtils (getSysLibDir) #if MIN_VERSION_ghc(7,7,0) -import DynFlags (dopt_set, DumpFlag(..), gopt_set,GeneralFlag(..)) -#endif +import DynFlags (DumpFlag(..), gopt_set) +#else import DynFlags (dopt_set) +#endif import System.Log.Logger(debugM) import Control.Monad.IO.Class (MonadIO(..)) +import Data.Text (Text) +import qualified Data.Text as T (pack, unpack) +import Data.Monoid ((<>)) #if !MIN_VERSION_ghc(7,7,0) -- this should not be repeated here, why is it necessary? @@ -63,9 +71,9 @@ #endif #if MIN_VERSION_ghc(7,7,0) -inGhcIO :: [String] -> [GeneralFlag] -> (DynFlags -> Ghc a) -> IO a +inGhcIO :: [Text] -> [GeneralFlag] -> (DynFlags -> Ghc a) -> IO a #else -inGhcIO :: [String] -> [DynFlag] -> (DynFlags -> Ghc a) -> IO a +inGhcIO :: [Text] -> [DynFlag] -> (DynFlags -> Ghc a) -> IO a #endif inGhcIO flags' udynFlags ghcAct = do debugM "leksah-server" $ "inGhcIO called with: " ++ show flags' @@ -83,7 +91,7 @@ ghcMode = CompManager, ghcLink = NoLink } - dynflags''' <- parseGhcFlags dynflags'' (map noLoc flags') flags' + dynflags''' <- parseGhcFlags dynflags'' (map (noLoc . T.unpack) flags') flags' res <- defaultCleanupHandler dynflags''' $ do setSessionDynFlags dynflags''' ghcAct dynflags''' @@ -91,7 +99,7 @@ return res where parseGhcFlags :: DynFlags -> [Located String] - -> [String] -> Ghc DynFlags + -> [Text] -> Ghc DynFlags parseGhcFlags dynflags flags_ _origFlags = do (dynflags', rest, _) <- parseDynamicFlags dynflags flags_ if not (null rest) @@ -155,11 +163,7 @@ let loc = mkSrcLoc (mkFastString src_filename) 1 0 #endif -#if MIN_VERSION_ghc(7,0,1) case unP P.parseModule (mkPState dflags buf' loc) of { -#else - case unP P.parseModule (mkPState buf' loc dflags) of { -#endif #if MIN_VERSION_ghc(7,6,0) PFailed span' err -> return (Left (mkPlainErrMsg dflags span' err)); @@ -192,7 +196,7 @@ -- ToDo: free the string buffer later. }} -myParseHeader :: FilePath -> String -> [String] -> IO (Either String (DynFlags, HsModule RdrName)) +myParseHeader :: FilePath -> String -> [Text] -> IO (Either Text (DynFlags, HsModule RdrName)) myParseHeader fp _str opts = inGhcIO (opts++["-cpp"]) [] $ \ _dynFlags -> do session <- getSession #if MIN_VERSION_ghc(7,2,0) @@ -206,7 +210,7 @@ case parseResult of Right (L _ mod') -> return (Right (dynFlags', mod')) Left errMsg -> do - let str = "Failed to parse " ++ show errMsg + let str = "Failed to parse " <> T.pack (show errMsg) return (Left str) --------------------------------------------------------------------- diff --git a/src/IDE/Utils/Server.hs b/src/IDE/Utils/Server.hs --- a/src/IDE/Utils/Server.hs +++ b/src/IDE/Utils/Server.hs @@ -32,8 +32,9 @@ import Data.Word import System.Log.Logger (infoM) +import Data.Text (Text) -data UserAndGroup = UserAndGroup String String | UserWithDefaultGroup String +data UserAndGroup = UserAndGroup Text Text | UserWithDefaultGroup Text -- | Set the user and group for the process. If the group is Nothing, then use the users default group. -- This is especially useful when you are root and want to become a user. diff --git a/src/IDE/Utils/Tool.hs b/src/IDE/Utils/Tool.hs --- a/src/IDE/Utils/Tool.hs +++ b/src/IDE/Utils/Tool.hs @@ -68,7 +68,8 @@ terminateProcess) import System.Process.Internals (StdStream(..)) #endif -import qualified Data.Text as T (null, lines, any, unpack, pack, filter) +import qualified Data.Text as T + (unlines, unwords, null, lines, any, unpack, pack, filter) import Control.DeepSeq import System.Log.Logger (debugM) import System.Exit (ExitCode(..)) @@ -79,6 +80,7 @@ import Data.Conduit as C ((=$), ($$), ($=)) import qualified Data.Conduit as C +import Control.Monad.Trans.Resource (runResourceT) import qualified Data.Conduit.Text as CT (decode, utf8) import qualified Data.Conduit.List as CL (consume, concatMap, concatMapAccumM, sequence, map) @@ -144,18 +146,18 @@ interruptProcessGroupOf = interruptProcessGroup #endif -runTool' :: FilePath -> [String] -> Maybe FilePath -> IO ([ToolOutput], ProcessHandle) +runTool' :: FilePath -> [Text] -> Maybe FilePath -> IO ([ToolOutput], ProcessHandle) runTool' fp args mbDir = do debugM "leksah-server" $ "Start: " ++ show (fp, args) (out,pid) <- runTool fp args mbDir - output <- C.runResourceT $ out $$ CL.consume + output <- runResourceT $ out $$ CL.consume waitForProcess pid debugM "leksah-server" $ "End: " ++ show (fp, args) return (output,pid) -runTool :: MonadIO m => FilePath -> [String] -> Maybe FilePath -> IO (C.Source m ToolOutput, ProcessHandle) +runTool :: MonadIO m => FilePath -> [Text] -> Maybe FilePath -> IO (C.Source m ToolOutput, ProcessHandle) runTool executable arguments mbDir = do - (Just inp,Just out,Just err,pid) <- createProcess (proc executable arguments) + (Just inp,Just out,Just err,pid) <- createProcess (proc executable (map T.unpack arguments)) { std_in = CreatePipe, std_out = CreatePipe, std_err = CreatePipe, @@ -186,11 +188,11 @@ ToolState -> CommandLineReader -> FilePath -> - [String] -> + [Text] -> Maybe FilePath -> IO () runInteractiveTool tool clr executable arguments mbDir = do - (Just inp,Just out,Just err,pid) <- createProcess (proc executable arguments) + (Just inp,Just out,Just err,pid) <- createProcess (proc executable (map T.unpack arguments)) { std_in = CreatePipe, std_out = CreatePipe, std_err = CreatePipe, @@ -258,7 +260,7 @@ return (s, []) {- -newInteractiveTool :: (Handle -> Handle -> Handle -> ProcessHandle -> IO [RawToolOutput]) -> FilePath -> [String] -> IO ToolState +newInteractiveTool :: (Handle -> Handle -> Handle -> ProcessHandle -> IO [RawToolOutput]) -> FilePath -> [Text] -> IO ToolState newInteractiveTool getOutput' executable arguments = do tool <- newToolState runInteractiveTool tool getOutput' executable arguments @@ -484,7 +486,7 @@ output <- getOutput noInputCommandLineReader inp out err pid return $ output $= CL.concatMap fromRawOutput -newGhci' :: [String] -> (C.Sink ToolOutput IO ()) -> IO ToolState +newGhci' :: [Text] -> (C.Sink ToolOutput IO ()) -> IO ToolState newGhci' flags startupOutputHandler = do tool <- newToolState writeChan (toolCommands tool) $ @@ -492,27 +494,27 @@ runInteractiveTool tool ghciCommandLineReader "ghci" flags Nothing return tool -newGhci :: FilePath -> Maybe String -> [String] -> (C.Sink ToolOutput IO ()) -> IO ToolState +newGhci :: FilePath -> Maybe Text -> [Text] -> (C.Sink ToolOutput IO ()) -> IO ToolState newGhci dir mbExe interactiveFlags startupOutputHandler = do tool <- newToolState writeChan (toolCommands tool) $ - ToolCommand (":set " <> T.pack (unwords interactiveFlags) <> "\n:set prompt " <> ghciPrompt) "" startupOutputHandler + ToolCommand (":set " <> T.unwords interactiveFlags <> "\n:set prompt " <> ghciPrompt) "" startupOutputHandler runInteractiveTool tool ghciCommandLineReader "cabal" ("repl" : maybeToList mbExe) (Just dir) return tool -executeCommand :: ToolState -> String -> String -> C.Sink ToolOutput IO () -> IO () +executeCommand :: ToolState -> Text -> Text -> C.Sink ToolOutput IO () -> IO () executeCommand tool command rawCommand handler = do - writeChan (toolCommands tool) $ ToolCommand (T.pack command) (T.pack rawCommand) handler + writeChan (toolCommands tool) $ ToolCommand command rawCommand handler -executeGhciCommand :: ToolState -> String -> C.Sink ToolOutput IO () -> IO () +executeGhciCommand :: ToolState -> Text -> C.Sink ToolOutput IO () -> IO () executeGhciCommand tool command handler = do - if '\n' `elem` command + if '\n' `elem` T.unpack command then executeCommand tool safeCommand command handler else executeCommand tool command command handler where - filteredLines = (filter safeLine (lines command)) - safeCommand = ":cmd (return " ++ show (":{\n" ++ unlines filteredLines ++ "\n:}") ++ ")" + filteredLines = (filter safeLine (T.lines command)) + safeCommand = ":cmd (return " <> T.pack (show $ ":{\n" <> T.unlines filteredLines <> "\n:}") <> ")" safeLine ":{" = False safeLine ":}" = False safeLine _ = True diff --git a/src/IDE/Utils/VersionUtils.hs b/src/IDE/Utils/VersionUtils.hs --- a/src/IDE/Utils/VersionUtils.hs +++ b/src/IDE/Utils/VersionUtils.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE ScopedTypeVariables, BangPatterns #-} +{-# LANGUAGE ScopedTypeVariables, BangPatterns, OverloadedStrings #-} ----------------------------------------------------------------------------- -- -- Module : IDE.Utils.VersionUtils @@ -24,6 +24,7 @@ import System.Log.Logger (debugM) import Control.Exception as E (SomeException, catch) import qualified Data.Text as T (unlines, unpack, init, last) +import Data.Text (Text) getGhcVersion :: IO FilePath getGhcVersion = E.catch (do @@ -36,20 +37,20 @@ return $ T.unpack vers2 ) $ \ (_ :: SomeException) -> error ("FileUtils>>getGhcVersion failed") -getGhcInfo :: IO String +getGhcInfo :: IO Text getGhcInfo = E.catch (do (!output,_) <- runTool' "ghc" ["--info"] Nothing - return . T.unpack . T.unlines $ map toolline output + return . T.unlines $ map toolline output ) $ \ (_ :: SomeException) -> error ("FileUtils>>getGhcInfo failed") -getHaddockVersion :: IO String +getHaddockVersion :: IO Text getHaddockVersion = E.catch (do (!output,_) <- runTool' "haddock" ["--version"] Nothing let vers = toolline $ head output vers2 = if ord (T.last vers) == 13 then T.init vers else vers - return $ T.unpack vers2 + return vers2 ) $ \ (_ :: SomeException) -> error ("FileUtils>>getHaddockVersion failed") diff --git a/src/LeksahEcho.hs b/src/LeksahEcho.hs --- a/src/LeksahEcho.hs +++ b/src/LeksahEcho.hs @@ -18,17 +18,19 @@ import System.Environment (getArgs) import IDE.Utils.VersionUtils (getHaddockVersion, getGhcVersion, getGhcInfo) +import qualified Data.Text as T (unpack) +import Control.Applicative ((<$>)) main :: IO () main = do args <- getArgs -- appendFile "/Users/hamish/lecho.log" $ show args ++ "/n" if elem "--version" args - then putStrLn =<< getHaddockVersion + then putStrLn =<< T.unpack <$> getHaddockVersion else if elem "--ghc-version" args then putStrLn =<< getGhcVersion else if elem "--info" args - then putStrLn =<< getGhcInfo + then putStrLn =<< T.unpack <$> getGhcInfo else if elem "--numeric-version" args then putStrLn =<< getGhcVersion else putStrLn $ unwords args