{-# LANGUAGE CPP               #-}
{-# LANGUAGE TemplateHaskell   #-}
{-# LANGUAGE QuasiQuotes       #-}
{-# LANGUAGE OverloadedStrings #-}
-- | Wrappers for generating prologue and epilogue code in Haskell.
module JsonToType.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           JsonToType.Format
import           JsonToType.Type
import           JsonToType.CodeGen.Generic(src)
import           JsonToType.CodeGen.HaskellFormat
import           JsonToType.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 :: String
defaultHaskellFilename = String
"JSONTypes.hs"

-- | Generate module header
header :: Text -> Text
header :: Text -> Text
header Text
moduleName = Text
[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-to-type`.
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
<> Text
[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 a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text
"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 = [Text
"aeson", Text
"json-alt", Text
"base", Text
"bytestring", Text
"text"]

-- | List of modules to import
importedModules :: [ModuleImport]
importedModules :: [Text]
importedModules = [
    Text
"          System.Exit        (exitFailure, exitSuccess)"
  , Text
"          System.IO          (stderr, hPutStrLn)"
  , Text
"qualified Data.ByteString.Lazy.Char8 as BSL"
  , Text
"          System.Environment (getArgs)"
  , Text
"          Control.Monad      (forM_, mzero, join)"
  , Text
"          Control.Applicative"
  , Text
"          JsonToType.Alternative"
  , Text
"          Data.Aeson(eitherDecode, Value(..), FromJSON(..), ToJSON(..),pairs,(.:), (.:?), (.=), object)"
  , Text
"          Data.Monoid((<>))"
  , Text
"          Data.Text (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 Text
toplevelName = Text
[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
<> Text
[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
<> Text
[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 -> Text
forall a. Semigroup a => a -> a -> a
<> Text
[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 :: String -> Text -> HashMap Text Type -> IO ()
writeHaskellModule String
outputFilename Text
toplevelName HashMap Text Type
types =
    String -> IOMode -> Handle -> (Handle -> IO ()) -> IO ()
forall r. String -> IOMode -> Handle -> (Handle -> IO r) -> IO r
withFileOrHandle String
outputFilename IOMode
WriteMode Handle
stdout ((Handle -> IO ()) -> IO ()) -> (Handle -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Handle
hOut ->
      Bool -> IO () -> IO ()
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (String
extension String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
".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
$ String -> Text
Text.pack String
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
    (String
moduleName, String
extension) =
       (String -> String) -> (String, String) -> (String, String)
forall b c d. (b -> c) -> (b, d) -> (c, d)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first String -> String
normalizeTypeName'     ((String, String) -> (String, String))
-> (String, String) -> (String, String)
forall a b. (a -> b) -> a -> b
$
       String -> (String, String)
splitExtension               (String -> (String, String)) -> String -> (String, String)
forall a b. (a -> b) -> a -> b
$
       if     String
outputFilename String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"-"
         then String
defaultHaskellFilename
         else String
outputFilename
    normalizeTypeName' :: String -> String
normalizeTypeName' = Text -> String
Text.unpack (Text -> String) -> (String -> Text) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
normalizeTypeName (Text -> Text) -> (String -> Text) -> String -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
Text.pack

-- | Function to run Haskell module
--
--   FIXME: just rely on `run-haskell-module` exports
runHaskellModule :: FilePath -> [String] -> IO ExitCode
runHaskellModule :: String -> [String] -> IO ExitCode
runHaskellModule = String -> [String] -> 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 { Run.additionalPackages = ["json-alt", "aeson"]
                          }

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