Miscellany

import Data.List
import Data.Char

doSubst :: (String, String) -> String -> (Bool, String, String)
doSubst subst str = doSubst' subst str

doSubst' :: (String, String) -> String -> (Bool, String, String)
doSubst' _ [] = (False, "", [])
doSubst' (from, to) target@(t:ts) = if from `isPrefixOf` target
	then if head to == '~'
		then (True, tail to, drop (length from) target)
		else (True, "", to ++ drop (length from) target)
	else let (b, o, s) = doSubst' (from, to) ts in (b, o, t:s)

runThue :: [(String, String)] -> String -> ([String], String)
runThue substs init = runThue' substs init []

runThue' :: [(String, String)] -> String -> [String] -> ([String], String)
runThue' substs init out = case runThue'' substs init [] False of
	(False, _, _) -> (out, init)
	(True, newout, newinit) -> runThue' substs newinit (out++newout)

runThue'' :: [(String, String)] -> String -> [String] -> Bool -> (Bool, [String], String)
runThue'' [] init out sure = (sure, out, init)
runThue'' (subst:substs) init out sure = case doSubst subst init of
	(False, _, _) -> runThue'' substs init out sure
	(True, outinc, newinit) -> if outinc == ""
		then runThue'' substs newinit out True
		else runThue'' substs newinit (out ++ [outinc]) True

dropAllWS :: [String] -> [String]
dropAllWS strs = filter (\str -> str /= "") $ map (\str -> filter (\chr -> and [chr /= ' ', chr /= '\n']) str) strs

pairUp :: [String] -> [(String, String)]
pairUp str = pairUp' str []

pairUp' :: [String] -> [(String, String)] -> [(String, String)]
pairUp' (a:b:str) pairs = pairUp' str ((a, b):pairs)
pairUp' [] pairs = pairs

removeRedundantLfs :: String -> String
removeRedundantLfs str = removeRedundantLfs' str "" True

removeRedundantLfs' :: String -> String -> Bool -> String
removeRedundantLfs' "" acc _ = acc
removeRedundantLfs' (fst:rst) acc lastwaslf =
	if and [fst=='\n', lastwaslf]
		then removeRedundantLfs' rst acc True
		else removeRedundantLfs' rst (acc++[fst]) (fst=='\n')

toTokens :: String -> [String]
toTokens str = toTokens' str [] ""

toTokens' :: String -> [String] -> String -> [String]
toTokens' [] tokens lasttoken = tokens ++ [lasttoken]
toTokens' (fst:rest) tokens lasttoken = if "::=" `isPrefixOf` rest
	then toTokens' (drop 3 rest) (tokens ++ [lasttoken ++ [fst]]) ""
	else if "\n" `isPrefixOf` rest
		then toTokens' (drop 1 rest) (tokens ++ [lasttoken ++ [fst]]) ""
		else toTokens' rest tokens (lasttoken ++ [fst])

finalize :: [(String, String)] -> ([(String, String)], String)
finalize strs = let clean = strs in
	((tail clean), snd $ head clean) -- first rule should be ("::=", initial string)

main = do
	putStr "Input file: "
	ifile <- getLine
	s <- readFile ifile
	let parsed =finalize $ pairUp $ dropAllWS $ toTokens $ removeRedundantLfs s in
		let result = runThue (fst parsed) (snd parsed) in
			print result