1{-# LANGUAGE ViewPatterns #-}
2-- |
3-- Module      :  Haddock.Parser
4-- Copyright   :  (c) Mateusz Kowalczyk 2013,
5--                    Simon Hengel      2013
6-- License     :  BSD-like
7--
8-- Maintainer  :  haddock@projects.haskell.org
9-- Stability   :  experimental
10-- Portability :  portable
11
12module Haddock.Parser ( parseParas
13                      , parseString
14                      , parseIdent
15                      ) where
16
17import qualified Documentation.Haddock.Parser as P
18import Documentation.Haddock.Types
19import Haddock.Types
20
21import DynFlags     ( DynFlags )
22import FastString   ( fsLit )
23import Lexer        ( mkPState, unP, ParseResult(..) )
24import OccName      ( occNameString )
25import Parser       ( parseIdentifier )
26import RdrName      ( RdrName(Qual) )
27import SrcLoc       ( mkRealSrcLoc, GenLocated(..) )
28import StringBuffer ( stringToStringBuffer )
29
30
31parseParas :: DynFlags -> Maybe Package -> String -> MetaDoc mod (Wrap NsRdrName)
32parseParas d p = overDoc (P.overIdentifier (parseIdent d)) . P.parseParas p
33
34parseString :: DynFlags -> String -> DocH mod (Wrap NsRdrName)
35parseString d = P.overIdentifier (parseIdent d) . P.parseString
36
37parseIdent :: DynFlags -> Namespace -> String -> Maybe (Wrap NsRdrName)
38parseIdent dflags ns str0 =
39  case unP parseIdentifier (pstate str1) of
40    POk _ (L _ name)
41      -- Guards against things like 'Q.--', 'Q.case', etc.
42      -- See https://github.com/haskell/haddock/issues/952 and Trac #14109
43      | Qual _ occ <- name
44      , PFailed{} <- unP parseIdentifier (pstate (occNameString occ))
45      -> Nothing
46      | otherwise
47      -> Just (wrap (NsRdrName ns name))
48    PFailed{} -> Nothing
49  where
50    realSrcLc = mkRealSrcLoc (fsLit "<unknown file>") 0 0
51    pstate str = mkPState dflags (stringToStringBuffer str) realSrcLc
52    (wrap,str1) = case str0 of
53                    '(' : s@(c : _) | c /= ',', c /= ')'  -- rule out tuple names
54                                    -> (Parenthesized, init s)
55                    '`' : s@(_ : _) -> (Backticked,    init s)
56                    _               -> (Unadorned,     str0)
57