From af425841a63ee73603cc09510d95a36e646ddafd Mon Sep 17 00:00:00 2001 From: Tom Smeding Date: Thu, 19 Apr 2018 11:45:46 +0200 Subject: Build with stack --- Main.hs | 145 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 145 insertions(+) create mode 100644 Main.hs (limited to 'Main.hs') diff --git a/Main.hs b/Main.hs new file mode 100644 index 0000000..b908807 --- /dev/null +++ b/Main.hs @@ -0,0 +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 + + +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 db + Just line -> do + addHistory line + let eexpr = parseExpression line + either (putStrLn . ("Error: "++)) handleExpression eexpr + repl db + where + generaldb = fromJust $ Map.lookup "general" db + sanitisedb = fromJust $ Map.lookup "sanitise" db + displaydb = fromJust $ Map.lookup "display" db + handleExpression expr = do + putStrLn $ prettyPrint expr + let sim = foldl (flip simplify) expr [generaldb,sanitisedb,displaydb] + putStrLn $ prettyPrint sim + + +main :: IO () +main = do + rulesdb <- withFile "rules.txt" ReadMode readrules + --sequence_ $ Map.foldlWithKey (\l sect rules -> putStrLn ("## "++sect) : printrules rules : putStrLn "" : l) [] rulesdb + repl rulesdb -- cgit v1.2.3-54-g00ecf