{-# LANGUAGE ViewPatterns #-}
-- |
-- Module      :  Haddock.Parser
-- Copyright   :  (c) Mateusz Kowalczyk 2013,
--                    Simon Hengel      2013
-- License     :  BSD-like
--
-- Maintainer  :  haddock@projects.haskell.org
-- Stability   :  experimental
-- Portability :  portable

module Haddock.Parser ( parseParas
                      , parseString
                      , parseIdent
                      ) where

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

import DynFlags     ( DynFlags )
import FastString   ( fsLit )
import Lexer        ( mkPState, unP, ParseResult(..) )
import OccName      ( occNameString )
import Parser       ( parseIdentifier )
import RdrName      ( RdrName(Qual) )
import SrcLoc       ( mkRealSrcLoc, GenLocated(..) )
import StringBuffer ( stringToStringBuffer )


parseParas :: DynFlags -> Maybe Package -> String -> MetaDoc mod (Wrap NsRdrName)
parseParas :: DynFlags
-> Maybe Package -> Package -> MetaDoc mod (Wrap NsRdrName)
parseParas DynFlags
d Maybe Package
p = (DocH mod Identifier -> DocH mod (Wrap NsRdrName))
-> MetaDoc mod Identifier -> MetaDoc mod (Wrap NsRdrName)
forall a b c d.
(DocH a b -> DocH c d) -> MetaDoc a b -> MetaDoc c d
overDoc ((Namespace -> Package -> Maybe (Wrap NsRdrName))
-> DocH mod Identifier -> DocH mod (Wrap NsRdrName)
forall a mod.
(Namespace -> Package -> Maybe a)
-> DocH mod Identifier -> DocH mod a
P.overIdentifier (DynFlags -> Namespace -> Package -> Maybe (Wrap NsRdrName)
parseIdent DynFlags
d)) (MetaDoc mod Identifier -> MetaDoc mod (Wrap NsRdrName))
-> (Package -> MetaDoc mod Identifier)
-> Package
-> MetaDoc mod (Wrap NsRdrName)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Package -> Package -> MetaDoc mod Identifier
forall mod. Maybe Package -> Package -> MetaDoc mod Identifier
P.parseParas Maybe Package
p

parseString :: DynFlags -> String -> DocH mod (Wrap NsRdrName)
parseString :: DynFlags -> Package -> DocH mod (Wrap NsRdrName)
parseString DynFlags
d = (Namespace -> Package -> Maybe (Wrap NsRdrName))
-> DocH mod Identifier -> DocH mod (Wrap NsRdrName)
forall a mod.
(Namespace -> Package -> Maybe a)
-> DocH mod Identifier -> DocH mod a
P.overIdentifier (DynFlags -> Namespace -> Package -> Maybe (Wrap NsRdrName)
parseIdent DynFlags
d) (DocH mod Identifier -> DocH mod (Wrap NsRdrName))
-> (Package -> DocH mod Identifier)
-> Package
-> DocH mod (Wrap NsRdrName)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Package -> DocH mod Identifier
forall mod. Package -> DocH mod Identifier
P.parseString

parseIdent :: DynFlags -> Namespace -> String -> Maybe (Wrap NsRdrName)
parseIdent :: DynFlags -> Namespace -> Package -> Maybe (Wrap NsRdrName)
parseIdent DynFlags
dflags Namespace
ns Package
str0 =
  case P (Located RdrName) -> PState -> ParseResult (Located RdrName)
forall a. P a -> PState -> ParseResult a
unP P (Located RdrName)
parseIdentifier (Package -> PState
pstate Package
str1) of
    POk PState
_ (L SrcSpan
_ RdrName
name)
      -- Guards against things like 'Q.--', 'Q.case', etc.
      -- See https://github.com/haskell/haddock/issues/952 and Trac #14109
      | Qual ModuleName
_ OccName
occ <- RdrName
name
      , PFailed{} <- P (Located RdrName) -> PState -> ParseResult (Located RdrName)
forall a. P a -> PState -> ParseResult a
unP P (Located RdrName)
parseIdentifier (Package -> PState
pstate (OccName -> Package
occNameString OccName
occ))
      -> Maybe (Wrap NsRdrName)
forall a. Maybe a
Nothing
      | Bool
otherwise
      -> Wrap NsRdrName -> Maybe (Wrap NsRdrName)
forall a. a -> Maybe a
Just (NsRdrName -> Wrap NsRdrName
forall n. n -> Wrap n
wrap (Namespace -> RdrName -> NsRdrName
NsRdrName Namespace
ns RdrName
name))
    PFailed{} -> Maybe (Wrap NsRdrName)
forall a. Maybe a
Nothing
  where
    realSrcLc :: RealSrcLoc
realSrcLc = FastString -> Int -> Int -> RealSrcLoc
mkRealSrcLoc (Package -> FastString
fsLit Package
"<unknown file>") Int
0 Int
0
    pstate :: Package -> PState
pstate Package
str = DynFlags -> StringBuffer -> RealSrcLoc -> PState
mkPState DynFlags
dflags (Package -> StringBuffer
stringToStringBuffer Package
str) RealSrcLoc
realSrcLc
    (n -> Wrap n
wrap,Package
str1) = case Package
str0 of
                    Char
'(' : s :: Package
s@(Char
c : Package
_) | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
',', Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
')'  -- rule out tuple names
                                    -> (n -> Wrap n
forall n. n -> Wrap n
Parenthesized, Package -> Package
forall a. [a] -> [a]
init Package
s)
                    Char
'`' : s :: Package
s@(Char
_ : Package
_) -> (n -> Wrap n
forall n. n -> Wrap n
Backticked,    Package -> Package
forall a. [a] -> [a]
init Package
s)
                    Package
_               -> (n -> Wrap n
forall n. n -> Wrap n
Unadorned,     Package
str0)