module Main where

import Control.Monad
import Data.Char
import Data.List
import Data.Maybe
import System.Console.Readline
import System.Exit
import System.IO
import qualified Data.Map.Strict as Map

import AST
import Simplify
import Parser
import PrettyPrint
import Debug


trimlr :: String -> String
trimlr = reverse . dropWhile isSpace . reverse . dropWhile isSpace

findstr :: String -> String -> Maybe Int
findstr pat topsub = go topsub 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 topdb includes = Map.foldlWithKey insertincludes topdb 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