haskell-tools-backend-ghc 0.7.0.0 → 0.8.0.0

raw patch · 12 files changed

+255/−131 lines, 12 filesdep +ghc-boot-thdep ~haskell-tools-astPVP ok

version bump matches the API change (PVP)

Dependencies added: ghc-boot-th

Dependency ranges changed: haskell-tools-ast

API changes (from Hackage documentation)

Files

• Language/Haskell/Tools/AST/FromGHC/AddTypeInfo.hs +9/−9
• Language/Haskell/Tools/AST/FromGHC/Binds.hs +9/−4
• Language/Haskell/Tools/AST/FromGHC/Decls.hs +71/−30
• Language/Haskell/Tools/AST/FromGHC/Exprs.hs +13/−5
• Language/Haskell/Tools/AST/FromGHC/GHCUtils.hs +13/−0
• Language/Haskell/Tools/AST/FromGHC/Modules.hs +34/−47
• Language/Haskell/Tools/AST/FromGHC/Monad.hs +65/−19
• Language/Haskell/Tools/AST/FromGHC/Names.hs +4/−4
• Language/Haskell/Tools/AST/FromGHC/TH.hs +13/−3
• Language/Haskell/Tools/AST/FromGHC/Types.hs +8/−5
• Language/Haskell/Tools/AST/FromGHC/Utils.hs +13/−3
• haskell-tools-backend-ghc.cabal +3/−2

@@ -1,5 +1,5 @@-{-# LANGUAGE TupleSections 
-           , LambdaCase 
+{-# LANGUAGE TupleSections
+           , LambdaCase
            , ScopedTypeVariables
            #-}
 module Language.Haskell.Tools.AST.FromGHC.AddTypeInfo (addTypeInfos) where
@@ -39,15 +39,15 @@   let getType = getType' ut
   fixities <- getFixities
   let createCName sc def id = mkCNameInfo sc def id fixity
-        where fixity = if any (any ((getOccName id ==) . getOccName)) (init sc) 
-                          then Nothing 
+        where fixity = if any (any ((getOccName id ==) . getOccName . fst)) (init sc) 
+                          then Nothing
                           else fmap (snd . snd) $ List.find (\(mod,(occ,_)) -> Just mod == (nameModule_maybe $ varName id) && occ == getOccName id) fixities
-  evalStateT (semaTraverse 
+  evalStateT (semaTraverse
     (AST.SemaTrf
-      (\ni -> case (AST.semanticsSourceInfo ni, AST.semanticsName ni) of 
+      (\ni -> case (AST.semanticsSourceInfo ni, AST.semanticsName ni) of
                 (_, Just name) -> lift $ createCName (AST.semanticsScope ni) (AST.semanticsDefining ni) <$> getType name
-                (Just l@(RealSrcSpan loc), _) 
-                  -> case Map.lookup l locMapping of 
+                (Just l@(RealSrcSpan loc), _)
+                  -> case Map.lookup l locMapping of
                             Just id -> return $ createCName (AST.semanticsScope ni) (AST.semanticsDefining ni) id
                             _ -> do (none,rest) <- gets (break ((\(RealSrcSpan sp) -> sp `containsSpan` loc) . fst))
                                     case rest of [] -> error $ "Ambiguous or implicit name missing, at: " ++ show loc
@@ -63,7 +63,7 @@         extractTypes = concatMap universeBi . bagToList
 
         mkUnknownType :: IO Type
-        mkUnknownType = do 
+        mkUnknownType = do
           tUnique <- mkSplitUniqSupply 'x'
           return $ mkTyVarTy $ mkVanillaGlobal (mkSystemName (uniqFromSupply tUnique) (mkDataOcc "TypeNotFound")) (mkTyConTy starKindTyCon)
 

@@ -62,16 +62,21 @@   = do implicitIdLoc <- mkSrcSpan <$> atTheStart <*> atTheStart
        parenOpLoc <- tokensLoc [AnnOpenP, AnnVal, AnnCloseP]
        nonFunOpLoc <- tokenLoc AnnVal
-       let infixLoc = parenOpLoc `mappend` nonFunOpLoc
+       let infixLoc = case (parenOpLoc, nonFunOpLoc) of
+                        (RealSrcSpan rsp1, RealSrcSpan rsp2)
+                          | srcLocCol (realSrcSpanStart rsp2) == srcLocCol (realSrcSpanStart rsp1) + 1
+                              && srcLocCol (realSrcSpanEnd rsp2) == srcLocCol (realSrcSpanEnd rsp1) - 1 -> parenOpLoc
+                        _ -> nonFunOpLoc -- sometimes parenOpLoc is not an actual operator in parentheses, it just grabs
+                                         -- a paren, so we need to check that it is actually what we seek
        closeLoc <- srcSpanStart <$> (combineSrcSpans <$> tokenLoc AnnEqual <*> tokenLoc AnnVbar)
        args <- mapM trfPattern pats
        let (n, isInfix) = case fb of NonFunBindMatch -> let token = if isSymOcc (occName name) && isGoodSrcSpan infixLoc then infixLoc else implicitIdLoc
                                                          in (L token name, length pats > 0 && srcSpanStart token >= srcSpanEnd (getLoc (pats !! 0)))
                                      FunBindMatch n inf -> (n, inf)
        annLocNoSema (mkSrcSpan <$> atTheStart <*> (pure closeLoc)) $
-         case (args, isInfix) of
-            (left:right:rest, True) -> AST.UInfixLhs left <$> define (trfOperator n) <*> pure right <*> makeList " " (pure closeLoc) (pure rest)
-            _                       -> AST.UNormalLhs <$> define (trfName n) <*> makeList " " (pure closeLoc) (pure args)
+        case (args, isInfix) of
+           (left:right:rest, True) -> AST.UInfixLhs left <$> define (trfOperator n) <*> pure right <*> makeList " " (pure closeLoc) (pure rest)
+           _                       -> AST.UNormalLhs <$> define (trfName n) <*> makeList " " (pure closeLoc) (pure args)
 
 trfRhss :: TransformName n r => [Located (GRHS n (LHsExpr n))] -> Trf (Ann AST.URhs (Dom r) RangeStage)
 -- the original location on the GRHS misleadingly contains the local bindings

@@ -28,7 +28,7 @@ import Language.Haskell.Tools.AST.FromGHC.Binds
 import Language.Haskell.Tools.AST.FromGHC.Exprs (trfExpr)
 import Language.Haskell.Tools.AST.FromGHC.GHCUtils
-import Language.Haskell.Tools.AST.FromGHC.Kinds (trfKindSig, trfKindSig')
+import Language.Haskell.Tools.AST.FromGHC.Kinds
 import Language.Haskell.Tools.AST.FromGHC.Monad
 import Language.Haskell.Tools.AST.FromGHC.Names
 import Language.Haskell.Tools.AST.FromGHC.Patterns (trfPattern)
@@ -40,14 +40,18 @@ import qualified Language.Haskell.Tools.AST as AST
 import Language.Haskell.Tools.AST.SemaInfoTypes as AST (nameInfo)
 
+import Outputable
+import Debug.Trace
+
 trfDecls :: TransformName n r => [LHsDecl n] -> Trf (AnnListG AST.UDecl (Dom r) RangeStage)
--- TODO: filter documentation comments
 trfDecls decls = addToCurrentScope decls $ makeIndentedListNewlineBefore atTheEnd (mapM trfDecl decls)
 
 trfDeclsGroup :: forall n r . TransformName n r => HsGroup n -> Trf (AnnListG AST.UDecl (Dom r) RangeStage)
 trfDeclsGroup (HsGroup vals splices tycls insts derivs fixities defaults foreigns warns anns rules vects _)
-  = do spls <- getDeclSplices
+  = do rdrSpls <- asks declSplices -- now we don't want to rename the splices, just interested in their locations to
+                                   -- filter out the declarations that are generated from them
        let (sigs, bagToList -> binds) = getBindsAndSigs vals
+           -- collect the declarations from the group
            alldecls :: [Located (HsDecl n)]
            alldecls = (map (fmap SpliceD) splices)
                         ++ (map (fmap ValD) binds)
@@ -62,11 +66,21 @@                         ++ (map (fmap AnnD) anns)
                         ++ (map (fmap RuleD) rules)
                         ++ (map (fmap VectD) vects)
-       let actualDefinitions = removeContained $ orderElems $ replaceSpliceDecls spls alldecls
-       addToCurrentScope actualDefinitions
-         $ makeIndentedListNewlineBefore atTheEnd
-            (orderDefs <$> ((++) <$> getDeclsToInsert <*> (mapM trfDecl actualDefinitions)))
+       -- Declarations generated from TH should only be in scope after the splice.
+       let (genNames, sourceNames) = partition (\d -> any (\spl -> getLoc spl `containsRealSpan` getLoc d) rdrSpls) alldecls
+       addToCurrentScope sourceNames $ do
+         -- use the definitions generated by previous splices when renaming one
+         spls <- asks declSplices >>= mapM (\(L l e) -> let namesGeneratedBefore = filter ((srcSpanStart l >) . srcSpanEnd . getLoc) genNames
+                                                         in addToCurrentScope namesGeneratedBefore ((L l) <$> transformSplice e))
+         let actualDefinitions = removeContained $ orderElems $ replaceSpliceDecls spls alldecls
+           in makeIndentedListNewlineBefore atTheEnd
+                (orderDefs <$> ((++) <$> getDeclsToInsert <*> (mapM (trfDeclsWithScope genNames) actualDefinitions)))
   where
+    -- use the definitions generated by previous splices when transforming a definition
+    trfDeclsWithScope genNames d = local (\s -> s {declSplices = []})
+                                     $ addToCurrentScope namesGeneratedBefore (trfDecl d)
+      where namesGeneratedBefore = filter ((srcSpanStart (getLoc d) >) . srcSpanEnd . getLoc) genNames
+
     replaceSpliceDecls :: [Located (HsSplice n)] -> [Located (HsDecl n)] -> [Located (HsDecl n)]
     replaceSpliceDecls splices decls = foldl mergeSplice decls splices
 
@@ -74,13 +88,14 @@     orderElems = sortOn (srcSpanStart . getLoc)
 
     removeContained :: [Located (HsDecl n)] -> [Located (HsDecl n)]
-    removeContained (fst:snd:rest) | RealSrcSpan fstLoc <- getLoc fst
-                                   , RealSrcSpan sndLoc <- getLoc snd
-                                   , fstLoc `containsSpan` sndLoc
+    removeContained (fst:snd:rest) | getLoc fst `containsRealSpan` getLoc snd
       = removeContained (fst:rest)
     removeContained (fst:rest) = fst : removeContained rest
     removeContained [] = []
 
+    (RealSrcSpan sp1) `containsRealSpan` (RealSrcSpan sp2) = sp1 `containsSpan` sp2
+    _ `containsRealSpan` _ = False
+
     mergeSplice :: [Located (HsDecl n)] -> Located (HsSplice n) -> [Located (HsDecl n)]
     mergeSplice decls spl@(L spLoc@(RealSrcSpan rss) _)
       = L spLoc (SpliceD (SpliceDecl spl ExplicitSplice)) : filter (\(L (RealSrcSpan rdsp) _) -> not (rss `containsSpan` rdsp)) decls
@@ -89,7 +104,7 @@     getDeclsToInsert :: Trf [Ann AST.UDecl (Dom r) RangeStage]
     getDeclsToInsert = do decls <- asks declsToInsert
                           allLocals <- asks localsInScope
-                          case allLocals of locals:_ -> liftGhc $ mapM (loadIdsForDecls locals) decls
+                          case allLocals of locals:_ -> liftGhc $ mapM (loadIdsForDecls (map fst locals)) decls
                                             [] -> error "getDeclsToInsert: empty scope"
        where loadIdsForDecls :: [GHC.Name] -> Ann AST.UDecl (Dom RdrName) RangeStage -> GHC.Ghc (Ann AST.UDecl (Dom r) RangeStage)
              loadIdsForDecls locals = AST.semaTraverse $
@@ -100,9 +115,9 @@ 
 trfDecl :: TransformName n r => Located (HsDecl n) -> Trf (Ann AST.UDecl (Dom r) RangeStage)
 trfDecl = trfLocNoSema $ \case
-  TyClD (FamDecl (FamilyDecl (ClosedTypeFamily typeEqs) name tyVars kindSig _))
+  TyClD (FamDecl (FamilyDecl (ClosedTypeFamily typeEqs) name tyVars kindSig inj))
     -> AST.UClosedTypeFamilyDecl <$> focusAfter AnnType (createDeclHead name tyVars)
-                                <*> trfFamilyKind kindSig
+                                <*> trfFamilyResultSig kindSig inj
                                 <*> trfTypeEqs typeEqs
   TyClD (FamDecl fd) -> AST.UTypeFamilyDecl <$> annContNoSema (trfTypeFam' fd)
   TyClD (SynDecl name vars rhs _)
@@ -209,7 +224,7 @@   = AST.URecordDecl <$> trfConTyVars tyVars <*> trfConCtx ctx <*> define (trfName name) <*> (between AnnOpenC AnnCloseC $ trfAnnList ", " trfFieldDecl' flds)
 trfConDecl' (ConDeclH98 { con_name = name, con_qvars = tyVars, con_cxt = ctx, con_details = InfixCon t1 t2 })
   = AST.UInfixConDecl <$> trfConTyVars tyVars <*> trfConCtx ctx <*> trfType t1 <*> define (trfOperator name) <*> trfType t2
-trfConDecl' (ConDeclGADT {}) = error "trfConDecl': GADT con received"
+trfConDecl' gadt@(ConDeclGADT {}) = unhandledElement "normal constructor declaration" gadt
 
 trfConTyVars :: TransformName n r => Maybe (LHsQTyVars n) -> Trf (AnnListG AST.UTyVar (Dom r) RangeStage)
 trfConTyVars Nothing = makeListAfter "." " " atTheStart (return [])
@@ -220,14 +235,17 @@ trfConCtx (Just ctx) = trfCtx atTheStart ctx
 
 trfGADTConDecl :: TransformName n r => Located (ConDecl n) -> Trf (Ann AST.UGadtConDecl (Dom r) RangeStage)
-trfGADTConDecl = trfLocNoSema $ \(ConDeclGADT { con_names = names, con_type = hsib_body -> typ })
-  -> let nameLoc = collectLocs names
-         typLoc = getLoc typ
-         (vars, ctx, t) = getTypeVarsAndCtx typ
-      in AST.UGadtConDecl <$> define (trfAnnList ", " trfName' names)
-                          <*> focusOn (mkSrcSpan (srcSpanEnd nameLoc) (srcSpanStart typLoc)) (trfBindings vars)
-                          <*> updateFocus (return . updateEnd (\_ -> srcSpanStart typLoc)) (focusAfterIfPresent AnnDot (trfCtx atTheStart ctx))
-                          <*> trfGadtConType t
+trfGADTConDecl = trfLocNoSema trfGADTConDecl'
+
+trfGADTConDecl' :: TransformName n r => ConDecl n -> Trf (AST.UGadtConDecl (Dom r) RangeStage)
+trfGADTConDecl' (ConDeclGADT { con_names = names, con_type = hsib_body -> typ })
+  = let nameLoc = collectLocs names
+        typLoc = getLoc typ
+        (vars, ctx, t) = getTypeVarsAndCtx typ
+     in AST.UGadtConDecl <$> define (trfAnnList ", " trfName' names)
+                         <*> focusOn (mkSrcSpan (srcSpanEnd nameLoc) (srcSpanStart typLoc)) (trfBindings vars)
+                         <*> updateFocus (return . updateEnd (\_ -> srcSpanStart typLoc)) (focusAfterIfPresent AnnDot (trfCtx atTheStart ctx))
+                         <*> trfGadtConType t
   where getTypeVarsAndCtx :: LHsType n -> ([LHsTyVarBndr n], LHsContext n, LHsType n)
         getTypeVarsAndCtx (L _ (HsForAllTy [] typ)) = getTypeVarsAndCtx typ
         getTypeVarsAndCtx (L _ (HsForAllTy bndrs typ)) = let (_,ctx,t) = getTypeVarsAndCtx typ in (bndrs, ctx, t)
@@ -436,17 +454,37 @@ 
 trfInstDataFam :: TransformName n r => Located (DataFamInstDecl n) -> Trf (Ann AST.UInstBodyDecl (Dom r) RangeStage)
 trfInstDataFam = trfLocNoSema $ \case
-  (DataFamInstDecl tc (hsib_body -> pats) (HsDataDefn dn ctx _ _ cons derivs) _)
+  (DataFamInstDecl tc (hsib_body -> pats) (HsDataDefn dn ctx _ ks cons derivs) _)
+    | all ((\case ConDeclH98{} -> True; _ -> False) . unLoc) cons
     -> AST.UInstBodyDataDecl
          <$> trfDataKeyword dn
          <*> annLocNoSema (pure $ collectLocs pats `combineSrcSpans` getLoc tc `combineSrcSpans` getLoc ctx)
                           (AST.UInstanceRule <$> nothing "" " . " atTheStart
                                              <*> trfCtx atTheStart ctx
-                                             <*> foldl (\r t -> annLocNoSema (combineSrcSpans (getLoc t) . getRange <$> r)
-                                                                             (AST.UInstanceHeadApp <$> r <*> (trfType t)))
-                                                       (copyAnnot AST.UInstanceHeadCon (trfName tc)) pats)
+                                             <*> transformNameAndPats tc pats)
          <*> trfAnnList "" trfConDecl' cons
          <*> trfMaybe " deriving " "" trfDerivings derivs
+    | otherwise
+    -> AST.UInstBodyGadtDataDecl
+        <$> trfDataKeyword dn
+        <*> annLocNoSema (pure $ collectLocs pats `combineSrcSpans` getLoc tc `combineSrcSpans` getLoc ctx)
+                         (AST.UInstanceRule <$> nothing "" " . " atTheStart
+                                            <*> trfCtx atTheStart ctx
+                                            <*> transformNameAndPats tc pats)
+        <*> trfKindSig ks
+        <*> trfAnnList "" trfGADTConDecl' cons
+        <*> trfMaybe " deriving " "" trfDerivings derivs
+  where transformNameAndPats tc pats
+          | all (\p -> srcSpanEnd (getLoc tc) < srcSpanStart (getLoc p)) pats -- prefix instance head application
+          = foldl (\r t -> annLocNoSema (combineSrcSpans (getLoc t) . getRange <$> r)
+                                          (AST.UInstanceHeadApp <$> r <*> (trfType t)))
+                  (copyAnnot AST.UInstanceHeadCon (trfName tc)) pats
+        transformNameAndPats tc (p:rest)
+          | otherwise -- infix instance head application
+          = foldl (\r t -> annLocNoSema (combineSrcSpans (getLoc t) . getRange <$> r)
+                                          (AST.UInstanceHeadApp <$> r <*> (trfType t)))
+                  (annLocNoSema (pure $ getLoc p `combineSrcSpans` getLoc tc)
+                          (AST.UInstanceHeadInfix <$> trfType p <*> trfOperator tc)) rest
 
 trfPatternSynonym :: forall n r . TransformName n r => PatSynBind n n -> Trf (AST.UPatternSynonym (Dom r) RangeStage)
 trfPatternSynonym (PSB id _ lhs def dir)
@@ -481,15 +519,18 @@ trfFamilyKind (unLoc -> fr) = case fr of
   NoSig -> nothing "" " " atTheEnd
   KindSig k -> trfKindSig (Just k)
-  TyVarSig {} -> error "trfFamilyKind: TyVarSig not supported yet"
+  TyVarSig tv -> error "trfFamilyKind: TyVarSig not supported"
 
 trfFamilyResultSig :: TransformName n r => Located (FamilyResultSig n) -> Maybe (LInjectivityAnn n) -> Trf (AnnMaybeG AST.UTypeFamilySpec (Dom r) RangeStage)
 trfFamilyResultSig (L l fr) Nothing = case fr of
   NoSig -> nothing "" " " atTheEnd
   KindSig k -> makeJust <$> (annLocNoSema (pure l) $ AST.UTypeFamilyKind <$> trfKindSig' k)
-  TyVarSig {} -> error "trfFamilyResultSig: TyVarSig not supported yet"
-trfFamilyResultSig _ (Just (L l (InjectivityAnn n deps)))
-  = makeJust <$> (annLocNoSema (pure l) $ AST.UTypeFamilyInjectivity <$> (annContNoSema $ AST.UInjectivityAnn <$> trfName n <*> trfAnnList ", " trfName' deps))
+  TyVarSig {} -> error "trfFamilyResultSig: TyVarSig not supported" {- makeJust <$> (annLocNoSema (combineSrcSpans (getLoc tv) <$> (tokenBefore (srcSpanStart (getLoc tv)) AnnDcolon))
+                              (AST.UKindConstraint <$> trfKindVar tv)) -}
+trfFamilyResultSig (L _ sig) (Just (L l (InjectivityAnn n deps)))
+  = makeJust <$> (annLocNoSema (pure l) $ AST.UTypeFamilyInjectivity <$> (annContNoSema $ AST.UInjectivityAnn <$> tv <*> trfAnnList ", " trfName' deps))
+    where tv = case sig of TyVarSig tv -> trfTyVar tv
+                           _ -> annLocNoSema (pure $ getLoc n) (AST.UTyVarDecl <$> trfName n <*> nothing "" "" (pure $ srcSpanEnd (getLoc n)))
 
 trfAnnotationSubject :: TransformName n r => SourceText -> AnnProvenance n -> SrcLoc -> Trf (Ann AST.UAnnotationSubject (Dom r) RangeStage)
 trfAnnotationSubject stxt subject payloadEnd

@@ -8,7 +8,8 @@ module Language.Haskell.Tools.AST.FromGHC.Exprs where
 
 import Control.Monad.Reader
-import Data.List (partition, find)
+import Data.List
+import Data.Function (on)
 import Data.Maybe (Maybe(..), isJust, fromMaybe, catMaybes)
 
 import BasicTypes as GHC (Boxity(..), StringLiteral(..))
@@ -45,10 +46,16 @@        annLoc createScopeInfo (pure actualSpan) (trfExpr' cs)
 trfExpr e | RealSrcSpan loce <- getLoc e
   = do exprSpls <- asks exprSplices
-       let contSplice = find (\sp -> case getSpliceLoc sp of (RealSrcSpan spLoc) -> spLoc `containsSpan` loce; _ -> False) exprSpls
-       case contSplice of Just sp -> case sp of HsQuasiQuote {} -> exprSpliceInserted sp (annLoc createScopeInfo (pure $ getSpliceLoc sp) (AST.UQuasiQuoteExpr <$> annLocNoSema (pure $ getSpliceLoc sp) (trfQuasiQuotation' sp)))
-                                                _               -> exprSpliceInserted sp (annLoc createScopeInfo (pure $ getSpliceLoc sp) (AST.USplice <$> trfSplice sp))
-                          Nothing -> trfLoc trfExpr' createScopeInfo e
+       let contSplice = filter (\sp -> case getLoc sp of (RealSrcSpan spLoc) -> spLoc `containsSpan` loce; _ -> False) exprSpls
+       case contSplice of
+         [] -> trfLoc trfExpr' createScopeInfo e
+         _ -> let lsp@(L l sp) = minimumBy (compareSpans `on` getLoc) contSplice
+               in case sp of
+                    (HsQuasiQuote {}) -> do
+                      sp' <- rdrSplice sp
+                      exprSpliceInserted lsp (annLoc createScopeInfo (pure l) (AST.UQuasiQuoteExpr <$> annLocNoSema (pure l) (trfQuasiQuotation' sp')))
+                    _ -> do sp' <- rdrSplice sp
+                            exprSpliceInserted lsp (annLoc createScopeInfo (pure l) (AST.USplice <$> trfSplice sp'))
   | otherwise = trfLoc trfExpr' createScopeInfo e
 
 createScopeInfo :: Trf ScopeInfo
@@ -70,6 +77,7 @@   = AST.UInfixApp <$> trfExpr e1 <*> trfOperator op <*> trfExpr e2
 trfExpr' (OpApp e1 (L nameLoc (HsRecFld fld)) _ e2)
   = AST.UInfixApp <$> trfExpr e1 <*> trfAmbiguousOperator' nameLoc fld <*> trfExpr e2
+trfExpr' (OpApp e1 (L _ op) _ e2) = unhandledElement "OpApp expression" op
 trfExpr' (NegApp e _) = AST.UPrefixApp <$> annLocNoSema loc (AST.UNormalOp <$> annLoc info loc (AST.nameFromList <$> trfOperatorStr False "-"))
                                        <*> trfExpr e
   where loc = mkSrcSpan <$> atTheStart <*> (pure $ srcSpanStart (getLoc e))

@@ -4,6 +4,7 @@            , ScopedTypeVariables
            , ViewPatterns
            , LambdaCase
+           , RecordWildCards
            #-}
 -- | Utility functions defined on the GHC AST representation.
 module Language.Haskell.Tools.AST.FromGHC.GHCUtils where
@@ -244,3 +245,15 @@      in foldl mergeWith s (map unLoc same) : mergeFixityDefs different
   where mergeWith (L l (FixitySig names fixity)) (FixitySig otherNames _) = L l (FixitySig (names ++ otherNames) fixity)
 mergeFixityDefs [] = []
+
+getGroupRange :: HsGroup n -> SrcSpan
+getGroupRange (HsGroup {..})
+  = foldr combineSrcSpans noSrcSpan locs
+  where locs = [getHsValRange hs_valds] ++ map getLoc hs_splcds ++ map getLoc (concatMap group_tyclds hs_tyclds) ++ map getLoc (concatMap group_roles hs_tyclds)
+                 ++ map getLoc hs_instds ++ map getLoc hs_derivds ++ map getLoc hs_fixds ++ map getLoc hs_defds
+                 ++ map getLoc hs_fords ++ map getLoc hs_warnds ++ map getLoc hs_annds ++ map getLoc hs_ruleds ++ map getLoc hs_vects
+                 ++ map getLoc hs_docs
+
+getHsValRange :: HsValBinds n -> SrcSpan
+getHsValRange (ValBindsIn vals sig) = foldr combineSrcSpans noSrcSpan $ map getLoc (bagToList vals) ++ map getLoc sig
+getHsValRange (ValBindsOut vals sig) = foldr combineSrcSpans noSrcSpan $ concatMap (map getLoc . bagToList . snd) vals ++ map getLoc sig

@@ -34,32 +34,34 @@ import RnExpr as GHC (rnLExpr)
 import SrcLoc as GHC
 import TcRnMonad as GHC
+import Outputable
 
 import Language.Haskell.Tools.AST (Ann(..), AnnMaybeG, AnnListG(..), Dom, RangeStage
                                   , sourceInfo, semantics, annotation, nodeSpan)
 import qualified Language.Haskell.Tools.AST as AST
 import Language.Haskell.Tools.AST.FromGHC.Decls (trfDecls, trfDeclsGroup)
 import Language.Haskell.Tools.AST.FromGHC.Exprs (trfText')
-import Language.Haskell.Tools.AST.FromGHC.GHCUtils (HsHasName(..))
+import Language.Haskell.Tools.AST.FromGHC.GHCUtils
 import Language.Haskell.Tools.AST.FromGHC.Monad
 import Language.Haskell.Tools.AST.FromGHC.Names (TransformName, trfName)
 import Language.Haskell.Tools.AST.FromGHC.Utils
 import Language.Haskell.Tools.AST.SemaInfoTypes as AST (nameInfo, implicitNames, importedNames)
 
 trfModule :: ModSummary -> Located (HsModule RdrName) -> Trf (Ann AST.UModule (Dom RdrName) RangeStage)
-trfModule mod = trfLocCorrect (createModuleInfo mod) (\sr -> combineSrcSpans sr <$> (uniqueTokenAnywhere AnnEofPos)) $
-                  \(HsModule name exports imports decls deprec _) ->
-                    AST.UModule <$> trfFilePragmas
-                                <*> trfModuleHead name exports deprec
-                                <*> trfImports imports
-                                <*> trfDecls decls
+trfModule mod hsMod = trfLocCorrect (createModuleInfo mod (maybe noSrcSpan getLoc $ hsmodName $ unLoc hsMod) (hsmodImports $ unLoc hsMod))
+                                    (\sr -> combineSrcSpans sr <$> (uniqueTokenAnywhere AnnEofPos))
+                  (\(HsModule name exports imports decls deprec _) ->
+                     AST.UModule <$> trfFilePragmas
+                                 <*> trfModuleHead name (srcSpanStart (foldLocs (map getLoc imports ++ map getLoc decls))) exports deprec
+                                 <*> trfImports imports
+                                 <*> trfDecls decls) $ hsMod
 
 trfModuleRename :: ModSummary -> Ann AST.UModule (Dom RdrName) RangeStage
                               -> (HsGroup Name, [LImportDecl Name], Maybe [LIE Name], Maybe LHsDocString)
                               -> Located (HsModule RdrName)
                               -> Trf (Ann AST.UModule (Dom GHC.Name) RangeStage)
 trfModuleRename mod rangeMod (gr,imports,exps,_) hsMod
-    = do info <- createModuleInfo mod
+    = do info <- createModuleInfo mod (maybe noSrcSpan getLoc $ hsmodName $ unLoc hsMod) imports
          trfLocCorrect (pure info) (\sr -> combineSrcSpans sr <$> (uniqueTokenAnywhere AnnEofPos)) (trfModuleRename' (info ^. implicitNames)) hsMod
   where roleAnnots = rangeMod ^? AST.modDecl&AST.annList&filtered ((\case Ann _ (AST.URoleDecl {}) -> True; _ -> False))
         originalNames = Map.fromList $ catMaybes $ map getSourceAndInfo (rangeMod ^? biplateRef)
@@ -69,55 +71,40 @@         trfModuleRename' preludeImports hsMod@(HsModule name exports _ _ deprec _) = do
           transformedImports <- orderAnnList <$> (trfImports imports)
 
-          addToScope (concat @[] (transformedImports ^? AST.annList&semantics&importedNames) ++ preludeImports)
+          let importNames impd = ( impd ^. AST.importModule & AST.moduleNameString
+                                 , impd ^? AST.importAs & AST.annJust & AST.importRename & AST.moduleNameString
+                                 , AST.isAnnJust (impd ^. AST.importQualified)
+                                 , impd ^. semantics&importedNames )
+              -- if there is a qualified form of the import Prelude, the names should be empty
+              importPrelude names = ( "Prelude", Nothing, False, names)
+
+          addToScopeImported (map importNames (transformedImports ^? AST.annList) ++ [importPrelude preludeImports])
             $ loadSplices mod hsMod transformedImports preludeImports gr $ setOriginalNames originalNames . setDeclsToInsert roleAnnots
-              $ AST.UModule <$> trfFilePragmas
-                            <*> trfModuleHead name (case (exports, exps) of (Just (L l _), Just ie) -> Just (L l ie)
-                                                                            _                       -> Nothing) deprec
-                            <*> return transformedImports
-                            <*> trfDeclsGroup gr
+              $ do filePrags <- trfFilePragmas
+                   AST.UModule filePrags
+                    <$> trfModuleHead name
+                         (srcSpanEnd (AST.getRange filePrags))
+                         (case (exports, exps) of (Just (L l _), Just ie) -> Just (L l ie)
+                                                  _                       -> Nothing)
+                         deprec
+                    <*> return transformedImports
+                    <*> trfDeclsGroup gr
 
 loadSplices :: ModSummary -> HsModule RdrName -> AnnListG AST.UImportDecl (Dom GHC.Name) RangeStage -> [GHC.Name] -> HsGroup Name -> Trf a -> Trf a
 loadSplices modSum hsMod imports preludeImports group trf = do
     let declSpls = map (\(SpliceDecl sp _) -> sp) $ hsMod ^? biplateRef :: [Located (HsSplice RdrName)]
-        exprSpls = catMaybes $ map (\case HsSpliceE sp -> Just sp; _ -> Nothing) $ hsMod ^? biplateRef :: [HsSplice RdrName]
-        typeSpls = catMaybes $ map (\case HsSpliceTy sp _ -> Just sp; _ -> Nothing) $ hsMod ^? biplateRef :: [HsSplice RdrName]
-    -- initialize reader environment
-    env <- liftGhc $ setSessionDynFlags (ms_hspp_opts modSum) >> getSession
-    importEnv <- liftIO $ hscRnImportDecls env (hsmodImports hsMod)
-    let locals = hsGetNames group
-        createLocalGRE n = [GRE n NoParent True []]
-        readEnv = mkOccEnv $ map (foldl1 (\e1 e2 -> (fst e1, snd e1 ++ snd e2)) . map snd) $ groupBy ((==) `on` fst) $ sortOn fst
-                   $ (map (\n -> (n, (GHC.occName n, createLocalGRE n))) (locals ++ preludeImports))
-    tcdSplices <- liftIO $ runTcInteractive env { hsc_dflags = xopt_set (hsc_dflags env) TemplateHaskellQuotes }
-      $ updGblEnv (\gbl -> gbl { tcg_rdr_env = plusOccEnv readEnv importEnv })
-      $ (,,) <$> mapM tcHsSplice declSpls <*> mapM tcHsSplice' typeSpls <*> mapM tcHsSplice' exprSpls
-    let (declSplices, typeSplices, exprSplices)
-          = fromMaybe (error $ "Splice expression could not be typechecked: "
-                                 ++ showSDocUnsafe (vcat (pprErrMsgBagWithLoc (fst (fst tcdSplices)))
-                                                      <+> vcat (pprErrMsgBagWithLoc (snd (fst tcdSplices)))))
-                      (snd tcdSplices)
-    setSplices declSplices typeSplices exprSplices trf
-  where
-    tcHsSplice :: Located (HsSplice RdrName) -> RnM (Located (HsSplice Name))
-    tcHsSplice (L l s) = L l <$> tcHsSplice' s
-    tcHsSplice' (HsTypedSplice id e)
-      = HsTypedSplice (mkUnboundNameRdr id) <$> (fst <$> rnLExpr e)
-    tcHsSplice' (HsUntypedSplice id e)
-      = HsUntypedSplice (mkUnboundNameRdr id) <$> (fst <$> rnLExpr e)
-    tcHsSplice' (HsQuasiQuote id1 id2 sp fs)
-      = pure $ HsQuasiQuote (mkUnboundNameRdr id1) (mkUnboundNameRdr id2) sp fs
+        exprSpls = catMaybes $ map (\case L l (HsSpliceE sp) -> Just (L l sp); _ -> Nothing) $ hsMod ^? biplateRef :: [Located (HsSplice RdrName)]
+        typeSpls = catMaybes $ map (\case L l (HsSpliceTy sp _) -> Just (L l sp); _ -> Nothing) $ hsMod ^? biplateRef :: [Located (HsSplice RdrName)]
+    setSplices declSpls typeSpls exprSpls trf
 
-trfModuleHead :: TransformName n r => Maybe (Located ModuleName) -> Maybe (Located [LIE n]) -> Maybe (Located WarningTxt) -> Trf (AnnMaybeG AST.UModuleHead (Dom r) RangeStage)
-trfModuleHead (Just mn) exports modPrag
+trfModuleHead :: TransformName n r => Maybe (Located ModuleName) -> SrcLoc -> Maybe (Located [LIE n]) -> Maybe (Located WarningTxt) -> Trf (AnnMaybeG AST.UModuleHead (Dom r) RangeStage)
+trfModuleHead (Just mn) _ exports modPrag
   = makeJust <$> (annLocNoSema (tokensLoc [AnnModule, AnnWhere])
                                (AST.UModuleHead <$> trfModuleName mn
                                                 <*> trfModulePragma (srcSpanEnd $ getLoc mn) modPrag
                                                 <*> trfExportList (before AnnWhere) exports))
-trfModuleHead _ Nothing _ = nothing "" "" moduleHeadPos
-  where moduleHeadPos = after AnnClose >>= \case loc@(RealSrcLoc _) -> return loc
-                                                 _ -> atTheStart
-trfModuleHead Nothing (Just _) _ = error "trfModuleHead: no head but has exports"
+trfModuleHead _ rng Nothing _ = nothing "" "" (pure rng)
+trfModuleHead Nothing _ (Just _) _ = error "trfModuleHead: no head but has exports"
 
 trfFilePragmas :: Trf (AnnListG AST.UFilePragma (Dom r) RangeStage)
 trfFilePragmas = do pragmas <- asks pragmaComms

@@ -1,18 +1,35 @@+{-# LANGUAGE TupleSections #-}
 -- | The transformation monad carries the necessary information that is passed top-down
 -- during the conversion from GHC AST to our representation.
 module Language.Haskell.Tools.AST.FromGHC.Monad where
 
-import ApiAnnotation (ApiAnnKey)
 import Control.Monad.Reader
 import Data.Function (on)
+import Data.List
+import Data.Maybe
+import Data.Monoid
 import Data.Map as Map (Map, lookup, empty)
 import Data.Maybe (fromMaybe)
-import GHC
+import qualified Data.Set as Set
 import Language.Haskell.Tools.AST
 import Language.Haskell.Tools.AST.FromGHC.GHCUtils (HsHasName(..), rdrNameStr)
 import Language.Haskell.Tools.AST.FromGHC.SourceMap (SourceMap, annotationsToSrcMap)
+
+import ApiAnnotation (ApiAnnKey)
+import GHC
 import Name (Name, isVarName, isTyVarName)
+import HscTypes
 import SrcLoc
+import TcRnTypes
+import OccName as GHC
+import RdrName
+import RnEnv
+import DynFlags
+import RnExpr
+import ErrUtils
+import Outputable hiding (empty)
+import TcRnMonad
+import GHC.LanguageExtensions.Type
 
 -- | The transformation monad type
 type Trf = ReaderT TrfInput Ghc
@@ -23,14 +40,14 @@              , pragmaComms :: Map String [Located String] -- ^ Pragma comments
              , declsToInsert :: [Ann UDecl (Dom RdrName) RangeStage] -- ^ Declarations that are from the parsed AST
              , contRange :: SrcSpan -- ^ The focus of the transformation
-             , localsInScope :: [[GHC.Name]] -- ^ Local names visible
+             , localsInScope :: [[(GHC.Name, Maybe [UsageSpec])]] -- ^ Local names visible
              , defining :: Bool -- ^ True, if names are defined in the transformed AST element.
              , definingTypeVars :: Bool -- ^ True, if type variable names are defined in the transformed AST element.
              , originalNames :: Map SrcSpan RdrName -- ^ Stores the original format of names.
-             , declSplices :: [Located (HsSplice GHC.Name)] -- ^ Location of the TH splices for extracting declarations from the renamed AST.
+             , declSplices :: [Located (HsSplice GHC.RdrName)] -- ^ Location of the TH splices for extracting declarations from the renamed AST.
                  -- ^ It is possible that multiple declarations stand in the place of the declaration splice or none at all.
-             , typeSplices :: [HsSplice GHC.Name] -- ^ Other types of splices (expressions, types).
-             , exprSplices :: [HsSplice GHC.Name] -- ^ Other types of splices (expressions, types).
+             , typeSplices :: [Located (HsSplice GHC.RdrName)] -- ^ Type splices
+             , exprSplices :: [Located (HsSplice GHC.RdrName)] -- ^ Expression splices
              }
 
 trfInit :: Map ApiAnnKey [SrcSpan] -> Map String [Located String] -> TrfInput
@@ -74,13 +91,18 @@ addEmptyScope = local (\s -> s { localsInScope = [] : localsInScope s })
 
 -- | Perform the transformation putting the given definition in a new local scope.
+addToScopeImported :: [(String, Maybe String, Bool, [GHC.Name])] -> Trf a -> Trf a
+addToScopeImported ls = local (\s -> s { localsInScope = concatMap (\(mn, asName, q, e) -> map (, Just [UsageSpec q mn (fromMaybe mn asName)]) e) ls : localsInScope s })
+
+
+-- | Perform the transformation putting the given definition in a new local scope.
 addToScope :: HsHasName e => e -> Trf a -> Trf a
-addToScope e = local (\s -> s { localsInScope = hsGetNames e : localsInScope s })
+addToScope e = local (\s -> s { localsInScope = map (, Nothing) (hsGetNames e) : localsInScope s })
 
 -- | Perform the transformation putting the given definitions in the current scope.
 addToCurrentScope :: HsHasName e => e -> Trf a -> Trf a
-addToCurrentScope e = local (\s -> s { localsInScope = case localsInScope s of lastScope:rest -> (hsGetNames e ++ lastScope):rest
-                                                                               []             -> [hsGetNames e] })
+addToCurrentScope e = local (\s -> s { localsInScope = case localsInScope s of lastScope:rest -> (map (, Nothing) (hsGetNames e) ++ lastScope):rest
+                                                                               []             -> [map (, Nothing) (hsGetNames e)] })
 
 -- | Performs the transformation given the tokens of the source file
 runTrf :: Map ApiAnnKey [SrcSpan] -> Map String [Located String] -> Trf a -> Ghc a
@@ -95,7 +117,7 @@                        asks (rdrNameStr . fromMaybe n . (Map.lookup sp) . originalNames)
 
 -- | Set splices that must replace the elements that are generated into the AST representation.
-setSplices :: [Located (HsSplice GHC.Name)] -> [HsSplice GHC.Name] -> [HsSplice GHC.Name] -> Trf a -> Trf a
+setSplices :: [Located (HsSplice GHC.RdrName)] -> [Located (HsSplice GHC.RdrName)] -> [Located (HsSplice GHC.RdrName)] -> Trf a -> Trf a
 setSplices declSpls typeSpls exprSpls
   = local (\s -> s { typeSplices = typeSpls, exprSplices = exprSpls, declSplices = declSpls })
 
@@ -104,16 +126,40 @@ setDeclsToInsert decls = local (\s -> s {declsToInsert = decls})
 
 -- Remove the splice that has already been added
-exprSpliceInserted :: HsSplice GHC.Name -> Trf a -> Trf a
-exprSpliceInserted spl = local (\s -> s { exprSplices = Prelude.filter (((/=) `on` getSpliceLoc) spl) (exprSplices s) })
+exprSpliceInserted :: Located (HsSplice n) -> Trf a -> Trf a
+exprSpliceInserted spl = local (\s -> s { exprSplices = Prelude.filter (\sp -> getLoc sp /= getLoc spl) (exprSplices s) })
 
 -- Remove the splice that has already been added
-typeSpliceInserted :: HsSplice GHC.Name -> Trf a -> Trf a
-typeSpliceInserted spl = local (\s -> s { typeSplices = Prelude.filter (((/=) `on` getSpliceLoc) spl) (typeSplices s) })
+typeSpliceInserted :: Located (HsSplice n) -> Trf a -> Trf a
+typeSpliceInserted spl = local (\s -> s { typeSplices = Prelude.filter (\sp -> getLoc sp /= getLoc spl) (typeSplices s) })
 
+rdrSplice :: HsSplice RdrName -> Trf (HsSplice GHC.Name)
+rdrSplice spl = do
+    env <- liftGhc getSession
+    locals <- unifyScopes [] <$> asks localsInScope
+    let createLocalGRE (n,imp) = [GRE n NoParent (isNothing imp) (maybe [] (map createGREImport) imp) ]
+        createGREImport (UsageSpec q useQ asQ) = ImpSpec (ImpDeclSpec (mkModuleName useQ) (mkModuleName asQ) q noSrcSpan) ImpAll
+    let readEnv = mkOccEnv $ map (foldl1 (\e1 e2 -> (fst e1, snd e1 ++ snd e2))) $ groupBy ((==) `on` fst) $ sortOn fst
+                   $ map (\n -> (GHC.occName (fst n), createLocalGRE n))
+                   $ map (foldl1 (\e1 e2 -> (fst e1, snd e1 `mappend` snd e2))) $ groupBy ((==) `on` fst) $ sortBy (compare `on` fst) locals
+    tcSpl <- liftIO $ runTcInteractive env { hsc_dflags = xopt_set (hsc_dflags env) TemplateHaskellQuotes }
+      $ updGblEnv (\gbl -> gbl { tcg_rdr_env = readEnv })
+      $ tcHsSplice' spl
+    let typecheckErrors = showSDocUnsafe (vcat (pprErrMsgBagWithLoc (fst (fst tcSpl)))
+                                            <+> vcat (pprErrMsgBagWithLoc (snd (fst tcSpl))))
+    when (not (null typecheckErrors)) $ liftIO $ putStrLn ("Typechecking of splice expressions: " ++ typecheckErrors)
+    return $ fromMaybe (error $ "Splice expression could not be typechecked.")
+                       (snd tcSpl)
+  where
+    tcHsSplice' (HsTypedSplice id e)
+      = HsTypedSplice (mkUnboundNameRdr id) <$> (fst <$> rnLExpr e)
+    tcHsSplice' (HsUntypedSplice id e)
+      = HsUntypedSplice (mkUnboundNameRdr id) <$> (fst <$> rnLExpr e)
+    tcHsSplice' (HsQuasiQuote id1 id2 sp fs)
+      = pure $ HsQuasiQuote (mkUnboundNameRdr id1) (mkUnboundNameRdr id2) sp fs
 
-getSpliceLoc :: HsSplice a -> SrcSpan
-getSpliceLoc (HsTypedSplice _ e) = getLoc e
-getSpliceLoc (HsUntypedSplice _ e) = getLoc e
-getSpliceLoc (HsQuasiQuote _ _ sp _) = sp
-getSpliceLoc (HsSpliced _ _) = noSrcSpan
+
+    unifyScopes :: [GHC.Name] -> [[(GHC.Name, Maybe [UsageSpec])]] -> [(GHC.Name, Maybe [UsageSpec])]
+    unifyScopes _ [] = []
+    unifyScopes ex (sc:scs) = filteredSc ++ unifyScopes (ex ++ map fst filteredSc) scs
+      where filteredSc = filter ((\s -> isNothing $ find (\e -> occName e == occName s) ex) . fst) sc

@@ -28,7 +28,7 @@ import qualified Language.Haskell.Tools.AST as AST
 
 import Language.Haskell.Tools.AST.FromGHC.GHCUtils
-import Language.Haskell.Tools.AST.FromGHC.Monad (TrfInput(..), Trf, getOriginalName)
+import Language.Haskell.Tools.AST.FromGHC.Monad
 import Language.Haskell.Tools.AST.FromGHC.Utils
 
 trfOperator :: TransformName n r => Located n -> Trf (Ann AST.UOperator (Dom r) RangeStage)
@@ -71,15 +71,15 @@ 
 class (DataId n, Eq n, GHCName n, FromGHCName n) => TransformableName n where
   correctNameString :: n -> Trf String
-  getDeclSplices :: Trf [Located (HsSplice n)]
+  transformSplice :: HsSplice RdrName -> Trf (HsSplice n)
 
 instance TransformableName RdrName where
   correctNameString = pure . rdrNameStr
-  getDeclSplices = pure []
+  transformSplice = pure
 
 instance TransformableName GHC.Name where
   correctNameString n = getOriginalName (rdrName n)
-  getDeclSplices = asks declSplices
+  transformSplice = rdrSplice
 
 -- | This class allows us to use the same transformation code for multiple variants of the GHC AST.
 -- GHC UName annotated with 'name' can be transformed to our representation with semantic annotations of 'res'.

@@ -9,9 +9,12 @@ import HsExpr as GHC (HsSplice(..), HsExpr(..), HsBracket(..))
 import SrcLoc as GHC
 
+import Outputable as GHC
+import Control.Monad.IO.Class
+
 import Language.Haskell.Tools.AST.FromGHC.Decls (trfDecls, trfDeclsGroup)
 import Language.Haskell.Tools.AST.FromGHC.Exprs (trfExpr, createScopeInfo)
-import Language.Haskell.Tools.AST.FromGHC.Monad (TrfInput(..), Trf, getSpliceLoc)
+import Language.Haskell.Tools.AST.FromGHC.Monad (TrfInput(..), Trf)
 import Language.Haskell.Tools.AST.FromGHC.Names
 import Language.Haskell.Tools.AST.FromGHC.Patterns (trfPattern)
 import Language.Haskell.Tools.AST.FromGHC.Types (trfType)
@@ -22,7 +25,7 @@ 
 trfQuasiQuotation' :: TransformName n r => HsSplice n -> Trf (AST.UQuasiQuote (Dom r) RangeStage)
  -- the lexer does not provide us with tokens '[', '|' and '|]'
-trfQuasiQuotation' (HsQuasiQuote id _ l str)
+trfQuasiQuotation' (HsQuasiQuote _ id l str)
   = AST.UQuasiQuote <$> annLocNoSema quoterLoc (trfName' id)
                     <*> annLocNoSema (pure strLoc) (pure $ AST.QQString (unpackFS str))
   where -- assume that there are no white spaces ain the head and the end of the quasi quote
@@ -32,7 +35,14 @@ trfQuasiQuotation' qq = unhandledElement "quasi quotation" qq
 
 trfSplice :: TransformName n r => HsSplice n -> Trf (Ann AST.USplice (Dom r) RangeStage)
-trfSplice spls = annLocNoSema (pure $ getSpliceLoc spls) (trfSplice' spls)
+trfSplice spls = do rng <- asks contRange
+                    annLocNoSema (pure $ getSpliceLoc spls `mappend` rng) (trfSplice' spls)
+
+getSpliceLoc :: HsSplice a -> SrcSpan
+getSpliceLoc (HsTypedSplice _ e) = getLoc e
+getSpliceLoc (HsUntypedSplice _ e) = getLoc e
+getSpliceLoc (HsQuasiQuote _ _ sp _) = sp
+getSpliceLoc (HsSpliced _ _) = noSrcSpan
 
 trfSplice' :: TransformName n r => HsSplice n -> Trf (AST.USplice (Dom r) RangeStage)
 trfSplice' (HsTypedSplice _ expr) = trfSpliceExpr expr

@@ -12,12 +12,15 @@ import SrcLoc as GHC
 import TyCon as GHC (TyCon(..))
 import TysWiredIn (heqTyCon)
+import Outputable
 
 import Control.Applicative (Applicative(..), (<$>), Alternative(..))
 import Control.Monad.Reader.Class (asks)
 import Control.Reference ((^.))
-import Data.List (find)
+import Data.Function (on)
+import Data.List
 import Data.Maybe (Maybe(..), fromJust)
+import Control.Monad.IO.Class
 
 import Language.Haskell.Tools.AST as AST
 import Language.Haskell.Tools.AST.FromGHC.GHCUtils (GHCName(..), cleanHsType)
@@ -30,10 +33,10 @@ trfType :: TransformName n r => Located (HsType n) -> Trf (Ann AST.UType (Dom r) RangeStage)
 trfType typ | RealSrcSpan loce <- getLoc typ
   = do othSplices <- asks typeSplices
-       let contSplice = find (\sp -> case getSpliceLoc sp of (RealSrcSpan spLoc) -> spLoc `containsSpan` loce; _ -> False) othSplices
-       case contSplice of Just sp -> let loc = pure $ getSpliceLoc sp
-                                      in typeSpliceInserted sp (annLocNoSema loc (AST.UTySplice <$> trfSplice sp))
-                          Nothing -> trfLocNoSema trfType' typ
+       let contSplice = filter (\sp -> case getLoc sp of (RealSrcSpan spLoc) -> spLoc `containsSpan` loce; _ -> False) othSplices
+       case contSplice of [] -> trfLocNoSema trfType' typ
+                          _ -> let lsp@(L l sp) = minimumBy (compareSpans `on` getLoc) contSplice
+                                in typeSpliceInserted lsp (annLocNoSema (pure l) (AST.UTySplice <$> (trfSplice =<< rdrSplice sp)))
   | otherwise = trfLocNoSema trfType' typ
 
 trfType' :: TransformName n r => HsType n -> Trf (AST.UType (Dom r) RangeStage)

@@ -46,9 +46,13 @@ import Language.Haskell.Tools.AST.FromGHC.SourceMap
 import Language.Haskell.Tools.AST.SemaInfoTypes as Sema
 
-createModuleInfo :: ModSummary -> Trf (Sema.ModuleInfo GHC.Name)
-createModuleInfo mod = do
-  let prelude = xopt ImplicitPrelude $ ms_hspp_opts mod
+import Debug.Trace
+
+createModuleInfo :: ModSummary -> SrcSpan -> [LImportDecl n] -> Trf (Sema.ModuleInfo GHC.Name)
+createModuleInfo mod nameLoc (filter (not . ideclImplicit . unLoc) -> imports) = do
+  let prelude = (xopt ImplicitPrelude $ ms_hspp_opts mod)
+                  && all (\idecl -> ("Prelude" /= (GHC.moduleNameString $ unLoc $ ideclName $ unLoc idecl))
+                                      || nameLoc == getLoc idecl) imports
   (_,preludeImports) <- if prelude then getImportedNames "Prelude" Nothing else return (ms_mod mod, [])
   (insts, famInsts) <- if prelude then lift $ getOrphanAndFamInstances (Module baseUnitId (GHC.mkModuleName "Prelude"))
                                   else return ([], [])
@@ -438,6 +442,12 @@         splitLocated' [] currLoc (Just (startLoc, str)) = [L (RealSrcSpan $ mkRealSrcSpan startLoc currLoc) (reverse str)]
         splitLocated' [] _ Nothing = []
 splitLocated _ = error "splitLocated: unhelpful span given"
+
+compareSpans :: SrcSpan -> SrcSpan -> Ordering
+compareSpans (RealSrcSpan a) (RealSrcSpan b)
+  | a `containsSpan` b = GT
+  | b `containsSpan` a = LT
+compareSpans _ _ = EQ
 
 -- | Report errors when cannot convert a type of element
 unhandledElement :: (Data a, Outputable a) => String -> a -> Trf b

@@ -1,5 +1,5 @@ name:                haskell-tools-backend-ghc
-version:             0.7.0.0
+version:             0.8.0.0
 synopsis:            Creating the Haskell-Tools AST from GHC's representations
 description:         This package collects information from various representations of a Haskell program in GHC. Basically GHC provides us with the parsed, the renamed and the type checked representation of the program, if it was type correct. Each version contains different information. For example, the renamed AST contains the unique names of the definitions, however, template haskell splices are already resolved and thus missing from that version of the AST. To get the final representation we perform a transformation on the parsed and renamed representation, and then use the type checked one to look up the types of the names. The whole transformation is defined in the `Modules` module. Other modules define the functions that convert elements of the GHC AST to our AST.
 homepage:            https://github.com/nboldi/haskell-tools
@@ -42,5 +42,6 @@                      , split             >= 0.2  && < 0.3
                      , template-haskell  >= 2.11 && < 2.12
                      , ghc               >= 8.0  && < 8.1
-                     , haskell-tools-ast >= 0.7  && < 0.8
+                     , haskell-tools-ast >= 0.8  && < 0.9
+                     , ghc-boot-th       >= 8.0  && < 8.1
   default-language:    Haskell2010