formatting: FillSig.hs

This commit is contained in:
Daniel Gröber 2014-09-16 05:33:01 +02:00
parent a0289420f9
commit b96ef00248

View File

@ -1,4 +1,5 @@
{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, CPP #-}
{-# LANGUAGE CPP, MultiParamTypeClasses, FunctionalDependencies #-}
{-# LANGUAGE FlexibleInstances #-}
module Language.Haskell.GhcMod.FillSig (
sig
@ -12,7 +13,8 @@ import Data.List (find, nub, sortBy)
import qualified Data.Map as M
import Data.Maybe (isJust, catMaybes)
import Exception (ghandle, SomeException(..))
import GHC (GhcMonad, Id, ParsedModule(..), TypecheckedModule(..), DynFlags, SrcSpan, Type, GenLocated(L))
import GHC (GhcMonad, Id, ParsedModule(..), TypecheckedModule(..), DynFlags,
SrcSpan, Type, GenLocated(L))
import qualified GHC as G
import qualified Name as G
import qualified Language.Haskell.GhcMod.Gap as Gap
@ -34,13 +36,19 @@ import Djinn.GHC
----------------------------------------------------------------
-- Possible signatures we can find: function or instance
data SigInfo = Signature SrcSpan [G.RdrName] (G.HsType G.RdrName)
| InstanceDecl SrcSpan G.Class
| TyFamDecl SrcSpan G.RdrName TyFamType {- True if closed -} [G.RdrName]
data SigInfo
= Signature SrcSpan [G.RdrName] (G.HsType G.RdrName)
| InstanceDecl SrcSpan G.Class
| TyFamDecl SrcSpan G.RdrName TyFamType {- True if closed -} [G.RdrName]
-- Signature for fallback operation via haskell-src-exts
data HESigInfo = HESignature HE.SrcSpan [HE.Name HE.SrcSpanInfo] (HE.Type HE.SrcSpanInfo)
| HEFamSignature HE.SrcSpan TyFamType (HE.Name HE.SrcSpanInfo) [HE.Name HE.SrcSpanInfo]
data HESigInfo
= HESignature HE.SrcSpan [HE.Name HE.SrcSpanInfo] (HE.Type HE.SrcSpanInfo)
| HEFamSignature
HE.SrcSpan
TyFamType
(HE.Name HE.SrcSpanInfo)
[HE.Name HE.SrcSpanInfo]
data TyFamType = Closed | Open | Data
initialTyFamString :: TyFamType -> (String, String)
@ -156,21 +164,25 @@ getSignatureFromHE file lineNo colNo = do
----------------------------------------------------------------
-- b. Code for generating initial code
-- A list of function arguments, and whether they are functions or normal arguments
-- is built from either a function signature or an instance signature
-- A list of function arguments, and whether they are functions or normal
-- arguments is built from either a function signature or an instance signature
data FnArg = FnArgFunction | FnArgNormal | FnExplicitName String
initialBody :: FnArgsInfo ty name => DynFlags -> PprStyle -> ty -> name -> String
initialBody dflag style ty name = initialBody' (getFnName dflag style name) (getFnArgs ty)
initialBody dflag style ty name =
initialBody' (getFnName dflag style name) (getFnArgs ty)
initialBody' :: String -> [FnArg] -> String
initialBody' fname args = initialHead fname args ++ " = "
++ (if isSymbolName fname then "" else '_':fname) ++ "_body"
initialBody' fname args =
initialHead fname args ++ " = " ++ n ++ "_body"
where n = if isSymbolName fname then "" else '_':fname
initialFamBody :: FnArgsInfo ty name => DynFlags -> PprStyle -> name -> [name] -> String
initialFamBody dflag style name args = initialHead (getFnName dflag style name)
(map (FnExplicitName . getFnName dflag style) args)
++ " = ()"
initialFamBody :: FnArgsInfo ty name
=> DynFlags -> PprStyle -> name -> [name] -> String
initialFamBody dflag style name args =
initialHead fnName fnArgs ++ " = ()"
where fnName = getFnName dflag style name
fnArgs = map (FnExplicitName . getFnName dflag style) args
initialHead :: String -> [FnArg] -> String
initialHead fname args =
@ -185,7 +197,8 @@ initialBodyArgs [] _ _ = []
initialBodyArgs (FnArgFunction:xs) vs (f:fs) = f : initialBodyArgs xs vs fs
initialBodyArgs (FnArgNormal:xs) (v:vs) fs = v : initialBodyArgs xs vs fs
initialBodyArgs (FnExplicitName n:xs) vs fs = n : initialBodyArgs xs vs fs
initialBodyArgs _ _ _ = error "This should never happen" -- Lists are infinite
initialBodyArgs _ _ _ =
error "initialBodyArgs: This should never happen" -- Lists are infinite
initialHead1 :: String -> [FnArg] -> [String] -> String
initialHead1 fname args elts =
@ -211,7 +224,8 @@ instance FnArgsInfo (G.HsType G.RdrName) (G.RdrName) where
getFnName dflag style name = showOccName dflag style $ Gap.occName name
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
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
@ -224,7 +238,8 @@ instance FnArgsInfo (HE.Type HE.SrcSpanInfo) (HE.Name HE.SrcSpanInfo) where
getFnName _ _ (HE.Symbol _ s) = s
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
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
@ -239,7 +254,10 @@ instance FnArgsInfo Type Id where
maybe (if Ty.isPredTy lTy then getFnArgs' rTy else FnArgNormal:getFnArgs' rTy)
(\_ -> FnArgFunction:getFnArgs' rTy)
$ Ty.splitFunTy_maybe lTy
getFnArgs' ty | Just (_,iTy) <- Ty.splitForAllTy_maybe ty = getFnArgs' iTy
getFnArgs' ty | Just (_,iTy) <- Ty.splitForAllTy_maybe ty =
getFnArgs' iTy
getFnArgs' _ = []
-- Infinite supply of variable and function variable names
@ -247,7 +265,9 @@ infiniteVars, infiniteFns :: [String]
infiniteVars = infiniteSupply ["x","y","z","t","u","v","w"]
infiniteFns = infiniteSupply ["f","g","h"]
infiniteSupply :: [String] -> [String]
infiniteSupply initialSupply = initialSupply ++ concatMap (\n -> map (\v -> v ++ show n) initialSupply) ([1 .. ] :: [Integer])
infiniteSupply initialSupply =
initialSupply ++ concatMap (\n -> map (\v -> v ++ show n) initialSupply)
([1 .. ] :: [Integer])
-- Check whether a String is a symbol name
isSymbolName :: String -> Bool
@ -273,14 +293,15 @@ refine file lineNo colNo expr = ghandle handler body
p <- G.parseModule modSum
tcm@TypecheckedModule{tm_typechecked_source = tcs} <- G.typecheckModule p
ety <- G.exprType expr
whenFound opt (findVar dflag style tcm tcs lineNo colNo) $ \(loc, name, rty, paren) ->
let eArgs = getFnArgs ety
rArgs = getFnArgs rty
diffArgs' = length eArgs - length rArgs
diffArgs = if diffArgs' < 0 then 0 else diffArgs'
iArgs = take diffArgs eArgs
text = initialHead1 expr iArgs (infinitePrefixSupply name)
in (fourInts loc, doParen paren text)
whenFound opt (findVar dflag style tcm tcs lineNo colNo) $
\(loc, name, rty, paren) ->
let eArgs = getFnArgs ety
rArgs = getFnArgs rty
diffArgs' = length eArgs - length rArgs
diffArgs = if diffArgs' < 0 then 0 else diffArgs'
iArgs = take diffArgs eArgs
text = initialHead1 expr iArgs (infinitePrefixSupply name)
in (fourInts loc, doParen paren text)
handler (SomeException _) = emptyResult =<< options
@ -289,14 +310,16 @@ findVar :: GhcMonad m => DynFlags -> PprStyle
-> G.TypecheckedModule -> G.TypecheckedSource
-> Int -> Int -> m (Maybe (SrcSpan, String, Type, Bool))
findVar dflag style tcm tcs lineNo colNo =
let lst = sortBy (cmp `on` G.getLoc) $ listifySpans tcs (lineNo, colNo) :: [G.LHsExpr Id]
let lst = sortBy (cmp `on` G.getLoc) $
listifySpans tcs (lineNo, colNo) :: [G.LHsExpr Id]
in case lst of
e@(L _ (G.HsVar i)):others ->
do tyInfo <- Gap.getType tcm e
let name = getFnName dflag style i
if (name == "undefined" || head name == '_') && isJust tyInfo
then let Just (s,t) = tyInfo
b = case others of -- If inside an App, we need parenthesis
b = case others of -- If inside an App, we need
-- parenthesis
[] -> False
L _ (G.HsApp (L _ a1) (L _ a2)):_ ->
isSearchedVar i a1 || isSearchedVar i a2
@ -333,24 +356,29 @@ auto file lineNo colNo = ghandle handler body
opt <- options
modSum <- Gap.fileModSummary file
p <- G.parseModule modSum
tcm@TypecheckedModule{tm_typechecked_source = tcs
,tm_checked_module_info = minfo} <- G.typecheckModule p
tcm@TypecheckedModule {
tm_typechecked_source = tcs
, tm_checked_module_info = minfo
} <- G.typecheckModule p
whenFound' opt (findVar dflag style tcm tcs lineNo colNo) $ \(loc, _name, rty, paren) -> do
topLevel <- getEverythingInTopLevel minfo
let (f,pats) = getPatsForVariable tcs (lineNo,colNo)
-- Remove self function to prevent recursion, and id to trim cases
-- Remove self function to prevent recursion, and id to trim
-- cases
filterFn (n,_) = let funName = G.getOccString n
recName = G.getOccString (G.getName f)
in funName `notElem` recName:notWantedFuns
-- Find without using other functions in top-level
localBnds = M.unions $ map (\(L _ pat) -> getBindingsForPat pat) pats
localBnds = M.unions $
map (\(L _ pat) -> getBindingsForPat pat) pats
lbn = filter filterFn (M.toList localBnds)
djinnsEmpty <- djinn True (Just minfo) lbn rty (Max 10) 100000
let -- Find with the entire top-level
almostEnv = M.toList $ M.union localBnds topLevel
env = filter filterFn almostEnv
djinns <- djinn True (Just minfo) env rty (Max 10) 100000
return (fourInts loc, map (doParen paren) $ nub (djinnsEmpty ++ djinns))
return ( fourInts loc
, map (doParen paren) $ nub (djinnsEmpty ++ djinns))
handler (SomeException _) = emptyResult =<< options
@ -372,7 +400,8 @@ getEverythingInTopLevel m = do
tyThingsToInfo :: [Ty.TyThing] -> M.Map G.Name Type
tyThingsToInfo [] = M.empty
tyThingsToInfo (G.AnId i : xs) = M.insert (G.getName i) (Ty.varType i) (tyThingsToInfo xs)
tyThingsToInfo (G.AnId i : xs) =
M.insert (G.getName i) (Ty.varType i) (tyThingsToInfo xs)
-- Getting information about constructors is not needed
-- because they will be added by djinn-ghc when traversing types
-- #if __GLASGOW_HASKELL__ >= 708
@ -385,7 +414,8 @@ tyThingsToInfo (_:xs) = tyThingsToInfo xs
-- Find the Id of the function and the pattern where the hole is located
getPatsForVariable :: G.TypecheckedSource -> (Int,Int) -> (Id, [Ty.LPat Id])
getPatsForVariable tcs (lineNo, colNo) =
let (L _ bnd:_) = sortBy (cmp `on` G.getLoc) $ listifySpans tcs (lineNo, colNo) :: [G.LHsBind Id]
let (L _ bnd:_) = sortBy (cmp `on` G.getLoc) $
listifySpans tcs (lineNo, colNo) :: [G.LHsBind Id]
in case bnd of
G.PatBind { Ty.pat_lhs = L ploc pat } -> case pat of
Ty.ConPatIn (L _ i) _ -> (i, [L ploc pat])
@ -405,25 +435,34 @@ getBindingsForPat :: Ty.Pat Id -> M.Map G.Name Type
getBindingsForPat (Ty.VarPat i) = M.singleton (G.getName i) (Ty.varType i)
getBindingsForPat (Ty.LazyPat (L _ l)) = getBindingsForPat l
getBindingsForPat (Ty.BangPat (L _ b)) = getBindingsForPat b
getBindingsForPat (Ty.AsPat (L _ a) (L _ i)) = M.insert (G.getName a) (Ty.varType a) (getBindingsForPat i)
getBindingsForPat (Ty.AsPat (L _ a) (L _ i)) =
M.insert (G.getName a) (Ty.varType a) (getBindingsForPat i)
#if __GLASGOW_HASKELL__ >= 708
getBindingsForPat (Ty.ListPat l _ _) = M.unions $ map (\(L _ i) -> getBindingsForPat i) l
getBindingsForPat (Ty.ListPat l _ _) =
M.unions $ map (\(L _ i) -> getBindingsForPat i) l
#else
getBindingsForPat (Ty.ListPat l _) = M.unions $ map (\(L _ i) -> getBindingsForPat i) l
getBindingsForPat (Ty.ListPat l _) =
M.unions $ map (\(L _ i) -> getBindingsForPat i) l
#endif
getBindingsForPat (Ty.TuplePat l _ _) = M.unions $ map (\(L _ i) -> getBindingsForPat i) l
getBindingsForPat (Ty.PArrPat l _) = M.unions $ map (\(L _ i) -> getBindingsForPat i) l
getBindingsForPat (Ty.TuplePat l _ _) =
M.unions $ map (\(L _ i) -> getBindingsForPat i) l
getBindingsForPat (Ty.PArrPat l _) =
M.unions $ map (\(L _ i) -> getBindingsForPat i) l
getBindingsForPat (Ty.ViewPat _ (L _ i) _) = getBindingsForPat i
getBindingsForPat (Ty.SigPatIn (L _ i) _) = getBindingsForPat i
getBindingsForPat (Ty.SigPatOut (L _ i) _) = getBindingsForPat i
getBindingsForPat (Ty.ConPatIn (L _ i) d) = M.insert (G.getName i) (Ty.varType i) (getBindingsForRecPat d)
getBindingsForPat (Ty.ConPatIn (L _ i) d) =
M.insert (G.getName i) (Ty.varType i) (getBindingsForRecPat d)
getBindingsForPat (Ty.ConPatOut { Ty.pat_args = d }) = getBindingsForRecPat d
getBindingsForPat _ = M.empty
getBindingsForRecPat :: Ty.HsConPatDetails Id -> M.Map G.Name Type
getBindingsForRecPat (Ty.PrefixCon args) = M.unions $ map (\(L _ i) -> getBindingsForPat i) args
getBindingsForRecPat (Ty.InfixCon (L _ a1) (L _ a2)) = M.union (getBindingsForPat a1) (getBindingsForPat a2)
getBindingsForRecPat (Ty.RecCon (Ty.HsRecFields { Ty.rec_flds = fields })) = getBindingsForRecFields fields
where getBindingsForRecFields [] = M.empty
getBindingsForRecFields (Ty.HsRecField { Ty.hsRecFieldArg = (L _ a) } : fs) =
M.union (getBindingsForPat a) (getBindingsForRecFields fs)
getBindingsForRecPat (Ty.PrefixCon args) =
M.unions $ map (\(L _ i) -> getBindingsForPat i) args
getBindingsForRecPat (Ty.InfixCon (L _ a1) (L _ a2)) =
M.union (getBindingsForPat a1) (getBindingsForPat a2)
getBindingsForRecPat (Ty.RecCon (Ty.HsRecFields { Ty.rec_flds = fields })) =
getBindingsForRecFields fields
where getBindingsForRecFields [] = M.empty
getBindingsForRecFields (Ty.HsRecField {Ty.hsRecFieldArg = (L _ a)}:fs) =
M.union (getBindingsForPat a) (getBindingsForRecFields fs)