Commit 63fbc9a6 authored by Duncan Coutts's avatar Duncan Coutts
Browse files

Fudge comment indentation in unliting to work with haddock

The rule is, if we see any bird track style code then we will indent all
comments by two spaces so that it should line up with the code. Otherwise
we use no indentation so that it'll work with latex style literate files.
This makes it work for takusen (once you change the '.' lines to be blank).
parent 3db7be04
......@@ -47,34 +47,62 @@ classify ('\\':s)
classify s | all isSpace s = Blank s
classify s = Ordinary s
unclassify :: 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 (Comment "") = "--"
unclassify (Comment s) = "-- " ++ 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 = either (Left . unlines
. map unclassify)
Right
. checkErrors
. reclassify
. map classify
. inlines
where 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
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,
......@@ -120,6 +148,8 @@ reclassify = blank -- begin in blank state
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.
......@@ -131,3 +161,6 @@ inlines xs = lines' xs id
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"
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment