Unlit.hs

module Unlit(CommentClass(..),unlit,readHaskellFile,optUnlit,isLiterateFile) where
import Prelude hiding (readFile)
import AbstractIO
import MUtils(apFst,pairWith)

-- Part of the following code is from "Report on the Programming Language Haskell",
-- version 1.2, appendix C.

import Char

readHaskellFile cpp path = optUnlit path =<< cppFile cpp path

cppFile Nothing path = readFile path
cppFile (Just cpp) path =
  do let tmpname = "hi/readHaskellFile.cpp.tmp" -- Use a unique name!!!
     ExitSuccess <- system (cpp++" "++path++" >"++tmpname) -- improve error message!
     src <- readFile tmpname
     removeFile tmpname
     return src

optUnlit path =
  if isLiterateFile path
  then \ s -> let ((litcmnts,code),es) = unlit path s
              in if null es
	         then return (litcmnts,unlines code)
		 else fail (unlines es)
  else \ s -> return ([],s)

isLiterateFile path = last4 path == ".lhs"
  where last4 = reverse . take 4 . reverse

--------------------------------------------------------------------------------

--unlit :: String -> String -> String
unlit file =
--apFst new_unclassify .        -- put literate text in nested comments
  apFst (unzip . map unclassify1) . -- return comment text and code separately
  pairWith (adjacent (Blank "") . addpos file 0) . -- error checking
  classify .
  lines
--------------------------------------------------------------------------------

data Classified
  = Program String String
  | Blank String
  | Comment String
  | Include Int String
  | Pre String

classify :: [String] -> [Classified]
classify []                = []
classify (l@('\\':x):xs) | x == "begin{code}" = Blank l : allProg xs
   where allProg [] = []  -- Should give an error message, but I have no good position information.
         allProg (l@('\\':x):xs) |  x == "end{code}" = Blank l : classify xs
	 allProg (x:xs) = Program "" x:allProg xs
classify (('>':x):xs)      = Program ">" (' ':x) : classify xs
classify (('!':x):xs)      = Program "!" (' ':x) : classify xs -- Programatica extra
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 x:classify xs
classify (x:xs)                 = Comment x:classify xs

-- Old version: put literate comment lines in one-line comments
--old_unclassify = unlines . map unclassify1

data CommentClass = CodePrefix | Directive | BlankLine | LitCmnt

unclassify1 :: Classified -> ((CommentClass,String),String)
unclassify1 (Program cmnt code) = ((CodePrefix,cmnt),code)
unclassify1 (Pre s)             = ((Directive,'#':s),"")
unclassify1 (Include i f)       = ((Directive,'#':' ':show i ++ ' ':f),"")
unclassify1 (Blank cmnt)        = ((BlankLine,cmnt),"")
unclassify1 (Comment cmnt)      = ((LitCmnt,cmnt),"")

-- 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 cmnt:Comment s:xs) = "{-+"++cmnt++"\n"++s++"\n"++unc xs -- -}
    un (x:xs) = snd (unclassify1 x)++"\n"++un xs -- ??

    -- Comment state, inside a literate comment
    unc [] = "-}\n"
    unc (Comment s:xs) = s++"\n"++unc xs
    unc (Blank s:xs) = s++"\n"++unb xs -- ??

    -- Blank line state, inside a literate comment, after a blank line
    unb [] = "-}\n"
    unb (Blank s:xs) = s++"\n"++unb xs -- ??
    unb xs@(Comment _:_) = "\n"++unc xs
    unb xs = "-}\n"++un xs

--adjacent :: Classified -> [((FilePath,Int),Classified)] -> [String]
adjacent _ [] = []
adjacent y ((pos,x):xs) =
  case (y,x) of
   (_        , Pre _      ) -> adjacent y xs
   (_        , Include _ _) -> adjacent y xs
   (Program _ _, Comment _) -> message pos "program" "comment":adjacent x xs
   (Comment _, Program _ _) -> message pos "comment" "program":adjacent x xs
   _                        -> adjacent x xs

addpos file n [] = []
addpos file n (x:xs) =
    case x of
      Include i f -> l:addpos f i xs
      _ -> l:addpos file (n+1) xs
  where l = ((file,n),x)

message pos p c = showpos pos++": "++p++ " line before "++c++" line.\n"
  where
    showpos ([],n)     = "Line "++show n
    showpos ("\"\"",n) = "Line "++show n
    showpos (file,n)   = "In file " ++ file ++ " at line "++show n