From e6d0b7bf0954f941357d77e8158aa52bb1c96686 Mon Sep 17 00:00:00 2001
From: alexwl <alexey.a.kiryushin@gmail.com>
Date: Sun, 23 Dec 2018 17:59:00 +0300
Subject: Add support for GHC 8.6.3

---
 src/HaskellCodeExplorer/GhcUtils.hs | 230 +++++++++++++++++++++++++++++++-----
 1 file changed, 203 insertions(+), 27 deletions(-)

(limited to 'src/HaskellCodeExplorer/GhcUtils.hs')

diff --git a/src/HaskellCodeExplorer/GhcUtils.hs b/src/HaskellCodeExplorer/GhcUtils.hs
index 3a4ec26..3ac1f86 100644
--- a/src/HaskellCodeExplorer/GhcUtils.hs
+++ b/src/HaskellCodeExplorer/GhcUtils.hs
@@ -69,7 +69,6 @@ import qualified Data.Generics.Uniplate.Data()
 import qualified Data.HashMap.Strict as HM
 import qualified Data.List as L
 import Data.Maybe (fromMaybe, isJust, mapMaybe)
-import Data.Ord (comparing)
 import qualified Data.Text as T
 import DataCon (dataConWorkId, flSelector)
 import Documentation.Haddock.Parser (overIdentifier, parseParas)
@@ -103,10 +102,9 @@ import GHC
   , IE(..)  
   , TyThing(..)
   , LHsDecl  
-  , HsDecl(..)  
+  , HsDecl(..)
   , DocDecl(..)  
   , ConDecl(..)
-  , PostRn  
   , HsConDetails(..)  
   , ConDeclField(..)  
   , DataFamInstDecl(..)
@@ -119,8 +117,16 @@ import GHC
   , getLoc
   , hsSigType
   , getConNames
+#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
+  , NHsValBindsLR(..)
+  , getConArgs
+  , unpackHDS
+  , NoExt(..)
+  , extFieldOcc  
+#else
   , getConDetails
   , selectorFieldOcc
+#endif
 #if MIN_VERSION_GLASGOW_HASKELL(8,2,2,0)    
   , tyClGroupTyClDecls
   , LIEWrappedName
@@ -275,11 +281,32 @@ instanceDeclToText :: DynFlags -> InstDecl Name -> T.Text
 #endif
 instanceDeclToText flags decl =
   case decl of
-    ClsInstD ClsInstDecl {..} -> T.append "instance " (toText flags cid_poly_ty)
-#if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
+#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
+    XInstDecl _ -> ""
+    ClsInstD _ (XClsInstDecl _) -> ""
+    ClsInstD _ ClsInstDecl {..} ->
+#else
+    ClsInstD ClsInstDecl {..} ->
+#endif
+      T.append "instance " (toText flags cid_poly_ty)
+
+#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
+    DataFamInstD _ di ->
+      let args =
+            T.intercalate " " . map (toText flags) .  feqn_pats  . hsib_body . dfid_eqn $ di
+       in T.concat
+            ["data instance ", toText flags (unLoc $ feqn_tycon . hsib_body . dfid_eqn $ di), " ", args]
+    TyFamInstD _ ti ->
+      let args =
+            T.intercalate " " .
+            map (toText flags) . feqn_pats . hsib_body . tfid_eqn $
+            ti
+       in T.concat
+            ["type instance ", toText flags $ tyFamInstDeclName ti, " ", args]
+#elif MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
     DataFamInstD di ->
       let args =
-            T.intercalate " " . map (toText flags) .  feqn_pats  .hsib_body . dfid_eqn $ di
+            T.intercalate " " . map (toText flags) .  feqn_pats  . hsib_body . dfid_eqn $ di
        in T.concat
             ["data instance ", toText flags (unLoc $ feqn_tycon . hsib_body . dfid_eqn $ di), " ", args]
     TyFamInstD ti ->
@@ -313,7 +340,7 @@ tyClDeclPrefix tyClDecl =
       isNewTy DataDecl {tcdDataDefn = HsDataDefn {dd_ND = NewType}} = True
       isNewTy _ = False
    in case tyClDecl of
-        FamDecl _
+        FamDecl {}
           | isDataFamilyDecl tyClDecl -> "data family "
           | otherwise -> "type family "
         SynDecl {} -> "type "
@@ -321,6 +348,9 @@ tyClDeclPrefix tyClDecl =
           | isNewTy tyClDecl -> "newtype "
           | otherwise -> "data "
         ClassDecl {} -> "class "
+#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
+        XTyClDecl _ -> ""
+#endif    
     
 demangleOccName :: Name -> T.Text
 demangleOccName name
@@ -411,7 +441,11 @@ hsGroupVals :: HsGroup Name -> [GenLocated SrcSpan (HsBindLR Name Name)]
 hsGroupVals hsGroup =
   filter (isGoodSrcSpan . getLoc) $
   case hs_valds hsGroup of
+#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)    
+    XValBindsLR (NValBinds binds _) -> concatMap (bagToList . snd) binds
+#else
     ValBindsOut binds _ -> concatMap (bagToList . snd) binds
+#endif
     _ -> []
 
 hsPatSynDetails :: HsPatSynDetails a -> [a]
@@ -450,15 +484,36 @@ ieLocNames :: IE pass -> [Located (IdP pass)]
 #else
 ieLocNames :: IE Name -> [Located Name]
 #endif
-ieLocNames (IEVar n) = [unwrapName n]
-ieLocNames (IEThingAbs n) = [unwrapName n]
-ieLocNames (IEThingAll n) = [unwrapName n]
+
+#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
+ieLocNames (XIE _) = []
+ieLocNames (IEVar _ n) =
+#else
+ieLocNames (IEVar n) = 
+#endif
+  [unwrapName n]
+#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
+ieLocNames (IEThingAbs _ n) =
+#else
+ieLocNames (IEThingAbs n) =
+#endif
+  [unwrapName n]
+#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
+ieLocNames (IEThingAll _ n) =
+#else
+ieLocNames (IEThingAll n) =
+#endif
+  [unwrapName n]
+#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
+ieLocNames (IEThingWith _ n _ ns labels) =
+#else
 ieLocNames (IEThingWith n _ ns labels) =
+#endif
   unwrapName n : (map unwrapName ns ++ map (fmap flSelector) labels)
-ieLocNames (IEModuleContents (L _ _)) = []
-ieLocNames (IEGroup _ _) = []
-ieLocNames (IEDoc _) = []
-ieLocNames (IEDocNamed _) = []
+ieLocNames IEModuleContents {} = []
+ieLocNames IEGroup {} = []
+ieLocNames IEDoc {} = []
+ieLocNames IEDocNamed {} = []
 
 --------------------------------------------------------------------------------
 -- Lookups
@@ -959,10 +1014,19 @@ collectDocs = go Nothing []
   where
     go Nothing _ [] = []
     go (Just prev) docs [] = finished prev docs []
+#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
+    go prev docs (L _ (DocD _ (DocCommentNext str)):ds)
+#else
     go prev docs (L _ (DocD (DocCommentNext str)):ds)
+#endif
+
       | Nothing <- prev = go Nothing (str : docs) ds
       | Just decl <- prev = finished decl docs (go Nothing [str] ds)
+#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)        
+    go prev docs (L _ (DocD _ (DocCommentPrev str)):ds) = go prev (str : docs) ds
+#else
     go prev docs (L _ (DocD (DocCommentPrev str)):ds) = go prev (str : docs) ds
+#endif
     go Nothing docs (d:ds) = go (Just d) docs ds
     go (Just prev) docs (d:ds) = finished prev docs (go (Just d) [] ds)
     finished decl docs rest = (decl, reverse docs) : rest
@@ -973,33 +1037,62 @@ ungroup :: HsGroup GhcRn -> [LHsDecl GhcRn]
 ungroup :: HsGroup Name -> [LHsDecl Name]
 #endif
 ungroup group_ =
-#if MIN_VERSION_GLASGOW_HASKELL(8,2,2,0)
+#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
+  mkDecls (tyClGroupTyClDecls . hs_tyclds) (TyClD NoExt) group_ ++  
+#elif MIN_VERSION_GLASGOW_HASKELL(8,2,2,0)
   mkDecls (tyClGroupTyClDecls . hs_tyclds) TyClD group_ ++  
 #else
   mkDecls (tyClGroupConcat . hs_tyclds) TyClD group_ ++
 #endif
+
+#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
+  mkDecls hs_derivds (DerivD NoExt) group_ ++
+  mkDecls hs_defds (DefD NoExt) group_ ++
+  mkDecls hs_fords (ForD NoExt) group_ ++
+  mkDecls hs_docs (DocD NoExt) group_ ++  
+#else
   mkDecls hs_derivds DerivD group_ ++
   mkDecls hs_defds DefD group_ ++
   mkDecls hs_fords ForD group_ ++
   mkDecls hs_docs DocD group_ ++
-#if MIN_VERSION_GLASGOW_HASKELL(8,2,2,0)  
+#endif
+  
+#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
+  mkDecls hsGroupInstDecls (InstD NoExt) group_ ++
+#elif MIN_VERSION_GLASGOW_HASKELL(8,2,2,0)  
   mkDecls hsGroupInstDecls InstD group_ ++
 #else
   mkDecls hs_instds InstD group_ ++
 #endif
+
+#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
+  mkDecls (typesigs . hs_valds) (SigD NoExt) group_ ++
+  mkDecls (valbinds . hs_valds) (ValD NoExt) group_
+#else
   mkDecls (typesigs . hs_valds) SigD group_ ++
   mkDecls (valbinds . hs_valds) ValD group_
+#endif  
+
+  
   where
+#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)    
+    typesigs (XValBindsLR (NValBinds _ sigs)) = filter isUserLSig sigs
+#else
     typesigs (ValBindsOut _ sigs) = filter isUserLSig sigs
+#endif
     typesigs _ = []
+#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)        
+    valbinds (XValBindsLR (NValBinds binds _)) = concatMap bagToList . snd . unzip $ binds
+#else
     valbinds (ValBindsOut binds _) = concatMap bagToList . snd . unzip $ binds
+#endif
     valbinds _ = []
 
 mkDecls :: (a -> [Located b]) -> (b -> c) -> a -> [Located c]
 mkDecls field con struct = [L loc (con decl) | L loc decl <- field struct]
 
 sortByLoc :: [Located a] -> [Located a]
-sortByLoc = L.sortBy (comparing getLoc)
+sortByLoc = L.sortOn getLoc
 
 #if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
 classDeclDocs :: TyClDecl GhcRn -> [(LHsDecl GhcRn, [HsDocString])]
@@ -1009,10 +1102,18 @@ classDeclDocs :: TyClDecl Name -> [(LHsDecl Name, [HsDocString])]
 classDeclDocs class_ = collectDocs . sortByLoc $ decls
   where
     decls = docs ++ defs ++ sigs ++ ats
+#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)    
+    docs = mkDecls tcdDocs (DocD NoExt) class_
+    defs = mkDecls (bagToList . tcdMeths) (ValD NoExt) class_
+    sigs = mkDecls tcdSigs (SigD NoExt) class_
+    ats = mkDecls tcdATs ((TyClD NoExt) . (FamDecl NoExt)) class_
+#else
     docs = mkDecls tcdDocs DocD class_
     defs = mkDecls (bagToList . tcdMeths) ValD class_
     sigs = mkDecls tcdSigs SigD class_
     ats = mkDecls tcdATs (TyClD . FamDecl) class_
+#endif
+
 
 #if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
 conDeclDocs :: ConDecl GhcRn -> [(Name, [HsDocString], SrcSpan)]
@@ -1025,18 +1126,30 @@ conDeclDocs conDecl =
   conDecl
 
 #if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
-selectorDocs :: ConDecl pass -> [(PostRn pass (IdP pass), [HsDocString], SrcSpan)]
+selectorDocs :: ConDecl GhcRn -> [(Name, [HsDocString], SrcSpan)]
 #else
-selectorDocs :: ConDecl name -> [(PostRn name name, [HsDocString], SrcSpan)]
+selectorDocs :: ConDecl Name -> [(Name, [HsDocString], SrcSpan)]
 #endif
 selectorDocs con =
+#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)  
+  case getConArgs con of
+#else
   case getConDetails con of
+#endif
     RecCon (L _ flds) ->
       concatMap
+#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
+        (\(L _ (ConDeclField _ fieldOccs _ mbDoc)) ->
+#else
         (\(L _ (ConDeclField fieldOccs _ mbDoc)) ->
+#endif
            map
              (\(L span f) ->
+#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
+                (extFieldOcc f, maybe [] ((: []) . unLoc) mbDoc, span))
+#else
                 (selectorFieldOcc f, maybe [] ((: []) . unLoc) mbDoc, span))
+#endif
              fieldOccs)
         flds
     _ -> []
@@ -1050,14 +1163,27 @@ subordinateNamesWithDocs =
     concatMap
     (\(L span tyClDecl) ->
        case tyClDecl of
+#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
+         TyClD _ classDecl@ClassDecl {..} ->
+#else
          TyClD classDecl@ClassDecl {..} ->
+#endif
            concatMap
              (\(L _ decl, docs) -> map (, docs, span) $ getMainDeclBinder decl) $
            classDeclDocs classDecl
+#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
+         TyClD _ DataDecl {..} ->
+#else
          TyClD DataDecl {..} ->
+#endif
            concatMap (\(L _ con) -> conDeclDocs con ++ selectorDocs con) $
            dd_cons tcdDataDefn
+#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
+         InstD _ (DataFamInstD _ DataFamInstDecl {..}) ->
+#else
          InstD (DataFamInstD DataFamInstDecl {..}) ->
+#endif
+
 #if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)               
            concatMap (conDeclDocs . unLoc) . dd_cons . feqn_rhs  . hsib_body $ dfid_eqn
 #else
@@ -1076,14 +1202,35 @@ getMainDeclBinder :: HsDecl pass -> [IdP pass]
 #else
 getMainDeclBinder :: HsDecl name -> [name]
 #endif
-getMainDeclBinder (TyClD d) = [tcdName d]
+#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
+getMainDeclBinder (TyClD _ d) =
+#else
+getMainDeclBinder (TyClD d) =
+#endif
+  [tcdName d]
+#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
+getMainDeclBinder (ValD _ d) =
+#else
 getMainDeclBinder (ValD d) =
+#endif
   case collectHsBindBinders d of
     [] -> []
     (name:_) -> [name]
+#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
+getMainDeclBinder (SigD _ d) = sigNameNoLoc d
+#else
 getMainDeclBinder (SigD d) = sigNameNoLoc d
+#endif
+#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
+getMainDeclBinder (ForD _ (ForeignImport _ name _ _)) = [unLoc name]
+#else
 getMainDeclBinder (ForD (ForeignImport name _ _ _)) = [unLoc name]
+#endif
+#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
+getMainDeclBinder (ForD _ ForeignExport {}) = []
+#else
 getMainDeclBinder (ForD ForeignExport {}) = []
+#endif
 getMainDeclBinder _ = []
 
 #if MIN_VERSION_GLASGOW_HASKELL(8,4,3,0)
@@ -1091,20 +1238,45 @@ sigNameNoLoc :: Sig pass -> [IdP pass]
 #else    
 sigNameNoLoc :: Sig name -> [name]
 #endif
-sigNameNoLoc (TypeSig      ns _)       = map unLoc ns
-sigNameNoLoc (ClassOpSig _ ns _)       = map unLoc ns
-#if MIN_VERSION_GLASGOW_HASKELL(8,2,2,0)
-sigNameNoLoc (PatSynSig    ns _)        = map unLoc ns
+#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
+sigNameNoLoc (TypeSig _ ns _) = map unLoc ns
+#else
+sigNameNoLoc (TypeSig ns _) = map unLoc ns
+#endif
+#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
+sigNameNoLoc (ClassOpSig _ _ ns _) = map unLoc ns
+#else
+sigNameNoLoc (ClassOpSig _ ns _) = map unLoc ns
+#endif
+#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
+sigNameNoLoc (PatSynSig _ ns _) = map unLoc ns
+#elif MIN_VERSION_GLASGOW_HASKELL(8,2,2,0)
+sigNameNoLoc (PatSynSig ns _) = map unLoc ns
+#else
+sigNameNoLoc (PatSynSig n _) = [unLoc n]
+#endif
+#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
+sigNameNoLoc (SpecSig _ n _ _) = [unLoc n]
+#else
+sigNameNoLoc (SpecSig n _ _) = [unLoc n]
+#endif
+#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
+sigNameNoLoc (InlineSig _ n _) = [unLoc n]
 #else
-sigNameNoLoc (PatSynSig    n _)        = [unLoc n]
+sigNameNoLoc (InlineSig n _) = [unLoc n]
 #endif
-sigNameNoLoc (SpecSig      n _ _)      = [unLoc n]
-sigNameNoLoc (InlineSig    n _)        = [unLoc n]
+#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
+sigNameNoLoc (FixSig _ (FixitySig _ ns _)) = map unLoc ns
+#else
 sigNameNoLoc (FixSig (FixitySig ns _)) = map unLoc ns
+#endif
 sigNameNoLoc _                         = []
 
 clsInstDeclSrcSpan :: ClsInstDecl a -> SrcSpan
 clsInstDeclSrcSpan ClsInstDecl {cid_poly_ty = ty} = getLoc (hsSigType ty)
+#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)
+clsInstDeclSrcSpan (XClsInstDecl _) = UnhelpfulSpan "XClsinstdecl"
+#endif
 
 hsDocsToDocH :: DynFlags -> GlobalRdrEnv -> [HsDocString] -> Doc Name
 hsDocsToDocH flags rdrEnv =
@@ -1116,7 +1288,11 @@ hsDocsToDocH flags rdrEnv =
 #else
     . parseParas
 #endif
+#if MIN_VERSION_GLASGOW_HASKELL(8,6,1,0)    
+    . concatMap unpackHDS
+#else
     . concatMap (unpackFS . (\(HsDocString s) -> s))
+#endif
 
 parseIdent :: DynFlags -> String -> Maybe RdrName
 parseIdent dflags str0 =
-- 
cgit v1.2.3