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) ...@@ -47,34 +47,62 @@ classify ('\\':s)
classify s | all isSpace s = Blank s classify s | all isSpace s = Blank s
classify s = Ordinary s classify s = Ordinary s
unclassify :: Classified -> String -- So the weird exception for comment indenting is to make things work with
unclassify (BirdTrack s) = ' ':s -- haddock, see classifyAndCheckForBirdTracks below.
unclassify (Blank s) = s unclassify :: Bool -> Classified -> String
unclassify (Ordinary s) = s unclassify _ (BirdTrack s) = ' ':s
unclassify (Line n file) = "# " ++ show n ++ " " ++ show file unclassify _ (Blank s) = s
unclassify (CPP s) = '#':s unclassify _ (Ordinary s) = s
unclassify (Comment "") = "--" unclassify _ (Line n file) = "# " ++ show n ++ " " ++ show file
unclassify (Comment s) = "-- " ++ s 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 -- | 'unlit' takes a filename (for error reports), and transforms the
-- given string, to eliminate the literate comments from the program text. -- given string, to eliminate the literate comments from the program text.
unlit :: FilePath -> String -> Either String String unlit :: FilePath -> String -> Either String String
unlit file = either (Left . unlines unlit file input =
. map unclassify) let (usesBirdTracks, classified) = classifyAndCheckForBirdTracks
Right . inlines
. checkErrors $ input
. reclassify in either (Left . unlines . map (unclassify usesBirdTracks))
. map classify Right
. inlines . checkErrors
. reclassify
where checkErrors ls = case [ e | Error e <- ls ] of $ classified
[] -> Left ls
(message:_) -> Right (f ++ ":" ++ show n ++ ": " ++ message) where
where (f, n) = errorPos file 1 ls -- So haddock requires comments and code to align, since it treats comments
errorPos f n [] = (f, n) -- as following the layout rule. This is a pain for us since bird track
errorPos f n (Error _:_) = (f, n) -- style literate code typically gets indented by two since ">" is replaced
errorPos _ _ (Line n' f':ls) = errorPos f' n' ls -- by " " and people usually use one additional space of indent ie
errorPos f n (_ :ls) = errorPos f (n+1) ls -- "> 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 -- Here we model a state machine, with each state represented by
-- a local function. We only have four states (well, five, -- a local function. We only have four states (well, five,
...@@ -120,6 +148,8 @@ reclassify = blank -- begin in blank state ...@@ -120,6 +148,8 @@ reclassify = blank -- begin in blank state
comment (Blank l:ls) = Blank l : blank ls comment (Blank l:ls) = Blank l : blank ls
comment (Line n f :ls) = Line n f : comment ls comment (Line n f :ls) = Line n f : comment ls
comment (Ordinary l:ls) = Comment l : 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). -- Re-implementation of 'lines', for better efficiency (but decreased laziness).
-- Also, importantly, accepts non-standard DOS and Mac line ending characters. -- Also, importantly, accepts non-standard DOS and Mac line ending characters.
...@@ -131,3 +161,6 @@ inlines xs = lines' xs id ...@@ -131,3 +161,6 @@ inlines xs = lines' xs id
lines' ('\^M':s) acc = acc [] : lines' s id -- MacOS lines' ('\^M':s) acc = acc [] : lines' s id -- MacOS
lines' ('\n':s) acc = acc [] : lines' s id -- Unix lines' ('\n':s) acc = acc [] : lines' s id -- Unix
lines' (c:s) acc = lines' s (acc . (c:)) 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