packages feed

hsdev 0.1.3.3 → 0.1.3.4

raw patch · 5 files changed

+115/−29 lines, 5 files

Files

hsdev.cabal view
@@ -2,7 +2,7 @@ --  see http://haskell.org/cabal/users-guide/
 
 name:                hsdev
-version:             0.1.3.3
+version:             0.1.3.4
 synopsis:            Haskell development library and tool with support of autocompletion, symbol info, go to declaration, find references etc.
 description:
   Haskell development library and tool with support of autocompletion, symbol info, go to declaration, find references, hayoo search etc.
src/HsDev/Database/Update.hs view
@@ -297,19 +297,18 @@ 		inDir = maybe False (dir `isParent`) . moduleSource . moduleIdLocation
 
 -- | Generic scan function. Reads cache only if data is not already loaded, removes obsolete modules and rescans changed modules.
-scan ::
-	(MonadIO m, MonadCatch m) =>
-	(FilePath -> ErrorT String IO Structured) ->
+scan :: (MonadIO m, MonadCatch m)
+	=> (FilePath -> ErrorT String IO Structured)
 	-- ^ Read data from cache
-	(Database -> Database) ->
+	-> (Database -> Database)
 	-- ^ Get data from database
-	[S.ModuleToScan] ->
+	-> [S.ModuleToScan]
 	-- ^ Actual modules. Other modules will be removed from database
-	[String] ->
+	-> [String]
 	-- ^ Extra scan options
-	([S.ModuleToScan] -> ErrorT String (UpdateDB m) ()) ->
+	-> ([S.ModuleToScan] -> ErrorT String (UpdateDB m) ())
 	-- ^ Function to update changed modules
-	ErrorT String (UpdateDB m) ()
+	-> ErrorT String (UpdateDB m) ()
 scan cache' part' mlocs opts act = do
 	dbval <- getCache cache' part'
 	let
src/HsDev/Inspect.hs view
@@ -14,12 +14,13 @@ import qualified Control.Exception as E import Control.Monad import Control.Monad.Error+import Data.Char (isSpace) import Data.Function (on) import Data.List import Data.Map (Map)-import Data.Maybe (fromMaybe, mapMaybe, catMaybes)+import Data.Maybe (fromMaybe, mapMaybe, catMaybes, listToMaybe) import Data.Ord (comparing)-import Data.String (fromString)+import Data.String (IsString, fromString) import qualified Data.Text as T (unpack) import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds) import Data.Traversable (traverse, sequenceA)@@ -59,10 +60,58 @@ 		untab '\t' = ' ' 		untab ch = ch +-- | Analize source contents+analyzeModule_ :: [String] -> Maybe FilePath -> String -> Either String Module+analyzeModule_ exts file source = do+	mname <- parseModuleName source'+	return $ Module {+		moduleName = fromString mname,+		moduleDocs = Nothing,+		moduleLocation = ModuleSource Nothing,+		moduleExports = Nothing,+		moduleImports = [],+		moduleDeclarations = sortDeclarations $ getDecls $ mapMaybe (uncurry parseDecl') parts }+	where+		parts :: [(Int, String)]+		parts = zip offsets (map unlines parts') where+			parts' :: [[String]]+			parts' = unfoldr break' $ lines source'+			offsets = scanl (+) 0 $ map length parts'+		break' :: [String] -> Maybe ([String], [String])+		break' [] = Nothing+		break' (l:ls) = Just $ first (l:) $ break (not . maybe True isSpace . listToMaybe) ls++		parseModuleName :: String -> Either String String+		parseModuleName cts = maybe (Left "match fail") Right $ do+			g <- matchRx "^module\\s+([\\w\\.]+)" cts+			g 1++		parseDecl' :: Int -> String -> Maybe H.Decl+		parseDecl' offset cts = fmap (transformBi addOffset) $ case H.parseDeclWithMode pmode cts of+			H.ParseFailed _ _ -> Nothing+			H.ParseOk decl' -> Just decl'+			where+				addOffset :: H.SrcLoc -> H.SrcLoc+				addOffset src = src { H.srcLine = H.srcLine src + offset }++		pmode :: H.ParseMode+		pmode = H.defaultParseMode {+			H.parseFilename = fromMaybe (H.parseFilename H.defaultParseMode) file,+			H.baseLanguage = H.Haskell2010,+			H.extensions = H.glasgowExts ++ map H.parseExtension exts,+			H.fixities = Just H.baseFixities }++		-- Replace all tabs to spaces to make SrcLoc valid, otherwise it treats tab as 8 spaces+		source' = map untab source+		untab '\t' = ' '+		untab ch = ch++-- | Get exports getExports :: H.ExportSpec -> [Export] getExports (H.EModuleContents (H.ModuleName m)) = [ExportModule $ fromString m] getExports e = map (uncurry ExportName . (fmap fromString *** fromString) . identOfQName) $ childrenBi e +-- | Get import getImport :: H.ImportDecl -> Import getImport d = Import 	(mname (H.importModule d))@@ -74,6 +123,7 @@ 		mname (H.ModuleName n) = fromString n 		importLst (hiding, specs) = ImportList hiding $ map (fromString . identOfName) (concatMap childrenBi specs :: [H.Name]) +-- | Decl declarations getDecls :: [H.Decl] -> [Declaration] getDecls decls = 	map mergeDecls .@@ -95,24 +145,23 @@ 		mergeInfos (Function ln ld) (Function rn rd) = Function (ln `mplus` rn) (ld ++ rd) 		mergeInfos l _ = l +-- | Get definitions getBinds :: H.Binds -> [Declaration] getBinds (H.BDecls decls) = getDecls decls getBinds _ = [] +-- | Get declaration and child declarations getDecl :: H.Decl -> [Declaration] getDecl decl' = case decl' of-	H.TypeSig loc names typeSignature -> [mkFun loc n (Function (Just $ fromString $ oneLinePrint typeSignature) []) | n <- names]+	H.TypeSig loc names typeSignature -> [mkFun loc n (Function (Just $ oneLinePrint typeSignature) []) | n <- names] 	H.TypeDecl loc n args _ -> [mkType loc n Type args]-	H.DataDecl loc dataOrNew ctx n args _ _ -> [mkType loc n (ctor dataOrNew `withCtx` ctx) args]-	H.GDataDecl loc dataOrNew ctx n args _ _ _ -> [mkType loc n (ctor dataOrNew `withCtx` ctx) args]+	H.DataDecl loc dataOrNew ctx n args cons _ -> mkType loc n (ctor dataOrNew `withCtx` ctx) args : concatMap (getConDecl n args) cons+	H.GDataDecl loc dataOrNew ctx n args _ gcons _ -> mkType loc n (ctor dataOrNew `withCtx` ctx) args : concatMap getGConDecl gcons 	H.ClassDecl loc ctx n args _ _ -> [mkType loc n (Class `withCtx` ctx) args] 	_ -> [] 	where-		mkFun :: H.SrcLoc -> H.Name -> DeclarationInfo -> Declaration-		mkFun loc n = setPosition loc . decl (fromString $ identOfName n)- 		mkType :: H.SrcLoc -> H.Name -> (TypeInfo -> DeclarationInfo) -> [H.TyVarBind] -> Declaration-		mkType loc n ctor' args = setPosition loc $ decl (fromString $ identOfName n) $ ctor' $ TypeInfo Nothing (map (fromString . oneLinePrint) args) Nothing+		mkType loc n ctor' args = setPosition loc $ decl (fromString $ identOfName n) $ ctor' $ TypeInfo Nothing (map oneLinePrint args) Nothing  		withCtx :: (TypeInfo -> DeclarationInfo) -> H.Context -> TypeInfo -> DeclarationInfo 		withCtx ctor' ctx tinfo = ctor' (tinfo { typeInfoContext = makeCtx ctx })@@ -124,9 +173,28 @@ 		makeCtx [] = Nothing 		makeCtx ctx = Just $ fromString $ intercalate ", " $ map oneLinePrint ctx -		oneLinePrint :: H.Pretty a => a -> String-		oneLinePrint = H.prettyPrintStyleMode (H.style { H.mode = H.OneLineMode }) H.defaultMode+-- | Get constructor and record fields declarations+getConDecl :: H.Name -> [H.TyVarBind] -> H.QualConDecl -> [Declaration]+getConDecl t as (H.QualConDecl loc _ _ cdecl) = case cdecl of+	H.ConDecl n cts -> [mkFun loc n (Function (Just $ oneLinePrint $ cts `tyFun` dataRes) [])]+	H.InfixConDecl ct n cts -> [mkFun loc n (Function (Just $ oneLinePrint $ (ct : [cts]) `tyFun` dataRes) [])]+	H.RecDecl n fields -> mkFun loc n (Function (Just $ oneLinePrint $ map snd fields `tyFun` dataRes) []) : concatMap (uncurry (getRec loc dataRes)) fields+	where+		dataRes :: H.Type+		dataRes = foldr H.TyApp (H.TyCon (H.UnQual t)) $ map (H.TyVar . nameOf) as where+			nameOf :: H.TyVarBind -> H.Name+			nameOf (H.KindedVar n' _) = n'+			nameOf (H.UnkindedVar n') = n' +-- | Get GADT constructor and record fields declarations+getGConDecl :: H.GadtDecl -> [Declaration]+getGConDecl (H.GadtDecl loc n fields r) = mkFun loc n (Function (Just $ oneLinePrint $ map snd fields `tyFun` r) []) : concatMap (uncurry (getRec loc r)) fields where++-- | Get record field declaration+getRec :: H.SrcLoc -> H.Type -> [H.Name] -> H.Type -> [Declaration]+getRec loc t ns rt = [mkFun loc n (Function (Just $ oneLinePrint $ t `H.TyFun` rt) []) | n <- ns]++-- | Get definitions getDef :: H.Decl -> [Declaration] getDef (H.FunBind []) = [] getDef (H.FunBind matches@(H.Match loc n _ _ _ _ : _)) = [setPosition loc $ decl (fromString $ identOfName n) fun] where@@ -159,19 +227,37 @@ 	fieldNames H.PFieldWildcard = [] getDef _ = [] +-- | Make function declaration by location, name and function type+mkFun :: H.SrcLoc -> H.Name -> DeclarationInfo -> Declaration+mkFun loc n = setPosition loc . decl (fromString $ identOfName n)++-- | Make function from arguments and result+--+-- @[a, b, c...] `tyFun` r == a `TyFun` b `TyFun` c ... `TyFun` r@+tyFun :: [H.Type] -> H.Type -> H.Type+tyFun as' r' = foldr H.TyFun r' as'++-- | Get name of qualified name identOfQName :: H.QName -> (Maybe String, String) identOfQName (H.Qual (H.ModuleName mname) name) = (Just mname, identOfName name) identOfQName (H.UnQual name) = (Nothing, identOfName name) identOfQName (H.Special sname) = (Nothing, H.prettyPrint sname) +-- | Get name of @H.Name@ identOfName :: H.Name -> String identOfName name = case name of 	H.Ident s -> s 	H.Symbol s -> s +-- | Print something in one line+oneLinePrint :: (H.Pretty a, IsString s) => a -> s+oneLinePrint = fromString . H.prettyPrintStyleMode (H.style { H.mode = H.OneLineMode }) H.defaultMode++-- | Convert @H.SrcLoc@ to @Position toPosition :: H.SrcLoc -> Position toPosition (H.SrcLoc _ l c) = Position l c +-- | Set @Declaration@ position setPosition :: H.SrcLoc -> Declaration -> Declaration setPosition loc d = d { declarationPosition = Just (toPosition loc) } @@ -197,7 +283,7 @@ -- | Inspect contents inspectContents :: String -> [String] -> String -> ErrorT String IO InspectedModule inspectContents name opts cts = inspect (ModuleSource $ Just name) (contentsInspection cts opts) $ do-	analyzed <- ErrorT $ return $ analyzeModule exts (Just name) cts+	analyzed <- ErrorT $ return $ analyzeModule exts (Just name) cts <|> analyzeModule_ exts (Just name) cts 	return $ setLoc analyzed 	where 		setLoc m = m { moduleLocation = ModuleSource (Just name) }@@ -217,7 +303,8 @@ 		-- 	then hdocsProcess absFilename opts 		-- 	else liftM Just $ hdocs (FileModule absFilename Nothing) opts 		forced <- ErrorT $ E.handle onError $ do-			analyzed <- liftM (analyzeModule exts (Just absFilename)) $ readFileUtf8 absFilename+			analyzed <- liftM (\s -> analyzeModule exts (Just absFilename) s <|> analyzeModule_ exts (Just absFilename) s) $+				readFileUtf8 absFilename 			force analyzed `deepseq` return analyzed 		-- return $ setLoc absFilename proj . maybe id addDocs docsMap $ forced 		return $ setLoc absFilename proj forced
src/HsDev/Tools/AutoFix.hs view
@@ -31,7 +31,7 @@ 	description :: String,
 	message :: String,
 	solution :: String,
-	corrector :: [Replace String] }
+	corrector :: Replace String }
 		deriving (Eq, Read, Show)
 
 instance Canonicalize Correction where
@@ -58,7 +58,7 @@ 		v .:: "corrector"
 
 correct :: Correction -> EditM String ()
-correct = run . corrector
+correct c = run [corrector c]
 
 corrections :: [OutputMessage] -> [Correction]
 corrections = mapMaybe toCorrection where
@@ -80,8 +80,8 @@ 
 updateRegion :: Correction -> EditM String Correction
 updateRegion corr = do
-	c' <- sequence [Replace <$> mapRegion r <*> pure cts | Replace r cts <- corrector corr]
-	return $ corr { corrector = c' }
+	region' <- mapRegion $ replaceRegion (corrector corr)
+	return $ corr { corrector = (corrector corr) { replaceRegion = region' } }
 
 type CorrectorMatch = FilePath -> Point -> String -> Maybe Correction
 
@@ -91,12 +91,12 @@ 		"Redundant import"
 		("Redundant import: " ++ (g `at` 1)) ""
 		"Remove import"
-		[eraser (pt `regionSize` linesSize 1)],
+		(eraser (pt `regionSize` linesSize 1)),
 	match "Found:\n  (.*?)\nWhy not:\n  (.*?)$" $ \g file pt -> Correction file
 		"Why not?"
 		("Replace '" ++ (g `at` 1) ++ "' with '" ++ (g `at` 2) ++ "'") ""
 		"Replace with suggestion"
-		[replacer (pt `regionSize` stringSize (length $ g `at` 1)) (g `at` 2)]]
+		(replacer (pt `regionSize` stringSize (length $ g `at` 1)) (g `at` 2))]
 
 match :: String -> ((Int -> Maybe String) -> FilePath -> Point -> Correction) -> CorrectorMatch
 match pat f file pt str = do
tools/hsinspect.hs view
@@ -32,7 +32,7 @@ 			im <- scanModule (ghcs opts) (FileModule fname' Nothing)
 			let
 				scanAdditional =
-					scanModify (\opts cabal -> inspectDocs opts) >=>
+					scanModify (\opts' _ -> inspectDocs opts') >=>
 					scanModify infer
 			toJSON <$> scanAdditional im
 		inspect' (Args [fcabal@(takeExtension -> ".cabal")] _) = do