    -----------------------------------------------------------------------------
    -- |
    -- Module      :  Distribution.Simple.PreProcess.Unlit
    -- Copyright   :  ...
    --
    -- Maintainer  :  cabal-devel@haskell.org
    -- Portability :  portable
    --
    -- Remove the \"literal\" markups from a Haskell source file, including
    -- \"@>@\", \"@\\begin{code}@\", \"@\\end{code}@\", and \"@#@\"

    -- This version is interesting because instead of striping comment lines, it
    -- turns them into "-- " style comments. This allows using haddock markup
    -- in literate scripts without having to use "> --" prefix.

    module Distribution.Simple.PreProcess.Unlit (unlit,plain) where

    import Prelude ()
    import Distribution.Compat.Prelude
    import Distribution.Utils.Generic (safeTail, safeLast, safeInit)

    import Data.List (mapAccumL)

    data Classified = BirdTrack String | Blank String | Ordinary String
                    | Line !Int String | CPP String
                    | BeginCode | EndCode
                    -- output only:
                    | Error String | Comment String

    -- | No unliteration.
    plain :: String -> String -> String
    plain :: String -> String -> String
    plain String
    _ String
    hs = String
    hs

    classify :: String -> Classified
    classify :: String -> Classified
    classify (Char
    '>':String
    s) = String -> Classified
    BirdTrack String
    s
    classify (Char
    '#':String
    s) = case String -> [String]
    tokens String
    s of
                         (String
    line:file :: String
    file@(Char
    '"':Char
    _:String
    _):[String]
    _) | (Char -> Bool) -> String -> Bool
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
    all Char -> Bool
    isDigit String
    line
                                                Bool -> Bool -> Bool
    && String -> Maybe Char
    forall a. [a] -> Maybe a
    safeLast String
    file Maybe Char -> Maybe Char -> Bool
    forall a. Eq a => a -> a -> Bool
    == Char -> Maybe Char
    forall a. a -> Maybe a
    Just Char
    '"'
                                    -- this shouldn't fail as we tested for 'all isDigit'
                                    -> Int -> String -> Classified
    Line (Int -> Maybe Int -> Int
    forall a. a -> Maybe a -> a
    fromMaybe (String -> Int
    forall a. HasCallStack => String -> a
    error (String -> Int) -> String -> Int
    forall a b. (a -> b) -> a -> b
    $ String
    "panic! read @Int " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String -> String
    forall a. Show a => a -> String
    show String
    line) (Maybe Int -> Int) -> Maybe Int -> Int
    forall a b. (a -> b) -> a -> b
    $ String -> Maybe Int
    forall a. Read a => String -> Maybe a
    readMaybe String
    line) (String -> String
    forall a. [a] -> [a]
    safeTail (String -> String
    forall a. [a] -> [a]
    safeInit String
    file)) -- TODO:eradicateNoParse
                         [String]
    _          -> String -> Classified
    CPP String
    s
      where tokens :: String -> [String]
    tokens = (String -> Maybe (String, String)) -> String -> [String]
    forall b a. (b -> Maybe (a, b)) -> b -> [a]
    unfoldr ((String -> Maybe (String, String)) -> String -> [String])
    -> (String -> Maybe (String, String)) -> String -> [String]
    forall a b. (a -> b) -> a -> b
    $ \String
    str -> case ReadS String
    lex String
    str of
                                       (t :: String
    t@(Char
    _:String
    _), String
    str'):[(String, String)]
    _ -> (String, String) -> Maybe (String, String)
    forall a. a -> Maybe a
    Just (String
    t, String
    str')
                                       [(String, String)]
    _                 -> Maybe (String, String)
    forall a. Maybe a
    Nothing
    classify (Char
    '\\':String
    s)
      | String
    "begin{code}" String -> String -> Bool
    forall a. Eq a => [a] -> [a] -> Bool
    `isPrefixOf` String
    s = Classified
    BeginCode
      | String
    "end{code}"   String -> String -> Bool
    forall a. Eq a => [a] -> [a] -> Bool
    `isPrefixOf` String
    s = Classified
    EndCode
    classify String
    s | (Char -> Bool) -> String -> Bool
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
    all Char -> Bool
    isSpace String
    s       = String -> Classified
    Blank String
    s
    classify String
    s                       = String -> Classified
    Ordinary String
    s

    -- So the weird exception for comment indenting is to make things work with
    -- haddock, see classifyAndCheckForBirdTracks below.
    unclassify :: Bool -> Classified -> String
    unclassify :: Bool -> Classified -> String
    unclassify Bool
    _     (BirdTrack String
    s) = Char
    ' 'Char -> String -> String
    forall a. a -> [a] -> [a]
    :String
    s
    unclassify Bool
    _     (Blank String
    s)     = String
    s
    unclassify Bool
    _     (Ordinary String
    s)  = String
    s
    unclassify Bool
    _     (Line Int
    n String
    file) = String
    "# " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ Int -> String
    forall a. Show a => a -> String
    show Int
    n String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    " " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String -> String
    forall a. Show a => a -> String
    show String
    file
    unclassify Bool
    _     (CPP String
    s)       = Char
    '#'Char -> String -> String
    forall a. a -> [a] -> [a]
    :String
    s
    unclassify Bool
    True  (Comment String
    "")  = String
    "  --"
    unclassify Bool
    True  (Comment String
    s)   = String
    "  -- " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    s
    unclassify Bool
    False (Comment String
    "")  = String
    "--"
    unclassify Bool
    False (Comment String
    s)   = String
    "-- " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    s
    unclassify Bool
    _     Classified
    _             = String
    forall a. a
    internalError

    -- | 'unlit' takes a filename (for error reports), and transforms the
    --   given string, to eliminate the literate comments from the program text.
    unlit :: FilePath -> String -> Either String String
    unlit :: String -> String -> Either String String
    unlit String
    file String
    input =
      let (Bool
    usesBirdTracks, [Classified]
    classified) = [String] -> (Bool, [Classified])
    classifyAndCheckForBirdTracks
                                       ([String] -> (Bool, [Classified]))
    -> (String -> [String]) -> String -> (Bool, [Classified])
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> [String]
    inlines
                                       (String -> (Bool, [Classified])) -> String -> (Bool, [Classified])
    forall a b. (a -> b) -> a -> b
    $ String
    input
       in ([Classified] -> Either String String)
    -> (String -> Either String String)
    -> Either [Classified] String
    -> Either String String
    forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
    either (String -> Either String String
    forall a b. a -> Either a b
    Left (String -> Either String String)
    -> ([Classified] -> String) -> [Classified] -> Either String String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . [String] -> String
    unlines ([String] -> String)
    -> ([Classified] -> [String]) -> [Classified] -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (Classified -> String) -> [Classified] -> [String]
    forall a b. (a -> b) -> [a] -> [b]
    map (Bool -> Classified -> String
    unclassify Bool
    usesBirdTracks))
                  String -> Either String String
    forall a b. b -> Either a b
    Right
        (Either [Classified] String -> Either String String)
    -> ([Classified] -> Either [Classified] String)
    -> [Classified]
    -> Either String String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . [Classified] -> Either [Classified] String
    checkErrors
        ([Classified] -> Either [Classified] String)
    -> ([Classified] -> [Classified])
    -> [Classified]
    -> Either [Classified] String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . [Classified] -> [Classified]
    reclassify
        ([Classified] -> Either String String)
    -> [Classified] -> Either String String
    forall a b. (a -> b) -> a -> b
    $ [Classified]
    classified

      where
        -- So haddock requires comments and code to align, since it treats comments
        -- as following the layout rule. This is a pain for us since bird track
        -- style literate code typically gets indented by two since ">" is replaced
        -- by " " and people usually use one additional space of indent ie
        -- "> then the code". On the other hand we cannot just go and indent all
        -- the comments by two since that does not work for latex style literate
        -- code. So the hacky solution we use here is that if we see any bird track
        -- style code then we'll indent all comments by two, otherwise by none.
        -- Of course this will not work for mixed latex/bird track .lhs files but
        -- nobody does that, it's silly and specifically recommended against in the
        -- H98 unlit spec.
        --
        classifyAndCheckForBirdTracks :: [String] -> (Bool, [Classified])
    classifyAndCheckForBirdTracks =
          ((Bool -> String -> (Bool, Classified))
     -> Bool -> [String] -> (Bool, [Classified]))
    -> Bool
    -> (Bool -> String -> (Bool, Classified))
    -> [String]
    -> (Bool, [Classified])
    forall a b c. (a -> b -> c) -> b -> a -> c
    flip (Bool -> String -> (Bool, Classified))
    -> Bool -> [String] -> (Bool, [Classified])
    forall (t :: * -> *) s a b.
    Traversable t =>
    (s -> a -> (s, b)) -> s -> t a -> (s, t b)
    mapAccumL Bool
    False ((Bool -> String -> (Bool, Classified))
     -> [String] -> (Bool, [Classified]))
    -> (Bool -> String -> (Bool, Classified))
    -> [String]
    -> (Bool, [Classified])
    forall a b. (a -> b) -> a -> b
    $ \Bool
    seenBirdTrack String
    line ->
            let classification :: Classified
    classification = String -> Classified
    classify String
    line
             in (Bool
    seenBirdTrack Bool -> Bool -> Bool
    || Classified -> Bool
    isBirdTrack Classified
    classification, Classified
    classification)

        isBirdTrack :: Classified -> Bool
    isBirdTrack (BirdTrack String
    _) = Bool
    True
        isBirdTrack Classified
    _             = Bool
    False

        checkErrors :: [Classified] -> Either [Classified] String
    checkErrors [Classified]
    ls = case [ String
    e | Error String
    e <- [Classified]
    ls ] of
          []          -> [Classified] -> Either [Classified] String
    forall a b. a -> Either a b
    Left  [Classified]
    ls
          (String
    message:[String]
    _) -> String -> Either [Classified] String
    forall a b. b -> Either a b
    Right (String
    f String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    ":" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ Int -> String
    forall a. Show a => a -> String
    show Int
    n String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    ": " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    message)
            where (String
    f, Int
    n) = String -> Int -> [Classified] -> (String, Int)
    errorPos String
    file Int
    1 [Classified]
    ls
        errorPos :: String -> Int -> [Classified] -> (String, Int)
    errorPos String
    f Int
    n []              = (String
    f, Int
    n)
        errorPos String
    f Int
    n (Error String
    _:[Classified]
    _)     = (String
    f, Int
    n)
        errorPos String
    _ Int
    _ (Line Int
    n' String
    f':[Classified]
    ls) = String -> Int -> [Classified] -> (String, Int)
    errorPos String
    f' Int
    n' [Classified]
    ls
        errorPos String
    f Int
    n (Classified
    _         :[Classified]
    ls) = String -> Int -> [Classified] -> (String, Int)
    errorPos String
    f  (Int
    nInt -> Int -> Int
    forall a. Num a => a -> a -> a
    +Int
    1) [Classified]
    ls

    -- Here we model a state machine, with each state represented by
    -- a local function. We only have four states (well, five,
    -- if you count the error state), but the rules
    -- to transition between then are not so simple.
    -- Would it be simpler to have more states?
    --
    -- Each state represents the type of line that was last read
    -- i.e. are we in a comment section, or a latex-code section,
    -- or a bird-code section, etc?
    reclassify :: [Classified] -> [Classified]
    reclassify :: [Classified] -> [Classified]
    reclassify = [Classified] -> [Classified]
    blank -- begin in blank state
      where
        latex :: [Classified] -> [Classified]
    latex []               = []
        latex (Classified
    EndCode    :[Classified]
    ls) = String -> Classified
    Blank String
    "" Classified -> [Classified] -> [Classified]
    forall a. a -> [a] -> [a]
    : [Classified] -> [Classified]
    comment [Classified]
    ls
        latex (Classified
    BeginCode  :[Classified]
    _ ) = [String -> Classified
    Error String
    "\\begin{code} in code section"]
        latex (BirdTrack String
    l:[Classified]
    ls) = String -> Classified
    Ordinary (Char
    '>'Char -> String -> String
    forall a. a -> [a] -> [a]
    :String
    l) Classified -> [Classified] -> [Classified]
    forall a. a -> [a] -> [a]
    : [Classified] -> [Classified]
    latex [Classified]
    ls
        latex (          Classified
    l:[Classified]
    ls) = Classified
    l Classified -> [Classified] -> [Classified]
    forall a. a -> [a] -> [a]
    : [Classified] -> [Classified]
    latex [Classified]
    ls

        blank :: [Classified] -> [Classified]
    blank []               = []
        blank (Classified
    EndCode    :[Classified]
    _ ) = [String -> Classified
    Error String
    "\\end{code} without \\begin{code}"]
        blank (Classified
    BeginCode  :[Classified]
    ls) = String -> Classified
    Blank String
    ""    Classified -> [Classified] -> [Classified]
    forall a. a -> [a] -> [a]
    : [Classified] -> [Classified]
    latex [Classified]
    ls
        blank (BirdTrack String
    l:[Classified]
    ls) = String -> Classified
    BirdTrack String
    l Classified -> [Classified] -> [Classified]
    forall a. a -> [a] -> [a]
    : [Classified] -> [Classified]
    bird [Classified]
    ls
        blank (Ordinary  String
    l:[Classified]
    ls) = String -> Classified
    Comment   String
    l Classified -> [Classified] -> [Classified]
    forall a. a -> [a] -> [a]
    : [Classified] -> [Classified]
    comment [Classified]
    ls
        blank (          Classified
    l:[Classified]
    ls) =           Classified
    l Classified -> [Classified] -> [Classified]
    forall a. a -> [a] -> [a]
    : [Classified] -> [Classified]
    blank [Classified]
    ls

        bird :: [Classified] -> [Classified]
    bird []              = []
        bird (Classified
    EndCode   :[Classified]
    _ ) = [String -> Classified
    Error String
    "\\end{code} without \\begin{code}"]
        bird (Classified
    BeginCode :[Classified]
    ls) = String -> Classified
    Blank String
    "" Classified -> [Classified] -> [Classified]
    forall a. a -> [a] -> [a]
    : [Classified] -> [Classified]
    latex [Classified]
    ls
        bird (Blank String
    l   :[Classified]
    ls) = String -> Classified
    Blank String
    l  Classified -> [Classified] -> [Classified]
    forall a. a -> [a] -> [a]
    : [Classified] -> [Classified]
    blank [Classified]
    ls
        bird (Ordinary String
    _:[Classified]
    _ ) = [String -> Classified
    Error String
    "program line before comment line"]
        bird (         Classified
    l:[Classified]
    ls) = Classified
    l Classified -> [Classified] -> [Classified]
    forall a. a -> [a] -> [a]
    : [Classified] -> [Classified]
    bird [Classified]
    ls

        comment :: [Classified] -> [Classified]
    comment []               = []
        comment (Classified
    EndCode    :[Classified]
    _ ) = [String -> Classified
    Error String
    "\\end{code} without \\begin{code}"]
        comment (Classified
    BeginCode  :[Classified]
    ls) = String -> Classified
    Blank String
    "" Classified -> [Classified] -> [Classified]
    forall a. a -> [a] -> [a]
    : [Classified] -> [Classified]
    latex [Classified]
    ls
        comment (CPP String
    l      :[Classified]
    ls) = String -> Classified
    CPP String
    l Classified -> [Classified] -> [Classified]
    forall a. a -> [a] -> [a]
    : [Classified] -> [Classified]
    comment [Classified]
    ls
        comment (BirdTrack String
    _:[Classified]
    _ ) = [String -> Classified
    Error String
    "comment line before program line"]
        -- a blank line and another ordinary line following a comment
        -- will be treated as continuing the comment. Otherwise it's
        -- then end of the comment, with a blank line.
        comment (Blank     String
    l:ls :: [Classified]
    ls@(Ordinary  String
    _:[Classified]
    _)) = String -> Classified
    Comment String
    l Classified -> [Classified] -> [Classified]
    forall a. a -> [a] -> [a]
    : [Classified] -> [Classified]
    comment [Classified]
    ls
        comment (Blank     String
    l:[Classified]
    ls) = String -> Classified
    Blank String
    l   Classified -> [Classified] -> [Classified]
    forall a. a -> [a] -> [a]
    : [Classified] -> [Classified]
    blank [Classified]
    ls
        comment (Line Int
    n String
    f   :[Classified]
    ls) = Int -> String -> Classified
    Line Int
    n String
    f  Classified -> [Classified] -> [Classified]
    forall a. a -> [a] -> [a]
    : [Classified] -> [Classified]
    comment [Classified]
    ls
        comment (Ordinary  String
    l:[Classified]
    ls) = String -> Classified
    Comment String
    l Classified -> [Classified] -> [Classified]
    forall a. a -> [a] -> [a]
    : [Classified] -> [Classified]
    comment [Classified]
    ls
        comment (Comment   String
    _: [Classified]
    _) = [Classified]
    forall a. a
    internalError
        comment (Error     String
    _: [Classified]
    _) = [Classified]
    forall a. a
    internalError

    -- Re-implementation of 'lines', for better efficiency (but decreased laziness).
    -- Also, importantly, accepts non-standard DOS and Mac line ending characters.
    inlines :: String -> [String]
    inlines :: String -> [String]
    inlines String
    xs = String -> (String -> String) -> [String]
    lines' String
    xs String -> String
    forall a. a -> a
    id
      where
      lines' :: String -> (String -> String) -> [String]
    lines' []             String -> String
    acc = [String -> String
    acc []]
      lines' (Char
    '\^M':Char
    '\n':String
    s) String -> String
    acc = String -> String
    acc [] String -> [String] -> [String]
    forall a. a -> [a] -> [a]
    : String -> (String -> String) -> [String]
    lines' String
    s String -> String
    forall a. a -> a
    id    -- DOS
      lines' (Char
    '\^M':String
    s)      String -> String
    acc = String -> String
    acc [] String -> [String] -> [String]
    forall a. a -> [a] -> [a]
    : String -> (String -> String) -> [String]
    lines' String
    s String -> String
    forall a. a -> a
    id    -- MacOS
      lines' (Char
    '\n':String
    s)       String -> String
    acc = String -> String
    acc [] String -> [String] -> [String]
    forall a. a -> [a] -> [a]
    : String -> (String -> String) -> [String]
    lines' String
    s String -> String
    forall a. a -> a
    id    -- Unix
      lines' (Char
    c:String
    s)          String -> String
    acc = String -> (String -> String) -> [String]
    lines' String
    s (String -> String
    acc (String -> String) -> (String -> String) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (Char
    cChar -> String -> String
    forall a. a -> [a] -> [a]
    :))

    internalError :: a
    internalError :: forall a. a
    internalError = String -> a
    forall a. HasCallStack => String -> a
    error String
    "unlit: internal error"