{-# LANGUAGE ScopedTypeVariables #-}
module Fun.Compiler where

import           Control.Exception
import           Fun.Generator
import           Fun.Grammar
import           Fun.Parser
import           Fun.Syntax
import           Fun.Tree
import           System.Exit
import           System.IO
import           Text.Read

traceBranch :: Int -> Trace -> String
traceBranch c (StringTrace t) = "\n" ++ (replicate c ' ') ++ t
traceBranch c (OrTrace t1 t2) =
  "\n"
    ++ (replicate c ' ')
    ++ "<either>"
    ++ (traceTree (c + 2) t1)
    ++ (traceTree (c + 2) t2)

traceTree :: Int -> [Trace] -> String -- TODO: Indent/arrow first map
traceTree c ts = foldr join "" $ map (traceBranch c) ts
  where join = (\a b -> a ++ if b == "" then b else " " ++ b)

genTrace :: [Trace] -> String
genTrace ts = "Trace of expectance:\n" ++ traceTree 0 ts

parse :: String -> Either String Program
parse s = case program s of
  Left a -> Left $ "Parse error!\n" ++ case a of
    State [] Nothing    -> "No context available"
    State t  Nothing    -> genTrace t
    State [] (Just str) -> "Around here:\n" ++ str
    State t  (Just str) -> genTrace t ++ "\nAround here:\n" ++ str
  Right (a, b) -> Right a

check :: Tree -> Either String Tree
check t = case checkTree t of
  Left  a -> Left $ "Syntax error!\n" ++ (join a)
  Right a -> Right a
 where
  join = foldr (\(SyntaxError a) b -> a ++ if b == "" then b else "\n" ++ b) ""

generate :: Tree -> Either String String
generate t = case generateAsm t of
  Left  (GenerateError a) -> Left $ "Error while generating ASM!\n" ++ a
  Right a                 -> Right a

failExit :: String -> IO ()
failExit err = do
  hPutStrLn stderr err
  exitWith (ExitFailure 1)

compile :: [String] -> IO ()
compile paths = do
  files <- sequence
    $ map (\p -> try $ readFile p :: IO (Either IOError String)) paths
  case sequence files of -- TODO: Improve this left/right chain
    Left  exception -> print (exception :: IOError)
    Right files     -> case sequence $ map parse files of
      Left  err -> failExit err
      Right ps  -> case check (Tree ps) >>= generate of
        Left  err -> failExit err
        Right gen -> putStrLn gen