module Unlit(unlit,readHaskellFile,optUnlit,isLiterateFile) where
-- Part of the following code is from "Report on the Programming Language Haskell",
-- version 1.2, appendix C.
import Char
readHaskellFile path = fmap (optUnlit path) (readFile path)
optUnlit path =
if isLiterateFile path
then unlit path
else id
isLiterateFile path = last4 path == ".lhs"
where last4 = reverse . take 4 . reverse
--------------------------------------------------------------------------------
data Classified = Program String | Blank | Comment String | Include Int String | Pre String
classify :: [String] -> [Classified]
classify [] = []
classify (('\\':x):xs) | x == "begin{code}" = Blank : allProg xs
where allProg [] = [] -- Should give an error message, but I have no good position information.
allProg (('\\':x):xs) | x == "end{code}" = Blank : classify xs
allProg (x:xs) = Program x:allProg xs
classify (('>':x):xs) = Program (' ':x) : classify xs
classify (('#':x):xs) = (case words x of
(line:file:_) | all isDigit line -> Include (read line) file
_ -> Pre x
) : classify xs
classify (x:xs) | all isSpace x = Blank:classify xs
classify (x:xs) = Comment x:classify xs
-- Old version: put literate comment lines in one-line comments
old_unclassify = unlines . map unclassify1
unclassify1 :: Classified -> String
unclassify1 (Program s) = s
unclassify1 (Pre s) = '#':s
unclassify1 (Include i f) = '#':' ':show i ++ ' ':f
unclassify1 Blank = ""
unclassify1 (Comment s) = "-- "++s
-- New version: put literate comment blocks in nested comments
-- (Drawback: these can potentially interfere with other comments)
new_unclassify = unclassify0
where
unclassify0 (Comment s:xs) = "{-+\t"++s++"\n"++unc xs -- -}
unclassify0 xs = un xs
-- Normal state, inside code block
un [] = []
un (Blank:Comment s:xs) = "{-+\n"++s++"\n"++unc xs -- -}
un (x:xs) = unclassify1 x++"\n"++un xs
-- Comment state, inside a literate comment
unc [] = "-}\n"
unc (Comment s:xs) = s++"\n"++unc xs
unc (Blank:xs) = unb xs
-- Blank line state, inside a literate comment, after a blank line
unb [] = "-}\n"
unb (Blank:xs) = "\n"++unb xs
unb xs@(Comment _:_) = "\n"++unc xs
unb xs = "-}\n"++un xs
unlit :: String -> String -> String
unlit file =
new_unclassify . adjecent file (0::Int) Blank . classify . lines
adjecent :: String -> Int -> Classified -> [Classified] -> [Classified]
adjecent file 0 _ (x :xs) = x : adjecent file 1 x xs -- force evaluation of line number
adjecent file n y@(Program _) (x@(Comment _) :xs) = error (message file n "program" "comment")
adjecent file n y@(Program _) (x@(Include i f):xs) = x: adjecent f i y xs
adjecent file n y@(Program _) (x@(Pre _) :xs) = x: adjecent file (n+1) y xs
adjecent file n y@(Comment _) (x@(Program _) :xs) = error (message file n "comment" "program")
adjecent file n y@(Comment _) (x@(Include i f):xs) = x: adjecent f i y xs
adjecent file n y@(Comment _) (x@(Pre _) :xs) = x: adjecent file (n+1) y xs
adjecent file n y@Blank (x@(Include i f):xs) = x: adjecent f i y xs
adjecent file n y@Blank (x@(Pre _) :xs) = x: adjecent file (n+1) y xs
adjecent file n _ (x@next :xs) = x: adjecent file (n+1) x xs
adjecent file n _ [] = []
message "\"\"" n p c = "Line "++show n++": "++p++ " line before "++c++" line.\n"
message [] n p c = "Line "++show n++": "++p++ " line before "++c++" line.\n"
message file n p c = "In file " ++ file ++ " at line "++show n++": "++p++ " line before "++c++" line.\n"