----------------------------------------------------------------------------- -- | -- 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 Data.Char import Data.List 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 _ hs = hs classify :: String -> Classified classify ('>':s) = BirdTrack s classify ('#':s) = case tokens s of (line:file:_) | all isDigit line && length file >= 2 && head file == '"' && last file == '"' -> Line (read line) (tail (init file)) _ -> CPP s where tokens = unfoldr $ \str -> case lex str of (t@(_:_), str'):_ -> Just (t, str') _ -> Nothing classify ('\\':s) | "begin{code}" `isPrefixOf` s = BeginCode | "end{code}" `isPrefixOf` s = EndCode classify s | all isSpace s = Blank s classify s = Ordinary s -- So the weird exception for comment indenting is to make things work with -- haddock, see classifyAndCheckForBirdTracks below. unclassify :: Bool -> Classified -> String unclassify _ (BirdTrack s) = ' ':s unclassify _ (Blank s) = s unclassify _ (Ordinary s) = s unclassify _ (Line n file) = "# " ++ show n ++ " " ++ show file unclassify _ (CPP s) = '#':s unclassify True (Comment "") = " --" unclassify True (Comment s) = " -- " ++ s unclassify False (Comment "") = "--" unclassify False (Comment s) = "-- " ++ s unclassify _ _ = 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 file input = let (usesBirdTracks, classified) = classifyAndCheckForBirdTracks . inlines $ input in either (Left . unlines . map (unclassify usesBirdTracks)) Right . checkErrors . reclassify $ 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 = flip mapAccumL False $ \seenBirdTrack line -> let classification = classify line in (seenBirdTrack || isBirdTrack classification, classification) isBirdTrack (BirdTrack _) = True isBirdTrack _ = False checkErrors ls = case [ e | Error e <- ls ] of [] -> Left ls (message:_) -> Right (f ++ ":" ++ show n ++ ": " ++ message) where (f, n) = errorPos file 1 ls errorPos f n [] = (f, n) errorPos f n (Error _:_) = (f, n) errorPos _ _ (Line n' f':ls) = errorPos f' n' ls errorPos f n (_ :ls) = errorPos f (n+1) 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 = blank -- begin in blank state where latex [] = [] latex (EndCode :ls) = Blank "" : comment ls latex (BeginCode :_ ) = [Error "\\begin{code} in code section"] latex (BirdTrack l:ls) = Ordinary ('>':l) : latex ls latex ( l:ls) = l : latex ls blank [] = [] blank (EndCode :_ ) = [Error "\\end{code} without \\begin{code}"] blank (BeginCode :ls) = Blank "" : latex ls blank (BirdTrack l:ls) = BirdTrack l : bird ls blank (Ordinary l:ls) = Comment l : comment ls blank ( l:ls) = l : blank ls bird [] = [] bird (EndCode :_ ) = [Error "\\end{code} without \\begin{code}"] bird (BeginCode :ls) = Blank "" : latex ls bird (Blank l :ls) = Blank l : blank ls bird (Ordinary _:_ ) = [Error "program line before comment line"] bird ( l:ls) = l : bird ls comment [] = [] comment (EndCode :_ ) = [Error "\\end{code} without \\begin{code}"] comment (BeginCode :ls) = Blank "" : latex ls comment (CPP l :ls) = CPP l : comment ls comment (BirdTrack _:_ ) = [Error "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 l:ls@(Ordinary _:_)) = Comment l : comment ls comment (Blank l:ls) = Blank l : blank ls comment (Line n f :ls) = Line n f : comment ls comment (Ordinary l:ls) = Comment l : comment ls comment (Comment _: _) = internalError comment (Error _: _) = 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 xs = lines' xs id where lines' [] acc = [acc []] lines' ('\^M':'\n':s) acc = acc [] : lines' s id -- DOS lines' ('\^M':s) acc = acc [] : lines' s id -- MacOS lines' ('\n':s) acc = acc [] : lines' s id -- Unix lines' (c:s) acc = lines' s (acc . (c:)) internalError :: a internalError = error "unlit: internal error"