hasufell/ghc-mod
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Merge remote-tracking branch 'kazu/master'

Browse Source 
Conflicts:
	Language/Haskell/GhcMod/Check.hs
	Language/Haskell/GhcMod/FillSig.hs
	Language/Haskell/GhcMod/GHCApi.hs
This commit is contained in:
Alejandro Serrano
2014-07-18 17:12:52 +02:00
parent 852d742796 0080f9b68c
commit 6302d4882e
28 changed files with 292 additions and 186 deletions
Download Patch File Download Diff File Expand all files Collapse all files

28
Language/Haskell/GhcMod/FillSig.hs
View File

@@ -6,7 +6,7 @@ module Language.Haskell.GhcMod.FillSig (
) where
import Data.Char (isSymbol)
import Data.List (find, intercalate)
import Data.List (find)
import Data.Maybe (isJust)
import Exception (ghandle, SomeException(..))
import GHC (GhcMonad, Id, ParsedModule(..), TypecheckedModule(..), DynFlags, SrcSpan, Type, GenLocated(L))
@@ -48,7 +48,7 @@ sig file lineNo colNo = ghandle handler body
whenFound opt (getSignature modSum lineNo colNo) $ \s -> case s of
Signature loc names ty ->
("function", fourInts loc, map (initialBody dflag style ty) names)
InstanceDecl loc cls -> do
InstanceDecl loc cls ->
("instance", fourInts loc, map (\x -> initialBody dflag style (G.idType x) x)
(Ty.classMethods cls))
@@ -112,8 +112,8 @@ initialBody' fname args =
case initialBodyArgs args infiniteVars infiniteFns of
[] -> fname
arglist -> if isSymbolName fname
then (head arglist) ++ " " ++ fname ++ " " ++ (intercalate " " (tail arglist))
else fname ++ " " ++ (intercalate " " arglist)
then head arglist ++ " " ++ fname ++ " " ++ unwords (tail arglist)
else fname ++ " " ++ unwords arglist
++ " = " ++ (if isSymbolName fname then "" else '_':fname) ++ "_body"
initialBodyArgs :: [FnArg] -> [String] -> [String] -> [String]
@@ -136,11 +136,11 @@ instance FnArgsInfo (G.HsType G.RdrName) (G.RdrName) where
getFnArgs (G.HsForAllTy _ _ _ (L _ iTy)) = getFnArgs iTy
getFnArgs (G.HsParTy (L _ iTy)) = getFnArgs iTy
getFnArgs (G.HsFunTy (L _ lTy) (L _ rTy)) = (if fnarg lTy then FnArgFunction else FnArgNormal):getFnArgs rTy
where fnarg = \ty -> case ty of
(G.HsForAllTy _ _ _ (L _ iTy)) -> fnarg iTy
(G.HsParTy (L _ iTy)) -> fnarg iTy
(G.HsFunTy _ _) -> True
_ -> False
where fnarg ty = case ty of
(G.HsForAllTy _ _ _ (L _ iTy)) -> fnarg iTy
(G.HsParTy (L _ iTy)) -> fnarg iTy
(G.HsFunTy _ _) -> True
_ -> False
getFnArgs _ = []
instance FnArgsInfo (HE.Type HE.SrcSpanInfo) (HE.Name HE.SrcSpanInfo) where
@@ -149,11 +149,11 @@ instance FnArgsInfo (HE.Type HE.SrcSpanInfo) (HE.Name HE.SrcSpanInfo) where
getFnArgs (HE.TyForall _ _ _ iTy) = getFnArgs iTy
getFnArgs (HE.TyParen _ iTy) = getFnArgs iTy
getFnArgs (HE.TyFun _ lTy rTy) = (if fnarg lTy then FnArgFunction else FnArgNormal):getFnArgs rTy
where fnarg = \ty -> case ty of
(HE.TyForall _ _ _ iTy) -> fnarg iTy
(HE.TyParen _ iTy) -> fnarg iTy
(HE.TyFun _ _ _) -> True
_ -> False
where fnarg ty = case ty of
(HE.TyForall _ _ _ iTy) -> fnarg iTy
(HE.TyParen _ iTy) -> fnarg iTy
(HE.TyFun _ _ _) -> True
_ -> False
getFnArgs _ = []
instance FnArgsInfo Type Id where