Use `unLoc`/`noLoc` from GHC instead of `unL`/`reL`

 * `unL` is already defined by GHC as `unLoc`
 * `reL` is already defined by GHC as `noLoc` (in a safer way too!)
 * Condense `setOutputDir` and add a about exporting from GHC

Fixes #978

5 files changed, 44 insertions, 57 deletions

diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs
index b4a605f2..63acb465 100644
--- a/haddock-api/src/Haddock/Backends/Hoogle.hs
+++ b/haddock-api/src/Haddock/Backends/Hoogle.hs
@@ -82,7 +82,7 @@ dropHsDocTy = f
         f (HsOpTy x a b c) = HsOpTy x (g a) b (g c)
         f (HsParTy x a) = HsParTy x (g a)
         f (HsKindSig x a b) = HsKindSig x (g a) b
-        f (HsDocTy _ a _) = f $ unL a
+        f (HsDocTy _ a _) = f $ unLoc a
         f x = x
 
 outHsType :: (OutputableBndrId p)
@@ -215,7 +215,7 @@ ppSynonym dflags x = [out dflags x]
 ppData :: DynFlags -> TyClDecl GhcRn -> [(Name, DocForDecl Name)] -> [String]
 ppData dflags decl@(DataDecl { tcdDataDefn = defn }) subdocs
     = showData decl{ tcdDataDefn = defn { dd_cons=[],dd_derivs=noLoc [] }} :
-      concatMap (ppCtor dflags decl subdocs . unL) (dd_cons defn)
+      concatMap (ppCtor dflags decl subdocs . unLoc) (dd_cons defn)
     where
 
         -- GHC gives out "data Bar =", we want to delete the equals.
@@ -244,22 +244,22 @@ ppCtor dflags dat subdocs con@ConDeclH98 {}
                            [out dflags (map (extFieldOcc . unLoc) $ cd_fld_names r) `typeSig` [resType, cd_fld_type r]]
                           | r <- map unLoc recs]
 
-        funs = foldr1 (\x y -> reL $ HsFunTy noExtField x y)
-        apps = foldl1 (\x y -> reL $ HsAppTy noExtField x y)
+        funs = foldr1 (\x y -> noLoc $ HsFunTy noExtField x y)
+        apps = foldl1 (\x y -> noLoc $ HsAppTy noExtField x y)
 
-        typeSig nm flds = operator nm ++ " :: " ++ outHsType dflags (unL $ funs flds)
+        typeSig nm flds = operator nm ++ " :: " ++ outHsType dflags (unLoc $ funs flds)
 
         -- We print the constructors as comma-separated list. See GHC
         -- docs for con_names on why it is a list to begin with.
-        name = commaSeparate dflags . map unL $ getConNames con
+        name = commaSeparate dflags . map unLoc $ getConNames con
 
-        resType = let c  = HsTyVar noExtField NotPromoted (reL (tcdName dat))
+        resType = let c  = HsTyVar noExtField NotPromoted (noLoc (tcdName dat))
                       as = map (tyVarBndr2Type . unLoc) (hsQTvExplicit $ tyClDeclTyVars dat)
-                  in apps (map reL (c : as))
+                  in apps (map noLoc (c : as))
 
         tyVarBndr2Type :: HsTyVarBndr GhcRn -> HsType GhcRn
         tyVarBndr2Type (UserTyVar _ n) = HsTyVar noExtField NotPromoted n
-        tyVarBndr2Type (KindedTyVar _ n k) = HsKindSig noExtField (reL (HsTyVar noExtField NotPromoted n)) k
+        tyVarBndr2Type (KindedTyVar _ n k) = HsKindSig noExtField (noLoc (HsTyVar noExtField NotPromoted n)) k
         tyVarBndr2Type (XTyVarBndr nec) = noExtCon nec
 
 ppCtor dflags _dat subdocs con@(ConDeclGADT { })
@@ -267,8 +267,8 @@ ppCtor dflags _dat subdocs con@(ConDeclGADT { })
     where
         f = [typeSig name (getGADTConTypeG con)]
 
-        typeSig nm ty = operator nm ++ " :: " ++ outHsType dflags (unL ty)
-        name = out dflags $ map unL $ getConNames con
+        typeSig nm ty = operator nm ++ " :: " ++ outHsType dflags (unLoc ty)
+        name = out dflags $ map unLoc $ getConNames con
 ppCtor _ _ _ (XConDecl nec) = noExtCon nec
 
 ppFixity :: DynFlags -> (Name, Fixity) -> [String]
@@ -298,7 +298,7 @@ docWith dflags header d
 mkSubdoc :: DynFlags -> Located Name -> [(Name, DocForDecl Name)] -> [String] -> [String]
 mkSubdoc dflags n subdocs s = concatMap (ppDocumentation dflags) getDoc ++ s
  where
-   getDoc = maybe [] (return . fst) (lookup (unL n) subdocs)
+   getDoc = maybe [] (return . fst) (lookup (unLoc n) subdocs)
 
 data Tag = TagL Char [Tags] | TagP Tags | TagPre Tags | TagInline String Tags | Str String
            deriving Show
diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs
index d52c136f..647812f9 100644
--- a/haddock-api/src/Haddock/Backends/LaTeX.hs
+++ b/haddock-api/src/Haddock/Backends/LaTeX.hs
@@ -624,7 +624,7 @@ ppClassDecl instances doc subdocs
       text "\\haddockpremethods{}" <> emph (text "Associated Types") $$
       vcat  [ ppFamDecl True (fst doc) [] (FamDecl noExtField decl) True
             | L _ decl <- ats
-            , let name = unL . fdLName $ decl
+            , let name = unLoc . fdLName $ decl
                   doc = lookupAnySubdoc name subdocs
             ]
 
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
index 25669ca7..ef0ba1b6 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
@@ -492,7 +492,7 @@ ppShortClassDecl summary links (ClassDecl { tcdCtxt = lctxt, tcdLName = lname, t
       +++ shortSubDecls False
           (
             [ ppAssocType summary links doc at [] splice unicode pkg qual | at <- ats
-              , let doc = lookupAnySubdoc (unL $ fdLName $ unL at) subdocs ]  ++
+              , let doc = lookupAnySubdoc (unLoc $ fdLName $ unLoc at) subdocs ]  ++
 
                 -- ToDo: add associated type defaults
 
@@ -544,7 +544,7 @@ ppClassDecl summary links instances fixities loc d subdocs
           <+>
         subDefaults (maybeToList defTys)
       | at <- ats
-      , let name = unL . fdLName $ unL at
+      , let name = unLoc . fdLName $ unLoc at
             doc = lookupAnySubdoc name subdocs
             subfixs = filter ((== name) . fst) fixities
             defTys = (declElem . ppDefaultAssocTy name) <$> lookupDAT name
diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs
index f600997a..923516b6 100644
--- a/haddock-api/src/Haddock/GhcUtils.hs
+++ b/haddock-api/src/Haddock/GhcUtils.hs
@@ -319,8 +319,8 @@ restrictCons names decls = [ L p d | L p (Just d) <- map (fmap keep) decls ]
       case con_args d of
         PrefixCon _ -> Just d
         RecCon fields
-          | all field_avail (unL fields) -> Just d
-          | otherwise -> Just (d { con_args = PrefixCon (field_types (map unL (unL fields))) })
+          | all field_avail (unLoc fields) -> Just d
+          | otherwise -> Just (d { con_args = PrefixCon (field_types (map unLoc (unLoc fields))) })
           -- if we have *all* the field names available, then
           -- keep the record declaration.  Otherwise degrade to
           -- a constructor declaration.  This isn't quite right, but
@@ -340,7 +340,7 @@ restrictDecls names = mapMaybe (filterLSigNames (`elem` names))
 
 
 restrictATs :: [Name] -> [LFamilyDecl GhcRn] -> [LFamilyDecl GhcRn]
-restrictATs names ats = [ at | at <- ats , unL (fdLName (unL at)) `elem` names ]
+restrictATs names ats = [ at | at <- ats , unLoc (fdLName (unLoc at)) `elem` names ]
 
 
 -------------------------------------------------------------------------------
@@ -444,18 +444,6 @@ reparenConDeclField c@XConDeclField{} = c
 
 
 -------------------------------------------------------------------------------
--- * Located
--------------------------------------------------------------------------------
-
-
-unL :: Located a -> a
-unL (L _ x) = x
-
-
-reL :: a -> Located a
-reL = L undefined
-
--------------------------------------------------------------------------------
 -- * NamedThing instances
 -------------------------------------------------------------------------------
 
@@ -475,17 +463,17 @@ class Parent a where
 instance Parent (ConDecl GhcRn) where
   children con =
     case con_args con of
-      RecCon fields -> map (extFieldOcc . unL) $
-                         concatMap (cd_fld_names . unL) (unL fields)
+      RecCon fields -> map (extFieldOcc . unLoc) $
+                         concatMap (cd_fld_names . unLoc) (unLoc fields)
       _             -> []
 
 instance Parent (TyClDecl GhcRn) where
   children d
-    | isDataDecl  d = map unL $ concatMap (getConNames . unL)
+    | isDataDecl  d = map unLoc $ concatMap (getConNames . unLoc)
                               $ (dd_cons . tcdDataDefn) $ d
     | isClassDecl d =
-        map (unL . fdLName . unL) (tcdATs d) ++
-        [ unL n | L _ (TypeSig _ ns _) <- tcdSigs d, n <- ns ]
+        map (unLoc . fdLName . unLoc) (tcdATs d) ++
+        [ unLoc n | L _ (TypeSig _ ns _) <- tcdSigs d, n <- ns ]
     | otherwise = []
 
 
@@ -495,13 +483,13 @@ family = getName &&& children
 
 
 familyConDecl :: ConDecl GHC.GhcRn -> [(Name, [Name])]
-familyConDecl d = zip (map unL (getConNames d)) (repeat $ children d)
+familyConDecl d = zip (map unLoc (getConNames d)) (repeat $ children d)
 
 -- | A mapping from the parent (main-binder) to its children and from each
 -- child to its grand-children, recursively.
 families :: TyClDecl GhcRn -> [(Name, [Name])]
 families d
-  | isDataDecl  d = family d : concatMap (familyConDecl . unL) (dd_cons (tcdDataDefn d))
+  | isDataDecl  d = family d : concatMap (familyConDecl . unLoc) (dd_cons (tcdDataDefn d))
   | isClassDecl d = [family d]
   | otherwise     = []
 
@@ -546,17 +534,16 @@ minimalDef n = do
 -- * DynFlags
 -------------------------------------------------------------------------------
 
-
-setObjectDir, setHiDir, setHieDir, setStubDir, setOutputDir :: String -> DynFlags -> DynFlags
-setObjectDir  f d = d{ objectDir  = Just f}
-setHiDir      f d = d{ hiDir      = Just f}
-setHieDir     f d = d{ hieDir     = Just f}
-setStubDir    f d = d{ stubDir    = Just f
-                     , includePaths = addGlobalInclude (includePaths d) [f] }
-  -- -stubdir D adds an implicit -I D, so that gcc can find the _stub.h file
-  -- \#included from the .hc file when compiling with -fvia-C.
-setOutputDir  f = setObjectDir f . setHiDir f . setHieDir f . setStubDir f
-
+-- TODO: use `setOutputDir` from GHC
+setOutputDir :: FilePath -> DynFlags -> DynFlags
+setOutputDir dir dynFlags =
+  dynFlags { objectDir    = Just dir
+           , hiDir        = Just dir
+           , hieDir       = Just dir
+           , stubDir      = Just dir
+           , includePaths = addGlobalInclude (includePaths dynFlags) [dir]
+           , dumpDir      = Just dir
+           }
 
 -------------------------------------------------------------------------------
 -- * 'StringBuffer' and 'ByteString'
diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs
index b182a615..af006d03 100644
--- a/haddock-api/src/Haddock/Interface/Create.hs
+++ b/haddock-api/src/Haddock/Interface/Create.hs
@@ -461,14 +461,14 @@ subordinates instMap decl = case decl of
     dataSubs :: HsDataDefn GhcRn -> [(Name, [HsDocString], Map Int HsDocString)]
     dataSubs dd = constrs ++ fields ++ derivs
       where
-        cons = map unL $ (dd_cons dd)
-        constrs = [ (unL cname, maybeToList $ fmap unL $ con_doc c, conArgDocs c)
+        cons = map unLoc $ (dd_cons dd)
+        constrs = [ (unLoc cname, maybeToList $ fmap unLoc $ con_doc c, conArgDocs c)
                   | c <- cons, cname <- getConNames c ]
-        fields  = [ (extFieldOcc n, maybeToList $ fmap unL doc, M.empty)
+        fields  = [ (extFieldOcc n, maybeToList $ fmap unLoc doc, M.empty)
                   | RecCon flds <- map getConArgs cons
                   , L _ (ConDeclField _ ns _ doc) <- (unLoc flds)
                   , L _ n <- ns ]
-        derivs  = [ (instName, [unL doc], M.empty)
+        derivs  = [ (instName, [unLoc doc], M.empty)
                   | (l, doc) <- mapMaybe (extract_deriv_ty . hsib_body) $
                                 concatMap (unLoc . deriv_clause_tys . unLoc) $
                                 unLoc $ dd_derivs dd
@@ -585,13 +585,13 @@ sortByLoc = sortBy (comparing getLoc)
 
 -- | Filter out declarations that we don't handle in Haddock
 filterDecls :: [(LHsDecl a, doc)] -> [(LHsDecl a, doc)]
-filterDecls = filter (isHandled . unL . fst)
+filterDecls = filter (isHandled . unLoc . fst)
   where
     isHandled (ForD _ (ForeignImport {})) = True
     isHandled (TyClD {})  = True
     isHandled (InstD {})  = True
     isHandled (DerivD {}) = True
-    isHandled (SigD _ d)  = isUserLSig (reL d)
+    isHandled (SigD _ d)  = isUserLSig (noLoc d)
     isHandled (ValD {})   = True
     -- we keep doc declarations to be able to get at named docs
     isHandled (DocD {})   = True
@@ -677,7 +677,7 @@ mkExportItems
       return [ExportDoc doc]
 
     lookupExport (IEDocNamed _ str, _)      = liftErrMsg $
-      findNamedDoc str [ unL d | d <- decls ] >>= \case
+      findNamedDoc str [ unLoc d | d <- decls ] >>= \case
         Nothing -> return  []
         Just docStr -> do
           doc <- processDocStringParas dflags pkgName gre docStr
@@ -725,13 +725,13 @@ availExportItem is_sig modMap thisMod semMod warnings exportedNames
           export <- hiValExportItem dflags t l doc (l `elem` splices) $ M.lookup t fixMap
           return [export]
         (ds, docs_) | decl : _ <- filter (not . isValD . unLoc) ds ->
-          let declNames = getMainDeclBinder (unL decl)
+          let declNames = getMainDeclBinder (unLoc decl)
           in case () of
             _
               -- We should not show a subordinate by itself if any of its
               -- parents is also exported. See note [1].
               | t `notElem` declNames,
-                Just p <- find isExported (parents t $ unL decl) ->
+                Just p <- find isExported (parents t $ unLoc decl) ->
                 do liftErrMsg $ tell [
                      "Warning: " ++ moduleString thisMod ++ ": " ++
                      pretty dflags (nameOccName t) ++ " is exported separately but " ++