{-# LANGUAGE RecordWildCards #-}
----------------------------------------------------------------------------
-- |
-- Module      :  Haddock.Interface.Rename
-- Copyright   :  (c) Simon Marlow 2003-2006,
--                    David Waern  2006-2009
-- License     :  BSD-like
--
-- Maintainer  :  haddock@projects.haskell.org
-- Stability   :  experimental
-- Portability :  portable
-----------------------------------------------------------------------------
module Haddock.Interface.Rename (renameInterface) where

import Data.Traversable (mapM)

import Haddock.GhcUtils
import Haddock.Types

import Bag (emptyBag)
import GHC hiding (NoLink)
import Name
import RdrName (RdrName(Exact))
import PrelNames (eqTyCon_RDR)

import Control.Applicative
import Control.Monad hiding (mapM)
import Data.List
import qualified Data.Map as Map hiding ( Map )
import Prelude hiding (mapM)

renameInterface :: DynFlags -> LinkEnv -> Bool -> Interface -> ErrMsgM Interface
renameInterface dflags renamingEnv warnings iface =

  -- first create the local env, where every name exported by this module
  -- is mapped to itself, and everything else comes from the global renaming
  -- env
  let localEnv = foldl fn renamingEnv (ifaceVisibleExports iface)
        where fn env name = Map.insert name (ifaceMod iface) env

      -- rename names in the exported declarations to point to things that
      -- are closer to, or maybe even exported by, the current module.
      (renamedExportItems, missingNames1)
        = runRnFM localEnv (renameExportItems (ifaceExportItems iface))

      (rnDocMap, missingNames2) = runRnFM localEnv (mapM renameDoc (ifaceDocMap iface))

      (rnArgMap, missingNames3) = runRnFM localEnv (mapM (mapM renameDoc) (ifaceArgMap iface))

      (renamedOrphanInstances, missingNames4)
        = runRnFM localEnv (mapM renameDocInstance (ifaceOrphanInstances iface))

      (finalModuleDoc, missingNames5)
        = runRnFM localEnv (renameDocumentation (ifaceDoc iface))

      -- combine the missing names and filter out the built-ins, which would
      -- otherwise always be missing.
      missingNames = nubByName id $ filter isExternalName  -- XXX: isExternalName filters out too much
                    (missingNames1 ++ missingNames2 ++ missingNames3
                     ++ missingNames4 ++ missingNames5)

      -- Filter out certain built in type constructors using their string
      -- representation.
      --
      -- Note that since the renamed AST represents equality constraints as
      -- @HasOpTy t1 eqTyCon_RDR t2@ (and _not_ as @HsEqTy t1 t2@), we need to
      -- manually filter out 'eqTyCon_RDR' (aka @~@).
      strings = [ pretty dflags n
                | n <- missingNames
                , not (isSystemName n)
                , not (isBuiltInSyntax n)
                , Exact n /= eqTyCon_RDR
                ]

  in do
    -- report things that we couldn't link to. Only do this for non-hidden
    -- modules.
    unless (OptHide `elem` ifaceOptions iface || null strings || not warnings) $
      tell ["Warning: " ++ moduleString (ifaceMod iface) ++
            ": could not find link destinations for:\n"++
            unwords ("   " : strings) ]

    return $ iface { ifaceRnDoc         = finalModuleDoc,
                     ifaceRnDocMap      = rnDocMap,
                     ifaceRnArgMap      = rnArgMap,
                     ifaceRnExportItems = renamedExportItems,
                     ifaceRnOrphanInstances = renamedOrphanInstances}

--------------------------------------------------------------------------------
-- Monad for renaming
--
-- The monad does two things for us: it passes around the environment for
-- renaming, and it returns a list of names which couldn't be found in
-- the environment.
--------------------------------------------------------------------------------

newtype RnM a =
  RnM { unRn :: (Name -> (Bool, DocName))  -- name lookup function
             -> (a,[Name])
      }

instance Monad RnM where
  (>>=) = thenRn
  return = pure

instance Functor RnM where
  fmap f x = do a <- x; return (f a)

instance Applicative RnM where
  pure = returnRn
  (<*>) = ap

returnRn :: a -> RnM a
returnRn a   = RnM (const (a,[]))
thenRn :: RnM a -> (a -> RnM b) -> RnM b
m `thenRn` k = RnM (\lkp -> case unRn m lkp of
  (a,out1) -> case unRn (k a) lkp of
    (b,out2) -> (b,out1++out2))

getLookupRn :: RnM (Name -> (Bool, DocName))
getLookupRn = RnM (\lkp -> (lkp,[]))

outRn :: Name -> RnM ()
outRn name = RnM (const ((),[name]))

lookupRn :: Name -> RnM DocName
lookupRn name = do
  lkp <- getLookupRn
  case lkp name of
    (False,maps_to) -> do outRn name; return maps_to
    (True, maps_to) -> return maps_to

runRnFM :: LinkEnv -> RnM a -> (a,[Name])
runRnFM env rn = unRn rn lkp
  where
    lkp n = case Map.lookup n env of
      Nothing  -> (False, Undocumented n)
      Just mdl -> (True,  Documented n mdl)

--------------------------------------------------------------------------------
-- Renaming
--------------------------------------------------------------------------------

rename :: Name -> RnM DocName
rename = lookupRn

renameL :: Located Name -> RnM (Located DocName)
renameL = mapM rename

renameExportItems :: [ExportItem GhcRn] -> RnM [ExportItem DocNameI]
renameExportItems = mapM renameExportItem

renameDocForDecl :: DocForDecl Name -> RnM (DocForDecl DocName)
renameDocForDecl (doc, fnArgsDoc) =
  (,) <$> renameDocumentation doc <*> renameFnArgsDoc fnArgsDoc

renameDocumentation :: Documentation Name -> RnM (Documentation DocName)
renameDocumentation (Documentation mDoc mWarning) =
  Documentation <$> mapM renameDoc mDoc <*> mapM renameDoc mWarning

renameLDocHsSyn :: LHsDocString -> RnM LHsDocString
renameLDocHsSyn = return

renameDoc :: Traversable t => t Name -> RnM (t DocName)
renameDoc = traverse rename

renameFnArgsDoc :: FnArgsDoc Name -> RnM (FnArgsDoc DocName)
renameFnArgsDoc = mapM renameDoc

renameLType :: LHsType GhcRn -> RnM (LHsType DocNameI)
renameLType = mapM renameType

renameLSigType :: LHsSigType GhcRn -> RnM (LHsSigType DocNameI)
renameLSigType = renameImplicit renameLType

renameLSigWcType :: LHsSigWcType GhcRn -> RnM (LHsSigWcType DocNameI)
renameLSigWcType = renameWc (renameImplicit renameLType)

renameLKind :: LHsKind GhcRn -> RnM (LHsKind DocNameI)
renameLKind = renameLType

renameMaybeLKind :: Maybe (LHsKind GhcRn) -> RnM (Maybe (LHsKind DocNameI))
renameMaybeLKind = traverse renameLKind

renameFamilyResultSig :: LFamilyResultSig GhcRn -> RnM (LFamilyResultSig DocNameI)
renameFamilyResultSig (L loc NoSig)
    = return (L loc NoSig)
renameFamilyResultSig (L loc (KindSig ki))
    = do { ki' <- renameLKind ki
         ; return (L loc (KindSig ki')) }
renameFamilyResultSig (L loc (TyVarSig bndr))
    = do { bndr' <- renameLTyVarBndr bndr
         ; return (L loc (TyVarSig bndr')) }

renameInjectivityAnn :: LInjectivityAnn GhcRn -> RnM (LInjectivityAnn DocNameI)
renameInjectivityAnn (L loc (InjectivityAnn lhs rhs))
    = do { lhs' <- renameL lhs
         ; rhs' <- mapM renameL rhs
         ; return (L loc (InjectivityAnn lhs' rhs')) }

renameMaybeInjectivityAnn :: Maybe (LInjectivityAnn GhcRn)
                          -> RnM (Maybe (LInjectivityAnn DocNameI))
renameMaybeInjectivityAnn = traverse renameInjectivityAnn

renameType :: HsType GhcRn -> RnM (HsType DocNameI)
renameType t = case t of
  HsForAllTy { hst_bndrs = tyvars, hst_body = ltype } -> do
    tyvars'   <- mapM renameLTyVarBndr tyvars
    ltype'    <- renameLType ltype
    return (HsForAllTy { hst_bndrs = tyvars', hst_body = ltype' })

  HsQualTy { hst_ctxt = lcontext , hst_body = ltype } -> do
    lcontext' <- renameLContext lcontext
    ltype'    <- renameLType ltype
    return (HsQualTy { hst_ctxt = lcontext', hst_body = ltype' })

  HsTyVar ip (L l n) -> return . HsTyVar ip . L l =<< rename n
  HsBangTy b ltype -> return . HsBangTy b =<< renameLType ltype

  HsAppTy a b -> do
    a' <- renameLType a
    b' <- renameLType b
    return (HsAppTy a' b')

  HsFunTy a b -> do
    a' <- renameLType a
    b' <- renameLType b
    return (HsFunTy a' b')

  HsListTy ty -> return . HsListTy =<< renameLType ty
  HsPArrTy ty -> return . HsPArrTy =<< renameLType ty
  HsIParamTy n ty -> liftM (HsIParamTy n) (renameLType ty)
  HsEqTy ty1 ty2 -> liftM2 HsEqTy (renameLType ty1) (renameLType ty2)

  HsTupleTy b ts -> return . HsTupleTy b =<< mapM renameLType ts
  HsSumTy ts -> HsSumTy <$> mapM renameLType ts

  HsOpTy a (L loc op) b -> do
    op' <- rename op
    a'  <- renameLType a
    b'  <- renameLType b
    return (HsOpTy a' (L loc op') b')

  HsParTy ty -> return . HsParTy =<< renameLType ty

  HsKindSig ty k -> do
    ty' <- renameLType ty
    k' <- renameLKind k
    return (HsKindSig ty' k')

  HsDocTy ty doc -> do
    ty' <- renameLType ty
    doc' <- renameLDocHsSyn doc
    return (HsDocTy ty' doc')

  HsTyLit x -> return (HsTyLit x)

  HsRecTy a               -> HsRecTy <$> mapM renameConDeclFieldField a
  HsCoreTy a              -> pure (HsCoreTy a)
  HsExplicitListTy i a b  -> HsExplicitListTy i a <$> mapM renameLType b
  HsExplicitTupleTy a b   -> HsExplicitTupleTy a <$> mapM renameLType b
  HsSpliceTy s _          -> renameHsSpliceTy s
  HsWildCardTy a          -> HsWildCardTy <$> renameWildCardInfo a
  HsAppsTy _              -> error "renameType: HsAppsTy"

-- | Rename splices, but _only_ those that turn out to be for types.
-- I think this is actually safe for our possible inputs:
--
--  * the input is from after GHC's renamer, so should have an 'HsSpliced'
--  * the input is typechecked, and only 'HsSplicedTy' should get through that
--
renameHsSpliceTy :: HsSplice GhcRn -> RnM (HsType DocNameI)
renameHsSpliceTy (HsSpliced _ (HsSplicedTy t)) = renameType t
renameHsSpliceTy (HsSpliced _ _) = error "renameHsSpliceTy: not an HsSplicedTy"
renameHsSpliceTy _ = error "renameHsSpliceTy: not an HsSpliced"

renameLHsQTyVars :: LHsQTyVars GhcRn -> RnM (LHsQTyVars DocNameI)
renameLHsQTyVars (HsQTvs { hsq_implicit = _, hsq_explicit = tvs })
  = do { tvs' <- mapM renameLTyVarBndr tvs
       ; return (HsQTvs { hsq_implicit = error "haddock:renameLHsQTyVars", hsq_explicit = tvs', hsq_dependent = error "haddock:renameLHsQTyVars" }) }
                -- This is rather bogus, but I'm not sure what else to do

renameLTyVarBndr :: LHsTyVarBndr GhcRn -> RnM (LHsTyVarBndr DocNameI)
renameLTyVarBndr (L loc (UserTyVar (L l n)))
  = do { n' <- rename n
       ; return (L loc (UserTyVar (L l n'))) }
renameLTyVarBndr (L loc (KindedTyVar (L lv n) kind))
  = do { n' <- rename n
       ; kind' <- renameLKind kind
       ; return (L loc (KindedTyVar (L lv n') kind')) }

renameLContext :: Located [LHsType GhcRn] -> RnM (Located [LHsType DocNameI])
renameLContext (L loc context) = do
  context' <- mapM renameLType context
  return (L loc context')

renameWildCardInfo :: HsWildCardInfo GhcRn -> RnM (HsWildCardInfo DocNameI)
renameWildCardInfo (AnonWildCard  (L l name)) = AnonWildCard . L l <$> rename name

renameInstHead :: InstHead GhcRn -> RnM (InstHead DocNameI)
renameInstHead InstHead {..} = do
  cname <- rename ihdClsName
  types <- mapM renameType ihdTypes
  itype <- case ihdInstType of
    ClassInst { .. } -> ClassInst
        <$> mapM renameType clsiCtx
        <*> renameLHsQTyVars clsiTyVars
        <*> mapM renameSig clsiSigs
        <*> mapM renamePseudoFamilyDecl clsiAssocTys
    TypeInst  ts -> TypeInst  <$> traverse renameType ts
    DataInst  dd -> DataInst  <$> renameTyClD dd
  return InstHead
    { ihdClsName = cname
    , ihdTypes = types
    , ihdInstType = itype
    }

renameLDecl :: LHsDecl GhcRn -> RnM (LHsDecl DocNameI)
renameLDecl (L loc d) = return . L loc =<< renameDecl d

renamePats :: [(HsDecl GhcRn, DocForDecl Name)] -> RnM [(HsDecl DocNameI, DocForDecl DocName)]
renamePats = mapM
  (\(d,doc) -> do { d'   <- renameDecl d
                  ; doc' <- renameDocForDecl doc
                  ; return (d',doc')})

renameDecl :: HsDecl GhcRn -> RnM (HsDecl DocNameI)
renameDecl decl = case decl of
  TyClD d -> do
    d' <- renameTyClD d
    return (TyClD d')
  SigD s -> do
    s' <- renameSig s
    return (SigD s')
  ForD d -> do
    d' <- renameForD d
    return (ForD d')
  InstD d -> do
    d' <- renameInstD d
    return (InstD d')
  DerivD d -> do
    d' <- renameDerivD d
    return (DerivD d')
  _ -> error "renameDecl"

renameLThing :: (a GhcRn -> RnM (a DocNameI)) -> Located (a GhcRn) -> RnM (Located (a DocNameI))
renameLThing fn (L loc x) = return . L loc =<< fn x

renameTyClD :: TyClDecl GhcRn -> RnM (TyClDecl DocNameI)
renameTyClD d = case d of
--  TyFamily flav lname ltyvars kind tckind -> do
  FamDecl { tcdFam = decl } -> do
    decl' <- renameFamilyDecl decl
    return (FamDecl { tcdFam = decl' })

  SynDecl { tcdLName = lname, tcdTyVars = tyvars, tcdFixity = fixity, tcdRhs = rhs, tcdFVs = _fvs } -> do
    lname'    <- renameL lname
    tyvars'   <- renameLHsQTyVars tyvars
    rhs'     <- renameLType rhs
    return (SynDecl { tcdLName = lname', tcdTyVars = tyvars', tcdFixity = fixity, tcdRhs = rhs', tcdFVs = placeHolderNames })

  DataDecl { tcdLName = lname, tcdTyVars = tyvars, tcdFixity = fixity, tcdDataDefn = defn, tcdFVs = _fvs } -> do
    lname'    <- renameL lname
    tyvars'   <- renameLHsQTyVars tyvars
    defn'     <- renameDataDefn defn
    return (DataDecl { tcdLName = lname', tcdTyVars = tyvars', tcdFixity = fixity, tcdDataDefn = defn', tcdDataCusk = PlaceHolder, tcdFVs = placeHolderNames })

  ClassDecl { tcdCtxt = lcontext, tcdLName = lname, tcdTyVars = ltyvars, tcdFixity = fixity
            , tcdFDs = lfundeps, tcdSigs = lsigs, tcdATs = ats, tcdATDefs = at_defs } -> do
    lcontext' <- renameLContext lcontext
    lname'    <- renameL lname
    ltyvars'  <- renameLHsQTyVars ltyvars
    lfundeps' <- mapM renameLFunDep lfundeps
    lsigs'    <- mapM renameLSig lsigs
    ats'      <- mapM (renameLThing renameFamilyDecl) ats
    at_defs'  <- mapM renameLTyFamDefltEqn at_defs
    -- we don't need the default methods or the already collected doc entities
    return (ClassDecl { tcdCtxt = lcontext', tcdLName = lname', tcdTyVars = ltyvars'
                      , tcdFixity = fixity
                      , tcdFDs = lfundeps', tcdSigs = lsigs', tcdMeths= emptyBag
                      , tcdATs = ats', tcdATDefs = at_defs', tcdDocs = [], tcdFVs = placeHolderNames })

  where
    renameLFunDep (L loc (xs, ys)) = do
      xs' <- mapM rename (map unLoc xs)
      ys' <- mapM rename (map unLoc ys)
      return (L loc (map noLoc xs', map noLoc ys'))

    renameLSig (L loc sig) = return . L loc =<< renameSig sig

renameFamilyDecl :: FamilyDecl GhcRn -> RnM (FamilyDecl DocNameI)
renameFamilyDecl (FamilyDecl { fdInfo = info, fdLName = lname
                             , fdTyVars = ltyvars
                             , fdFixity = fixity
                             , fdResultSig = result
                             , fdInjectivityAnn = injectivity }) = do
    info'        <- renameFamilyInfo info
    lname'       <- renameL lname
    ltyvars'     <- renameLHsQTyVars ltyvars
    result'      <- renameFamilyResultSig result
    injectivity' <- renameMaybeInjectivityAnn injectivity
    return (FamilyDecl { fdInfo = info', fdLName = lname'
                       , fdTyVars = ltyvars'
                       , fdFixity = fixity
                       , fdResultSig = result'
                       , fdInjectivityAnn = injectivity' })

renamePseudoFamilyDecl :: PseudoFamilyDecl GhcRn
                       -> RnM (PseudoFamilyDecl DocNameI)
renamePseudoFamilyDecl (PseudoFamilyDecl { .. }) =  PseudoFamilyDecl
    <$> renameFamilyInfo pfdInfo
    <*> renameL pfdLName
    <*> mapM renameLType pfdTyVars
    <*> renameFamilyResultSig pfdKindSig

renameFamilyInfo :: FamilyInfo GhcRn -> RnM (FamilyInfo DocNameI)
renameFamilyInfo DataFamily     = return DataFamily
renameFamilyInfo OpenTypeFamily = return OpenTypeFamily
renameFamilyInfo (ClosedTypeFamily eqns)
  = do { eqns' <- mapM (mapM (mapM renameTyFamInstEqn)) eqns
       ; return $ ClosedTypeFamily eqns' }

renameDataDefn :: HsDataDefn GhcRn -> RnM (HsDataDefn DocNameI)
renameDataDefn (HsDataDefn { dd_ND = nd, dd_ctxt = lcontext, dd_cType = cType
                           , dd_kindSig = k, dd_cons = cons }) = do
    lcontext' <- renameLContext lcontext
    k'        <- renameMaybeLKind k
    cons'     <- mapM (mapM renameCon) cons
    -- I don't think we need the derivings, so we return Nothing
    return (HsDataDefn { dd_ND = nd, dd_ctxt = lcontext', dd_cType = cType
                       , dd_kindSig = k', dd_cons = cons'
                       , dd_derivs = noLoc [] })

renameCon :: ConDecl GhcRn -> RnM (ConDecl DocNameI)
renameCon decl@(ConDeclH98 { con_name = lname, con_qvars = ltyvars
                           , con_cxt = lcontext, con_details = details
                           , con_doc = mbldoc }) = do
      lname'    <- renameL lname
      ltyvars'  <- traverse renameLHsQTyVars ltyvars
      lcontext' <- traverse renameLContext lcontext
      details'  <- renameDetails details
      mbldoc'   <- mapM renameLDocHsSyn mbldoc
      return (decl { con_name = lname', con_qvars = ltyvars', con_cxt = lcontext'
                   , con_details = details', con_doc = mbldoc' })

  where
    renameDetails (RecCon (L l fields)) = do
      fields' <- mapM renameConDeclFieldField fields
      return (RecCon (L l fields'))
    renameDetails (PrefixCon ps) = return . PrefixCon =<< mapM renameLType ps
    renameDetails (InfixCon a b) = do
      a' <- renameLType a
      b' <- renameLType b
      return (InfixCon a' b')

renameCon decl@(ConDeclGADT { con_names = lnames
                            , con_type = lty
                            , con_doc = mbldoc }) = do
      lnames'   <- mapM renameL lnames
      lty'      <- renameLSigType lty
      mbldoc'   <- mapM renameLDocHsSyn mbldoc
      return (decl { con_names = lnames'
                   , con_type = lty', con_doc = mbldoc' })

renameConDeclFieldField :: LConDeclField GhcRn -> RnM (LConDeclField DocNameI)
renameConDeclFieldField (L l (ConDeclField names t doc)) = do
  names' <- mapM renameLFieldOcc names
  t'   <- renameLType t
  doc' <- mapM renameLDocHsSyn doc
  return $ L l (ConDeclField names' t' doc')

renameLFieldOcc :: LFieldOcc GhcRn -> RnM (LFieldOcc DocNameI)
renameLFieldOcc (L l (FieldOcc lbl sel)) = do
  sel' <- rename sel
  return $ L l (FieldOcc lbl sel')

renameSig :: Sig GhcRn -> RnM (Sig DocNameI)
renameSig sig = case sig of
  TypeSig lnames ltype -> do
    lnames' <- mapM renameL lnames
    ltype' <- renameLSigWcType ltype
    return (TypeSig lnames' ltype')
  ClassOpSig is_default lnames sig_ty -> do
    lnames' <- mapM renameL lnames
    ltype' <- renameLSigType sig_ty
    return (ClassOpSig is_default lnames' ltype')
  PatSynSig lnames sig_ty -> do
    lnames' <- mapM renameL lnames
    sig_ty' <- renameLSigType sig_ty
    return $ PatSynSig lnames' sig_ty'
  FixSig (FixitySig lnames fixity) -> do
    lnames' <- mapM renameL lnames
    return $ FixSig (FixitySig lnames' fixity)
  MinimalSig src (L l s) -> do
    s' <- traverse renameL s
    return $ MinimalSig src (L l s')
  -- we have filtered out all other kinds of signatures in Interface.Create
  _ -> error "expected TypeSig"

renameForD :: ForeignDecl GhcRn -> RnM (ForeignDecl DocNameI)
renameForD (ForeignImport lname ltype co x) = do
  lname' <- renameL lname
  ltype' <- renameLSigType ltype
  return (ForeignImport lname' ltype' co x)
renameForD (ForeignExport lname ltype co x) = do
  lname' <- renameL lname
  ltype' <- renameLSigType ltype
  return (ForeignExport lname' ltype' co x)

renameInstD :: InstDecl GhcRn -> RnM (InstDecl DocNameI)
renameInstD (ClsInstD { cid_inst = d }) = do
  d' <- renameClsInstD d
  return (ClsInstD { cid_inst = d' })
renameInstD (TyFamInstD { tfid_inst = d }) = do
  d' <- renameTyFamInstD d
  return (TyFamInstD { tfid_inst = d' })
renameInstD (DataFamInstD { dfid_inst = d }) = do
  d' <- renameDataFamInstD d
  return (DataFamInstD { dfid_inst = d' })

renameDerivD :: DerivDecl GhcRn -> RnM (DerivDecl DocNameI)
renameDerivD (DerivDecl { deriv_type = ty
                        , deriv_strategy = strat
                        , deriv_overlap_mode = omode }) = do
  ty' <- renameLSigType ty
  return (DerivDecl { deriv_type = ty'
                    , deriv_strategy = strat
                    , deriv_overlap_mode = omode })

renameClsInstD :: ClsInstDecl GhcRn -> RnM (ClsInstDecl DocNameI)
renameClsInstD (ClsInstDecl { cid_overlap_mode = omode
                            , cid_poly_ty =ltype, cid_tyfam_insts = lATs
                            , cid_datafam_insts = lADTs }) = do
  ltype' <- renameLSigType ltype
  lATs'  <- mapM (mapM renameTyFamInstD) lATs
  lADTs' <- mapM (mapM renameDataFamInstD) lADTs
  return (ClsInstDecl { cid_overlap_mode = omode
                      , cid_poly_ty = ltype', cid_binds = emptyBag
                      , cid_sigs = []
                      , cid_tyfam_insts = lATs', cid_datafam_insts = lADTs' })

renameTyFamInstD :: TyFamInstDecl GhcRn -> RnM (TyFamInstDecl DocNameI)
renameTyFamInstD (TyFamInstDecl { tfid_eqn = eqn })
  = do { eqn' <- renameTyFamInstEqn eqn
       ; return (TyFamInstDecl { tfid_eqn = eqn' }) }

renameTyFamInstEqn :: TyFamInstEqn GhcRn -> RnM (TyFamInstEqn DocNameI)
renameTyFamInstEqn eqn
  = renameImplicit rename_ty_fam_eqn eqn
  where
    rename_ty_fam_eqn
      :: FamEqn GhcRn (HsTyPats GhcRn) (LHsType GhcRn)
      -> RnM (FamEqn DocNameI (HsTyPats DocNameI) (LHsType DocNameI))
    rename_ty_fam_eqn (FamEqn { feqn_tycon = tc, feqn_pats = pats
                              , feqn_fixity = fixity, feqn_rhs = rhs })
      = do { tc' <- renameL tc
           ; pats' <- mapM renameLType pats
           ; rhs' <- renameLType rhs
           ; return (FamEqn { feqn_tycon  = tc'
                            , feqn_pats   = pats'
                            , feqn_fixity = fixity
                            , feqn_rhs    = rhs' }) }

renameLTyFamDefltEqn :: LTyFamDefltEqn GhcRn -> RnM (LTyFamDefltEqn DocNameI)
renameLTyFamDefltEqn (L loc (FamEqn { feqn_tycon = tc, feqn_pats = tvs
                                    , feqn_fixity = fixity, feqn_rhs = rhs }))
  = do { tc'  <- renameL tc
       ; tvs' <- renameLHsQTyVars tvs
       ; rhs' <- renameLType rhs
       ; return (L loc (FamEqn { feqn_tycon  = tc'
                               , feqn_pats   = tvs'
                               , feqn_fixity = fixity
                               , feqn_rhs    = rhs' })) }

renameDataFamInstD :: DataFamInstDecl GhcRn -> RnM (DataFamInstDecl DocNameI)
renameDataFamInstD (DataFamInstDecl { dfid_eqn = eqn })
  = do { eqn' <- renameImplicit rename_data_fam_eqn eqn
       ; return (DataFamInstDecl { dfid_eqn = eqn' }) }
  where
    rename_data_fam_eqn
      :: FamEqn GhcRn (HsTyPats GhcRn) (HsDataDefn GhcRn)
      -> RnM (FamEqn DocNameI (HsTyPats DocNameI) (HsDataDefn DocNameI))
    rename_data_fam_eqn (FamEqn { feqn_tycon = tc, feqn_pats = pats
                                , feqn_fixity = fixity, feqn_rhs = defn })
      = do { tc' <- renameL tc
           ; pats' <- mapM renameLType pats
           ; defn' <- renameDataDefn defn
           ; return (FamEqn { feqn_tycon  = tc'
                            , feqn_pats   = pats'
                            , feqn_fixity = fixity
                            , feqn_rhs    = defn' }) }

renameImplicit :: (in_thing -> RnM out_thing)
               -> HsImplicitBndrs GhcRn in_thing
               -> RnM (HsImplicitBndrs DocNameI out_thing)
renameImplicit rn_thing (HsIB { hsib_body = thing })
  = do { thing' <- rn_thing thing
       ; return (HsIB { hsib_body = thing'
                      , hsib_vars = PlaceHolder
                      , hsib_closed = PlaceHolder }) }

renameWc :: (in_thing -> RnM out_thing)
         -> HsWildCardBndrs GhcRn in_thing
         -> RnM (HsWildCardBndrs DocNameI out_thing)
renameWc rn_thing (HsWC { hswc_body = thing })
  = do { thing' <- rn_thing thing
       ; return (HsWC { hswc_body = thing'
                      , hswc_wcs = PlaceHolder }) }

renameDocInstance :: DocInstance GhcRn -> RnM (DocInstance DocNameI)
renameDocInstance (inst, idoc, L l n, m) = do
  inst' <- renameInstHead inst
  n' <- rename n
  idoc' <- mapM renameDoc idoc
  return (inst', idoc', L l n', m)

renameExportItem :: ExportItem GhcRn -> RnM (ExportItem DocNameI)
renameExportItem item = case item of
  ExportModule mdl -> return (ExportModule mdl)
  ExportGroup lev id_ doc -> do
    doc' <- renameDoc doc
    return (ExportGroup lev id_ doc')
  ExportDecl decl pats doc subs instances fixities splice -> do
    decl' <- renameLDecl decl
    pats' <- renamePats pats
    doc'  <- renameDocForDecl doc
    subs' <- mapM renameSub subs
    instances' <- forM instances renameDocInstance
    fixities' <- forM fixities $ \(name, fixity) -> do
      name' <- lookupRn name
      return (name', fixity)
    return (ExportDecl decl' pats' doc' subs' instances' fixities' splice)
  ExportNoDecl x subs -> do
    x'    <- lookupRn x
    subs' <- mapM lookupRn subs
    return (ExportNoDecl x' subs')
  ExportDoc doc -> do
    doc' <- renameDoc doc
    return (ExportDoc doc')

renameSub :: (Name, DocForDecl Name) -> RnM (DocName, DocForDecl DocName)
renameSub (n,doc) = do
  n' <- rename n
  doc' <- renameDocForDecl doc
  return (n', doc')


{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE RecordWildCards #-}

module Haddock.Interface.Specialize
    ( specializeInstHead
    ) where

import Haddock.Syb
import Haddock.Types

import GHC
import Name
import FastString

import Control.Monad
import Control.Monad.Trans.State

import Data.Data
import qualified Data.List as List
import Data.Maybe
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Set (Set)
import qualified Data.Set as Set

-- | Instantiate all occurrences of given names with corresponding types.
specialize :: forall name a. (Ord (IdP name), DataId name, NamedThing (IdP name))
            => Data a
            => [(IdP name, HsType name)] -> a -> a
specialize specs = go spec_map0
  where
    go :: forall x. Data x => Map (IdP name) (HsType name) -> x -> x
    go spec_map = everywhereButType @name $ mkT $ sugar . strip_kind_sig . specialize_ty_var spec_map

    strip_kind_sig :: HsType name -> HsType name
    strip_kind_sig (HsKindSig (L _ t) _) = t
    strip_kind_sig typ = typ

    specialize_ty_var :: Map (IdP name) (HsType name) -> HsType name -> HsType name
    specialize_ty_var spec_map (HsTyVar _ (L _ name'))
      | Just t <- Map.lookup name' spec_map = t
    specialize_ty_var _ typ = typ

    -- This is a tricky recursive definition. By adding in the specializations
    -- one by one, we should avoid infinite loops.
    spec_map0 = foldr (\(n,t) acc -> Map.insert n (go acc t) acc) mempty specs

-- | Instantiate given binders with corresponding types.
--
-- Again, it is just a convenience function around 'specialize'. Note that
-- length of type list should be the same as the number of binders.
specializeTyVarBndrs :: (Ord (IdP name), DataId name, NamedThing (IdP name))
                     => Data a
                     => LHsQTyVars name -> [HsType name]
                     -> a -> a
specializeTyVarBndrs bndrs typs =
    specialize $ zip bndrs' typs
  where
    bndrs' = map (bname . unLoc) . hsq_explicit $ bndrs
    bname (UserTyVar (L _ name)) = name
    bname (KindedTyVar (L _ name) _) = name

specializePseudoFamilyDecl :: (Ord (IdP name), DataId name, NamedThing (IdP name))
                           => LHsQTyVars name -> [HsType name]
                           -> PseudoFamilyDecl name
                           -> PseudoFamilyDecl name
specializePseudoFamilyDecl bndrs typs decl =
  decl {pfdTyVars = map (specializeTyVarBndrs bndrs typs) (pfdTyVars decl)}

specializeSig :: forall name . (Ord (IdP name), DataId name, SetName (IdP name), NamedThing (IdP name))
              => LHsQTyVars name -> [HsType name]
              -> Sig name
              -> Sig name
specializeSig bndrs typs (TypeSig lnames typ) =
  TypeSig lnames (typ {hswc_body = (hswc_body typ) {hsib_body = noLoc typ'}})
  where
    true_type :: HsType name
    true_type = unLoc (hsSigWcType typ)
    typ' :: HsType name
    typ' = rename fv $ specializeTyVarBndrs bndrs typs true_type
    fv = foldr Set.union Set.empty . map freeVariables $ typs
specializeSig _ _ sig = sig

-- | Make all details of instance head (signatures, associated types)
-- specialized to that particular instance type.
specializeInstHead :: (Ord (IdP name), DataId name, SetName (IdP name), NamedThing (IdP name))
                   => InstHead name -> InstHead name
specializeInstHead ihd@InstHead { ihdInstType = clsi@ClassInst { .. }, .. } =
    ihd { ihdInstType = instType' }
  where
    instType' = clsi
        { clsiSigs = map specializeSig' clsiSigs
        , clsiAssocTys = map specializeFamilyDecl' clsiAssocTys
        }
    specializeSig' = specializeSig clsiTyVars ihdTypes
    specializeFamilyDecl' = specializePseudoFamilyDecl clsiTyVars ihdTypes
specializeInstHead ihd = ihd

-- | Make given type use tuple and list literals where appropriate.
--
-- After applying 'specialize' function some terms may not use idiomatic list
-- and tuple literals resulting in types like @[] a@ or @(,,) a b c@. This
-- can be fixed using 'sugar' function, that will turn such types into @[a]@
-- and @(a, b, c)@.
sugar :: forall name. (NamedThing (IdP name), DataId name)
      => HsType name -> HsType name
sugar = sugarOperators . sugarTuples . sugarLists

sugarLists :: NamedThing (IdP name) => HsType name -> HsType name
sugarLists (HsAppTy (L _ (HsTyVar _ (L _ name))) ltyp)
    | isBuiltInSyntax name' && strName == "[]" = HsListTy ltyp
  where
    name' = getName name
    strName = occNameString . nameOccName $ name'
sugarLists typ = typ

sugarTuples :: NamedThing (IdP name) => HsType name -> HsType name
sugarTuples typ =
    aux [] typ
  where
    aux apps (HsAppTy (L _ ftyp) atyp) = aux (atyp:apps) ftyp
    aux apps (HsParTy (L _ typ')) = aux apps typ'
    aux apps (HsTyVar _ (L _ name))
        | isBuiltInSyntax name' && suitable = HsTupleTy HsBoxedTuple apps
      where
        name' = getName name
        strName = occNameString . nameOccName $ name'
        suitable = case parseTupleArity strName of
            Just arity -> arity == length apps
            Nothing -> False
    aux _ _ = typ

sugarOperators :: NamedThing (IdP name) => HsType name -> HsType name
sugarOperators (HsAppTy (L _ (HsAppTy (L _ (HsTyVar _ (L l name))) la)) lb)
    | isSymOcc $ getOccName name' = mkHsOpTy la (L l name) lb
    | isBuiltInSyntax name' && getOccString name == "(->)" = HsFunTy la lb
  where
    name' = getName name
sugarOperators typ = typ

-- | Compute arity of given tuple operator.
--
-- >>> parseTupleArity "(,,)"
-- Just 3
--
-- >>> parseTupleArity "(,,,,)"
-- Just 5
--
-- >>> parseTupleArity "abc"
-- Nothing
--
-- >>> parseTupleArity "()"
-- Nothing
parseTupleArity :: String -> Maybe Int
parseTupleArity ('(':commas) = do
    n <- parseCommas commas
    guard $ n /= 0
    return $ n + 1
  where
    parseCommas (',':rest) = (+ 1) <$> parseCommas rest
    parseCommas ")" = Just 0
    parseCommas _ = Nothing
parseTupleArity _ = Nothing

-- | Haskell AST type representation.
--
-- This type is used for renaming (more below), essentially the ambiguous (!)
-- version of 'Name'. So, why is this 'FastString' instead of 'OccName'? Well,
-- it was 'OccName' before, but turned out that 'OccName' sometimes also
-- contains namespace information, differentiating visually same types.
--
-- And 'FastString' is used because it is /visual/ part of 'OccName' - it is
-- not converted to 'String' or alike to avoid new allocations. Additionally,
-- since it is stored mostly in 'Set', fast comparison of 'FastString' is also
-- quite nice.
type NameRep = FastString

getNameRep :: NamedThing name => name -> NameRep
getNameRep = occNameFS . getOccName

nameRepString :: NameRep -> String
nameRepString = unpackFS

stringNameRep :: String -> NameRep
stringNameRep = mkFastString

setInternalNameRep :: SetName name => NameRep -> name -> name
setInternalNameRep = setInternalOccName . mkVarOccFS

setInternalOccName :: SetName name => OccName -> name -> name
setInternalOccName occ name =
    setName nname' name
  where
    nname = getName name
    nname' = mkInternalName (nameUnique nname) occ (nameSrcSpan nname)

-- | Compute set of free variables of given type.
freeVariables :: forall name. (NamedThing (IdP name), DataId name)
              => HsType name -> Set Name
freeVariables =
    everythingWithState Set.empty Set.union query
  where
    query term ctx = case cast term :: Maybe (HsType name) of
        Just (HsForAllTy bndrs _) ->
            (Set.empty, Set.union ctx (bndrsNames bndrs))
        Just (HsTyVar _ (L _ name))
            | getName name `Set.member` ctx -> (Set.empty, ctx)
            | otherwise -> (Set.singleton $ getName name, ctx)
        _ -> (Set.empty, ctx)
    bndrsNames = Set.fromList . map (getName . tyVarName . unLoc)

-- | Make given type visually unambiguous.
--
-- After applying 'specialize' method, some free type variables may become
-- visually ambiguous - for example, having @a -> b@ and specializing @a@ to
-- @(a -> b)@ we get @(a -> b) -> b@ where first occurrence of @b@ refers to
-- different type variable than latter one. Applying 'rename' function
-- will fix that type to be visually unambiguous again (making it something
-- like @(a -> b0) -> b@).
rename :: (Eq (IdP name), DataId name, SetName (IdP name))
       => Set Name-> HsType name -> HsType name
rename fv typ = evalState (renameType typ) env
  where
    env = RenameEnv
      { rneHeadFVs = Map.fromList . map mkPair . Set.toList $ fv
      , rneSigFVs = Set.map getNameRep $ freeVariables typ
      , rneCtx = Map.empty
      }
    mkPair name = (getNameRep name, name)

-- | Renaming monad.
type Rename name = State (RenameEnv name)

data RenameEnv name = RenameEnv
  { rneHeadFVs :: Map NameRep Name
  , rneSigFVs :: Set NameRep
  , rneCtx :: Map Name name
  }

renameType :: (Eq (IdP name), SetName (IdP name))
           => HsType name -> Rename (IdP name) (HsType name)
renameType (HsForAllTy bndrs lt) =
    HsForAllTy
        <$> mapM (located renameBinder) bndrs
        <*> renameLType lt
renameType (HsQualTy lctxt lt) =
    HsQualTy
        <$> located renameContext lctxt
        <*> renameLType lt
renameType (HsTyVar ip name) = HsTyVar ip <$> located renameName name
renameType (HsAppTy lf la) = HsAppTy <$> renameLType lf <*> renameLType la
renameType (HsFunTy la lr) = HsFunTy <$> renameLType la <*> renameLType lr
renameType (HsListTy lt) = HsListTy <$> renameLType lt
renameType (HsPArrTy lt) = HsPArrTy <$> renameLType lt
renameType (HsTupleTy srt lt) = HsTupleTy srt <$> mapM renameLType lt
renameType (HsSumTy lt) = HsSumTy <$> mapM renameLType lt
renameType (HsOpTy la lop lb) =
    HsOpTy <$> renameLType la <*> located renameName lop <*> renameLType lb
renameType (HsParTy lt) = HsParTy <$> renameLType lt
renameType (HsIParamTy ip lt) = HsIParamTy ip <$> renameLType lt
renameType (HsEqTy la lb) = HsEqTy <$> renameLType la <*> renameLType lb
renameType (HsKindSig lt lk) = HsKindSig <$> renameLType lt <*> pure lk
renameType t@(HsSpliceTy _ _) = pure t
renameType (HsDocTy lt doc) = HsDocTy <$> renameLType lt <*> pure doc
renameType (HsBangTy bang lt) = HsBangTy bang <$> renameLType lt
renameType t@(HsRecTy _) = pure t
renameType t@(HsCoreTy _) = pure t
renameType (HsExplicitListTy ip ph ltys) =
    HsExplicitListTy ip ph <$> renameLTypes ltys
renameType (HsExplicitTupleTy phs ltys) =
    HsExplicitTupleTy phs <$> renameLTypes ltys
renameType t@(HsTyLit _) = pure t
renameType (HsWildCardTy wc) = pure (HsWildCardTy wc)
renameType (HsAppsTy _) = error "HsAppsTy: Only used before renaming"

renameLType :: (Eq (IdP name), SetName (IdP name))
            => LHsType name -> Rename (IdP name) (LHsType name)
renameLType = located renameType

renameLTypes :: (Eq (IdP name), SetName (IdP name))
             => [LHsType name] -> Rename (IdP name) [LHsType name]
renameLTypes = mapM renameLType

renameContext :: (Eq (IdP name), SetName (IdP name))
              => HsContext name -> Rename (IdP name) (HsContext name)
renameContext = renameLTypes

renameBinder :: (Eq (IdP name), SetName (IdP name))
             => HsTyVarBndr name -> Rename (IdP name) (HsTyVarBndr name)
renameBinder (UserTyVar lname) = UserTyVar <$> located renameName lname
renameBinder (KindedTyVar lname lkind) =
  KindedTyVar <$> located renameName lname <*> located renameType lkind

-- | Core renaming logic.
renameName :: (Eq name, SetName name) => name -> Rename name name
renameName name = do
    RenameEnv { .. } <- get
    case Map.lookup (getName name) rneCtx of
      Nothing
        | Just headTv <- Map.lookup (getNameRep name) rneHeadFVs
        , headTv /= getName name -> freshName name
      Just name' -> return name'
      _ -> return name

-- | Generate fresh occurrence name, put it into context and return.
freshName :: SetName name => name -> Rename name name
freshName name = do
    taken <- takenNames
    let name' = setInternalNameRep (findFreshName taken rep) name
    modify $ \rne -> rne
      { rneCtx = Map.insert (getName name) name' (rneCtx rne) }
    return name'
  where
    nname = getName name
    rep = getNameRep nname

takenNames :: NamedThing name => Rename name (Set NameRep)
takenNames = do
    RenameEnv { .. } <- get
    return $ Set.unions [headReps rneHeadFVs, rneSigFVs, ctxElems rneCtx]
  where
    headReps = Set.fromList . Map.keys
    ctxElems = Set.fromList . map getNameRep . Map.elems

findFreshName :: Set NameRep -> NameRep -> NameRep
findFreshName taken =
    fromJust . List.find isFresh . alternativeNames
  where
    isFresh = not . flip Set.member taken

alternativeNames :: NameRep -> [NameRep]
alternativeNames name =
    [ stringNameRep $ str ++ show i | i :: Int <- [0..] ]
  where
    str = nameRepString name

located :: Functor f => (a -> f b) -> Located a -> f (Located b)
located f (L loc e) = L loc <$> f e

tyVarName :: HsTyVarBndr name -> IdP name
tyVarName (UserTyVar name) = unLoc name
tyVarName (KindedTyVar (L _ name) _) = name


{-# LANGUAGE OverloadedStrings #-}

-- | Minimal JSON / RFC 7159 support
--
-- The API is heavily inspired by @aeson@'s API but puts emphasis on
-- simplicity rather than performance. The 'ToJSON' instances are
-- intended to have an encoding compatible with @aeson@'s encoding.
--
module Haddock.Utils.Json
    ( Value(..)
    , Object, object, Pair, (.=)
    , encodeToString
    , encodeToBuilder
    , ToJSON(toJSON)
    )
    where

import Data.Char
import Data.Int
import Data.String
import Data.Word
import Data.List
import Data.Monoid

import Data.ByteString.Builder (Builder)
import qualified Data.ByteString.Builder as BB

-- TODO: We may want to replace 'String' with 'Text' or 'ByteString'

-- | A JSON value represented as a Haskell value.
data Value = Object !Object
           | Array  [Value]
           | String  String
           | Number !Double
           | Bool   !Bool
           | Null
           deriving (Eq, Read, Show)

-- | A key\/value pair for an 'Object'
type Pair = (String, Value)

-- | A JSON \"object\" (key/value map).
type Object = [Pair]

infixr 8 .=

-- | A key-value pair for encoding a JSON object.
(.=) :: ToJSON v => String -> v -> Pair
k .= v  = (k, toJSON v)

-- | Create a 'Value' from a list of name\/value 'Pair's.
object :: [Pair] -> Value
object = Object

instance IsString Value where
  fromString = String

-- | A type that can be converted to JSON.
class ToJSON a where
  -- | Convert a Haskell value to a JSON-friendly intermediate type.
  toJSON :: a -> Value

instance ToJSON () where
  toJSON () = Array []

instance ToJSON Value where
  toJSON = id

instance ToJSON Bool where
  toJSON = Bool

instance ToJSON a => ToJSON [a] where
  toJSON = Array . map toJSON

instance ToJSON a => ToJSON (Maybe a) where
  toJSON Nothing  = Null
  toJSON (Just a) = toJSON a

instance (ToJSON a,ToJSON b) => ToJSON (a,b) where
  toJSON (a,b) = Array [toJSON a, toJSON b]

instance (ToJSON a,ToJSON b,ToJSON c) => ToJSON (a,b,c) where
  toJSON (a,b,c) = Array [toJSON a, toJSON b, toJSON c]

instance (ToJSON a,ToJSON b,ToJSON c, ToJSON d) => ToJSON (a,b,c,d) where
  toJSON (a,b,c,d) = Array [toJSON a, toJSON b, toJSON c, toJSON d]

instance ToJSON Float where
  toJSON = Number . realToFrac

instance ToJSON Double where
  toJSON = Number

instance ToJSON Int    where  toJSON = Number . realToFrac
instance ToJSON Int8   where  toJSON = Number . realToFrac
instance ToJSON Int16  where  toJSON = Number . realToFrac
instance ToJSON Int32  where  toJSON = Number . realToFrac

instance ToJSON Word   where  toJSON = Number . realToFrac
instance ToJSON Word8  where  toJSON = Number . realToFrac
instance ToJSON Word16 where  toJSON = Number . realToFrac
instance ToJSON Word32 where  toJSON = Number . realToFrac

-- | Possibly lossy due to conversion to 'Double'
instance ToJSON Int64  where  toJSON = Number . realToFrac

-- | Possibly lossy due to conversion to 'Double'
instance ToJSON Word64 where  toJSON = Number . realToFrac

-- | Possibly lossy due to conversion to 'Double'
instance ToJSON Integer where toJSON = Number . fromInteger

------------------------------------------------------------------------------
-- 'BB.Builder'-based encoding

-- | Serialise value as JSON/UTF8-encoded 'Builder'
encodeToBuilder :: ToJSON a => a -> Builder
encodeToBuilder = encodeValueBB . toJSON

encodeValueBB :: Value -> Builder
encodeValueBB jv = case jv of
  Bool True  -> "true"
  Bool False -> "false"
  Null       -> "null"
  Number n
    | isNaN n || isInfinite n   -> encodeValueBB Null
    | Just i <- doubleToInt64 n -> BB.int64Dec i
    | otherwise                 -> BB.doubleDec n
  Array a  -> encodeArrayBB a
  String s -> encodeStringBB s
  Object o -> encodeObjectBB o

encodeArrayBB :: [Value] -> Builder
encodeArrayBB [] = "[]"
encodeArrayBB jvs = BB.char8 '[' <> go jvs <> BB.char8 ']'
  where
    go = Data.Monoid.mconcat . intersperse (BB.char8 ',') . map encodeValueBB

encodeObjectBB :: Object -> Builder
encodeObjectBB [] = "{}"
encodeObjectBB jvs = BB.char8 '{' <> go jvs <> BB.char8 '}'
  where
    go = Data.Monoid.mconcat . intersperse (BB.char8 ',') . map encPair
    encPair (l,x) = encodeStringBB l <> BB.char8 ':' <> encodeValueBB x

encodeStringBB :: String -> Builder
encodeStringBB str = BB.char8 '"' <> go str <> BB.char8 '"'
  where
    go = BB.stringUtf8 . escapeString

------------------------------------------------------------------------------
-- 'String'-based encoding

-- | Serialise value as JSON-encoded Unicode 'String'
encodeToString :: ToJSON a => a -> String
encodeToString jv = encodeValue (toJSON jv) []

encodeValue :: Value -> ShowS
encodeValue jv = case jv of
  Bool b   -> showString (if b then "true" else "false")
  Null     -> showString "null"
  Number n
    | isNaN n || isInfinite n    -> encodeValue Null
    | Just i <- doubleToInt64 n -> shows i
    | otherwise                 -> shows n
  Array a -> encodeArray a
  String s -> encodeString s
  Object o -> encodeObject o

encodeArray :: [Value] -> ShowS
encodeArray [] = showString "[]"
encodeArray jvs = ('[':) . go jvs . (']':)
  where
    go []     = id
    go [x]    = encodeValue x
    go (x:xs) = encodeValue x . (',':) . go xs

encodeObject :: Object -> ShowS
encodeObject [] = showString "{}"
encodeObject jvs = ('{':) . go jvs . ('}':)
  where
    go []          = id
    go [(l,x)]     = encodeString l . (':':) . encodeValue x
    go ((l,x):lxs) = encodeString l . (':':) . encodeValue x . (',':) . go lxs

encodeString :: String -> ShowS
encodeString str = ('"':) . showString (escapeString str) . ('"':)

------------------------------------------------------------------------------
-- helpers

-- | Try to convert 'Double' into 'Int64', return 'Nothing' if not
-- representable loss-free as integral 'Int64' value.
doubleToInt64 :: Double -> Maybe Int64
doubleToInt64 x
  | fromInteger x' == x
  , x' <= toInteger (maxBound :: Int64)
  , x' >= toInteger (minBound :: Int64)
    = Just (fromIntegral x')
  | otherwise = Nothing
  where
    x' = round x

-- | Minimally escape a 'String' in accordance with RFC 7159, "7. Strings"
escapeString :: String -> String
escapeString s
  | not (any needsEscape s) = s
  | otherwise               = escape s
  where
    escape [] = []
    escape (x:xs) = case x of
      '\\' -> '\\':'\\':escape xs
      '"'  -> '\\':'"':escape xs
      '\b' -> '\\':'b':escape xs
      '\f' -> '\\':'f':escape xs
      '\n' -> '\\':'n':escape xs
      '\r' -> '\\':'r':escape xs
      '\t' -> '\\':'t':escape xs
      c | ord c < 0x10 -> '\\':'u':'0':'0':'0':intToDigit (ord c):escape xs
        | ord c < 0x20 -> '\\':'u':'0':'0':'1':intToDigit (ord c - 0x10):escape xs
        | otherwise    -> c : escape xs

    -- unescaped = %x20-21 / %x23-5B / %x5D-10FFFF
    needsEscape c = ord c < 0x20 || c `elem` ['\\','"']


{-# OPTIONS_GHC -F -pgmF hspec-discover #-}


module Haddock.Backends.Hyperlinker.ParserSpec (main, spec) where

import Test.Hspec
import Test.QuickCheck

import qualified GHC
import Control.Monad.IO.Class

import Haddock (getGhcDirs)
import Haddock.Backends.Hyperlinker.Parser
import Haddock.Backends.Hyperlinker.Types

withDynFlags :: (GHC.DynFlags -> IO ()) -> IO ()
withDynFlags cont = do
  libDir <- fmap snd (getGhcDirs [])
  GHC.runGhc (Just libDir) $ do
    dflags <- GHC.getSessionDynFlags
    liftIO $ cont dflags

main :: IO ()
main = hspec spec

spec :: Spec
spec = describe "parse" parseSpec

-- | Defined for its instance of 'Arbitrary'. Represents strings that, when
-- considered as GHC source, won't be rewritten.
newtype NoGhcRewrite = NoGhcRewrite String deriving (Show, Eq)

-- | Filter out strings where GHC would replace/remove some characters during
-- lexing.
noGhcRewrite :: String -> Bool
noGhcRewrite ('\t':_) = False        -- GHC replaces tabs with 8 spaces
noGhcRewrite ('\r':_) = False
noGhcRewrite ('\f':_) = False
noGhcRewrite ('\v':_) = False
noGhcRewrite (' ':'\n':_) = False    -- GHC strips whitespace on empty lines
noGhcRewrite (_:s) = noGhcRewrite s
noGhcRewrite "" = True

instance Arbitrary NoGhcRewrite where
  arbitrary = fmap NoGhcRewrite (arbitrary `suchThat` noGhcRewrite)
  shrink (NoGhcRewrite src) = [ NoGhcRewrite shrunk
                              | shrunk <- shrink src
                              , noGhcRewrite shrunk
                              ]

parseSpec :: Spec
parseSpec = around withDynFlags $ do

    it "is total" $ \dflags ->
        property $ \src -> length (parse dflags "" src) `shouldSatisfy` (>= 0)

    it "retains file layout" $ \dflags ->
        property $ \(NoGhcRewrite src) -> concatMap tkValue (parse dflags "" src) == src

    context "when parsing single-line comments" $ do

        it "should ignore content until the end of line" $ \dflags ->
            shouldParseTo
                "-- some very simple comment\nidentifier"
                [TkComment, TkSpace, TkIdentifier]
                dflags

        it "should allow endline escaping" $ \dflags ->
            shouldParseTo
                "#define first line\\\nsecond line\\\nand another one"
                [TkCpp]
                dflags

    context "when parsing multi-line comments" $ do

        it "should support nested comments" $ \dflags ->
            shouldParseTo
                "{- comment {- nested -} still comment -} {- next comment -}"
                [TkComment, TkSpace, TkComment]
                dflags

        it "should distinguish compiler pragma" $ \dflags ->
            shouldParseTo
                "{- comment -}{-# LANGUAGE GADTs #-}{- comment -}"
                [TkComment, TkPragma, TkComment]
                dflags

    it "should recognize preprocessor directives" $ \dflags -> do
            shouldParseTo
                "\n#define foo bar"
                [TkSpace, TkCpp]
                dflags
            shouldParseTo
                "x # y"
                [TkIdentifier, TkSpace, TkOperator, TkSpace,TkIdentifier]
                dflags

    it "should distinguish basic language constructs" $ \dflags -> do

        shouldParseTo
            "(* 2) <$> (\"abc\", foo)"
            [ TkSpecial, TkOperator, TkSpace, TkNumber, TkSpecial
            , TkSpace, TkOperator, TkSpace
            , TkSpecial, TkString, TkSpecial, TkSpace, TkIdentifier, TkSpecial
            ]
            dflags

        shouldParseTo
            "let foo' = foo in foo' + foo'"
            [ TkKeyword, TkSpace, TkIdentifier
            , TkSpace, TkGlyph, TkSpace
            , TkIdentifier, TkSpace, TkKeyword, TkSpace
            , TkIdentifier, TkSpace, TkOperator, TkSpace, TkIdentifier
            ]
            dflags

        shouldParseTo
            "square x = y^2 where y = x"
            [ TkIdentifier, TkSpace, TkIdentifier
            , TkSpace, TkGlyph, TkSpace
            , TkIdentifier, TkOperator, TkNumber
            , TkSpace, TkKeyword, TkSpace
            , TkIdentifier, TkSpace, TkGlyph, TkSpace, TkIdentifier
            ]
            dflags

    it "should parse do-notation syntax" $ \dflags -> do
        shouldParseTo
            "do { foo <- getLine; putStrLn foo }"
            [ TkKeyword, TkSpace, TkSpecial, TkSpace
            , TkIdentifier, TkSpace, TkGlyph, TkSpace
            , TkIdentifier, TkSpecial, TkSpace
            , TkIdentifier, TkSpace, TkIdentifier, TkSpace, TkSpecial
            ]
            dflags

        shouldParseTo
            (unlines
                [ "do"
                , "    foo <- getLine"
                , "    putStrLn foo"
                ])
            [ TkKeyword, TkSpace, TkIdentifier
            , TkSpace, TkGlyph, TkSpace, TkIdentifier, TkSpace
            , TkIdentifier, TkSpace, TkIdentifier, TkSpace
            ]
            dflags
  where
    shouldParseTo :: String -> [TokenType] -> GHC.DynFlags -> Expectation
    shouldParseTo str tokens dflags = map tkType (parse dflags "" str) `shouldBe` tokens


import Distribution.Simple
main = defaultMain


{-# LANGUAGE DeriveGeneric, StandaloneDeriving #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Main (main) where

import Control.Applicative ((<|>))
import Control.Exception (IOException, catch)
import Control.Monad (when)
import Data.Foldable (traverse_)
import Data.List (foldl')
import Data.Traversable (for)
import GHC.Generics (Generic)
import Prelude ()
import Prelude.Compat
import System.Directory (getDirectoryContents)
import System.Exit (exitFailure)
import System.FilePath
import System.IO

import Data.TreeDiff
import Data.TreeDiff.Golden

import qualified Options.Applicative as O

import           Documentation.Haddock.Types
import qualified Documentation.Haddock.Parser as Parse

type Doc id = DocH () id

data Fixture = Fixture
    { fixtureName   :: FilePath
    , fixtureOutput :: FilePath
    }
  deriving Show

data  Result = Result
    { _resultSuccess :: !Int
    , _resultTotal   :: !Int
    }
  deriving Show

combineResults :: Result -> Result -> Result
combineResults (Result s t) (Result s' t') = Result (s + s') (t + t')

readFixtures :: IO [Fixture]
readFixtures = do
    let dir = "fixtures/examples"
    files <- getDirectoryContents dir
    let inputs = filter (\fp -> takeExtension fp == ".input") files
    return $ flip map inputs $ \fp -> Fixture
        { fixtureName = dir </> fp
        , fixtureOutput = dir </> fp -<.> "parsed"
        }

goldenFixture
    :: String
    -> IO Expr
    -> IO Expr
    -> (Expr -> Expr -> IO (Maybe String))
    -> (Expr -> IO ())
    -> IO Result
goldenFixture name expect actual cmp wrt = do
    putStrLn $ "running " ++ name
    a <- actual
    e <- expect `catch` handler a
    mres <- cmp e a
    case mres of
        Nothing  -> return (Result 1 1)
        Just str -> do
            putStrLn str
            return (Result 0 1)
  where
    handler :: Expr -> IOException -> IO Expr
    handler a exc = do
        putStrLn $ "Caught " ++ show exc
        putStrLn "Accepting the test"
        wrt a
        return a

runFixtures :: [Fixture] -> IO ()
runFixtures fixtures = do
    results <- for fixtures $ \(Fixture i o) -> do
        let name = takeBaseName i
        let readDoc = do
                input <- readFile i
                return (parseString input)
        ediffGolden goldenFixture name o readDoc
    case foldl' combineResults (Result 0 0) results of
        Result s t -> do
            putStrLn $ "Fixtures: success " ++ show s ++ "; total " ++ show t
            when (s /= t) exitFailure

listFixtures :: [Fixture] -> IO ()
listFixtures = traverse_ $ \(Fixture i _) -> do
    let name = takeBaseName i
    putStrLn name

acceptFixtures :: [Fixture] -> IO ()
acceptFixtures = traverse_ $ \(Fixture i o) -> do
    input <- readFile i
    let doc = parseString input
    let actual = show (prettyExpr $ toExpr doc) ++ "\n"
    writeFile o actual

parseString :: String -> Doc String
parseString = Parse.toRegular . _doc . Parse.parseParas Nothing

data Cmd = CmdRun | CmdAccept | CmdList

main :: IO ()
main = do
    hSetBuffering stdout NoBuffering -- For interleaved output when debugging
    runCmd =<< O.execParser opts
  where
    opts = O.info (O.helper <*> cmdParser) O.fullDesc

    cmdParser :: O.Parser Cmd
    cmdParser = cmdRun <|> cmdAccept <|> cmdList <|> pure CmdRun

    cmdRun = O.flag' CmdRun $ mconcat
        [ O.long "run"
        , O.help "Run parser fixtures"
        ]

    cmdAccept = O.flag' CmdAccept $ mconcat
        [ O.long "accept"
        , O.help "Run & accept parser fixtures"
        ]

    cmdList = O.flag' CmdList $ mconcat
        [ O.long "list"
        , O.help "List fixtures"
        ]

runCmd :: Cmd -> IO ()
runCmd CmdRun    = readFixtures >>= runFixtures
runCmd CmdList   = readFixtures >>= listFixtures
runCmd CmdAccept = readFixtures >>= acceptFixtures

-------------------------------------------------------------------------------
-- Orphans
-------------------------------------------------------------------------------

deriving instance Generic (DocH mod id)
instance (ToExpr mod, ToExpr id)  => ToExpr (DocH mod id)

deriving instance Generic (Header id)
instance ToExpr id => ToExpr (Header id)

deriving instance Generic Hyperlink
instance ToExpr Hyperlink

deriving instance Generic Picture
instance ToExpr Picture

deriving instance Generic Example
instance ToExpr Example

deriving instance Generic (Table id)
instance ToExpr id => ToExpr (Table id)

deriving instance Generic (TableRow id)
instance ToExpr id => ToExpr (TableRow id)

deriving instance Generic (TableCell id)
instance ToExpr id => ToExpr (TableCell id)


{-# OPTIONS_GHC -fno-warn-orphans #-}
module Documentation.Haddock.Doc (docParagraph, docAppend,
                                  docConcat, metaDocConcat,
                                  metaDocAppend, emptyMetaDoc,
                                  metaAppend, metaConcat) where

import Control.Applicative ((<|>), empty)
import Documentation.Haddock.Types
import Data.Char (isSpace)

docConcat :: [DocH mod id] -> DocH mod id
docConcat = foldr docAppend DocEmpty

-- | Concat using 'metaAppend'.
metaConcat :: [Meta] -> Meta
metaConcat = foldr metaAppend emptyMeta

-- | Like 'docConcat' but also joins the 'Meta' info.
metaDocConcat :: [MetaDoc mod id] -> MetaDoc mod id
metaDocConcat = foldr metaDocAppend emptyMetaDoc

-- | We do something perhaps unexpected here and join the meta info
-- in â€˜reverseâ€™: this results in the metadata from the â€˜latestâ€™
-- paragraphs taking precedence.
metaDocAppend :: MetaDoc mod id -> MetaDoc mod id -> MetaDoc mod id
metaDocAppend (MetaDoc { _meta = m, _doc = d })
              (MetaDoc { _meta = m', _doc = d' }) =
  MetaDoc { _meta = m' `metaAppend` m, _doc = d `docAppend` d' }

-- | This is not a monoidal append, it uses '<|>' for the '_version' and
-- '_package'.
metaAppend :: Meta -> Meta -> Meta
metaAppend (Meta v1 p1) (Meta v2 p2) = Meta (v1 <|> v2) (p1 <|> p2)

emptyMetaDoc :: MetaDoc mod id
emptyMetaDoc = MetaDoc { _meta = emptyMeta, _doc = DocEmpty }

emptyMeta :: Meta
emptyMeta = Meta empty empty

docAppend :: DocH mod id -> DocH mod id -> DocH mod id
docAppend (DocDefList ds1) (DocDefList ds2) = DocDefList (ds1++ds2)
docAppend (DocDefList ds1) (DocAppend (DocDefList ds2) d) = DocAppend (DocDefList (ds1++ds2)) d
docAppend (DocOrderedList ds1) (DocOrderedList ds2) = DocOrderedList (ds1 ++ ds2)
docAppend (DocOrderedList ds1) (DocAppend (DocOrderedList ds2) d) = DocAppend (DocOrderedList (ds1++ds2)) d
docAppend (DocUnorderedList ds1) (DocUnorderedList ds2) = DocUnorderedList (ds1 ++ ds2)
docAppend (DocUnorderedList ds1) (DocAppend (DocUnorderedList ds2) d) = DocAppend (DocUnorderedList (ds1++ds2)) d
docAppend DocEmpty d = d
docAppend d DocEmpty = d
docAppend (DocString s1) (DocString s2) = DocString (s1 ++ s2)
docAppend (DocAppend d (DocString s1)) (DocString s2) = DocAppend d (DocString (s1 ++ s2))
docAppend (DocString s1) (DocAppend (DocString s2) d) = DocAppend (DocString (s1 ++ s2)) d
docAppend d1 d2 = DocAppend d1 d2

-- again to make parsing easier - we spot a paragraph whose only item
-- is a DocMonospaced and make it into a DocCodeBlock
docParagraph :: DocH mod id -> DocH mod id
docParagraph (DocMonospaced p)
  = DocCodeBlock (docCodeBlock p)
docParagraph (DocAppend (DocString s1) (DocMonospaced p))
  | all isSpace s1
  = DocCodeBlock (docCodeBlock p)
docParagraph (DocAppend (DocString s1)
    (DocAppend (DocMonospaced p) (DocString s2)))
  | all isSpace s1 && all isSpace s2
  = DocCodeBlock (docCodeBlock p)
docParagraph (DocAppend (DocMonospaced p) (DocString s2))
  | all isSpace s2
  = DocCodeBlock (docCodeBlock p)
docParagraph p
  = DocParagraph p

-- Drop trailing whitespace from @..@ code blocks.  Otherwise this:
--
--    -- @
--    -- foo
--    -- @
--
-- turns into (DocCodeBlock "\nfoo\n ") which when rendered in HTML
-- gives an extra vertical space after the code block.  The single space
-- on the final line seems to trigger the extra vertical space.
--
docCodeBlock :: DocH mod id -> DocH mod id
docCodeBlock (DocString s)
  = DocString (reverse $ dropWhile (`elem` " \t") $ reverse s)
docCodeBlock (DocAppend l r)
  = DocAppend l (docCodeBlock r)
docCodeBlock d = d


-- | @since 1.4.5
module Documentation.Haddock.Markup (
    markup
  , idMarkup
  ) where

import Documentation.Haddock.Types

markup :: DocMarkupH mod id a -> DocH mod id -> a
markup m DocEmpty                    = markupEmpty m
markup m (DocAppend d1 d2)           = markupAppend m (markup m d1) (markup m d2)
markup m (DocString s)               = markupString m s
markup m (DocParagraph d)            = markupParagraph m (markup m d)
markup m (DocIdentifier x)           = markupIdentifier m x
markup m (DocIdentifierUnchecked x)  = markupIdentifierUnchecked m x
markup m (DocModule mod0)            = markupModule m mod0
markup m (DocWarning d)              = markupWarning m (markup m d)
markup m (DocEmphasis d)             = markupEmphasis m (markup m d)
markup m (DocBold d)                 = markupBold m (markup m d)
markup m (DocMonospaced d)           = markupMonospaced m (markup m d)
markup m (DocUnorderedList ds)       = markupUnorderedList m (map (markup m) ds)
markup m (DocOrderedList ds)         = markupOrderedList m (map (markup m) ds)
markup m (DocDefList ds)             = markupDefList m (map (markupPair m) ds)
markup m (DocCodeBlock d)            = markupCodeBlock m (markup m d)
markup m (DocHyperlink l)            = markupHyperlink m l
markup m (DocAName ref)              = markupAName m ref
markup m (DocPic img)                = markupPic m img
markup m (DocMathInline mathjax)     = markupMathInline m mathjax
markup m (DocMathDisplay mathjax)    = markupMathDisplay m mathjax
markup m (DocProperty p)             = markupProperty m p
markup m (DocExamples e)             = markupExample m e
markup m (DocHeader (Header l t))    = markupHeader m (Header l (markup m t))
markup m (DocTable (Table h b))      = markupTable m (Table (map (fmap (markup m)) h) (map (fmap (markup m)) b))

markupPair :: DocMarkupH mod id a -> (DocH mod id, DocH mod id) -> (a, a)
markupPair m (a,b) = (markup m a, markup m b)

-- | The identity markup
idMarkup :: DocMarkupH mod id (DocH mod id)
idMarkup = Markup {
  markupEmpty                = DocEmpty,
  markupString               = DocString,
  markupParagraph            = DocParagraph,
  markupAppend               = DocAppend,
  markupIdentifier           = DocIdentifier,
  markupIdentifierUnchecked  = DocIdentifierUnchecked,
  markupModule               = DocModule,
  markupWarning              = DocWarning,
  markupEmphasis             = DocEmphasis,
  markupBold                 = DocBold,
  markupMonospaced           = DocMonospaced,
  markupUnorderedList        = DocUnorderedList,
  markupOrderedList          = DocOrderedList,
  markupDefList              = DocDefList,
  markupCodeBlock            = DocCodeBlock,
  markupHyperlink            = DocHyperlink,
  markupAName                = DocAName,
  markupPic                  = DocPic,
  markupMathInline           = DocMathInline,
  markupMathDisplay          = DocMathDisplay,
  markupProperty             = DocProperty,
  markupExample              = DocExamples,
  markupHeader               = DocHeader,
  markupTable                = DocTable
  }


{-# LANGUAGE CPP               #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ViewPatterns      #-}
-- |
-- Module      :  Documentation.Haddock.Parser
-- Copyright   :  (c) Mateusz Kowalczyk 2013-2014,
--                    Simon Hengel      2013
-- License     :  BSD-like
--
-- Maintainer  :  haddock@projects.haskell.org
-- Stability   :  experimental
-- Portability :  portable
--
-- Parser used for Haddock comments. For external users of this
-- library, the most commonly used combination of functions is going
-- to be
--
-- @'toRegular' . '_doc' . 'parseParas'@
module Documentation.Haddock.Parser (
  parseString,
  parseParas,
  overIdentifier,
  toRegular,
  Identifier
) where

import           Control.Applicative
import           Control.Arrow (first)
import           Control.Monad
import           Data.Char (chr, isUpper, isAlpha, isAlphaNum, isSpace)
import           Data.List (intercalate, unfoldr, elemIndex, notElem)
import           Data.Maybe (fromMaybe, mapMaybe)
import           Data.Monoid
import qualified Data.Set as Set
import           Documentation.Haddock.Doc
import           Documentation.Haddock.Parser.Monad
import           Documentation.Haddock.Parser.Util
import           Documentation.Haddock.Types
import           Prelude hiding (takeWhile)
import qualified Prelude as P

import qualified Text.Parsec as Parsec
import           Text.Parsec (try)

import qualified Data.Text as T
import           Data.Text (Text)

#if MIN_VERSION_base(4,9,0)
import           Text.Read.Lex                      (isSymbolChar)
#else
import           Data.Char                          (GeneralCategory (..),
                                                     generalCategory)
#endif

-- $setup
-- >>> :set -XOverloadedStrings

#if !MIN_VERSION_base(4,9,0)
-- inlined from base-4.10.0.0
isSymbolChar :: Char -> Bool
isSymbolChar c = not (isPuncChar c) && case generalCategory c of
    MathSymbol           -> True
    CurrencySymbol       -> True
    ModifierSymbol       -> True
    OtherSymbol          -> True
    DashPunctuation      -> True
    OtherPunctuation     -> c `notElem` ("'\"" :: String)
    ConnectorPunctuation -> c /= '_'
    _                    -> False
  where
    -- | The @special@ character class as defined in the Haskell Report.
    isPuncChar :: Char -> Bool
    isPuncChar = (`elem` (",;()[]{}`" :: String))
#endif

-- | Identifier string surrounded with opening and closing quotes/backticks.
type Identifier = (Char, String, Char)

-- | Drops the quotes/backticks around all identifiers, as if they
-- were valid but still 'String's.
toRegular :: DocH mod Identifier -> DocH mod String
toRegular = fmap (\(_, x, _) -> x)

-- | Maps over 'DocIdentifier's over 'String' with potentially failing
-- conversion using user-supplied function. If the conversion fails,
-- the identifier is deemed to not be valid and is treated as a
-- regular string.
overIdentifier :: (String -> Maybe a)
               -> DocH mod Identifier
               -> DocH mod a
overIdentifier f d = g d
  where
    g (DocIdentifier (o, x, e)) = case f x of
      Nothing -> DocString $ o : x ++ [e]
      Just x' -> DocIdentifier x'
    g DocEmpty = DocEmpty
    g (DocAppend x x') = DocAppend (g x) (g x')
    g (DocString x) = DocString x
    g (DocParagraph x) = DocParagraph $ g x
    g (DocIdentifierUnchecked x) = DocIdentifierUnchecked x
    g (DocModule x) = DocModule x
    g (DocWarning x) = DocWarning $ g x
    g (DocEmphasis x) = DocEmphasis $ g x
    g (DocMonospaced x) = DocMonospaced $ g x
    g (DocBold x) = DocBold $ g x
    g (DocUnorderedList x) = DocUnorderedList $ fmap g x
    g (DocOrderedList x) = DocOrderedList $ fmap g x
    g (DocDefList x) = DocDefList $ fmap (\(y, z) -> (g y, g z)) x
    g (DocCodeBlock x) = DocCodeBlock $ g x
    g (DocHyperlink x) = DocHyperlink x
    g (DocPic x) = DocPic x
    g (DocMathInline x) = DocMathInline x
    g (DocMathDisplay x) = DocMathDisplay x
    g (DocAName x) = DocAName x
    g (DocProperty x) = DocProperty x
    g (DocExamples x) = DocExamples x
    g (DocHeader (Header l x)) = DocHeader . Header l $ g x
    g (DocTable (Table h b)) = DocTable (Table (map (fmap g) h) (map (fmap g) b))

choice' :: [Parser a] -> Parser a
choice' [] = empty
choice' [p] = p
choice' (p : ps) = try p <|> choice' ps

parse :: Parser a -> Text -> (ParserState, a)
parse p = either err id . parseOnly (p <* Parsec.eof)
  where
    err = error . ("Haddock.Parser.parse: " ++)

-- | Main entry point to the parser. Appends the newline character
-- to the input string.
parseParas :: Maybe Package
           -> String -- ^ String to parse
           -> MetaDoc mod Identifier
parseParas pkg input = case parseParasState input of
  (state, a) -> MetaDoc { _meta = Meta { _version = parserStateSince state
                                       , _package = pkg
                                       }
                        , _doc = a
                        }

parseParasState :: String -> (ParserState, DocH mod Identifier)
parseParasState = parse (emptyLines *> p) . T.pack . (++ "\n") . filter (/= '\r')
  where
    p :: Parser (DocH mod Identifier)
    p = docConcat <$> many (paragraph <* emptyLines)

    emptyLines :: Parser ()
    emptyLines = void $ many (try (skipHorizontalSpace *> "\n"))

parseParagraphs :: String -> Parser (DocH mod Identifier)
parseParagraphs input = case parseParasState input of
  (state, a) -> Parsec.putState state *> pure a

-- | Variant of 'parseText' for 'String' instead of 'Text'
parseString :: String -> DocH mod Identifier
parseString = parseText . T.pack

-- | Parse a text paragraph. Actually just a wrapper over 'parseParagraph' which
-- drops leading whitespace.
parseText :: Text -> DocH mod Identifier
parseText = parseParagraph . T.dropWhile isSpace . T.filter (/= '\r')

parseParagraph :: Text -> DocH mod Identifier
parseParagraph = snd . parse p
  where
    p :: Parser (DocH mod Identifier)
    p = docConcat <$> many (choice' [ monospace
                                    , anchor
                                    , identifier
                                    , moduleName
                                    , picture
                                    , mathDisplay
                                    , mathInline
                                    , markdownImage
                                    , hyperlink
                                    , bold
                                    , emphasis
                                    , encodedChar
                                    , string'
                                    , skipSpecialChar
                                    ])

-- | Parses and processes
-- <https://en.wikipedia.org/wiki/Numeric_character_reference Numeric character references>
--
-- >>> parseString "A"
-- DocString "A"
encodedChar :: Parser (DocH mod a)
encodedChar = "&#" *> c <* ";"
  where
    c = DocString . return . chr <$> num
    num = hex <|> decimal
    hex = ("x" <|> "X") *> hexadecimal

-- | List of characters that we use to delimit any special markup.
-- Once we have checked for any of these and tried to parse the
-- relevant markup, we can assume they are used as regular text.
specialChar :: [Char]
specialChar = "_/<@\"&'`# "

-- | Plain, regular parser for text. Called as one of the last parsers
-- to ensure that we have already given a chance to more meaningful parsers
-- before capturing their characers.
string' :: Parser (DocH mod a)
string' = DocString . unescape . T.unpack <$> takeWhile1_ (`notElem` specialChar)
  where
    unescape "" = ""
    unescape ('\\':x:xs) = x : unescape xs
    unescape (x:xs) = x : unescape xs

-- | Skips a single special character and treats it as a plain string.
-- This is done to skip over any special characters belonging to other
-- elements but which were not deemed meaningful at their positions.
skipSpecialChar :: Parser (DocH mod a)
skipSpecialChar = DocString . return <$> Parsec.oneOf specialChar

-- | Emphasis parser.
--
-- >>> parseString "/Hello world/"
-- DocEmphasis (DocString "Hello world")
emphasis :: Parser (DocH mod Identifier)
emphasis = DocEmphasis . parseParagraph <$>
  disallowNewline ("/" *> takeWhile1_ (/= '/') <* "/")

-- | Bold parser.
--
-- >>> parseString "__Hello world__"
-- DocBold (DocString "Hello world")
bold :: Parser (DocH mod Identifier)
bold = DocBold . parseParagraph <$> disallowNewline ("__" *> takeUntil "__")

disallowNewline :: Parser Text -> Parser Text
disallowNewline = mfilter (T.all (/= '\n'))

-- | Like `takeWhile`, but unconditionally take escaped characters.
takeWhile_ :: (Char -> Bool) -> Parser Text
takeWhile_ p = scan p_ False
  where
    p_ escaped c
      | escaped = Just False
      | not $ p c = Nothing
      | otherwise = Just (c == '\\')

-- | Like 'takeWhile1', but unconditionally take escaped characters.
takeWhile1_ :: (Char -> Bool) -> Parser Text
takeWhile1_ = mfilter (not . T.null) . takeWhile_

-- | Text anchors to allow for jumping around the generated documentation.
--
-- >>> parseString "#Hello world#"
-- DocAName "Hello world"
anchor :: Parser (DocH mod a)
anchor = DocAName . T.unpack <$>
         disallowNewline ("#" *> takeWhile1_ (/= '#') <* "#")

-- | Monospaced strings.
--
-- >>> parseString "@cruel@"
-- DocMonospaced (DocString "cruel")
monospace :: Parser (DocH mod Identifier)
monospace = DocMonospaced . parseParagraph
            <$> ("@" *> takeWhile1_ (/= '@') <* "@")

-- | Module names.
--
-- Note that we allow '#' and '\' to support anchors (old style anchors are of
-- the form "SomeModule\#anchor").
moduleName :: Parser (DocH mod a)
moduleName = DocModule <$> ("\"" *> modid <* "\"")
  where
    modid = intercalate "." <$> conid `Parsec.sepBy1` "."
    conid = (:)
      <$> Parsec.satisfy (\c -> isAlpha c && isUpper c)
      <*> many (conChar <|> Parsec.oneOf "\\#")

    conChar = Parsec.alphaNum <|> Parsec.char '_'

-- | Picture parser, surrounded by \<\< and \>\>. It's possible to specify
-- a title for the picture.
--
-- >>> parseString "<<hello.png>>"
-- DocPic (Picture {pictureUri = "hello.png", pictureTitle = Nothing})
-- >>> parseString "<<hello.png world>>"
-- DocPic (Picture {pictureUri = "hello.png", pictureTitle = Just "world"})
picture :: Parser (DocH mod a)
picture = DocPic . makeLabeled Picture
          <$> disallowNewline ("<<" *> takeUntil ">>")

-- | Inline math parser, surrounded by \\( and \\).
--
-- >>> parseString "\\(\\int_{-\\infty}^{\\infty} e^{-x^2/2} = \\sqrt{2\\pi}\\)"
-- DocMathInline "\\int_{-\\infty}^{\\infty} e^{-x^2/2} = \\sqrt{2\\pi}"
mathInline :: Parser (DocH mod a)
mathInline = DocMathInline . T.unpack
             <$> disallowNewline  ("\\(" *> takeUntil "\\)")

-- | Display math parser, surrounded by \\[ and \\].
--
-- >>> parseString "\\[\\int_{-\\infty}^{\\infty} e^{-x^2/2} = \\sqrt{2\\pi}\\]"
-- DocMathDisplay "\\int_{-\\infty}^{\\infty} e^{-x^2/2} = \\sqrt{2\\pi}"
mathDisplay :: Parser (DocH mod a)
mathDisplay = DocMathDisplay . T.unpack
              <$> ("\\[" *> takeUntil "\\]")

markdownImage :: Parser (DocH mod a)
markdownImage = fromHyperlink <$> ("!" *> linkParser)
  where
    fromHyperlink (Hyperlink url label) = DocPic (Picture url label)

-- | Paragraph parser, called by 'parseParas'.
paragraph :: Parser (DocH mod Identifier)
paragraph = choice' [ examples
                    , table
                    , do indent <- takeIndent
                         choice' [ since
                                 , unorderedList indent
                                 , orderedList indent
                                 , birdtracks
                                 , codeblock
                                 , property
                                 , header
                                 , textParagraphThatStartsWithMarkdownLink
                                 , definitionList indent
                                 , docParagraph <$> textParagraph
                                 ]
                    ]

-- | Provides support for grid tables.
--
-- Tables are composed by an optional header and body. The header is composed by
-- a single row. The body is composed by a non-empty list of rows.
--
-- Example table with header:
--
-- > +----------+----------+
-- > | /32bit/  |   64bit  |
-- > +==========+==========+
-- > |  0x0000  | @0x0000@ |
-- > +----------+----------+
--
-- Algorithms loosely follows ideas in
-- http://docutils.sourceforge.net/docutils/parsers/rst/tableparser.py
--
table :: Parser (DocH mod Identifier)
table = do
    -- first we parse the first row, which determines the width of the table
    firstRow <- parseFirstRow
    let len = T.length firstRow

    -- then we parse all consequtive rows starting and ending with + or |,
    -- of the width `len`.
    restRows <- many (try (parseRestRows len))

    -- Now we gathered the table block, the next step is to split the block
    -- into cells.
    DocTable <$> tableStepTwo len (firstRow : restRows)
  where
    parseFirstRow :: Parser Text
    parseFirstRow = do
        skipHorizontalSpace
        -- upper-left corner is +
        c <- Parsec.char '+'
        cs <- some (Parsec.char '-' <|> Parsec.char '+')

        -- upper right corner is + too
        guard (last cs == '+')

        -- trailing space
        skipHorizontalSpace
        _ <- Parsec.newline

        return (T.cons c $ T.pack cs)

    parseRestRows :: Int -> Parser Text
    parseRestRows l = do
        skipHorizontalSpace

        c <- Parsec.char '|' <|> Parsec.char '+'
        bs <- scan predicate (l - 2)
        c2 <- Parsec.char '|' <|> Parsec.char '+'

        -- trailing space
        skipHorizontalSpace
        _ <- Parsec.newline

        return (T.cons c (T.snoc bs c2))
      where
        predicate n c
            | n <= 0    = Nothing
            | c == '\n' = Nothing
            | otherwise = Just (n - 1)

-- Second step searchs for row of '+' and '=' characters, records it's index
-- and changes to '=' to '-'.
tableStepTwo
    :: Int              -- ^ width
    -> [Text]           -- ^ rows
    -> Parser (Table (DocH mod Identifier))
tableStepTwo width = go 0 [] where
    go _ left [] = tableStepThree width (reverse left) Nothing
    go n left (r : rs)
        | T.all (`elem` ['+', '=']) r =
            tableStepThree width (reverse left ++ r' : rs) (Just n)
        | otherwise =
            go (n + 1) (r :  left) rs
      where
        r' = T.map (\c -> if c == '=' then '-' else c) r

-- Third step recognises cells in the table area, returning a list of TC, cells.
tableStepThree
    :: Int              -- ^ width
    -> [Text]           -- ^ rows
    -> Maybe Int        -- ^ index of header separator
    -> Parser (Table (DocH mod Identifier))
tableStepThree width rs hdrIndex = do
    cells <- loop (Set.singleton (0, 0))
    tableStepFour rs hdrIndex cells
  where
    height = length rs

    loop :: Set.Set (Int, Int) -> Parser [TC]
    loop queue = case Set.minView queue of
        Nothing -> return []
        Just ((y, x), queue')
            | y + 1 >= height || x + 1 >= width -> loop queue'
            | otherwise -> case scanRight x y of
                Nothing -> loop queue'
                Just (x2, y2) -> do
                    let tc = TC y x y2 x2
                    fmap (tc :) $ loop $ queue' `Set.union` Set.fromList
                        [(y, x2), (y2, x), (y2, x2)]

    -- scan right looking for +, then try scan down
    --
    -- do we need to record + saw on the way left and down?
    scanRight :: Int -> Int -> Maybe (Int, Int)
    scanRight x y = go (x + 1) where
        bs = rs !! y
        go x' | x' >= width          = fail "overflow right "
              | T.index bs x' == '+' = scanDown x y x' <|> go (x' + 1)
              | T.index bs x' == '-' = go (x' + 1)
              | otherwise            = fail $ "not a border (right) " ++ show (x,y,x')

    -- scan down looking for +
    scanDown :: Int -> Int -> Int -> Maybe (Int, Int)
    scanDown x y x2 = go (y + 1) where
        go y' | y' >= height                 = fail "overflow down"
              | T.index (rs !! y') x2 == '+' = scanLeft x y x2 y' <|> go (y' + 1)
              | T.index (rs !! y') x2 == '|' = go (y' + 1)
              | otherwise                    = fail $ "not a border (down) " ++ show (x,y,x2,y')

    -- check that at y2 x..x2 characters are '+' or '-'
    scanLeft :: Int -> Int -> Int -> Int -> Maybe (Int, Int)
    scanLeft x y x2 y2
        | all (\x' -> T.index bs x' `elem` ['+', '-']) [x..x2] = scanUp x y x2 y2
        | otherwise                                            = fail $ "not a border (left) " ++ show (x,y,x2,y2)
      where
        bs = rs !! y2

    -- check that at y2 x..x2 characters are '+' or '-'
    scanUp :: Int -> Int -> Int -> Int -> Maybe (Int, Int)
    scanUp x y x2 y2
        | all (\y' -> T.index (rs !! y') x `elem` ['+', '|']) [y..y2] = return (x2, y2)
        | otherwise                                                   = fail $ "not a border (up) " ++ show (x,y,x2,y2)

-- | table cell: top left bottom right
data TC = TC !Int !Int !Int !Int
  deriving Show

tcXS :: TC -> [Int]
tcXS (TC _ x _ x2) = [x, x2]

tcYS :: TC -> [Int]
tcYS (TC y _ y2 _) = [y, y2]

-- | Fourth step. Given the locations of cells, forms 'Table' structure.
tableStepFour :: [Text] -> Maybe Int -> [TC] -> Parser (Table (DocH mod Identifier))
tableStepFour rs hdrIndex cells =  case hdrIndex of
    Nothing -> return $ Table [] rowsDoc
    Just i  -> case elemIndex i yTabStops of
        Nothing -> return $ Table [] rowsDoc
        Just i' -> return $ uncurry Table $ splitAt i' rowsDoc
  where
    xTabStops = sortNub $ concatMap tcXS cells
    yTabStops = sortNub $ concatMap tcYS cells

    sortNub :: Ord a => [a] -> [a]
    sortNub = Set.toList . Set.fromList

    init' :: [a] -> [a]
    init' []       = []
    init' [_]      = []
    init' (x : xs) = x : init' xs

    rowsDoc = (fmap . fmap) parseParagraph rows

    rows = map makeRow (init' yTabStops)
      where
        makeRow y = TableRow $ mapMaybe (makeCell y) cells
        makeCell y (TC y' x y2 x2)
            | y /= y' = Nothing
            | otherwise = Just $ TableCell xts yts (extract (x + 1) (y + 1) (x2 - 1) (y2 - 1))
          where
            xts = length $ P.takeWhile (< x2) $ dropWhile (< x) xTabStops
            yts = length $ P.takeWhile (< y2) $ dropWhile (< y) yTabStops

    -- extract cell contents given boundaries
    extract :: Int -> Int -> Int -> Int -> Text
    extract x y x2 y2 = T.intercalate "\n"
        [ T.take (x2 - x + 1) $ T.drop x $ rs !! y'
        | y' <- [y .. y2]
        ]

-- | Parse \@since annotations.
since :: Parser (DocH mod a)
since = ("@since " *> version <* skipHorizontalSpace <* endOfLine) >>= setSince >> return DocEmpty
  where
    version = decimal `Parsec.sepBy1` "."

-- | Headers inside the comment denoted with @=@ signs, up to 6 levels
-- deep.
--
-- >>> snd <$> parseOnly header "= Hello"
-- Right (DocHeader (Header {headerLevel = 1, headerTitle = DocString "Hello"}))
-- >>> snd <$> parseOnly header "== World"
-- Right (DocHeader (Header {headerLevel = 2, headerTitle = DocString "World"}))
header :: Parser (DocH mod Identifier)
header = do
  let psers = map (string . flip T.replicate "=") [6, 5 .. 1]
      pser = choice' psers
  delim <- T.unpack <$> pser
  line <- skipHorizontalSpace *> nonEmptyLine >>= return . parseText
  rest <- try paragraph <|> return DocEmpty
  return $ DocHeader (Header (length delim) line) `docAppend` rest

textParagraph :: Parser (DocH mod Identifier)
textParagraph = parseText . T.intercalate "\n" <$> some nonEmptyLine

textParagraphThatStartsWithMarkdownLink :: Parser (DocH mod Identifier)
textParagraphThatStartsWithMarkdownLink = docParagraph <$> (docAppend <$> markdownLink <*> optionalTextParagraph)
  where
    optionalTextParagraph :: Parser (DocH mod Identifier)
    optionalTextParagraph = choice' [ docAppend <$> whitespace <*> textParagraph
                                    , pure DocEmpty ]

    whitespace :: Parser (DocH mod a)
    whitespace = DocString <$> (f <$> takeHorizontalSpace <*> optional "\n")
      where
        f :: Text -> Maybe Text -> String
        f xs (fromMaybe "" -> x)
          | T.null (xs <> x) = ""
          | otherwise = " "

-- | Parses unordered (bullet) lists.
unorderedList :: Text -> Parser (DocH mod Identifier)
unorderedList indent = DocUnorderedList <$> p
  where
    p = ("*" <|> "-") *> innerList indent p

-- | Parses ordered lists (numbered or dashed).
orderedList :: Text -> Parser (DocH mod Identifier)
orderedList indent = DocOrderedList <$> p
  where
    p = (paren <|> dot) *> innerList indent p
    dot = (decimal :: Parser Int) <* "."
    paren = "(" *> decimal <* ")"

-- | Generic function collecting any further lines belonging to the
-- list entry and recursively collecting any further lists in the
-- same paragraph. Usually used as
--
-- > someListFunction = listBeginning *> innerList someListFunction
innerList :: Text -> Parser [DocH mod Identifier]
          -> Parser [DocH mod Identifier]
innerList indent item = do
  c <- takeLine
  (cs, items) <- more indent item
  let contents = docParagraph . parseText . dropNLs . T.unlines $ c : cs
  return $ case items of
    Left p -> [contents `docAppend` p]
    Right i -> contents : i

-- | Parses definition lists.
definitionList :: Text -> Parser (DocH mod Identifier)
definitionList indent = DocDefList <$> p
  where
    p = do
      label <- "[" *> (parseParagraph <$> takeWhile1_ (`notElem` ("]\n" :: String))) <* ("]" <* optional ":")
      c <- takeLine
      (cs, items) <- more indent p
      let contents = parseText . dropNLs . T.unlines $ c : cs
      return $ case items of
        Left x -> [(label, contents `docAppend` x)]
        Right i -> (label, contents) : i

-- | Drops all trailing newlines.
dropNLs :: Text -> Text
dropNLs = T.dropWhileEnd (== '\n')

-- | Main worker for 'innerList' and 'definitionList'.
-- We need the 'Either' here to be able to tell in the respective functions
-- whether we're dealing with the next list or a nested paragraph.
more :: Monoid a => Text -> Parser a
     -> Parser ([Text], Either (DocH mod Identifier) a)
more indent item = choice' [ innerParagraphs indent
                           , moreListItems indent item
                           , moreContent indent item
                           , pure ([], Right mempty)
                           ]

-- | Used by 'innerList' and 'definitionList' to parse any nested paragraphs.
innerParagraphs :: Text
                -> Parser ([Text], Either (DocH mod Identifier) a)
innerParagraphs indent = (,) [] . Left <$> ("\n" *> indentedParagraphs indent)

-- | Attempts to fetch the next list if possibly. Used by 'innerList' and
-- 'definitionList' to recursively grab lists that aren't separated by a whole
-- paragraph.
moreListItems :: Text -> Parser a
              -> Parser ([Text], Either (DocH mod Identifier) a)
moreListItems indent item = (,) [] . Right <$> indentedItem
  where
    indentedItem = string indent *> Parsec.spaces *> item

-- | Helper for 'innerList' and 'definitionList' which simply takes
-- a line of text and attempts to parse more list content with 'more'.
moreContent :: Monoid a => Text -> Parser a
            -> Parser ([Text], Either (DocH mod Identifier) a)
moreContent indent item = first . (:) <$> nonEmptyLine <*> more indent item

-- | Parses an indented paragraph.
-- The indentation is 4 spaces.
indentedParagraphs :: Text -> Parser (DocH mod Identifier)
indentedParagraphs indent =
    (T.unpack . T.concat <$> dropFrontOfPara indent') >>= parseParagraphs
  where
    indent' = string $ indent <> "    "

-- | Grab as many fully indented paragraphs as we can.
dropFrontOfPara :: Parser Text -> Parser [Text]
dropFrontOfPara sp = do
  currentParagraph <- some (try (sp *> takeNonEmptyLine))
  followingParagraphs <-
    choice' [ skipHorizontalSpace *> nextPar -- we have more paragraphs to take
            , skipHorizontalSpace *> nlList -- end of the ride, remember the newline
            , Parsec.eof *> return []       -- nothing more to take at all
            ]
  return (currentParagraph ++ followingParagraphs)
  where
    nextPar = (++) <$> nlList <*> dropFrontOfPara sp
    nlList = "\n" *> return ["\n"]

nonSpace :: Text -> Parser Text
nonSpace xs
  | T.all isSpace xs = fail "empty line"
  | otherwise = return xs

-- | Takes a non-empty, not fully whitespace line.
--
--  Doesn't discard the trailing newline.
takeNonEmptyLine :: Parser Text
takeNonEmptyLine = do
    l <- takeWhile1 (Parsec.noneOf "\n") >>= nonSpace
    _ <- "\n"
    pure (l <> "\n")

-- | Takes indentation of first non-empty line.
--
-- More precisely: skips all whitespace-only lines and returns indentation
-- (horizontal space, might be empty) of that non-empty line.
takeIndent :: Parser Text
takeIndent = do
  indent <- takeHorizontalSpace
  choice' [ "\n" *> takeIndent
          , return indent
          ]

-- | Blocks of text of the form:
--
-- >> foo
-- >> bar
-- >> baz
--
birdtracks :: Parser (DocH mod a)
birdtracks = DocCodeBlock . DocString . T.unpack . T.intercalate "\n" . stripSpace <$> some line
  where
    line = try (skipHorizontalSpace *> ">" *> takeLine)

stripSpace :: [Text] -> [Text]
stripSpace = fromMaybe <*> mapM strip'
  where
    strip' t = case T.uncons t of
                 Nothing -> Just ""
                 Just (' ',t') -> Just t'
                 _ -> Nothing

-- | Parses examples. Examples are a paragraph level entitity (separated by an empty line).
-- Consecutive examples are accepted.
examples :: Parser (DocH mod a)
examples = DocExamples <$> (many (try (skipHorizontalSpace *> "\n")) *> go)
  where
    go :: Parser [Example]
    go = do
      prefix <- takeHorizontalSpace <* ">>>"
      expr <- takeLine
      (rs, es) <- resultAndMoreExamples
      return (makeExample prefix expr rs : es)
      where
        resultAndMoreExamples :: Parser ([Text], [Example])
        resultAndMoreExamples = choice' [ moreExamples, result, pure ([], []) ]
          where
            moreExamples :: Parser ([Text], [Example])
            moreExamples = (,) [] <$> go

            result :: Parser ([Text], [Example])
            result = first . (:) <$> nonEmptyLine <*> resultAndMoreExamples

    makeExample :: Text -> Text -> [Text] -> Example
    makeExample prefix expression res =
      Example (T.unpack (T.strip expression)) result
      where
        result = map (T.unpack . substituteBlankLine . tryStripPrefix) res

        tryStripPrefix xs = fromMaybe xs (T.stripPrefix prefix xs)

        substituteBlankLine "<BLANKLINE>" = ""
        substituteBlankLine xs = xs

nonEmptyLine :: Parser Text
nonEmptyLine = try (mfilter (T.any (not . isSpace)) takeLine)

takeLine :: Parser Text
takeLine = try (takeWhile (Parsec.noneOf "\n") <* endOfLine)

endOfLine :: Parser ()
endOfLine = void "\n" <|> Parsec.eof

-- | Property parser.
--
-- >>> snd <$> parseOnly property "prop> hello world"
-- Right (DocProperty "hello world")
property :: Parser (DocH mod a)
property = DocProperty . T.unpack . T.strip <$> ("prop>" *> takeWhile1 (Parsec.noneOf "\n"))

-- |
-- Paragraph level codeblock. Anything between the two delimiting \@ is parsed
-- for markup.
codeblock :: Parser (DocH mod Identifier)
codeblock =
  DocCodeBlock . parseParagraph . dropSpaces
  <$> ("@" *> skipHorizontalSpace *> "\n" *> block' <* "@")
  where
    dropSpaces xs =
      case splitByNl xs of
        [] -> xs
        ys -> case T.uncons (last ys) of
          Just (' ',_) -> case mapM dropSpace ys of
                            Nothing -> xs
                            Just zs -> T.intercalate "\n" zs
          _ -> xs

    -- This is necessary because â€˜linesâ€™ swallows up a trailing newline
    -- and we lose information about whether the last line belongs to @ or to
    -- text which we need to decide whether we actually want to be dropping
    -- anything at all.
    splitByNl = unfoldr (\x -> case T.uncons x of
                                 Just ('\n',x') -> Just (T.span (/= '\n') x')
                                 _ -> Nothing)
                . ("\n" <>)

    dropSpace t = case T.uncons t of
                    Nothing -> Just ""
                    Just (' ',t') -> Just t'
                    _ -> Nothing

    block' = scan p False
      where
        p isNewline c
          | isNewline && c == '@' = Nothing
          | isNewline && isSpace c = Just isNewline
          | otherwise = Just $ c == '\n'

hyperlink :: Parser (DocH mod a)
hyperlink = choice' [ angleBracketLink, markdownLink, autoUrl ]

angleBracketLink :: Parser (DocH mod a)
angleBracketLink =
    DocHyperlink . makeLabeled Hyperlink
    <$> disallowNewline ("<" *> takeUntil ">")

markdownLink :: Parser (DocH mod a)
markdownLink = DocHyperlink <$> linkParser

linkParser :: Parser Hyperlink
linkParser = flip Hyperlink <$> label <*> (whitespace *> url)
  where
    label :: Parser (Maybe String)
    label = Just . decode . T.strip <$> ("[" *> takeUntil "]")

    whitespace :: Parser ()
    whitespace = skipHorizontalSpace <* optional ("\n" *> skipHorizontalSpace)

    url :: Parser String
    url = rejectWhitespace (decode <$> ("(" *> takeUntil ")"))

    rejectWhitespace :: MonadPlus m => m String -> m String
    rejectWhitespace = mfilter (all (not . isSpace))

    decode :: Text -> String
    decode = T.unpack . removeEscapes

-- | Looks for URL-like things to automatically hyperlink even if they
-- weren't marked as links.
autoUrl :: Parser (DocH mod a)
autoUrl = mkLink <$> url
  where
    url = mappend <$> choice' [ "http://", "https://", "ftp://"] <*> takeWhile1 (Parsec.satisfy (not . isSpace))

    mkLink :: Text -> DocH mod a
    mkLink s = case T.unsnoc s of
      Just (xs,x) | x `elem` (",.!?" :: String) -> DocHyperlink (mkHyperlink xs) `docAppend` DocString [x]
      _ -> DocHyperlink (mkHyperlink s)

    mkHyperlink :: Text -> Hyperlink
    mkHyperlink lnk = Hyperlink (T.unpack lnk) Nothing

-- | Parses strings between identifier delimiters. Consumes all input that it
-- deems to be valid in an identifier. Note that it simply blindly consumes
-- characters and does no actual validation itself.
parseValid :: Parser String
parseValid = p some
  where
    idChar = Parsec.satisfy (\c -> isAlphaNum c || isSymbolChar c || c == '_')

    p p' = do
      vs <- p' idChar
      c <- peekChar'
      case c of
        '`' -> return vs
        '\'' -> choice' [ (\x -> vs ++ "'" ++ x) <$> ("'" *> p many), return vs ]
        _ -> fail "outofvalid"

-- | Parses identifiers with help of 'parseValid'. Asks GHC for
-- 'String' from the string it deems valid.
identifier :: Parser (DocH mod Identifier)
identifier = do
  o <- idDelim
  vid <- parseValid
  e <- idDelim
  return $ DocIdentifier (o, vid, e)
  where
    idDelim = Parsec.satisfy (\c -> c == '\'' || c == '`')