{-# LANGUAGE CPP               #-}
{-# LANGUAGE TemplateHaskell   #-}
{-# LANGUAGE QuasiQuotes       #-}
{-# LANGUAGE OverloadedStrings #-}
-- | Wrappers for generating prologue and epilogue code in Haskell.
module Data.Aeson.AutoType.CodeGen.Haskell(
    writeHaskellModule
  , runHaskellModule
  , runHaskellModuleStrict
  , defaultHaskellFilename
  , importedModules
  , requiredPackages
  , generateModuleImports
  , ModuleImport
  ) where

import qualified Data.Text           as Text
import qualified Data.Text.IO        as Text
import           Data.Text hiding (unwords)
import qualified Data.HashMap.Strict as Map
import           Control.Arrow               (first)
import           Control.Exception (assert)
import           Data.Default
import           Data.Monoid                 ((<>))
import           System.FilePath
import           System.IO
import           System.Process                 (system)
import qualified System.Environment             (lookupEnv)
import           System.Exit                    (ExitCode)

import           Data.Aeson.AutoType.Format
import           Data.Aeson.AutoType.Type
import           Data.Aeson.AutoType.CodeGen.Generic(src)
import           Data.Aeson.AutoType.CodeGen.HaskellFormat
import           Data.Aeson.AutoType.Util

import qualified Language.Haskell.RunHaskellModule as Run

-- | Default output filname is used, when there is no explicit output file path, or it is "-" (stdout).
-- Default module name is consistent with it.
defaultHaskellFilename :: FilePath
defaultHaskellFilename :: FilePath
defaultHaskellFilename = "JSONTypes.hs"

-- | Generate module header
header :: Text -> Text
header :: Text -> Text
header moduleName :: Text
moduleName = [src|
{-# LANGUAGE TemplateHaskell     #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE RecordWildCards     #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE TypeOperators       #-}
{-# LANGUAGE DeriveGeneric       #-}
-- | DO NOT EDIT THIS FILE MANUALLY!
--   It was automatically generated by `json-autotype`.
module |] Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
capitalize Text
moduleName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [src| where
|] Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
generateModuleImports [Text]
importedModules

-- | Alias for indicating that this is item in module imports list.
type ModuleImport = Text

-- | Given a list of imports, generate source code.
generateModuleImports :: [ModuleImport] -> Text
generateModuleImports :: [Text] -> Text
generateModuleImports  = [Text] -> Text
Text.unlines
                       ([Text] -> Text) -> ([Text] -> [Text]) -> [Text] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Text) -> [Text] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ("import " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>)

-- | List of packages required by modules below.
--   Keep and maintain together.
requiredPackages :: [Text]
requiredPackages :: [Text]
requiredPackages = ["aeson", "json-alt", "base", "bytestring", "text"]

-- | List of modules to import
importedModules :: [ModuleImport]
importedModules :: [Text]
importedModules = [
    "          System.Exit        (exitFailure, exitSuccess)"
  , "          System.IO          (stderr, hPutStrLn)"
  , "qualified Data.ByteString.Lazy.Char8 as BSL"
  , "          System.Environment (getArgs)"
  , "          Control.Monad      (forM_, mzero, join)"
  , "          Control.Applicative"
  , "          Data.Aeson.AutoType.Alternative"
  , "          Data.Aeson(eitherDecode, Value(..), FromJSON(..), ToJSON(..),pairs,(.:), (.:?), (.=), object)"
  , "          Data.Monoid((<>))"
  , "          Data.Text (Text)"
  , "qualified GHC.Generics"
  ]

-- | Epilogue for generated code:
--
--   * function to use parser to get data from `Text`
--   * main function in case we use `runghc` for testing parser immediately
epilogue :: Text -> Text
epilogue :: Text -> Text
epilogue toplevelName :: Text
toplevelName = [src|

-- | Use parser to get |] Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
toplevelName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [src| object
parse :: FilePath -> IO |] Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
toplevelName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [src|
parse filename = do
    input <- BSL.readFile filename
    case eitherDecode input of
      Left errTop -> fatal $ case (eitherDecode input :: Either String Value) of
                           Left  err -> "Invalid JSON file: " ++ filename ++ "\n   " ++ err
                           Right _   -> "Mismatched JSON value from file: " ++ filename
                                     ++ "\n" ++ errTop
      Right r     -> return (r :: |] Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
toplevelName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ")" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [src|
  where
    fatal :: String -> IO a
    fatal msg = do hPutStrLn stderr msg
                   exitFailure

-- | For quick testing
main :: IO ()
main = do
  filenames <- getArgs
  forM_ filenames (\f -> parse f >>= (\p -> p `seq` putStrLn $ "Successfully parsed " ++ f))
  exitSuccess
|]

-- | Write a Haskell module to an output file, or stdout if `-` filename is given.
writeHaskellModule :: FilePath -> Text -> Map.HashMap Text Type -> IO ()
writeHaskellModule :: FilePath -> Text -> HashMap Text Type -> IO ()
writeHaskellModule outputFilename :: FilePath
outputFilename toplevelName :: Text
toplevelName types :: HashMap Text Type
types =
    FilePath -> IOMode -> Handle -> (Handle -> IO ()) -> IO ()
forall r. FilePath -> IOMode -> Handle -> (Handle -> IO r) -> IO r
withFileOrHandle FilePath
outputFilename IOMode
WriteMode Handle
stdout ((Handle -> IO ()) -> IO ()) -> (Handle -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \hOut :: Handle
hOut ->
      Bool -> IO () -> IO ()
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (FilePath
extension FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== ".hs") (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        Handle -> Text -> IO ()
Text.hPutStrLn Handle
hOut (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> Text
header (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ FilePath -> Text
Text.pack FilePath
moduleName
        -- We write types as Haskell type declarations to output handle
        Handle -> Text -> IO ()
Text.hPutStrLn Handle
hOut (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ HashMap Text Type -> Text
displaySplitTypes HashMap Text Type
types
        Handle -> Text -> IO ()
Text.hPutStrLn Handle
hOut (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> Text
epilogue Text
toplevelName
  where
    (moduleName :: FilePath
moduleName, extension :: FilePath
extension) =
       (FilePath -> FilePath)
-> (FilePath, FilePath) -> (FilePath, FilePath)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first FilePath -> FilePath
normalizeTypeName'     ((FilePath, FilePath) -> (FilePath, FilePath))
-> (FilePath, FilePath) -> (FilePath, FilePath)
forall a b. (a -> b) -> a -> b
$
       FilePath -> (FilePath, FilePath)
splitExtension               (FilePath -> (FilePath, FilePath))
-> FilePath -> (FilePath, FilePath)
forall a b. (a -> b) -> a -> b
$
       if     FilePath
outputFilename FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== "-"
         then FilePath
defaultHaskellFilename
         else FilePath
outputFilename
    normalizeTypeName' :: FilePath -> FilePath
normalizeTypeName' = Text -> FilePath
Text.unpack (Text -> FilePath) -> (FilePath -> Text) -> FilePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
normalizeTypeName (Text -> Text) -> (FilePath -> Text) -> FilePath -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Text
Text.pack

-- | Function to run Haskell module
--
--   FIXME: just rely on `run-haskell-module` exports
runHaskellModule :: FilePath -> [String] -> IO ExitCode
runHaskellModule :: FilePath -> [FilePath] -> IO ExitCode
runHaskellModule = FilePath -> [FilePath] -> IO ExitCode
Run.runHaskellModule

-- | Options to be used when running Haskell module
defaultHaskellOpts :: Run.RunOptions
defaultHaskellOpts :: RunOptions
defaultHaskellOpts  = RunOptions
forall a. Default a => a
def { additionalPackages :: [FilePath]
Run.additionalPackages = ["json-alt", "aeson"]
                          }

-- | Run Haskell module with strict warning options (each warning is an error)
runHaskellModuleStrict :: FilePath -> [String] -> IO ExitCode
runHaskellModuleStrict :: FilePath -> [FilePath] -> IO ExitCode
runHaskellModuleStrict = RunOptions -> FilePath -> [FilePath] -> IO ExitCode
Run.runHaskellModule' RunOptions
opts
  where
      opts :: RunOptions
opts = RunOptions
forall a. Default a => a
def { compileArgs :: [FilePath]
Run.compileArgs = ["-Wall", "-Werror"]}