1 -- uh yeah, another literate programming tool 2 3 module Heave 4 5 ( heave, gheave, stream 6 , Formatter 7 ) 8 9 where 10 11 import Trace 12 13 14 import System 15 import Stuff (intersperse) 16 import Char (isSpace) 17 18 import Options 19 import Command 20 21 ------------------------------------------------------------------ 22 23 24 25 -- we use a stack of options 26 type Optss = [Opts] 27 28 ------------------------------------------------------- 29 30 {- 31 32 an essay on line breaking: 33 34 inline code (in between $) will be sent directly to the code parser, 35 which calls myLex which ignores linebreaks completely. 36 37 display code (.begin ... .end) will be chopped into lines, 38 those are sent to the code parser separately, 39 i. e. each line must be a complete expression. 40 41 if an expression doesn't fit on one line, you may use 42 a continuation line: one that starts with a white space. 43 such lines will be appended to the most recent line 44 that started at position 0 45 46 -} 47 48 glueLines :: [String] -> (String, [String]) 49 -- returns first logical line (including continuations), and rest 50 glueLines [] = ([],[]) 51 glueLines (l : ls) = 52 let (as, bs) = span (\ l' -> null l' || isSpace (head l')) ls 53 in (unlines (l : as), bs) 54 55 --------------------------------------------------------- 56 57 type Formatter a = (Opts, a) -> String -> IO a 58 59 -- a formatter reads a line and outputs something (to stdout) 60 -- it has a state :: a that is chained through 61 -- it may also read (not change) the environment provided by the unlit-ter 62 63 --------------------------------------------------------- 64 65 unlit :: Formatter a -> (Optss, a) -> [String] -> IO (Optss, a) 66 67 unlit f oss [] = return oss 68 69 -- commands must start at the beginning of a line 70 -- and they start with a dot 71 unlit f oss (('.' : cmd) : rest) = 72 do { oss' <- unlitcmd f oss cmd 73 ; unlit f oss' rest 74 } 75 76 -- otherwise it's not a command 77 unlit f oss @ (os @ (opts:_), state) lines = 78 caseopts opts "current" 79 [ ("text", do { let (h : t) = lines 80 ; unlittext f oss h 81 ; maybePutChar opts '\n' 82 ; unlit f oss t 83 } ) 84 , ("code", do { let (h, t) = glueLines lines 85 86 -- start of line hook 87 ; if onoff opts "output" 88 then caseopts opts "code" 89 [ ("latex", putStr "\\\\\n & & ") 90 , ("plain", return ()) 91 ] 92 else return () 93 94 ; oss' <- unlitcode f oss h 95 96 -- end of line hook 97 ; if onoff opts "output" 98 then caseopts opts "code" 99 [ ("latex", putChar '\n') 100 , ("plain", putChar '\n') 101 ] 102 else return () 103 104 ; unlit f oss' t 105 } ) 106 ] 107 108 -------------------------------------------------------------------- 109 110 unlittext :: Formatter a -> (Optss, a) -> String -> IO () 111 112 -- inline code, look for $..$ (keepsep) or |..| (omitsep) 113 -- result () because it may not change opts or env 114 115 unlittext f oss @ (os @ (opts : _), state) cs = 116 do { let [keep] = getopt opts "keepsep" 117 ; let [omit] = getopt opts "omitsep" 118 119 ; let (as, bs) = span (\ c -> c /= keep && c /= omit) cs 120 121 ; maybePutStr opts as 122 123 ; let sep = head bs -- only called when bs /= [] 124 ; let ds = drop 1 bs 125 ; let (es, fs) = span (/= sep) ds 126 ; let gs = drop 1 fs 127 128 ; let opts1 = addListToOpts opts 129 [("current","code"), ("context", "inline")] 130 131 ; if not (null bs) then do 132 { if onoff opts "output" && sep == keep 133 then if getopt opts "text" == "latex" 134 && getopt opts "code" == "plain" 135 then putStr "\\verb;" 136 else putChar sep 137 else return () 138 139 ; f (opts1, state) es 140 141 ; if onoff opts "output" && sep == keep 142 then if getopt opts "text" == "latex" 143 && getopt opts "code" == "plain" 144 then putStr ";" 145 else putChar sep 146 else return () 147 148 ; unlittext f oss gs 149 } 150 else return () -- line finished 151 } 152 153 -------------------------------------------------------------------- 154 155 unlitcode :: Formatter a -> (Optss, a) -> String -> IO (Optss, a) 156 unlitcode f (oss @ (opts: _), state) s = 157 do { state' <- f (opts, state) s -- execute code 158 ; return (oss, state') 159 } 160 161 162 -------------------------------------------------------------------- 163 164 165 -- perhaps start or end a code block 166 -- this: current options, that: previous options 167 block this that = 168 if -- we've changed current mode 169 getopt this "current" /= getopt that "current" 170 -- we're latexing 171 && caseopts that "text" [("latex",True),("plain",False)] 172 173 then 174 if -- we are in code mode now 175 caseopts this "current" [("code",True),("text",False)] 176 -- we were in text mode before 177 && caseopts that "current" [("text",True),("code",False)] 178 -- we _are_ printing 179 && onoff this "output" 180 then 181 caseopts this "code" 182 [ ("plain", putStrLn "\\begin{verbatim}") 183 184 -- nice hack ----------------------------------------------------------- 185 -- output "%%" at end of line 186 -- so that latex ignores the "\\" 187 -- that will be output before first code line 188 , ("latex", putStr "\\begin{eqnarray*} %% hack: ") 189 -- end hack ------------------------------------------------------------- 190 191 ] 192 else if -- we were in code mode 193 caseopts that "current" [("code",True),("text",False)] 194 -- we return to text mode 195 && caseopts this "current" [("text",True),("code",False)] 196 -- we _were_ printing 197 && onoff that "output" 198 then 199 caseopts this "code" 200 [ ("plain", putStrLn "\\end{verbatim}") 201 , ("latex", putStrLn "\\end{eqnarray*}") 202 ] 203 else return () 204 else return () 205 206 207 unlitcmd :: Formatter a -> (Optss, a) -> String -> IO (Optss, a) 208 unlitcmd f oss @ (os @ (opts:ros), state ) cmd = 209 case pcmd opts cmd of 210 211 -- import a file, change environment locally only 212 -- but globally thread the state through 213 Import g name -> 214 do { let opts1 = plusOpts opts g 215 ; block opts1 opts 216 217 ; cs <- if name == "-" -- means stdin 218 then 219 trace ("\nreading stdin\n") $ 220 getContents 221 else 222 trace ("\nreading file " ++ name ++ "\n") $ 223 readFile name 224 225 ; (opts2, state2) <- unlit f (opts1 : os, state) (lines cs) 226 ; block opts (head opts2) 227 ; return (os, state2) 228 } 229 230 -- change environment, continue parsing 231 Set g -> 232 do { let opts1 = plusOpts opts g 233 ; block opts1 opts 234 ; return (opts1 : ros , state) 235 } 236 237 -- begin of a display code group 238 Begin g -> 239 do { let opts1 = plusOpts opts g 240 ; block opts1 opts 241 ; return (opts1 : os, state) 242 } 243 244 -- end of a display code group 245 End -> 246 if null ros then error "error: extraneous .end" 247 else do 248 { let opts1 = head ros 249 ; block opts1 opts -- note: the other way round 250 ; return (ros, state) 251 } 252 253 -- some unknown command 254 Unknown cs -> 255 do { putStrLn ("unkown cmd: " ++ cs) 256 ; return oss 257 } 258 259 260 ---------------------------------------------------------------------- 261 262 -- the command line is preprended to the input 263 stream opts f init argv = 264 let 265 process arg = 266 if '=' `elem` arg 267 then -- it's a binding 268 ".set (" ++ arg ++ ")" 269 else -- it's a file name 270 ".import \"" ++ arg ++ "\"" 271 272 limbo = [ process arg | arg <- argv ] 273 274 in unlit f ([opts], init) limbo >> return () 275 276 -- what we do when interpreted (i. e. we type the command line) 277 -- read arguments from string, read input from file 278 gheave opts f init args = 279 stream opts f init (words args) 280 281 282 -- what we call when compiled 283 -- read arguments (don't read stdin per default. give "-" argument instead) 284 heave opts f init = 285 getArgs >>= \ argv -> 286 stream opts f init argv 287 288