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

Add missing cases for signatures

Browse Source
This commit is contained in:
Alejandro Serrano 2014-06-16 22:10:01 +02:00
parent 32d76b209d
commit 8a63ae078b
1 changed files with 59 additions and 44 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

101
Language/Haskell/GhcMod/Info.hs
View File

@ -1,4 +1,4 @@
{-# LANGUAGE TupleSections, FlexibleInstances, Rank2Types #-} {-# LANGUAGE TupleSections, FlexibleInstances, Rank2Types, LambdaCase #-}
{-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -fno-warn-orphans #-}
module Language.Haskell.GhcMod.Info ( module Language.Haskell.GhcMod.Info (
@ -15,6 +15,7 @@ module Language.Haskell.GhcMod.Info (
import Control.Applicative ((<$>)) import Control.Applicative ((<$>))
import CoreMonad (liftIO) import CoreMonad (liftIO)
import CoreUtils (exprType) import CoreUtils (exprType)
import Data.Char (isSymbol)
import Data.Function (on) import Data.Function (on)
import Data.Generics import Data.Generics
import Data.List (find, intercalate, sortBy) import Data.List (find, intercalate, sortBy)
@ -326,12 +327,12 @@ sig opt file lineNo colNo = ghandle handler body
Just (Signature loc names ty) -> do Just (Signature loc names ty) -> do
return $ convert opt $ ( fourInts loc return $ convert opt $ ( fourInts loc
, intercalate "\n" , intercalate "\n"
(map (initialBody dflag style ty) names) (map (initialFnBody dflag style ty) names)
) )
Just (InstanceDecl loc cls) -> do Just (InstanceDecl loc cls) -> do
return $ convert opt $ ( fourInts loc return $ convert opt $ ( fourInts loc
, intercalate "\n" , intercalate "\n"
(map (initialInstanceBody dflag style) (Ty.classMethods cls)) (map (initialInstBody dflag style) (Ty.classMethods cls))
) )
handler (SomeException _) = return "" handler (SomeException _) = return ""
@ -349,8 +350,17 @@ getSignature modSum lineNo colNo = do
TypecheckedModule{tm_renamed_source = Just tcs TypecheckedModule{tm_renamed_source = Just tcs
,tm_checked_module_info = minfo} <- G.typecheckModule p ,tm_checked_module_info = minfo} <- G.typecheckModule p
case listifyRenamedSpans tcs (lineNo, colNo) :: [G.LInstDecl G.Name] of case listifyRenamedSpans tcs (lineNo, colNo) :: [G.LInstDecl G.Name] of
-- Instance declarations of sort 'instance F (G a)'
[L loc (G.ClsInstD (G.ClsInstDecl {G.cid_poly_ty = [L loc (G.ClsInstD (G.ClsInstDecl {G.cid_poly_ty =
(L _ (G.HsForAllTy _ _ _ (L _ (G.HsAppTy (L _ (G.HsTyVar clsName)) _))))}))] -> do (L _ (G.HsForAllTy _ _ _ (L _ (G.HsAppTy (L _ (G.HsTyVar clsName)) _))))}))] ->
obtainClassInfo minfo clsName loc
-- Instance declarations of sort 'instance F G' (no variables)
[L loc (G.ClsInstD (G.ClsInstDecl {G.cid_poly_ty =
(L _ (G.HsAppTy (L _ (G.HsTyVar clsName)) _))}))] ->
obtainClassInfo minfo clsName loc
_ -> return Nothing
_ -> return Nothing
where obtainClassInfo minfo clsName loc = do
tyThing <- G.modInfoLookupName minfo clsName tyThing <- G.modInfoLookupName minfo clsName
case tyThing of case tyThing of
Just (Ty.ATyCon clsCon) -> Just (Ty.ATyCon clsCon) ->
@ -358,52 +368,57 @@ getSignature modSum lineNo colNo = do
Just cls -> return $ Just $ InstanceDecl loc cls Just cls -> return $ Just $ InstanceDecl loc cls
Nothing -> return Nothing Nothing -> return Nothing
_ -> return Nothing _ -> return Nothing
_ -> return Nothing
_ ->return Nothing
initialBody :: DynFlags -> PprStyle -> G.HsType G.RdrName -> G.RdrName -> String -- A list of function arguments, and whether they are functions or normal arguments
initialBody dflag style ty name = -- is built from either a function signature or an instance signature
let fName = showOccName dflag style $ occName name -- get function name data FnArg = FnArgFunction | FnArgNormal
args = initialArgs infiniteVars infiniteFns ty
in fName ++ " " ++ args ++ " = _" ++ fName ++ "_body"
initialArgs :: [String] -> [String] -> G.HsType a -> String initialBody :: String -> [FnArg] -> String
-- Contexts and foralls: continue inside initialBody fname args =
initialArgs vars fns (G.HsForAllTy _ _ _ (L _ ty)) = case initialBodyArgs args infiniteVars infiniteFns of
initialArgs vars fns ty [] -> fname
-- Function whose first argument is another function arglist -> if isSymbolName fname
initialArgs vars (f:fs) (G.HsFunTy (L _ (G.HsFunTy _ _)) (L _ rTy)) = then (head arglist) ++ " " ++ fname ++ " " ++ (intercalate " " (tail arglist))
f ++ " " ++ initialArgs vars fs rTy else fname ++ " " ++ (intercalate " " arglist)
-- Function whose first argument is not another function ++ " = _" ++ fname ++ "_body"
initialArgs (v:vs) fns (G.HsFunTy _ (L _ rTy)) =
v ++ " " ++ initialArgs vs fns rTy
-- Rest of the cases: just write a variable
initialArgs (v:_) _ _ = v
-- Lists are infinite, so this should never happen
initialArgs _ _ _ = error "this should never happen"
initialInstanceBody :: DynFlags -> PprStyle -> Id -> String initialBodyArgs :: [FnArg] -> [String] -> [String] -> [String]
initialInstanceBody dflag style method = initialBodyArgs [] _ _ = []
let fName = showOccName dflag style $ G.getOccName method -- get function name initialBodyArgs (FnArgFunction:xs) vs (f:fs) = f : initialBodyArgs xs vs fs
args = initialInstanceArgs infiniteVars infiniteFns (G.idType method) initialBodyArgs (FnArgNormal:xs) (v:vs) fs = v : initialBodyArgs xs vs fs
in fName ++ " " ++ args ++ " = _" ++ fName ++ "_body" initialBodyArgs _ _ _ = error "This should never happen" -- Lists are infinite
initialInstanceArgs :: [String] -> [String] -> G.Type -> String initialFnBody :: DynFlags -> PprStyle -> G.HsType G.RdrName -> G.RdrName -> String
-- Contexts and foralls: continue inside initialFnBody dflag style ty name =
initialInstanceArgs vars fns ty | Just (_,iTy) <- Ty.splitForAllTy_maybe ty = let fname = showOccName dflag style $ occName name -- get function name
initialInstanceArgs vars fns iTy args = \case (G.HsForAllTy _ _ _ (L _ iTy)) -> args iTy
-- Function whose first argument is another function (G.HsParTy (L _ iTy)) -> args iTy
initialInstanceArgs (v:vs) (f:fs) ty | Just (argTy,rTy) <- Ty.splitFunTy_maybe ty = (G.HsFunTy (L _ lTy) (L _ rTy)) -> (if fnarg lTy then FnArgFunction else FnArgNormal):args rTy
case Ty.splitFunTy_maybe argTy of _ -> []
Just _ -> f ++ " " ++ initialInstanceArgs (v:vs) fs rTy fnarg = \case (G.HsForAllTy _ _ _ (L _ iTy)) -> fnarg iTy
Nothing -> v ++ " " ++ initialInstanceArgs vs (f:fs) rTy (G.HsParTy (L _ iTy)) -> fnarg iTy
-- Rest of the cases: just write a variable (G.HsFunTy _ _) -> True
initialInstanceArgs (v:_) _ _ = v _ -> False
-- Lists are infinite, so this should never happen in initialBody fname (args ty)
initialInstanceArgs _ _ _ = error "this should never happen"
initialInstBody :: DynFlags -> PprStyle -> Id -> String
initialInstBody dflag style method =
let fname = showOccName dflag style $ G.getOccName method -- get function name
args = \case ty | Just (lTy,rTy) <- Ty.splitFunTy_maybe ty ->
case Ty.splitFunTy_maybe lTy of
Just _ -> FnArgFunction:args rTy
Nothing -> -- Drop the class predicates
if Ty.isPredTy lTy then args rTy else FnArgNormal:args rTy
ty | Just (_,iTy) <- Ty.splitForAllTy_maybe ty -> args iTy
_ -> []
in initialBody fname (args (Ty.dropForAlls $ G.idType method))
infiniteVars, infiniteFns :: [String] infiniteVars, infiniteFns :: [String]
infiniteVars = infiniteSupply ["x","y","z","t","u","v","w"] infiniteVars = infiniteSupply ["x","y","z","t","u","v","w"]
infiniteFns = infiniteSupply ["f","g","h"] infiniteFns = infiniteSupply ["f","g","h"]
infiniteSupply :: [String] -> [String] 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])
isSymbolName :: String -> Bool
isSymbolName (c:_) = c `elem` "!#$%&*+./<=>?@\\^|-~" || isSymbol c
isSymbolName [] = error "This should never happen"