" code_end = -- "" ++ html_trailer code_to_comm = "{-" comm_to_code = "
-}"
oner_start = "{-"
oner_end = "-}"
block_start = code_to_comm
block_end = comm_to_code
html_header name
= "\n\n\n"
++ "" ++ name
++ " \n\n\n"
++ ("\n")
++ ""
html_trailer
= "
"
++ "\n\n\n\n"
{- I can't see color with lynx so these are probably crazy. -}
oner_color = "#FF00FF"
bgcolor = "#FFFFFF"
{- the state machine -}
code b cs
= case cs of
"" -> pcode (b cs) ++ code_end
[c] -> pcode (b cs) ++ code_end
('{':'-':cs') -> pcode (b "") ++ comm (\x->x) cs'
(c1:c2:cs') -> code (b . (c1 :)) (c2:cs')
comm b cs
= case cs of
"" -> error "end of file in comment"
[c] -> error "end of file in comment"
('-':'}':cs') -> pcomm (b "") ++ code (\x->x) cs'
(c1:c2:cs') -> comm (b . (c1 :)) (c2:cs' )
pcode str = str -- "" ++ str ++ "
"
pcomm str = if '\n' `elem` str
then let ls = lines str
blank l = strip l == ""
paras ls = if (null ls)
then []
else let (bef,aft) = break blank ls
(jnk,aft') = break (not . blank) aft
in bef : paras aft'
strip = dropWhile (\c -> c ==' ' || c == '\t')
indentation = length . takeWhile (\c -> c ==' ')
layp = concat . map (\l -> l++" \n")
layps = concat . map (\p -> p++"\n")
str' = layps (map layp (paras ls))
in "{-
\n" ++ str' ++ "\n-}\n"
else "{- " ++ str ++ "-}"
{- END -}
data Memory
= Leaf String | Fork (Char -> Memory)
contents :: (String -> String) -> Memory -> [(String,String)]
contents a t
= case t of
Leaf v -> [(a "",v)]
Fork phi -> concat [ contents (a . (c:)) (phi c)
| c <- "abcdefghijklmnopqrstuvwxyz" ]
write addr val t
= case addr of
"" -> Leaf val
(c:cs) ->
case t of
Leaf str -> write addr val (Fork ( \c -> t ))
Fork phi -> let t' = write cs val (phi c)
in Fork (\ c' -> if c == c' then t' else phi c' )
{- experiments -}
reada b addr t
= case t of
Leaf val -> (b "",val) -- return address used
Fork phi -> case addr of
"" -> reada b " " t
(c:cs) -> reada (b . (c:)) cs (phi c)
tree = (foldr (\(addr,val) t -> write addr val t) (Leaf "") . reverse )
[("foo","bar"),("ab","ba"),("a","a"),("b","b"),("ab","ba")]
prefix "" str = 0 == 0
prefix (c:cs) "" = 0 == 1
prefix (c:cs) (d:ds) = if (c == d) then prefix cs ds else 0 == 2
blank l = let (n,rest) = indent l in rest == ""
eat = eat' . map indent . filter (not . blank)
eat' [] = []
-- eat' ((i,l):ls) = let e = (i:l)
indent line
= indent' 0 line
where indent' n (' ':cs) = indent' (n+1) cs
indent' n ('\t':cs) = indent' (8*(1+n/8)) cs
indent' n str = (n,str)
{- return the pieces of a string, where str is the separator -}
pieces :: String -> String -> [ String ]
pieces sep str
= case sep of
"" -> let x = "":x in x
(c:_)
-> pieces1 str (\x->x)
where
pieces1 str b
= case str of
"" -> [b ""]
_ -> let (bef,aft) = break (c ==) str
in
case aft of
"" -> [b bef]
_:aft'
-> if sep `prefix` aft
then let str' = drop (length sep) aft
in (b bef: pieces1 str' (\x->x))
else pieces1 aft' (b . (bef++) . (c:))
mybreak p str
= mybreak1 str (\x -> x)
where
mybreak1 str b
= case str of
"" -> [b ""]
(c:cs) -> if p c then (b "":mybreak1 cs (\x->x))
else mybreak1 cs (b . (c:))
sb p
= sb1 (\x->x)
where sb1 b str
= if (p str) then [(b "",str)]
else case str of
"" -> []
(c:cs) -> sb1 (b . (c:)) cs
{- experiments
upto c "" = ("","")
upto c
(ch:str) = upto1 c (ch:) str
where upto1 c b "" = (b "","")
upto1 c b (ch:str')
= if (c == ch)
then ( b "", str )
else upto1 c (b . (ch:)) str'
seq' p q str = let { (a,str') = p str ; (b,str'') = q str' } in (a++b,str'')
empty "" = 0 == 0
empty (c:cs) = 0 == 1
upto' "" str = ""
upto' (c:cs) "" = ""
upto' (c:cs) (d:ds) = if c == d then if prefix cs ds then ""
else d:upto' (c:cs) ds
else d : upto' (c:cs) ds
un a = \s -> (a,s)
bi p f = \s-> let { (a,s') = p s } in f a s'
{-\
script = cd `bi` \cod ->
rep (co `bi` \ com ->
cd `bi` \ cod ->
un (comm++fs) )
`bi` \rest ->
un (cod++rest)
cd = \ str ->
let x = upto "{-" str
str' = drop (length x) str
in (x,str')
co = \str ->
let y = upto "-}" str
str' = dtrop (length y) str
in (y,str')
rep p = \str ->
case str of
"" -> ("","")
(c:cs) ->
-}
-}