{-# #-}

{- |
  Module      :  hstidy
  Copyright   :  (c) Matt Morrow 2008
  License     :  BSD3

  Maintainer  :  Matt Morrow <mjm2002@gmail.com>
  Stability   :  unstable
  Portability :  portable
-}

module Main where
import System.IO
import System.Exit
import System.Environment
import System.Console.GetOpt
import Language.Haskell.Exts.Syntax
import Language.Haskell.Exts.Parser
import Language.Haskell.Exts.Pretty

main :: IO ()
main = do
  (opts,_,_) <- return . getOpt Permute options =<< getArgs
  case opts of
    ModO:_  -> go parseHsModule
    ExpO:_  -> go parseHsExp
    PatO:_  -> go parseHsPat
    HelpO:_ -> goHelp
    VersO:_ -> goVersion
    _       -> go parseHsModule

go :: (Pretty a) => (String -> Either String a) -> IO ()
go p = either  (hPutStrLn stderr)
               (hPutStrLn stdout . prettyPrint)
           . p =<< getContents

goHelp :: IO ()
goHelp = putStrLn (usageInfo "hstidy" options)

goVersion :: IO ()
goVersion = putStrLn "0.1"

data Opt
  = HelpO
  | VersO
  | ModO
  | ExpO
  | PatO
  deriving (Eq,Ord,Show,Read)

options :: [OptDescr Opt]
options =
  [ Option ['h'] ["help"] (NoArg HelpO) "display help and usage information"
  , Option ['v','V'] ["version"] (NoArg VersO) "show version information"
  , Option ['m'] ["module"] (NoArg ModO) "tidy a module from stdin"
  , Option ['e'] ["expression"] (NoArg ExpO) "tidy an expression from stdin"
  , Option ['p'] ["pattern"] (NoArg PatO) "tidy a pattern from stdin"
  ]

-- HsModule SrcLoc Module (Maybe [HsExportSpec]) [HsImportDecl] [HsDecl]

parseHsModule :: String -> Either String HsModule
parseHsModule s =
  case parseModule s of
    ParseOk m -> Right m
    ParseFailed loc e ->
      let line = srcLine loc - 1
      in Left (unlines [show line,show loc,e])

parseHsDecls :: String -> Either String [HsDecl]
parseHsDecls s =
  let s' = unlines [pprHsModule (emptyHsModule "Main"), s]
  in case parseModule s' of
      ParseOk m -> Right (moduleDecls m)
      ParseFailed loc e ->
        let line = srcLine loc - 1
        in Left (unlines [show line,show loc,e])

parseHsExp :: String -> Either String HsExp
parseHsExp s =
  case parseHsDecls ("main = ("++(filter (/='\n') s)++")") of
    Left err -> Left err
    Right xs ->
      case [ e | HsPatBind _ _ (HsUnGuardedRhs e) _ <- xs] of
        []    -> Left "invalid expression"
        (e:_) -> Right e

parseHsPat :: String -> Either String HsPat
parseHsPat s =
  case parseHsDecls ("("++(filter (/='\n') s)++")=()") of
    Left err -> Left err
    Right xs ->
      case [ p | HsPatBind _ p _ _ <- xs] of
        []    -> Left "invalid pattern"
        (p:_) -> Right p

pprHsModule :: HsModule -> String
pprHsModule = prettyPrint

moduleDecls :: HsModule -> [HsDecl]
moduleDecls (HsModule _ _ _ _ x) = x

mkModule :: String -> Module
mkModule = Module

emptySrcLoc :: SrcLoc
emptySrcLoc = (SrcLoc [] 0 0)

emptyHsModule :: String -> HsModule
emptyHsModule n =
    (HsModule
        emptySrcLoc
        (mkModule n)
        Nothing
        []
        [])