import Data.List
import Layout
import Lexer
import System.Environment
import System.Exit
import System.IO
import Unlit

trans lineNumbers fname xs = f 0 xs where
    f n rs@(L (AlexPn _ l cp) _ _:_) | n /= l =
        (if l == n + 1 || not lineNumbers then (Token "\n":)
            else (Token ("{-# LINE " ++ show l ++ " " ++ show fname ++ " #-}"):))
                $ TokenNL cp:f l rs
    f n (L _ c s:rs@(L _ _ "{":_)) | s `elem` layoutStarters = Token s:f n rs
    f n (L _ c s:rs@(L (AlexPn _ _ cp) _ _:_)) | s `elem` layoutStarters =
        Token s:TokenVLCurly s cp:f n rs
    f n (L _ c s:rs) = Token s:f n rs
    f _ [] = []

showT (TokenVLCurly _ n) = "{" ++ show n ++"}"
showT (TokenNL n) = "(" ++ show n ++ ")"
showT (Token ('{':'-':s)) = '\n':'{':'-':s ++ "\n"
showT (Token s) = s

readHsFile rfn fn
    | "shl." `isPrefixOf` reverse fn = unlit rfn `fmap` readFile fn
    | otherwise = readFile fn

errorMsg = do
    putStrLn "Usage:"
    putStrLn "./getlaid [input files..]"
    putStrLn "./getlaidF [original file name] [output file name] [input file name]"
    putStrLn "./getlaidF is suitable for directly using from ghcs preprocessor -pgmF ./getlaidF"
    putStrLn "options.."
    putStrLn "    -l       omit line number annotations on output."
    putStrLn "    -t       print internal token stream rather than unlaid file."
    exitWith ExitSuccess

main = do
    as <- getArgs
    pnam <- fmap (take 1 . reverse) getProgName
    (as,os,[]) <- case parseOpt "lt" as of
        Left s -> do
            putStrLn s
            errorMsg
        Right s -> return s
    case as of
        [ofilename,infile,outfile] | "F" == pnam -> do
            hPutStrLn stderr $ "getlaid " ++ ofilename ++ ": " ++ infile ++ " -> " ++ outfile
            s <- readHsFile ofilename infile
            if "-- dontlay" `isPrefixOf` s
                then writeFile outfile s
                else writeFile outfile (f os ofilename s)
        ["-"] -> do
            s <- getContents
            putStr (f ('l':os) "(stdin)" s)
        xs@(_:_) | "F" /= pnam -> do
            flip mapM_ xs $ \infile -> do
                s <- readHsFile infile infile
                putStr (f os infile s)
        _ -> errorMsg

-- convert a string to a simplified token stream,
-- pulls out just the strings and line start positions from the lexeme stream
-- from alex
tokenize :: FilePath -> String -> String -> [Token]
tokenize fname options s = case scanner s of
        Right ss@(L _ LReservedId "module":_) -> trans ('l' `notElem` options) fname ss
        Right ss@(L (AlexPn _ _ cp) _ _:_) ->
            mainHeader ++ TokenVLCurly "where" cp:trans ('l' `notElem` options) fname ss
        Left s -> error $ "error parsing file: " ++ show s
        x -> error (show x)

f options fname s = unwords (map showT finished) ++ "\n" where
    tokens = tokenize fname options s
    finished = if 't' `elem` options then tokens else layout tokens []

mainHeader = [TokenNL 1] ++ map Token ["module","Main","(","main",")","where"]

-- | Process options with an option string like the standard C getopt function call.
parseOpt :: Monad m =>
    String -- ^ Argument string, list of valid options with : after ones which accept an argument
    -> [String]  -- ^ Arguments
    -> m ([String],[Char],[(Char,String)])  -- ^ (non-options,flags,options with arguments)
parseOpt ps as = f ([],[],[]) as where
    (args,oargs) = g ps [] [] where
        g (':':_) _ _ = error "getOpt: Invalid option string"
        g (c:':':ps) x y = g ps x (c:y)
        g (c:ps) x y = g ps (c:x) y
        g [] x y = (x,y)
    f cs [] = return cs
    f (xs,ys,zs) ("--":rs) = return (xs ++ rs, ys, zs)
    f cs (('-':as@(_:_)):rs) = z cs as where
        z (xs,ys,zs) (c:cs)
            | c `elem` args = z (xs,c:ys,zs) cs
            | c `elem` oargs = case cs of
                [] -> case rs of
                    (x:rs) -> f (xs,ys,(c,x):zs) rs
                    [] -> fail $ "Option requires argument: " ++ [c]
                x -> f (xs,ys,(c,x):zs) rs
            | otherwise = fail $ "Invalid option: " ++ [c]
        z cs [] = f cs rs
    f (xs,ys,zs) (r:rs) = f (xs ++ [r], ys, zs) rs