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

[Type-constraints] Generalize some code, cleanup

Browse Source
This commit is contained in:
Nikolay Yakimov 2016-01-20 02:23:51 +03:00
parent c117ed3b52
commit 8449d36eca
1 changed files with 10 additions and 8 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

18
Language/Haskell/GhcMod/SrcUtils.hs
View File

@ -41,25 +41,27 @@ instance HasType (LPat Id) where
---------------------------------------------------------------- ----------------------------------------------------------------
type CstGenQS = M.Map Var Type type CstGenQS = M.Map Var Type
type CstGenQT = forall m. GhcMonad m => CstGenQS -> (m [(SrcSpan, Type)], CstGenQS) type CstGenQT a = forall m. GhcMonad m => a Id -> CstGenQS -> (m [(SrcSpan, Type)], CstGenQS)
collectSpansTypes :: (GhcMonad m) => Bool -> G.TypecheckedModule -> (Int, Int) -> m [(SrcSpan, Type)] collectSpansTypes :: (GhcMonad m) => Bool -> G.TypecheckedModule -> (Int, Int) -> m [(SrcSpan, Type)]
collectSpansTypes withConstraints tcs lc = collectSpansTypes withConstraints tcs lc =
everythingStagedWithContext TypeChecker M.empty (liftM2 (++)) everythingStagedWithContext TypeChecker M.empty (liftM2 (++))
(return []) (return [])
((return [],) `mkQ` hsBind `extQ` hsExpr `extQ` hsPat) ((return [],)
`mkQ` (hsBind :: CstGenQT G.LHsBind)
`extQ` (genericCT :: CstGenQT G.LHsExpr)
`extQ` (genericCT :: CstGenQT G.LPat)
)
(G.tm_typechecked_source tcs) (G.tm_typechecked_source tcs)
where where
insExp x = M.insert (G.abe_mono x) (G.varType $ G.abe_poly x) insExp x = M.insert (G.abe_mono x) (G.varType $ G.abe_poly x)
hsBind :: G.LHsBind Id -> CstGenQT
hsBind (L _ G.AbsBinds{abs_exports = es'}) s hsBind (L _ G.AbsBinds{abs_exports = es'}) s
| withConstraints = (return [], foldr insExp s es') | withConstraints = (return [], foldr insExp s es')
| otherwise = (return [], s) | otherwise = (return [], s)
hsBind x@(L _ b) s = constrainedType' (G.collectHsBindBinders b) s x hsBind x s = genericCT x s
hsExpr :: G.LHsExpr Id -> CstGenQT genericCT x s = constrainedType' (collectBinders x) s x
hsExpr x s = (maybeToList <$> getType' x, s) collectBinders :: Data a => a -> [Id]
hsPat :: G.LPat Id -> CstGenQT collectBinders = listifyStaged TypeChecker (const True)
hsPat x@(L _ _) s = constrainedType' (G.collectPatBinders x) s x
getType' x@(L spn _) getType' x@(L spn _)
| G.isGoodSrcSpan spn && spn `G.spans` lc | G.isGoodSrcSpan spn && spn `G.spans` lc
= getType tcs x = getType tcs x