json-autotype-3.1.2: app/GenerateJSONParser.hs
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Main where
import Control.Applicative
import Control.Exception (assert)
import Control.Monad (forM_, when, unless)
import Data.Maybe
import Data.Monoid
import Data.List (partition)
import System.Exit
import System.IO (stdin, stderr, IOMode(..))
--import System.IO.Posix.MMap (mmapFileByteString)
import System.FilePath (splitExtension)
import System.Process (system)
import qualified Data.ByteString.Lazy.Char8 as BSL
import qualified Data.HashMap.Strict as Map
import Data.Aeson(Value(..), eitherDecode, encode, FromJSON(..), ToJSON(..))
import qualified Data.Text as Text
import qualified Data.Text.IO as Text
import qualified Data.Text.Encoding as Text(decodeUtf8)
import Data.Text (Text)
import Text.PrettyPrint.GenericPretty (pretty)
import Data.Version(showVersion)
import Data.Aeson.AutoType.CodeGen
import Data.Aeson.AutoType.Extract
import Data.Aeson.AutoType.Format
import Data.Aeson.AutoType.Split
import Data.Aeson.AutoType.Type
import Data.Aeson.AutoType.Util
import qualified Data.Yaml as Yaml
import Options.Applicative
import CommonCLI
import Paths_json_autotype
-- * Command line flags
data Options = Options {
tyOpts :: TypeOpts
, outputFilename :: FilePath
, typecheck :: Bool
, yaml :: Bool
, preprocessor :: Bool
, filenames :: [FilePath]
}
versionOption =
infoOption
(showVersion version)
(long "version" <> help "Show version")
optParser :: Parser Options
optParser =
versionOption <*> (
Options <$> tyOptParser
<*> strOption (short 'o' <>
long "output" <>
long "outputFilename" <> value "")
<*> unflag (short 'n' <>
long "no-typecheck" <> help "Do not typecheck after unification")
<*> switch (long "yaml" <> help "Parse inputs as YAML instead of JSON")
<*> switch (short 'p' <>
long "preprocessor" <>
help "Work as GHC preprocessor (and skip preprocessor pragma)")
<*> some (argument str (metavar "FILES..."))
)
-- | Report an error to error output.
report :: Text -> IO ()
report = Text.hPutStrLn stderr
-- | Report an error and terminate the program.
fatal :: Text -> IO ()
fatal msg = do report msg
exitFailure
-- | Extracts type from JSON file, along with the original @Value@.
-- In order to facilitate dealing with failures, it returns a triple of
-- @FilePath@, extracted @Type@, and a JSON @Value@.
extractTypeFromJSONFile :: Options -> FilePath -> IO (Maybe (FilePath, Type, Value))
extractTypeFromJSONFile opts inputFilename =
withFileOrHandle inputFilename ReadMode stdin $ \hInput ->
-- First we decode JSON input into Aeson's Value type
do Text.hPutStrLn stderr $ "Processing " `Text.append` Text.pack (show inputFilename)
decodedJSON :: Either Text Value <- decoder <$> BSL.hGetContents hInput
--let decodedJSON :: Maybe Value = decodeValue input
-- myTrace ("Decoded JSON: " ++ pretty decoded)
case decodedJSON of
Left err -> do report $ Text.concat ["Cannot decode JSON input from "
, Text.pack (show inputFilename)
, err
]
return Nothing
Right v -> do -- If decoding JSON was successful...
-- We extract type structure from the JSON value.
let t :: Type = extractType v
myTrace $ "Type: " ++ pretty t
(v `typeCheck` t) `unless` fatal ("Typecheck against base type failed for "
`Text.append` Text.pack inputFilename)
return $ Just (inputFilename, t, v)
where
decoder :: FromJSON v => BSL.ByteString -> Either Text v
decoder input | yaml opts = case Yaml.decodeEither' $ BSL.toStrict input of
Left exc -> Left $ Text.pack $ Yaml.prettyPrintParseException exc
Right r -> Right r
| otherwise = case eitherDecode input of
Left e -> Left $ Text.pack e
Right r -> Right r
-- | Works like @Debug.trace@ when the --debug flag is enabled, and does nothing otherwise.
myTrace :: String -> IO ()
myTrace msg = debug (tyOpts opts) `when` putStrLn msg
-- | Perform preprocessing of JSON input to drop initial pragma.
preprocess :: BSL.ByteString -> BSL.ByteString
preprocess | preprocessor opts = dropPragma
| otherwise = id
-- | Type checking all input files with given type,
-- and return a list of filenames for files that passed the check.
typeChecking :: Type -> [FilePath] -> [Value] -> IO [FilePath]
typeChecking ty inputFilenames values = do
unless (null failures) $ report $ Text.unwords $ "Failed to typecheck with unified type: ":
(Text.pack `map` failures)
when ( null successes) $ fatal "No files passed the typecheck."
return successes
where
checkedFiles = zip inputFilenames $ map (`typeCheck` ty) values
(map fst -> successes,
map fst -> failures) = partition snd checkedFiles
-- | Take a set of JSON input filenames, Haskell output filename, and generate module parsing these JSON files.
generateHaskellFromJSONs :: Options -> [FilePath] -> FilePath -> IO ()
generateHaskellFromJSONs opts@Options { tyOpts=TyOptions { toplevel
, lang
, test }
}
inputFilenames outputFilename = do
-- Read type from each file
(filenames,
typeForEachFile,
valueForEachFile) <- unzip3 . catMaybes <$> mapM (extractTypeFromJSONFile opts) inputFilenames
-- Unify all input types
when (null typeForEachFile) $ do
report "No valid JSON input file..."
exitFailure
let finalType = foldr1 unifyTypes typeForEachFile
passedTypeCheck <- if typecheck opts
then typeChecking finalType filenames valueForEachFile
else return filenames
-- We split different dictionary labels to become different type trees (and thus different declarations.)
let splitted = splitTypeByLabel toplevelName finalType
myTrace $ "SPLITTED: " ++ pretty splitted
assert (not $ any hasNonTopTObj $ Map.elems splitted) $ do
-- We compute which type labels are candidates for unification
let uCands = unificationCandidates splitted
myTrace $ "CANDIDATES:\n" ++ pretty uCands
when (suggest $ tyOpts opts) $ forM_ uCands $ \cs -> do
putStr "-- "
Text.putStrLn $ "=" `Text.intercalate` cs
-- We unify the all candidates or only those that have been given as command-line flags.
let unified = if autounify $ tyOpts opts
then unifyCandidates uCands splitted
else splitted
myTrace $ "UNIFIED:\n" ++ pretty unified
-- We start by writing module header
writeModule lang outputFilename toplevelName unified
when (test && (outputFilename /= "")) $
exitWith =<< runModule lang outputFilename passedTypeCheck
where
-- | Works like @Debug.trace@ when the --debug flag is enabled, and does nothing otherwise.
myTrace :: String -> IO ()
myTrace msg = debug (tyOpts opts) `when` putStrLn msg
toplevelName = capitalize $ Text.pack toplevel
-- | Drop initial pragma.
dropPragma :: BSL.ByteString -> BSL.ByteString
dropPragma input | "{-#" `BSL.isPrefixOf` input = BSL.dropWhile (/='\n') input
| otherwise = input
-- | Initialize flags, and run @generateHaskellFromJSONs@.
main :: IO ()
main = do opts <- execParser optInfo
generateHaskellFromJSONs opts (filenames opts) (outputFilename opts)
where
optInfo = info (optParser <**> helper)
( fullDesc
<> progDesc "Parser JSON or YAML, get its type, and generate appropriate parser."
<> header "json-autotype -- automatic type and parser generation from JSON")