diff options
Diffstat (limited to 'main.hs')
| -rw-r--r-- | main.hs | 130 |
1 files changed, 122 insertions, 8 deletions
@@ -1,31 +1,145 @@ module Main where import Control.Monad +import Data.Char +import Data.List import Data.Either import Data.Maybe import System.Console.Readline +import System.Exit +import System.IO +import qualified Data.Map.Strict as Map +import AST hiding (main) import Simplify import Parser import PrettyPrint +import Utility +import Debug -repl :: IO () -repl = do +trimlr :: String -> String +trimlr = reverse . dropWhile isSpace . reverse . dropWhile isSpace + +findstr :: String -> String -> Maybe Int +findstr pat sub = go sub 0 + where len = length pat + go :: String -> Int -> Maybe Int + go "" _ = Nothing + go sub i = if take len sub == pat then Just i else go (tail sub) (i+1) + +mayberead :: Read a => String -> Maybe a +mayberead s = + let r = reads s + ok = if null r then False else null $ snd $ head r + v = fst $ head r + in if ok then Just v else Nothing + +readrule :: String -> IO (AST,AST) +readrule line = do + let (patstr',(repstr')) = break (=='|') line + patstr = desugar $ trimlr patstr' + repstr = desugar $ trimlr $ tail repstr' + if null repstr' + then die $ "No pipe separator found: " ++ line + else do + let mpat = mayberead patstr :: Maybe AST + mrep = mayberead repstr :: Maybe AST + when (isNothing mpat) $ die $ "Could not parse pattern! (from '" ++ patstr ++ "')" + when (isNothing mrep) $ die $ "Could not parse replacement! (from '" ++ repstr ++ "')" + return (fromJust mpat,fromJust mrep) + +desugar :: String -> String +desugar "" = "" +desugar ('{':cs) = + let midx = findIndex (=='}') cs + idx = fromJust midx + termcap = head cs == '{' && length cs > idx+1 && cs !! (idx+1) == '}' + endidx = if termcap then idx+1 else idx + after = drop (endidx+1) cs + name' = if termcap then tail $ take (endidx-1) cs else take endidx cs + name = map (\c -> if c == '\\' || c == '"' then '_' else c) name' + in if isNothing midx + then '{':desugar cs + else if termcap + then let mcolonidx = findIndex (==':') name + colonidx = fromJust mcolonidx + precolon = take colonidx name + postcolon = drop (colonidx+1) name + stub = case postcolon of + "Number" -> "Number 42" + "Variable" -> "Variable \"\"" + _ -> trace postcolon undefined + in if isNothing mcolonidx + then "(CaptureTerm \"" ++ name ++ "\")" ++ desugar after + else "(CaptureConstr \"" ++ precolon ++ "\" (" ++ stub ++ "))" ++ desugar after + else "(Capture \"" ++ name ++ "\")" ++ desugar after +desugar (':':cs) = + let midx = findIndex (==':') cs + endidx = fromJust midx + after = drop (endidx+1) cs + name = map (\c -> if c == '\\' || c == '"' then '_' else c) $ take endidx cs + in if isNothing midx + then ':':desugar cs + else "Apply \"" ++ name ++ "\" " ++ desugar after +desugar (c:cs) = c : desugar cs + +readrules :: Handle -> IO (Map.Map String [(AST,AST)]) +readrules handle = liftM (uncurry fixincludes) $ go "general" Map.empty Map.empty + where + go :: String -- current section + -> Map.Map String [String] -- sections still to be included (#+) + -> Map.Map String [(AST,AST)] -- current rules db + -> IO (Map.Map String [(AST,AST)],Map.Map String [String]) -- (rules db,includes) + go sect includes db = hIsEOF handle >>= \eof -> if eof then return (db,includes) else do + line <- hGetLine handle + case take 3 line of + "" -> go sect includes db + "-- " -> go sect includes db + "## " -> go (trimlr $ drop 3 line) includes db + "#+ " -> go sect (Map.insertWith (++) sect [trimlr $ drop 3 line] includes) db + _ -> readrule (trimlr line) >>= \rule -> go sect includes (Map.insertWith (flip (++)) sect [rule] db) + + fixincludes :: Map.Map String [(AST,AST)] -- rules db + -> Map.Map String [String] -- to be included sections + -> Map.Map String [(AST,AST)] -- resulting rules db + fixincludes db includes = Map.foldlWithKey insertincludes db includes + where + insertincludes :: Map.Map String [(AST,AST)] -- db + -> String -- section + -> [String] -- sections to be included + -> Map.Map String [(AST,AST)] -- resulting db + insertincludes db sect incls = foldl (\db incl -> insertinclude db sect incl) db incls + where insertinclude db sect incl = Map.insertWith (++) sect (fromJust $ Map.lookup incl db) db + + +printrules :: [(AST,AST)] -> IO () +printrules db = sequence_ $ foldl (\l (pat,sub) -> l ++ [print pat,putStr " -> ",print sub]) [] db + + +repl :: Map.Map String [(AST,AST)] -> IO () +repl db = do mline <- readline "> " case mline of Nothing -> return () -- EOF - Just "" -> repl + Just "" -> repl db Just line -> do addHistory line let eexpr = parseExpression line either (putStrLn . ("Error: "++)) handleExpression eexpr - repl + repl db where + generaldb = fromJust $ Map.lookup "general" db + sanitisedb = fromJust $ Map.lookup "sanitise" db + displaydb = fromJust $ Map.lookup "display" db handleExpression expr = do - print expr - let sim = simplify expr - print sim + putStrLn $ prettyPrint expr + let sim = foldl (flip simplify) expr [generaldb,sanitisedb,displaydb] + putStrLn $ prettyPrint sim + main :: IO () -main = repl +main = do + rulesdb <- withFile "rules.txt" ReadMode readrules + --sequence_ $ Map.foldlWithKey (\l sect rules -> putStrLn ("## "++sect) : printrules rules : putStrLn "" : l) [] rulesdb + repl rulesdb |