json-autotype 2.0.0 → 3.0.0

raw patch · 39 files changed

+2100/−2040 lines, 39 filesdep +json-altdep +json-autotypedep +template-haskelldep ~aesonPVP ok

version bump matches the API change (PVP)

Dependencies added: json-alt, json-autotype, template-haskell

Dependency ranges changed: aeson

API changes (from Hackage documentation)

Files

• CommonCLI.hs +0/−39
• Data/Aeson/AutoType/Alternative.hs +0/−47
• Data/Aeson/AutoType/CodeGen.hs +0/−39
• Data/Aeson/AutoType/CodeGen/Elm.hs +0/−67
• Data/Aeson/AutoType/CodeGen/ElmFormat.hs +0/−313
• Data/Aeson/AutoType/CodeGen/Haskell.hs +0/−116
• Data/Aeson/AutoType/CodeGen/HaskellFormat.hs +0/−284
• Data/Aeson/AutoType/Extract.hs +0/−157
• Data/Aeson/AutoType/Format.hs +0/−17
• Data/Aeson/AutoType/Pretty.hs +0/−53
• Data/Aeson/AutoType/Split.hs +0/−143
• Data/Aeson/AutoType/Test.hs +0/−92
• Data/Aeson/AutoType/Type.hs +0/−155
• Data/Aeson/AutoType/Util.hs +0/−34
• GenerateJSONParser.hs +0/−175
• GenerateTestJSON.hs +0/−200
• README.md +12/−4
• app/GenerateJSONParser.hs +193/−0
• changelog.md +16/−0
• common/CommonCLI.hs +39/−0
• examples/colors.json +15/−0
• examples/union.json +14/−0
• json-autotype.cabal +86/−95
• src/Data/Aeson/AutoType/CodeGen.hs +39/−0
• src/Data/Aeson/AutoType/CodeGen/Elm.hs +67/−0
• src/Data/Aeson/AutoType/CodeGen/ElmFormat.hs +316/−0
• src/Data/Aeson/AutoType/CodeGen/Generic.hs +13/−0
• src/Data/Aeson/AutoType/CodeGen/Haskell.hs +116/−0
• src/Data/Aeson/AutoType/CodeGen/HaskellFormat.hs +284/−0
• src/Data/Aeson/AutoType/Extract.hs +164/−0
• src/Data/Aeson/AutoType/Format.hs +17/−0
• src/Data/Aeson/AutoType/Pretty.hs +48/−0
• src/Data/Aeson/AutoType/Split.hs +144/−0
• src/Data/Aeson/AutoType/Test.hs +92/−0
• src/Data/Aeson/AutoType/Type.hs +157/−0
• src/Data/Aeson/AutoType/Util.hs +34/−0
• test/GenerateTestJSON.hs +191/−0
• test/TestExamples.hs +42/−10
• test/TestQC.hs +1/−0

@@ -1,39 +0,0 @@-module CommonCLI(TypeOpts(..), unflag, tyOptParser) where---import           Data.Monoid                    ((<>))-import           Options.Applicative-import           System.Process                 (system)-import qualified System.Environment             (lookupEnv)-import           System.Exit                    (ExitCode)--import           Data.Aeson.AutoType.CodeGen    (Lang(..))--data TypeOpts = TyOptions {-                  autounify :: Bool-                , toplevel  :: String-                , debug     :: Bool-                , test      :: Bool-                , suggest   :: Bool-                , lang      :: Lang-                }--unflag :: Mod FlagFields Bool -> Parser Bool-unflag  = flag True False--tyOptParser :: Parser TypeOpts-tyOptParser  = TyOptions-            <$> unflag (long "no-autounify" <> help "Do not automatically unify suggested candidates")-            <*> strOption (short 't'        <>-                           long "toplevel"  <> value "TopLevel"-                                            <> help "Name for toplevel data type")-            <*> switch (long "debug"        <> help "Set this flag to see more debugging info"       )-            <*> unflag (long "no-test"      <> help "Do not run generated parser afterwards"         )-            <*> unflag (long "no-suggest"   <> help "Do not suggest candidates for unification"      )-            <*> langOpts---langOpts :: Parser Lang-langOpts  =  flag Haskell Haskell (long "haskell")-         <|> flag Haskell Elm     (long "elm")-

@@ -1,47 +0,0 @@-{-# LANGUAGE TypeOperators #-}--- | This module defines data type (a :|: b) that behaves all like @Either@,--- except that has no tag in JSON representation as used by @FromJSON@ and @ToJSON@.-module Data.Aeson.AutoType.Alternative(-    (:|:)(..)-  , toEither, fromEither-  , alt-  ) where--import Data.Aeson-import Control.Applicative---- | Data type (a :|: b) that behaves all like @Either@,--- except that has no tag in JSON representation as used by @FromJSON@ and @ToJSON@.-data a :|: b = AltLeft  a-             | AltRight b-  deriving(Show,Eq,Ord)-infixr 5 :|:---- | Convert to @Either@ datatype.-toEither :: a :|: b -> Either a b-toEither (AltLeft  a) = Left  a-toEither (AltRight b) = Right b-{-# INLINE toEither #-}---- | Convert from @Either@ datatype.-fromEither :: Either a b -> a :|: b-fromEither (Left  a) = AltLeft  a-fromEither (Right b) = AltRight b-{-# INLINE fromEither #-}---- | Deconstruct the type with two functions corresponding to constructors.--- This is like @either@.-alt :: (a -> c) -> (b -> c) -> a :|: b -> c-alt f _ (AltLeft  a) = f a-alt _ g (AltRight b) = g b--instance (ToJSON a, ToJSON b) => ToJSON (a :|: b) where-    toJSON (AltLeft  a) = toJSON a-    toJSON (AltRight b) = toJSON b-    {-# INLINE toJSON #-}--instance (FromJSON a, FromJSON b) => FromJSON (a :|: b) where-    parseJSON input = (AltLeft  <$> parseJSON input) <|>-                      (AltRight <$> parseJSON input) <|>-                      fail ("Neither alternative was found for: " ++ show input)-    {-# INLINE parseJSON #-}

@@ -1,39 +0,0 @@-{-# LANGUAGE CPP               #-}-{-# LANGUAGE OverloadedStrings #-}--- | Code generation and test running in different languages. (Switchbox.)-module Data.Aeson.AutoType.CodeGen(-    Lang(..)-  , writeModule-  , runModule-  , defaultOutputFilename-  ) where--import           Data.Text(Text)-import qualified Data.HashMap.Strict as Map-import           Data.Aeson.AutoType.Type--import           Data.Aeson.AutoType.CodeGen.Haskell-import           Data.Aeson.AutoType.CodeGen.Elm---- | Available output languages.-data Lang = Haskell-          | HaskellStrict-          | Elm---- | Default output filname is used, when there is no explicit output file path, or it is "-" (stdout).--- Default module name is consistent with it.-defaultOutputFilename :: Lang -> FilePath-defaultOutputFilename Haskell       = defaultHaskellFilename-defaultOutputFilename HaskellStrict = defaultHaskellFilename-defaultOutputFilename Elm           = defaultElmFilename---- | Write a Haskell module to an output file, or stdout if `-` filename is given.-writeModule :: Lang -> FilePath -> Text -> Map.HashMap Text Type -> IO ()-writeModule Haskell       = writeHaskellModule-writeModule HaskellStrict = writeHaskellModule-writeModule Elm           = writeElmModule---- | Run module in a given language.-runModule Haskell       = runHaskellModule-runModule HaskellStrict = runHaskellModuleStrict-runModule Elm           = runElmModule

@@ -1,67 +0,0 @@-{-# LANGUAGE CPP               #-}-{-# LANGUAGE OverloadedStrings #-}--- | Wrappers for generating prologue and epilogue code in Haskell.-module Data.Aeson.AutoType.CodeGen.Elm(-    defaultElmFilename-  , writeElmModule-  , runElmModule-  ) where--import qualified Data.Text           as Text-import qualified Data.Text.IO        as Text-import           Data.Text-import qualified Data.HashMap.Strict as Map-import           Control.Arrow               (first)-import           Control.Exception (assert)-import           Data.Monoid                 ((<>))-import           System.FilePath-import           System.IO-import           System.Process                 (system)-import           System.Exit                    (ExitCode)--import           Data.Aeson.AutoType.Format-import           Data.Aeson.AutoType.Type-import           Data.Aeson.AutoType.Util-import           Data.Aeson.AutoType.CodeGen.ElmFormat--import Debug.Trace(trace)--defaultElmFilename = "JSONTypes.elm"--header :: Text -> Text-header moduleName = Text.unlines [-   Text.unwords ["module ", capitalize moduleName, " exposing(..)"]-  ,""-  ,"-- elm-package install toastal/either"-  ,"-- elm-package install NoRedInk/elm-decode-pipeline"-  ,"import Either               exposing (Either, unpack)"-  ,"import Json.Encode          exposing (..)"-  ,"import Json.Decode          exposing (..)"-  ,"import Json.Decode.Pipeline exposing (..)"-  ,""]--epilogue :: Text -> Text-epilogue toplevelName = Text.unlines []---- | Write a Haskell module to an output file, or stdout if `-` filename is given.-writeElmModule :: FilePath -> Text -> Map.HashMap Text Type -> IO ()-writeElmModule outputFilename toplevelName types =-    withFileOrHandle outputFilename WriteMode stdout $ \hOut ->-      assert (trace extension extension == ".elm") $ do-        Text.hPutStrLn hOut $ header $ Text.pack moduleName-        -- We write types as Haskell type declarations to output handle-        Text.hPutStrLn hOut $ displaySplitTypes types-        Text.hPutStrLn hOut $ epilogue toplevelName-  where-    (moduleName, extension) =-       first normalizeTypeName'     $-       splitExtension               $-       if     outputFilename == "-"-         then defaultElmFilename-         else outputFilename-    normalizeTypeName' = Text.unpack . normalizeTypeName . Text.pack--runElmModule :: [String] -> IO ExitCode-runElmModule arguments = do-    hPutStrLn stderr "Compiling *not* running Elm module for a test."-    system $ Prelude.unwords $ ["elm", "make", Prelude.head arguments] -- ignore parsing args

@@ -1,313 +0,0 @@-{-# LANGUAGE CPP                 #-}-{-# LANGUAGE TemplateHaskell     #-}-{-# LANGuaGE ScopedTypeVariables #-}-{-# LANGUAGE ViewPatterns        #-}-{-# LANGUAGE OverloadedStrings   #-}-{-# LANGuaGE DeriveGeneric       #-}-{-# LANGuaGE FlexibleContexts    #-}--- | Formatting type declarations and class instances for inferred types.-module Data.Aeson.AutoType.CodeGen.ElmFormat(-  displaySplitTypes,-  normalizeTypeName) where--import           Control.Arrow             ((&&&))-import           Control.Applicative       ((<$>), (<*>))-import           Control.Lens.TH-import           Control.Lens-import           Control.Monad             (forM)-import           Control.Exception(assert)-import qualified Data.HashMap.Strict        as Map-import           Data.Monoid-import qualified Data.Set                   as Set-import qualified Data.Text                  as Text-import           Data.Text                 (Text)-import           Data.Set                  (Set, toList)-import           Data.List                 (foldl1')-import           Data.Char                 (isAlpha, isDigit)-import           Control.Monad.State.Class-import           Control.Monad.State.Strict(State, runState)-import           GHC.Generics              (Generic)--import           Data.Aeson.AutoType.Type-import           Data.Aeson.AutoType.Extract-import           Data.Aeson.AutoType.Split-import           Data.Aeson.AutoType.Format-import           Data.Aeson.AutoType.Util  ()----import           Debug.Trace -- DEBUG-trace _ x = x--fst3 ::  (t, t1, t2) -> t-fst3 (a, _b, _c) = a--data DeclState = DeclState { _decls   :: [Text]-                           , _counter :: Int-                           }-  deriving (Eq, Show, Ord, Generic)--makeLenses ''DeclState--type DeclM = State DeclState--type Map k v = Map.HashMap k v--stepM :: DeclM Int-stepM = counter %%= (\i -> (i, i+1))--tShow :: (Show a) => a -> Text-tShow = Text.pack . show---- | Wrap a type alias.-wrapAlias :: Text -> Text -> Text-wrapAlias identifier contents = Text.unwords ["type alias ", identifier, "=", contents]---- | Wrap a data type declaration-wrapDecl ::  Text -> Text -> Text-wrapDecl identifier contents = Text.unlines [header, contents, "  }"]-                                            --,"\nderiveJSON defaultOptions ''" `Text.append` identifier]-  where-    header = Text.concat ["type alias ", identifier, " = ", " { "]---- | Explanatory type alias for making declarations--- First element of the triple is original JSON identifier,--- second element of the triple is the mapped identifier name in Haskell.--- third element of the triple shows the type in a formatted way-type MappedKey = (Text, Text, Text, Type, Bool)---- | Make Decoder declaration, given identifier (object name in Haskell) and mapping of its keys--- from JSON to Haskell identifiers *in the same order* as in *data type declaration*.-makeDecoder ::  Text -> [MappedKey] -> Text-makeDecoder identifier contents =-  Text.unlines [-      Text.concat  [decodeIdentifier, " : Json.Decode.Decoder ", identifier]-    , Text.concat  [decodeIdentifier, " ="]-    , Text.unwords ["    Json.Decode.Pipeline.decode", identifier]-    , Text.unlines (makeParser identifier <$> contents) ]-  where-    decodeIdentifier         = decoderIdent identifier-    makeParser identifier (jsonId, _, _, ty, isOptional) = Text.unwords [-          "  |>"-        , if isOptional-             then "Json.Decode.Pipeline.optional"-             else "Json.Decode.Pipeline.required"-        , Text.concat ["\"", jsonId, "\""]-        , "(" <> getDecoder ty <> ")"] -- quote--getDecoder  TString    = "Json.Decode.string"-getDecoder  TNum       = "Json.Decode.float"-getDecoder  TBool      = "Json.Decode.bool"-getDecoder (TArray  t) = "Json.Decode.list (" <> getDecoder t <> ")"-getDecoder (TLabel  l) = decoderIdent l-getDecoder (TObj    o) = error   "getDecoder cannot handle complex object types!"-getDecoder (TUnion  u) = case nonNull of-                           []  -> "Json.Decode.value"-                           [x] -> getDecoder x-                           _   -> foldl1' altDecoder $ map getDecoder nonNull-  where-    nonNull = nonNullComponents u---error $ "getDecoder cannot yet handle union types:" <> show u--altDecoder a b = "(Json.Decode.oneOf [Json.Decode.map Either.Left ("-              <> a <> "), Json.Decode.map Either.Right ("-              <> b <> ")])"-{-Json.Decode.Pipeline.decode Something-"Json.Decode.Pipeline " <>-}-                     --decoderIdent ident = "decode" <> capitalize (normalizeTypeName ident)--- Contents example for wrapFromJSON:--- " <$>---"                           v .: "hexValue"  <*>---"                           v .: "colorName\""--encoderIdent ident = "encode" <> capitalize (normalizeTypeName ident)---- | Make Encoder declaration, given identifier (object name in Haskell) and mapping of its keys--- from JSON to Haskell identifiers in the same order as in declaration-makeEncoder :: Text -> [MappedKey] -> Text-makeEncoder identifier contents =-    Text.unlines [-        Text.unwords [encoderIdent identifier, ":", identifier, "->", "Json.Encode.Value"]-      , encoderIdent identifier <> " record ="-      , "    Json.Encode.object ["-      , "        " <> (joinWith "\n      , " (makeEncoder <$> contents))-      , "    ]"-      ]-  where-    makeEncoder (jsonId, haskellId, _typeText, ty, _nullable) = Text.concat [-            "(", tShow jsonId, ", (", getEncoder ty, ") record.", normalizeFieldName identifier jsonId, ")"-        ]-    --"answers",  Json.Encode.list <| List.map encodeAnswer <| record.answers-    escapeText = Text.pack . show . Text.unpack--getEncoder :: Type -> Text-getEncoder  TString   = "Json.Encode.string"-getEncoder  TNum      = "Json.Encode.float"-getEncoder  TBool     = "Json.Encode.bool"-getEncoder  TNull     = "identity"-getEncoder (TLabel l) = encoderIdent l-getEncoder (TArray e) = "Json.Encode.list << List.map (" <> getEncoder e <> ")"-getEncoder (TObj   o) = error $ "Seeing direct object encoder: "         <> show o-getEncoder (TUnion u) = case nonNull of-                           []  -> "identity"-                           [x] -> getDecoder x-                           _   -> foldl1' altEncoder $ map getEncoder nonNull-  where-    nonNull = nonNullComponents u--altEncoder a b = "Either.unpack (" <> a <> ") (" <> b <> ")"---- Contents example for wrapToJSON---"hexValue"  .= hexValue---                                        ,"colorName" .= colorName]--- | Join text with other as separator.-joinWith :: Text -> [Text] -> Text-joinWith _      []            = ""-joinWith joiner (aFirst:rest) = aFirst <> Text.concat (map (joiner <>) rest)---- | Makes a generic identifier name.-genericIdentifier :: DeclM Text-genericIdentifier = do-  i <- stepM-  return $! "Obj" `Text.append` tShow i---- * Printing a single data type declaration-newDecl :: Text -> [(Text, Type)] -> DeclM Text-newDecl identifier kvs = do attrs <- forM kvs $ \(k, v) -> do-                              formatted <- formatType v-                              return (k, normalizeFieldName identifier k, formatted, v, isNullable v)-                            let decl = Text.unlines [wrapDecl    identifier $ fieldDecls attrs-                                                    ,""-                                                    ,makeDecoder identifier              attrs-                                                    ,""-                                                    ,makeEncoder identifier              attrs]-                            addDecl decl-                            return identifier-  where-    fieldDecls attrList = Text.intercalate ",\n" $ map fieldDecl attrList-    fieldDecl :: (Text, Text, Text, Type, Bool) -> Text-    fieldDecl (_jsonName, haskellName, fType, _type, _nullable) = Text.concat [-                                                                    "    ", haskellName, " : ", fType]--addDecl decl = decls %%= (\ds -> ((), decl:ds))---- | Add new type alias for Array type-newAlias :: Text -> Type -> DeclM Text-newAlias identifier content = do formatted <- formatType content-                                 addDecl $ Text.unlines [wrapAlias identifier formatted]-                                 return identifier---- | Convert a JSON key name given by second argument,--- from within a dictionary keyed with first argument,--- into a name of Haskell record field (hopefully distinct from other such selectors.)-normalizeFieldName ::  Text -> Text -> Text-normalizeFieldName identifier = escapeKeywords             .-                                uncapitalize               .-                                (normalizeTypeName identifier `Text.append`) .-                                normalizeTypeName--keywords ::  Set Text-keywords = Set.fromList ["type", "alias", "exposing", "module", "class",-                         "where", "let", "do"]--escapeKeywords ::  Text -> Text-escapeKeywords k | k `Set.member` keywords = k `Text.append` "_"-escapeKeywords k                           = k--nonNullComponents = Set.toList . Set.filter (TNull /=)--- | Format the type within DeclM monad, that records--- the separate declarations on which this one is dependent.-formatType :: Type -> DeclM Text-formatType  TString                          = return "String"-formatType  TNum                             = return "Float"-formatType  TBool                            = return "Bool"-formatType (TLabel l)                        = return $ normalizeTypeName l-formatType (TUnion u)                        = wrap <$> case length nonNull of-                                                          0 -> return emptyTypeRepr-                                                          1 -> formatType $ head nonNull-                                                          _ -> foldl1' join <$> mapM formatType nonNull-  where-    nonNull = nonNullComponents u-    wrap                                :: Text -> Text-    wrap   inner  | TNull `Set.member` u = Text.concat ["(Maybe (", inner, "))"]-                  | otherwise            =                          inner-    join fAlt fOthers = Text.concat ["Either (", fAlt, ") (", fOthers, ")"]-formatType (TArray a)                        = do inner <- formatType a-                                                  return $ Text.concat ["List (", inner, ")"]-formatType (TObj   o)                        = do ident <- genericIdentifier-                                                  newDecl ident d-  where-    d = Map.toList $ unDict o-formatType  e | e `Set.member` emptySetLikes = return emptyTypeRepr-formatType  t                                = return $ "ERROR: Don't know how to handle: " `Text.append` tShow t--emptyTypeRepr :: Text-emptyTypeRepr = "Json.Decode.Value" -- default, accepts future extension where we found no data--runDecl ::  DeclM a -> Text-runDecl decl = Text.unlines $ finalState ^. decls-  where-    initialState    = DeclState [] 1-    (_, finalState) = runState decl initialState---- * Splitting object types by label for unification.-type TypeTree    = Map Text [Type]--type TypeTreeM a = State TypeTree a--addType :: Text -> Type -> TypeTreeM ()-addType label typ = modify $ Map.insertWith (++) label [typ]--formatObjectType ::  Text -> Type -> DeclM Text-formatObjectType identifier (TObj o) = newDecl  identifier d-  where-    d = Map.toList $ unDict o-formatObjectType identifier  other   = newAlias identifier other---- | Display an environment of types split by name.-displaySplitTypes ::  Map Text Type -> Text-displaySplitTypes dict = trace ("displaySplitTypes: " ++ show (toposort dict)) $ runDecl declarations-  where-    declarations =-      forM (toposort dict) $ \(name, typ) ->-        formatObjectType (normalizeTypeName name) typ---- | Normalize type name by:--- 1. Treating all characters that are not acceptable in Haskell variable name as end of word.--- 2. Capitalizing each word, but a first (camelCase).--- 3. Adding underscore if first character is non-alphabetic.--- 4. Escaping Haskell keywords if the whole identifier is such keyword.--- 5. If identifier is empty, then substituting "JsonEmptyKey" for its name.-normalizeTypeName :: Text -> Text-normalizeTypeName s  = ifEmpty "JsonEmptyKey"                  .-                       escapeKeywords                          .-                       escapeFirstNonAlpha                     .-                       Text.concat                             .-                       map capitalize                          .-                       filter     (not . Text.null)            .-                       Text.split (not . acceptableInVariable) $ s-  where-    ifEmpty x ""       = x-    ifEmpty _ nonEmpty = nonEmpty-    acceptableInVariable c = isAlpha c || isDigit c-    escapeFirstNonAlpha cs                  | Text.null cs =                   cs-    escapeFirstNonAlpha cs@(Text.head -> c) | isAlpha   c  =                   cs-    escapeFirstNonAlpha cs                                 = "_" `Text.append` cs---- | Computes all type labels referenced by a given type.-allLabels :: Type -> [Text]-allLabels = flip go []-  where-    go (TLabel l) ls = l:ls-    go (TArray t) ls = go t ls-    go (TUnion u) ls = Set.foldr go ls          u-    go (TObj   o) ls = Map.foldr go ls $ unDict o-    go _other     ls = ls---- | Remaps type labels according to a `Map`.-remapLabels :: Map Text Text -> Type -> Type-remapLabels ls (TObj   o) = TObj   $ Dict $ Map.map (remapLabels ls) $ unDict o-remapLabels ls (TArray t) = TArray $                 remapLabels ls  t-remapLabels ls (TUnion u) = TUnion $        Set.map (remapLabels ls) u-remapLabels ls (TLabel l) = TLabel $ Map.lookupDefault l l ls-remapLabels _  other      = other

@@ -1,116 +0,0 @@-{-# LANGUAGE CPP               #-}-{-# LANGUAGE OverloadedStrings #-}--- | Wrappers for generating prologue and epilogue code in Haskell.-module Data.Aeson.AutoType.CodeGen.Haskell(-    writeHaskellModule-  , runHaskellModule-  , runHaskellModuleStrict-  , defaultHaskellFilename-  ) 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.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.HaskellFormat-import           Data.Aeson.AutoType.Util---- | 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 = "JSONTypes.hs"--header :: Text -> Text-header moduleName = Text.unlines [-   "{-# LANGUAGE TemplateHaskell     #-}"-  ,"{-# LANGUAGE ScopedTypeVariables #-}"-  ,"{-# LANGUAGE RecordWildCards     #-}"-  ,"{-# LANGUAGE OverloadedStrings   #-}"-  ,"{-# LANGUAGE TypeOperators       #-}"-  ,"{-# LANGUAGE DeriveGeneric       #-}"-  ,""-  ,Text.concat ["module ", capitalize moduleName, " where"]-  ,""-  ,"import           System.Exit        (exitFailure, exitSuccess)"-  ,"import           System.IO          (stderr, hPutStrLn)"-  ,"import qualified Data.ByteString.Lazy.Char8 as BSL"-  ,"import           System.Environment (getArgs)"-  ,"import           Control.Monad      (forM_, mzero, join)"-  ,"import           Control.Applicative"-  ,"import           Data.Aeson.AutoType.Alternative"-  ,"import           Data.Aeson(decode, Value(..), FromJSON(..), ToJSON(..),"-#if MIN_VERSION_aeson(0,11,0)-  ,"                            pairs,"-#endif-  ,"                            (.:), (.:?), (.=), object)"-  ,"import           Data.Monoid"-  ,"import           Data.Text (Text)"-  ,"import qualified GHC.Generics" -  ,""-  ,"-- | Workaround for https://github.com/bos/aeson/issues/287."-  ,"o .:?? val = fmap join (o .:? val)"-  ,""]--epilogue :: Text -> Text-epilogue toplevelName = Text.unlines-  [""-  ,"parse :: FilePath -> IO " <> toplevelName-  ,"parse filename = do input <- BSL.readFile filename"-  ,"                    case decode input of"-  ,"                      Nothing -> fatal $ case (decode input :: Maybe Value) of"-  ,"                                           Nothing -> \"Invalid JSON file: \"     ++ filename"-  ,"                                           Just _  -> \"Mismatched JSON value from file: \" ++ filename"-  ,"                      Just r  -> return (r :: " <> toplevelName <> ")"-  ,"  where"-  ,"    fatal :: String -> IO a"-  ,"    fatal msg = do hPutStrLn stderr msg"-  ,"                   exitFailure"-  ,""-  ,"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 outputFilename toplevelName types =-    withFileOrHandle outputFilename WriteMode stdout $ \hOut ->-      assert (extension == ".hs") $ do-        Text.hPutStrLn hOut $ header $ Text.pack moduleName-        -- We write types as Haskell type declarations to output handle-        Text.hPutStrLn hOut $ displaySplitTypes types-        Text.hPutStrLn hOut $ epilogue toplevelName-  where-    (moduleName, extension) =-       first normalizeTypeName'     $-       splitExtension               $-       if     outputFilename == "-"-         then defaultHaskellFilename-         else outputFilename-    normalizeTypeName' = Text.unpack . normalizeTypeName . Text.pack--runHaskellModule :: [String] -> IO ExitCode-runHaskellModule arguments = do-    maybeStack <- System.Environment.lookupEnv "STACK_EXEC"-    maybeCabal <- System.Environment.lookupEnv "CABAL_SANDBOX_CONFIG"-    let execPrefix | Just stackExec <- maybeStack = [stackExec, "exec", "--"]-                   | Just _         <- maybeCabal = ["cabal",   "exec", "--"]-                   | otherwise                    = []-    system $ Prelude.unwords $ execPrefix ++ ["runghc"] ++ arguments--runHaskellModuleStrict :: [String] -> IO ExitCode-runHaskellModuleStrict  = runHaskellModule . ("-Wall":) . ("-Werror":)-

@@ -1,284 +0,0 @@-{-# LANGUAGE CPP                 #-}-{-# LANGUAGE TemplateHaskell     #-}-{-# LANGuaGE ScopedTypeVariables #-}-{-# LANGUAGE ViewPatterns        #-}-{-# LANGUAGE OverloadedStrings   #-}-{-# LANGuaGE DeriveGeneric       #-}-{-# LANGuaGE FlexibleContexts    #-}--- | Formatting type declarations and class instances for inferred types. -module Data.Aeson.AutoType.CodeGen.HaskellFormat(-  displaySplitTypes, normalizeTypeName-) where--import           Control.Arrow             ((&&&))-import           Control.Applicative       ((<$>), (<*>))-import           Control.Lens.TH-import           Control.Lens-import           Control.Monad             (forM)-import           Control.Exception(assert)-import qualified Data.HashMap.Strict        as Map-import           Data.Monoid-import qualified Data.Set                   as Set-import qualified Data.Text                  as Text-import           Data.Text                 (Text)-import           Data.Set                  (Set )-import           Data.List                 (foldl1')-import           Data.Char                 (isAlpha, isDigit)-import           Control.Monad.State.Class-import           Control.Monad.State.Strict(State, runState)-import qualified Data.Graph          as Graph-import           GHC.Generics              (Generic)--import           Data.Aeson.AutoType.Type-import           Data.Aeson.AutoType.Extract-import           Data.Aeson.AutoType.Format-import           Data.Aeson.AutoType.Split (toposort)-import           Data.Aeson.AutoType.Util  ()----import           Debug.Trace -- DEBUG-trace _ x = x--fst3 ::  (t, t1, t2) -> t-fst3 (a, _b, _c) = a--data DeclState = DeclState { _decls   :: [Text]-                           , _counter :: Int-                           }-  deriving (Eq, Show, Ord, Generic)--makeLenses ''DeclState--type DeclM = State DeclState--type Map k v = Map.HashMap k v --stepM :: DeclM Int-stepM = counter %%= (\i -> (i, i+1))--tShow :: (Show a) => a -> Text-tShow = Text.pack . show ---- | Wrap a type alias.-wrapAlias :: Text -> Text -> Text-wrapAlias identifier contents = Text.unwords ["type", identifier, "=", contents]---- | Wrap a data type declaration-wrapDecl ::  Text -> Text -> Text-wrapDecl identifier contents = Text.unlines [header, contents, "  } deriving (Show,Eq,GHC.Generics.Generic)"]-                                            --,"\nderiveJSON defaultOptions ''" `Text.append` identifier]-  where-    header = Text.concat ["data ", identifier, " = ", identifier, " { "]---- | Explanatory type alias for making declarations--- First element of the triple is original JSON identifier,--- second element of the triple is the mapped identifier name in Haskell.--- third element of the triple shows the type in a formatted way-type MappedKey = (Text, Text, Text, Bool)---- | Make ToJSON declaration, given identifier (object name in Haskell) and mapping of its keys--- from JSON to Haskell identifiers *in the same order* as in *data type declaration*.-makeFromJSON ::  Text -> [MappedKey] -> Text-makeFromJSON identifier contents =-  Text.unlines [-      Text.unwords ["instance FromJSON", identifier, "where"]-    , Text.unwords ["  parseJSON (Object v) =", makeParser identifier contents]-    , "  parseJSON _          = mzero" ]-  where-    makeParser identifier [] = Text.unwords ["return ", identifier]-    makeParser identifier _  = Text.unwords [identifier, "<$>", inner]-    inner                    = " <*> " `Text.intercalate`-                                  map takeValue contents-    takeValue (jsonId, _, ty, True ) = Text.concat ["v .:?? \"", jsonId, "\""] -- nullable types-    takeValue (jsonId, _, _ , False) = Text.concat ["v .:   \"", jsonId, "\""]--- Contents example for wrapFromJSON:--- " <$>---"                           v .: "hexValue"  <*>---"                           v .: "colorName\""---- | Make ToJSON declaration, given identifier (object name in Haskell) and mapping of its keys--- from JSON to Haskell identifiers in the same order as in declaration-makeToJSON :: Text -> [MappedKey] -> Text-makeToJSON identifier contents =-    Text.unlines [-        Text.concat ["instance ToJSON ", identifier, " where"]-      , Text.concat ["  toJSON     (", identifier, " {", wildcard, "}) = object [", inner ", ", "]"]-#if MIN_VERSION_aeson(0,11,0)-      , maybeToEncoding-#endif-      ]-  where-    maybeToEncoding | null contents = ""-                    | otherwise     =-                        Text.concat ["  toEncoding (", identifier, " {", wildcard, "}) = pairs  (", inner "<>", ")"]-    wildcard | null contents = ""-             | otherwise     = ".."-    inner separator = separator `Text.intercalate`-                      map putValue contents-    putValue (jsonId, haskellId, _typeText, _nullable) = Text.unwords [escapeText jsonId, ".=", haskellId]-    escapeText = Text.pack . show . Text.unpack--- Contents example for wrapToJSON---"hexValue"  .= hexValue---                                        ,"colorName" .= colorName]----- | Makes a generic identifier name.-genericIdentifier :: DeclM Text-genericIdentifier = do-  i <- stepM-  return $! "Obj" `Text.append` tShow i---- * Printing a single data type declaration-newDecl :: Text -> [(Text, Type)] -> DeclM Text-newDecl identifier kvs = do attrs <- forM kvs $ \(k, v) -> do-                              formatted <- formatType v-                              return (k, normalizeFieldName identifier k, formatted, isNullable v)-                            let decl = Text.unlines [wrapDecl     identifier $ fieldDecls attrs-                                                    ,""-                                                    ,makeFromJSON identifier              attrs-                                                    ,""-                                                    ,makeToJSON   identifier              attrs]-                            addDecl decl-                            return identifier-  where-    fieldDecls attrList = Text.intercalate ",\n" $ map fieldDecl attrList-    fieldDecl :: (Text, Text, Text, Bool) -> Text-    fieldDecl (_jsonName, haskellName, fType, _nullable) = Text.concat [-                                                             "    ", haskellName, " :: ", fType]--addDecl decl = decls %%= (\ds -> ((), decl:ds))---- | Add new type alias for Array type-newAlias :: Text -> Type -> DeclM Text-newAlias identifier content = do formatted <- formatType content-                                 addDecl $ Text.unlines [wrapAlias identifier formatted]-                                 return identifier---- | Convert a JSON key name given by second argument,--- from within a dictionary keyed with first argument,--- into a name of Haskell record field (hopefully distinct from other such selectors.)-normalizeFieldName ::  Text -> Text -> Text-normalizeFieldName identifier = escapeKeywords             .-                                uncapitalize               .-                                (normalizeTypeName identifier `Text.append`) .-                                normalizeTypeName--keywords ::  Set Text-keywords = Set.fromList ["type", "data", "module", "class", "where", "let", "do"]--escapeKeywords ::  Text -> Text-escapeKeywords k | k `Set.member` keywords = k `Text.append` "_"-escapeKeywords k                           = k---- | Format the type within DeclM monad, that records--- the separate declarations on which this one is dependent.-formatType :: Type -> DeclM Text-formatType  TString                          = return "Text"-formatType  TNum                             = return "Double"-formatType  TBool                            = return "Bool"-formatType (TLabel l)                        = return $ normalizeTypeName l-formatType (TUnion u)                        = wrap <$> case length nonNull of-                                                          0 -> return emptyTypeRepr-                                                          1 -> formatType $ head nonNull-                                                          _ -> Text.intercalate ":|:" <$> mapM formatType nonNull-  where-    nonNull       = Set.toList $ Set.filter (TNull /=) u-    wrap                                :: Text -> Text-    wrap   inner  | TNull `Set.member` u = Text.concat ["(Maybe (", inner, "))"]-                  | otherwise            =                          inner-formatType (TArray a)                        = do inner <- formatType a-                                                  return $ Text.concat ["[", inner, "]"]-formatType (TObj   o)                        = do ident <- genericIdentifier-                                                  newDecl ident d-  where-    d = Map.toList $ unDict o -formatType  e | e `Set.member` emptySetLikes = return emptyTypeRepr-formatType  t                                = return $ "ERROR: Don't know how to handle: " `Text.append` tShow t--emptyTypeRepr :: Text-emptyTypeRepr = "(Maybe Value)" -- default, accepts future extension where we found no data--runDecl ::  DeclM a -> Text-runDecl decl = Text.unlines $ finalState ^. decls-  where-    initialState    = DeclState [] 1-    (_, finalState) = runState decl initialState---- * Splitting object types by label for unification.-type TypeTree    = Map Text [Type]--type TypeTreeM a = State TypeTree a--addType :: Text -> Type -> TypeTreeM ()-addType label typ = modify $ Map.insertWith (++) label [typ]--splitTypeByLabel' :: Text -> Type -> TypeTreeM Type-splitTypeByLabel' _  TString   = return TString-splitTypeByLabel' _  TNum      = return TNum-splitTypeByLabel' _  TBool     = return TBool-splitTypeByLabel' _  TNull     = return TNull-splitTypeByLabel' _ (TLabel r) = assert False $ return $ TLabel r -- unnecessary?-splitTypeByLabel' l (TUnion u) = do m <- mapM (splitTypeByLabel' l) $ Set.toList u-                                    return $! TUnion $! Set.fromList m-splitTypeByLabel' l (TArray a) = do m <- splitTypeByLabel' (l `Text.append` "Elt") a-                                    return $! TArray m-splitTypeByLabel' l (TObj   o) = do kvs <- forM (Map.toList $ unDict o) $ \(k, v) -> do-                                       component <- splitTypeByLabel' k v-                                       return (k, component)-                                    addType l (TObj $ Dict $ Map.fromList kvs)-                                    return $! TLabel l---- | Splits initial type with a given label, into a mapping of object type names and object type structures.-splitTypeByLabel :: Text -> Type -> Map Text Type-splitTypeByLabel topLabel t = Map.map (foldl1' unifyTypes) finalState-  where-    finalize (TLabel l) = assert (l == topLabel) $ return ()-    finalize  topLevel  = addType topLabel topLevel-    initialState    = Map.empty-    (_, finalState) = runState (splitTypeByLabel' topLabel t >>= finalize) initialState--formatObjectType ::  Text -> Type -> DeclM Text-formatObjectType identifier (TObj o) = newDecl  identifier d-  where-    d = Map.toList $ unDict o-formatObjectType identifier  other   = newAlias identifier other---- | Display an environment of types split by name.-displaySplitTypes ::  Map Text Type -> Text-displaySplitTypes dict = trace ("displaySplitTypes: " ++ show (toposort dict)) $ runDecl declarations-  where-    declarations =-      forM (toposort dict) $ \(name, typ) ->-        formatObjectType (normalizeTypeName name) typ---- | Normalize type name by:--- 1. Treating all characters that are not acceptable in Haskell variable name as end of word.--- 2. Capitalizing each word, but a first (camelCase).--- 3. Adding underscore if first character is non-alphabetic.--- 4. Escaping Haskell keywords if the whole identifier is such keyword.--- 5. If identifier is empty, then substituting "JsonEmptyKey" for its name.-normalizeTypeName :: Text -> Text-normalizeTypeName = ifEmpty "JsonEmptyKey"                  .-                    escapeKeywords                          .-                    escapeFirstNonAlpha                     .-                    Text.concat                             .-                    map capitalize                          .-                    filter     (not . Text.null)            .-                    Text.split (not . acceptableInVariable)-  where-    ifEmpty x ""       = x-    ifEmpty _ nonEmpty = nonEmpty-    acceptableInVariable c = isAlpha c || isDigit c-    escapeFirstNonAlpha cs                  | Text.null cs =                   cs-    escapeFirstNonAlpha cs@(Text.head -> c) | isAlpha   c  =                   cs-    escapeFirstNonAlpha cs                                 = "_" `Text.append` cs---- | Computes all type labels referenced by a given type.-allLabels :: Type -> [Text]-allLabels = flip go []-  where-    go (TLabel l) ls = l:ls-    go (TArray t) ls = go t ls-    go (TUnion u) ls = Set.foldr go ls          u-    go (TObj   o) ls = Map.foldr go ls $ unDict o-    go _other     ls = ls-

@@ -1,157 +0,0 @@--- | Extraction and unification of AutoType's @Type@ from Aeson @Value@.-module Data.Aeson.AutoType.Extract(valueSize, valueTypeSize,-                                   valueDepth, Dict(..),-                                   Type(..), emptyType,-                                   extractType, unifyTypes,-                                   typeCheck) where--import           Control.Arrow ((&&&))-import           Control.Exception               (assert)-import           Data.Aeson.AutoType.Type-import qualified Data.Graph          as Graph-import qualified Data.HashMap.Strict      as Map-import           Data.HashMap.Strict             (HashMap)-import qualified Data.Set                 as Set-import qualified Data.Vector              as V-import           Data.Aeson-import           Data.Text                       (Text)-import           Data.Set                        (Set )-import           Data.List                       (foldl1')----import           Debug.Trace---- | Compute total number of nodes (and leaves) within the value tree.--- Each simple JavaScript type (including String) is counted as of size 1,--- whereas both Array or object types are counted as 1+sum of the sizes--- of their member values.-valueSize :: Value -> Int-valueSize  Null      = 1-valueSize (Bool   _) = 1-valueSize (Number _) = 1-valueSize (String _) = 1-valueSize (Array  a) = V.foldl' (+) 1 $ V.map valueSize a-valueSize (Object o) = (1+) . sum . map valueSize . Map.elems $ o---- | Compute total size of the type of the @Value@.--- For:--- * simple types it is always 1,--- * for arrays it is just 1+_maximum_ size of the (single) element type,--- * for objects it is _sum_ of the sizes of fields (since each field type---   is assumed to be different.)-valueTypeSize :: Value -> Int-valueTypeSize  Null      = 1-valueTypeSize (Bool   _) = 1-valueTypeSize (Number _) = 1-valueTypeSize (String _) = 1-valueTypeSize (Array  a) = (1+) . V.foldl' max 0 $ V.map valueTypeSize a-valueTypeSize (Object o) = (1+) . sum . map valueTypeSize . Map.elems $ o---- | Compute total depth of the value.--- For:--- * simple types it is 1--- * for either Array or Object, it is 1 + maximum of depths of their members-valueDepth :: Value -> Int-valueDepth  Null      = 1-valueDepth (Bool   _) = 1-valueDepth (Number _) = 1-valueDepth (String _) = 1-valueDepth (Array  a) = (1+) . V.foldl' max 0 $ V.map valueDepth a-valueDepth (Object o) = (1+) . maximum . (0:) . map valueDepth . Map.elems $ o---- | Extract @Type@ from the JSON @Value@.--- Unifying types of array elements, if necessary.-extractType                             :: Value -> Type-extractType (Object o)                   = TObj $ Dict $ Map.map extractType o-extractType  Null                        = TNull-extractType (Bool   _)                   = TBool-extractType (Number _)                   = TNum-extractType (String _)                   = TString-extractType (Array  a) | V.null a        = TArray   emptyType-extractType (Array  a)                   = TArray $ V.foldl1' unifyTypes $ traceShow $ V.map extractType a-  where-    --traceShow a = trace (show a) a-    traceShow = id---- | Type check the value with the derived type.-typeCheck :: Value -> Type -> Bool-typeCheck  Null          TNull            = True-typeCheck  v            (TUnion  u)       = typeCheck v `any` Set.toList u-typeCheck (Bool   _)     TBool            = True-typeCheck (Number _)     TNum             = True-typeCheck (String _)     TString          = True-typeCheck (Array  elts) (TArray  eltType) = (`typeCheck` eltType) `all` V.toList elts-typeCheck (Object d)    (TObj    e      ) = typeCheckKey `all` keysOfBoth-  where-    typeCheckKey k = getValue k d `typeCheck` get k e-    getValue   :: Text -> HashMap Text Value -> Value-    getValue    = Map.lookupDefault Null-    keysOfBoth :: [Text]-    keysOfBoth  =  Set.toList $ Set.fromList (Map.keys d) `Set.union` keys e-typeCheck         _     (TLabel  _      ) = error "Cannot typecheck labels without environment!"-typeCheck   {-a-} _      _ {-b-}          = {-trace msg $-} False-  where-    -- msg = "Mismatch: " ++ show a ++ " :: " ++ show b--allKeys :: Dict -> Dict -> [Text]-d `allKeys` e = Set.toList (keys d `Set.union` keys e)---- | Standard unification procedure on @Type@s,--- with inclusion of @Type@ unions.-unifyTypes :: Type -> Type -> Type-unifyTypes  TBool      TBool     = TBool-unifyTypes  TNum       TNum      = TNum-unifyTypes  TString    TString   = TString-unifyTypes  TNull      TNull     = TNull-unifyTypes (TObj   d) (TObj   e) = TObj newDict-  where-    newDict :: Dict-    newDict = Dict $ Map.fromList [(k, get k d `unifyTypes`-                                        get k e) | k <- allKeys d e ]-unifyTypes (TArray u) (TArray v) = TArray $ u `unifyTypes` v-unifyTypes t           s         = typeAsSet t `unifyUnion` typeAsSet s---- | Unify sets of types (sets are union types of alternatives).-unifyUnion :: Set Type -> Set Type -> Type-unifyUnion u v = assertions $-                   union $ uSimple        `Set.union`-                           vSimple        `Set.union`-                           unifiedObjects `Set.union`-                           Set.singleton unifiedArray-  where-    -- We partition our types for easier unification into simple and compound-    (uSimple, uCompound) = Set.partition isSimple u-    (vSimple, vCompound) = Set.partition isSimple v-    assertions = assert (Set.null $ Set.filter (not . isArray) uArr) .-                 assert (Set.null $ Set.filter (not . isArray) vArr)-    -- then we partition compound typs into objects and arrays.-    -- Note that there should be no TUnion here, since we are inside a TUnion already.-    -- (That is reduced by @union@ smart costructor as superfluous.)-    (uObj, uArr)   = Set.partition isObject uCompound-    (vObj, vArr)   = Set.partition isObject vCompound-    unifiedObjects = Set.fromList $ if null objects-                                       then []-                                       else [foldl1' unifyTypes objects]-    objects = Set.toList $ uObj `Set.union` vObj-    arrayElts :: [Type]-    arrayElts  = map (\(TArray ty) -> ty) $-                   Set.toList $-                     uArr `Set.union` vArr-    unifiedArray = TArray $ if null arrayElts-                               then emptyType-                               else foldl1' unifyTypes arrayElts---- | Smart constructor for union types.-union ::  Set Type -> Type-union = simplifyUnion . TUnion---- | Simplify TUnion's so there is no TUnion directly inside TUnion.--- If there is only one element of the set, then return this single--- element as a type.-simplifyUnion :: Type -> Type-simplifyUnion (TUnion s) | Set.size s == 1 = head $ Set.toList s-simplifyUnion (TUnion s)                   = TUnion $ Set.unions $ map elements $ Set.toList s-  where-    elements (TUnion elems) = elems-    elements sing           = Set.singleton sing-simplifyUnion unexpected                   = error ("simplifyUnion: unexpected argument " ++ show unexpected)-

@@ -1,17 +0,0 @@--- | Formatting tools for code generation.-module Data.Aeson.AutoType.Format(capitalize, uncapitalize) where--import Data.Text(Text)-import qualified Data.Text as Text---- | Make the first letter of a Text upper case.-capitalize :: Text -> Text-capitalize word = Text.toUpper first `Text.append` rest-  where-    (first, rest) = Text.splitAt 1 word---- | Make the first letter of a Text lower case.-uncapitalize :: Text -> Text-uncapitalize word = Text.toLower first `Text.append` rest-  where-    (first, rest) = Text.splitAt 1 word

@@ -1,53 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE OverloadedStrings   #-}-{-# LANGUAGE DeriveGeneric       #-}-{-# LANGUAGE StandaloneDeriving  #-}-{-# LANGUAGE ViewPatterns        #-}-{-# LANGUAGE CPP                 #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}---- | Instances of @Text.PrettyPrint.Out@ class to visualize--- Aeson @Value@ data structure.-module Data.Aeson.AutoType.Pretty() where--import qualified Data.HashMap.Strict as Hash-import           Data.HashMap.Strict(HashMap)-import           Data.Aeson-import qualified Data.Text                  as Text-import           Data.Text                 (Text)-import           Data.Set                   as Set(Set, toList)-import           Data.Scientific-import           Data.Vector                as V(Vector, toList)-import           Text.PrettyPrint.GenericPretty-import           Text.PrettyPrint--formatPair :: (Out a, Out b) => (a, b) -> Doc-formatPair (a, b) = nest 1 (doc a <+> ": " <+> doc b <+> ",")---- * This is to make prettyprinting possible for Aeson @Value@ type.-instance Out Scientific where-  doc = doc . show-  docPrec _ = doc--instance (Out a) => Out (Vector a) where-  doc (V.toList -> v) = "<" <+> doc v <+> ">"-  docPrec _ = doc--#if MIN_VERSION_aeson(1,2,1)-#else-deriving instance Generic Value-#endif--instance Out Value      -- orphan instance--instance (Out a) => Out (Set a) where-  doc     (Set.toList -> s) = "{" <+> doc s <+> "}"-  docPrec _                 = doc--instance (Out a, Out b) => Out (HashMap a b) where-  doc (Hash.toList -> dict) = foldl ($$) "{" (map formatPair dict) $$ nest 1 "}"-  docPrec _ = doc--instance Out Text where-  doc       = text . Text.unpack -- TODO: check if there may be direct way?-  docPrec _ = doc

@@ -1,143 +0,0 @@-{-# LANGUAGE CPP                 #-}-{-# LANGUAGE TemplateHaskell     #-}-{-# LANGuaGE ScopedTypeVariables #-}-{-# LANGUAGE ViewPatterns        #-}-{-# LANGUAGE OverloadedStrings   #-}-{-# LANGuaGE DeriveGeneric       #-}-{-# LANGuaGE FlexibleContexts    #-}--- | Formatting type declarations and class instances for inferred types. -module Data.Aeson.AutoType.Split(-  splitTypeByLabel, unificationCandidates,-  unifyCandidates, toposort-) where--import           Control.Arrow             ((&&&))-import           Control.Applicative       ((<$>), (<*>))-import           Control.Lens.TH-import           Control.Lens-import           Control.Monad             (forM)-import           Control.Exception(assert)-import qualified Data.HashMap.Strict        as Map-import           Data.Monoid-import qualified Data.Set                   as Set-import qualified Data.Text                  as Text-import           Data.Text                 (Text)-import           Data.Set                  (Set )-import           Data.List                 (foldl1')-import           Data.Char                 (isAlpha, isDigit)-import           Control.Monad.State.Class-import           Control.Monad.State.Strict(State, runState)-import qualified Data.Graph          as Graph-import           GHC.Generics              (Generic)--import           Data.Aeson.AutoType.Type-import           Data.Aeson.AutoType.Extract-import           Data.Aeson.AutoType.Util  ()----import           Debug.Trace -- DEBUG-trace _ x = x--fst3 ::  (t, t1, t2) -> t-fst3 (a, _b, _c) = a--type Map k v = Map.HashMap k v ---- | Explanatory type alias for making declarations--- First element of the triple is original JSON identifier,--- second element of the triple is the mapped identifier name in Haskell.--- third element of the triple shows the type in a formatted way-type MappedKey = (Text, Text, Text, Bool)---- * Splitting object types by label for unification.-type TypeTree    = Map Text [Type]--type TypeTreeM a = State TypeTree a--addType :: Text -> Type -> TypeTreeM ()-addType label typ = modify $ Map.insertWith (++) label [typ]--splitTypeByLabel' :: Text -> Type -> TypeTreeM Type-splitTypeByLabel' _  TString   = return TString-splitTypeByLabel' _  TNum      = return TNum-splitTypeByLabel' _  TBool     = return TBool-splitTypeByLabel' _  TNull     = return TNull-splitTypeByLabel' _ (TLabel r) = assert False $ return $ TLabel r -- unnecessary?-splitTypeByLabel' l (TUnion u) = do m <- mapM (splitTypeByLabel' l) $ Set.toList u-                                    return $! TUnion $! Set.fromList m-splitTypeByLabel' l (TArray a) = do m <- splitTypeByLabel' (l `Text.append` "Elt") a-                                    return $! TArray m-splitTypeByLabel' l (TObj   o) = do kvs <- forM (Map.toList $ unDict o) $ \(k, v) -> do-                                       component <- splitTypeByLabel' k v-                                       return (k, component)-                                    addType l (TObj $ Dict $ Map.fromList kvs)-                                    return $! TLabel l---- | Splits initial type with a given label, into a mapping of object type names and object type structures.-splitTypeByLabel :: Text -> Type -> Map Text Type-splitTypeByLabel topLabel t = Map.map (foldl1' unifyTypes) finalState-  where-    finalize (TLabel l) = assert (l == topLabel) $ return ()-    finalize  topLevel  = addType topLabel topLevel-    initialState    = Map.empty-    (_, finalState) = runState (splitTypeByLabel' topLabel t >>= finalize) initialState---- | Topological sorting of splitted types so that it is accepted declaration order.-toposort :: Map Text Type -> [(Text, Type)]  -toposort splitted = map ((id &&& (splitted Map.!)) . fst3 . graphKey) $ Graph.topSort graph-  where-    (graph, graphKey) = Graph.graphFromEdges' $ map makeEntry $ Map.toList splitted-    makeEntry (k, v) = (k, k, allLabels v)---- | Computes all type labels referenced by a given type.-allLabels :: Type -> [Text]-allLabels = flip go []-  where-    go (TLabel l) ls = l:ls-    go (TArray t) ls = go t ls-    go (TUnion u) ls = Set.foldr go ls          u-    go (TObj   o) ls = Map.foldr go ls $ unDict o-    go _other     ls = ls---- * Finding candidates for extra unifications--- | For a given splitted types, it returns candidates for extra--- unifications.-unificationCandidates :: Map.HashMap t Type -> [[t]]-unificationCandidates = Map.elems             .-                        Map.filter candidates .-                        Map.fromListWith (++) .-                        concatMap entry       .-                        Map.toList-  where-    -- | Candidate entry has to have at least two candidates, so that unification makes sense-    candidates [ ] = False-    candidates [_] = False-    candidates _   = True-    -- | Make a candidate entry for each object type, which points from its keys to its label.-    entry (k, TObj o)                 = [(Set.fromList $ Map.keys $ unDict o, [k])]-    entry  _                          = [] -- ignore array elements and toplevel type if it is Array---- | Unifies candidates on a give input list.-unifyCandidates :: [[Text]] -> Map Text Type -> Map Text Type-unifyCandidates candidates splitted = Map.map (remapLabels labelMapping) $ replacements splitted-  where-    unifiedType  :: [Text] -> Type-    unifiedType cset      = foldr1 unifyTypes         $ -                            map (splitted Map.!) cset-    replace      :: [Text] -> Map Text Type -> Map Text Type-    replace  cset@(c:_) s = Map.insert c (unifiedType cset) (foldr Map.delete s cset)-    replace  []         _ = error "Empty candidate set in replace"-    replacements :: Map Text Type -> Map Text Type-    replacements        s = foldr replace s candidates-    labelMapping :: Map Text Text-    labelMapping          = Map.fromList $ concatMap mapEntry candidates-    mapEntry cset@(c:_)   = [(x, c) | x <- cset]-    mapEntry []           = error "Empty candidate set in mapEntry"---- | Remaps type labels according to a `Map`.-remapLabels :: Map Text Text -> Type -> Type-remapLabels ls (TObj   o) = TObj   $ Dict $ Map.map (remapLabels ls) $ unDict o-remapLabels ls (TArray t) = TArray $                 remapLabels ls  t-remapLabels ls (TUnion u) = TUnion $        Set.map (remapLabels ls) u-remapLabels ls (TLabel l) = TLabel $ Map.lookupDefault l l ls-remapLabels _  other      = other-

@@ -1,92 +0,0 @@-{-# LANGUAGE FlexibleInstances     #-}-{-# LANGUAGE MultiParamTypeClasses #-}--- | Arbitrary instances for the JSON @Value@.-module Data.Aeson.AutoType.Test (-    arbitraryTopValue-  ) where--import           Data.Aeson.AutoType.Pretty          () -- Generic instance for Value--import           Control.Applicative                 ((<$>), (<*>))-import           Data.Aeson-import           Data.Function                       (on)-import           Data.Hashable                       (Hashable)-import           Data.Generics.Uniplate.Data-import           Data.List-import           Data.Scientific-import qualified Data.Text                   as Text-import           Data.Text                           (Text)-import qualified Data.Vector                 as V-import qualified Data.HashMap.Strict         as Map-import           GHC.Generics--import           Test.QuickCheck.Arbitrary-import           Test.QuickCheck-import           Test.SmallCheck.Series--instance Arbitrary Text where-  arbitrary = Text.pack  <$> sized (`vectorOf` alphabetic)-    where-      alphabetic = choose ('a', 'z')--instance (Arbitrary a) => Arbitrary (V.Vector a) where-  arbitrary = V.fromList <$> arbitrary--instance (Arbitrary v) => Arbitrary (Map.HashMap Text v) where-  arbitrary = makeMap <$> arbitrary---- | Helper function for generating Arbitrary and Series instances--- for @Data.HashMap.Strict.Map@ from lists of pairs.-makeMap :: (Ord a, Hashable a) =>[(a, b)] -> Map.HashMap a b-makeMap  = Map.fromList-         . nubBy  ((==)    `on` fst)-         . sortBy (compare `on` fst)--instance Arbitrary Scientific where-  arbitrary = scientific <$> arbitrary <*> arbitrary---- TODO: top value has to be complex: Object or Array--- TODO: how to accumulate cost when generating the series?-instance Arbitrary Value where-  arbitrary = sized arb-    where-      arb n | n < 0 = error "Negative size!"-      arb 0         = return Null-      arb 1         = oneof                          simpleGens-      arb i         = oneof $ complexGens (i - 1) ++ simpleGens-      simpleGens    = [Number <$> arbitrary-                      ,Bool   <$> arbitrary-                      ,String <$> arbitrary]-  shrink = concatMap simpleShrink-         . universe---- | Transformation to shrink top level of @Value@, doesn't consider nested sub-@Value@s.-simpleShrink           :: Value -> [Value]-simpleShrink (Array  a) = map (Array  .   V.fromList) $ shrink $ V.toList   a-simpleShrink (Object o) = map (Object . Map.fromList) $ shrink $ Map.toList o-simpleShrink _          = [] -- Nothing for simple objects---- | Generator for compound @Value@s-complexGens ::  Int -> [Gen Value]-complexGens i = [Object . Map.fromList <$> resize i arbitrary,-                 Array                 <$> resize i arbitrary]---- | Arbitrary JSON (must start with Object or Array.)-arbitraryTopValue :: Gen Value-arbitraryTopValue  = sized $ oneof . complexGens---- * SmallCheck Serial instances-instance Monad m => Serial m Text where-  series = newtypeCons Text.pack--instance Monad m => Serial m Scientific where-  series = cons2 scientific--instance Serial m a => Serial m (V.Vector a) where-  series = newtypeCons V.fromList--instance Serial m v => Serial m (Map.HashMap Text v) where-  series = newtypeCons makeMap---- This one is generated with Generics and instances above-instance Monad m => Serial m Value

@@ -1,155 +0,0 @@-{-# LANGUAGE DeriveDataTypeable    #-}-{-# LANGUAGE DeriveGeneric         #-}-{-# LANGUAGE FlexibleInstances     #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE OverloadedStrings     #-}--- | Union types describing JSON objects, and operations for querying these types.-module Data.Aeson.AutoType.Type(typeSize,-                                Dict(..), keys, get, withDict,-                                Type(..), emptyType,-                                isSimple, isArray, isObject, typeAsSet,-                                hasNonTopTObj,-                                hasTObj,-                                isNullable,-                                emptySetLikes-  ) where--import           Prelude             hiding (any)-import qualified Data.HashMap.Strict as Hash-import qualified Data.Set            as Set-import           Data.Data          (Data(..))-import           Data.Typeable      (Typeable)-import           Data.Foldable      (any)-import           Data.Text          (Text)-import           Data.Set           (Set )-import           Data.HashMap.Strict(HashMap)-import           Data.List          (sort)-import           Data.Ord           (comparing)-import           Data.Generics.Uniplate-import           Text.PrettyPrint.GenericPretty--import           Data.Aeson.AutoType.Pretty ()---- * Dictionary types for overloading of usual class instances.--- | Type alias for HashMap-type Map = HashMap---- | Dictionary of types indexed by names.-newtype Dict = Dict { unDict :: Map Text Type }-  deriving (Eq, Data, Typeable, Generic)--instance Out Dict where-  doc       = doc       . unDict-  docPrec p = docPrec p . unDict--instance Show Dict where-  show = show . sort . Hash.toList . unDict--instance Ord Dict where-  compare = comparing $ sort . Hash.toList . unDict---- | Make operation on a map to an operation on a Dict.-withDict :: (Map Text Type -> Map Text Type) -> Dict -> Dict-f `withDict` (Dict m) = Dict $ f m---- | Take all keys from dictionary.-keys :: Dict -> Set Text-keys = Set.fromList . Hash.keys . unDict---- | Union types for JSON values.-data Type = TNull | TBool | TNum | TString |-            TUnion (Set      Type)         |-            TLabel  Text                   |-            TObj    Dict                   |-            TArray  Type-  deriving (Show,Eq, Ord, Data, Typeable, Generic)--instance Out Type---- These are missing Uniplate instances...-{--instance Biplate (Set a) a where-  biplate s = (Set.toList s, Set.fromList)--instance Biplate (HashMap k v) v where-  biplate m = (Hash.elems m, Hash.fromList . zip (Hash.keys m))- -}--instance Uniplate Type where-  uniplate (TUnion s) = (Set.toList s, TUnion .        Set.fromList                     )-  uniplate (TObj   d) = (Hash.elems m, TObj   . Dict . Hash.fromList . zip (Hash.keys m))-    where-      m = unDict d-  uniplate (TArray t) = ([t],          TArray . head  )-  uniplate s          = ([],           const s        )---- | Empty type-emptyType :: Type-emptyType = TUnion Set.empty---- | Lookup the Type within the dictionary.-get :: Text -> Dict -> Type-get key = Hash.lookupDefault TNull key . unDict---- $derive makeUniplateDirect ''Type---- | Size of the `Type` term.-typeSize           :: Type -> Int-typeSize TNull      = 1-typeSize TBool      = 1-typeSize TNum       = 1-typeSize TString    = 1-typeSize (TObj   o) = (1+) . sum     . map typeSize . Hash.elems . unDict $ o-typeSize (TArray a) = 1 + typeSize a-typeSize (TUnion u) = (1+) . sum . (0:) . map typeSize . Set.toList $ u-typeSize (TLabel _) = error "Don't know how to compute typeSize of TLabel."---- | Check if this is nullable (Maybe) type, or not.--- Nullable type will always accept TNull or missing key that contains it.-isNullable :: Type -> Bool-isNullable  TNull     = True-isNullable (TUnion u) = isNullable `any` u-isNullable  _         = False---- | "Null-ish" types-emptySetLikes ::  Set Type-emptySetLikes = Set.fromList [TNull, TArray $ TUnion $ Set.fromList []]--- Q: and TObj $ Map.fromList []?-{-# INLINE emptySetLikes #-}---- | Convert any type into union type (even if just singleton).-typeAsSet :: Type -> Set Type-typeAsSet (TUnion s) = s-typeAsSet t          = Set.singleton t---- | Is the top-level constructor a TObj?-isObject         :: Type -> Bool-isObject (TObj _) = True-isObject _        = False---- | Is it a simple (non-compound) Type?-isSimple  :: Type -> Bool-isSimple x = not (isObject x) && not (isArray x) && not (isUnion x)---- | Is the top-level constructor a TUnion?-isUnion           :: Type -> Bool-isUnion (TUnion _) = True-isUnion _          = False---- | Is the top-level constructor a TArray?--- | Check if the given type has non-top TObj.-isArray           :: Type -> Bool-isArray (TArray _) = True-isArray _          = False---- | Check if the given type has non-top TObj.-hasNonTopTObj         :: Type -> Bool-hasNonTopTObj (TObj o) = any hasTObj $ Hash.elems $ unDict o-hasNonTopTObj _        = False---- | Check if the given type has TObj on top or within array..-hasTObj           :: Type -> Bool-hasTObj (TObj   _) = True-hasTObj (TArray a) = hasTObj a-hasTObj (TUnion u) = any hasTObj u-hasTObj _          = False

@@ -1,34 +0,0 @@-{-# OPTIONS_GHC -fno-warn-orphans #-}---- | Utility functions that may be ultimately moved to some library.-module Data.Aeson.AutoType.Util( withFileOrHandle-                               , withFileOrDefaultHandle-                               ) where--import           Data.Hashable-import qualified Data.Set as Set-import           System.IO                 (withFile, IOMode(..), Handle, stdin, stdout)---- | Generic function for opening file if the filename is not empty nor "-",---   or using given handle otherwise (probably stdout, stderr, or stdin).--- TODO: Should it become utility function?-withFileOrHandle :: FilePath -> IOMode -> Handle -> (Handle -> IO r) -> IO r-withFileOrHandle        ""       _         handle action =                      action handle-withFileOrHandle        "-"      _         handle action =                      action handle-withFileOrHandle        name     ioMode    _      action = withFile name ioMode action---- | Generic function for choosing either file with given name or stdin/stdout as input/output.--- It accepts the function that takes the corresponding handle.--- Stdin/stdout is selected by "-".-withFileOrDefaultHandle :: FilePath -> IOMode -> (Handle -> IO r) -> IO r-withFileOrDefaultHandle "-"      ReadMode         action = action stdin-withFileOrDefaultHandle "-"      WriteMode        action = action stdout-withFileOrDefaultHandle "-"      otherMode        _      = error $ "Incompatible io mode ("-                                                                ++ show otherMode-                                                                ++ ") for `-` in withFileOrDefaultHandle."-withFileOrDefaultHandle filename ioMode           action = withFile filename ioMode action---- Missing instances-instance Hashable a => Hashable (Set.Set a) where-  hashWithSalt = Set.foldr (flip hashWithSalt)-

@@ -1,175 +0,0 @@-{-# 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(..), decode, encode, FromJSON(..), ToJSON(..))-import qualified Data.Text                  as Text-import qualified Data.Text.IO               as Text-import           Data.Text                      (Text)-import           Text.PrettyPrint.GenericPretty (pretty)--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---- * Command line flags-data Options = Options {-                 tyOpts :: TypeOpts-               , outputFilename :: FilePath-               , typecheck :: Bool-               , yaml :: Bool-               , preprocessor :: Bool-               , filenames :: [FilePath]-               }--optParser :: Parser Options-optParser  =-    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 :: Maybe Value <- decoder <$> BSL.hGetContents hInput-           --let decodedJSON :: Maybe Value =  decodeValue input-           -- myTrace ("Decoded JSON: " ++ pretty decoded)-           case decodedJSON of-             Nothing -> do report $ "Cannot decode JSON input from " `Text.append` Text.pack (show inputFilename)-                           return Nothing-             Just 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 | yaml opts = Yaml.decode . BSL.toStrict-            | otherwise =      decode-    -- | 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 $-      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")

@@ -1,200 +0,0 @@-{-# LANGUAGE ScopedTypeVariables  #-}-{-# LANGUAGE OverloadedStrings    #-}-{-# LANGUAGE NamedFieldPuns       #-}-{-# LANGUAGE RecordWildCards      #-}-{-# LANGUAGE FlexibleInstances    #-}-{-# LANGUAGE FlexibleContexts     #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}-module Main where--import           Control.Applicative-import           Control.Monad.State        as State-import           Data.Maybe-import           System.Exit-import           System.IO                 (stdin, stderr, stdout, IOMode(..))-import           System.FilePath           (splitExtension, (<.>))-import           System.Directory          (removeFile)-import           System.Process            (system)-import           Control.Monad             (forM_, forM, when)-import           Control.Exception         (assert)-import qualified Data.ByteString.Lazy.Char8 as BSL-import qualified Data.HashMap.Strict        as Map-import qualified Data.Set                   as Set-import           Data.Monoid               ((<>))-import           Data.Aeson                (Value(..), decode, encode, FromJSON(..), ToJSON(..))-import           Data.Function             (on)-import           Data.List-import qualified Data.Text                  as Text-import qualified Data.Text.IO               as Text-import           Data.Text                 (Text)-import qualified Data.Vector                as V-import           Data.Scientific           (scientific, Scientific)-import           Text.PrettyPrint.GenericPretty (pretty)-import           Test.QuickCheck--import           Data.Aeson.AutoType.CodeGen(writeModule, runModule, Lang(..))-import           Data.Aeson.AutoType.Extract-import           Data.Aeson.AutoType.Format-import           Data.Aeson.AutoType.Pretty-import           Data.Aeson.AutoType.Split-import           Data.Aeson.AutoType.Test-import           Data.Aeson.AutoType.Type-import           Data.Aeson.AutoType.Util-import           Options.Applicative--import           CommonCLI---- * Command line flags---defineFlag "z:size"            (10     :: Int)        "Size of generated elements"---defineFlag "s:stem"            ("Test" :: FilePath)   "Test filename stem"---defineFlag "c:count"           (100    :: Int)        "Number of test cases to generate."---defineFlag "o:outputFilename"   defaultOutputFilename "Write output to the given file"---flags_suggest = True---defineFlag "suggest"            True                  "Suggest candidates for unification"---defineFlag "autounify"          True                  "Automatically unify suggested candidates"---defineFlag "t:test"             True                  "Try to run generated parser after"---defineFlag "d:debug"            False                 "Set this flag to see more debugging info"---defineFlag "keep"               False                 "Keep also the successful tests"---defineFlag "fakeFlag"           True                  "Ignore this flag - it doesn't exist!!! It is workaround for a library problem."--data Options = Options {-                 tyOpts    :: TypeOpts-               , keep      :: Bool-               , stem      :: FilePath-               , count     :: Int-               , size      :: Int-               }--optParser :: Parser Options-optParser  =-    Options  <$> tyOptParser-             <*> switch    (long "keep"                  <> help "Also keep successful tests"  )-             <*> strOption (long "stem"  <> value "Test" <> help "Output filename stem"        )-             <*> intOpt    (long "count" <> value 100    <> help "Number of tests to perform"  )-             <*> intOpt    (long "size"  <> value 10     <> help "size of generated test cases")-             -- <*> some (argument str (metavar "FILES..."))-  where-    intOpt = option auto---- | 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---- | Read JSON and extract @Type@ information from it.-extractTypeFromJSONFile :: (String -> IO ()) -> FilePath -> IO (Maybe Type)-extractTypeFromJSONFile myTrace inputFilename =-      withFileOrHandle inputFilename ReadMode stdin $ \hIn ->-        -- First we decode JSON input into Aeson's Value type-        do bs <- BSL.hGetContents hIn-           Text.hPutStrLn stderr $ "Processing " `Text.append` Text.pack (show inputFilename)-           myTrace ("Decoded JSON: " ++ pretty (decode bs :: Maybe Value))-           case decode bs of-             Nothing -> do report $ "Cannot decode JSON input from " `Text.append` Text.pack (show inputFilename)-                           return Nothing-             Just v  -> do -- If decoding JSON was successful...-               -- We extract type structure from the JSON value.-               let t        = extractType v-               myTrace $ "Type: " ++ pretty t-               return $ Just t---vectorWithoutDuplicates ::  Ord b => Int -> Gen b -> Gen [b]-vectorWithoutDuplicates i gen = take i-                              .  removeDuplicates-                             <$> infiniteListOf gen--removeDuplicates ::  Ord a => [a] -> [a]-removeDuplicates list = filterM checkDup list `evalState` Set.empty-  where-    checkDup x = do seen <- State.get-                    if x `Set.member` seen-                      then-                        return False-                      else do-                        State.put $ x `Set.insert` seen-                        return True---- TODO: check for generic Ord?-instance Ord Value where-  Null       `compare`  Null      = EQ-  Null       `compare`  _         = LT-  _          `compare`  Null      = GT-  (Bool   a) `compare` (Bool   b) = a `compare` b-  (Bool   a) `compare`  _         = LT-  _          `compare` (Bool   b) = GT-  (Number a) `compare` (Number b) = a `compare` b-  (Number _) `compare`  _         = LT-  _          `compare` (Number _) = GT-  (String a) `compare` (String b) = a `compare` b-  (String a) `compare` _          = LT-  _          `compare` (String b) = GT-  (Array  a) `compare` (Array  b) = a `compare` b-  (Array  a) `compare` _          = LT-  _          `compare` (Array  b) = GT-  (Object a) `compare` (Object b) = Map.toList a `compare` Map.toList b---- | Take a set of JSON input filenames, Haskell output filename, and generate module parsing these JSON files.-generateTestJSONs :: Options -> IO ()-generateTestJSONs Options {tyOpts=TyOptions {..},-                           ..}= do-    testValues :: [Value] <- generate $-                               resize size $-                                 vectorWithoutDuplicates 100 arbitraryTopValue-    results               <- forM (zip3 inputFilenames outputFilenames testValues) $-      \(inputFilename, outputFilename, jsonValue) -> do-        BSL.writeFile inputFilename $ encode jsonValue-        -- Read type from each file-        typeForEachFile  <- catMaybes <$> mapM (extractTypeFromJSONFile myTrace) [inputFilename]-        -- Unify all input types-        when (null typeForEachFile) $ do-          report "No valid JSON input file..."-          exitFailure-        let finalType = foldr1 unifyTypes typeForEachFile-        -- 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 $ 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-                          then unifyCandidates uCands splitted-                          else splitted-          myTrace $ "UNIFIED:\n" ++ pretty unified-          -- We start by writing module header-          writeModule lang outputFilename toplevelName unified-          if test-            then do-              r <- (==ExitSuccess) <$> runModule lang [outputFilename, inputFilename]-              when r $ mapM_ removeFile [inputFilename, outputFilename]-              return r-            else-              return True-    putStrLn $ "Successfully generated "      ++ show (length results) ++-               " JSON files, out of planned " ++ show count  ++ " cases."-  where-    makeInputFilename  = (<.>".json") . (stem ++) . show-    makeOutputFilename = (<.>".hs")   . (stem ++) . show-    inputFilenames     = map makeInputFilename  [1..count]-    outputFilenames    = map makeOutputFilename [1..count]-    myTrace :: String -> IO ()-    myTrace msg = debug `when` putStrLn msg-    toplevelName = capitalize $ Text.pack toplevel--main :: IO ()-main = do opts <- execParser optInfo-          generateTestJSONs opts-    where-      optInfo = info (optParser <**> helper)-        ( fullDesc-       <> progDesc "Generate a number of JSON test files, and generate type and parser for each."-       <> header   "Self-test for json-autotype" )

@@ -8,15 +8,18 @@  I should probably write a short paper to explain the methodology. -[![Build Status](https://circleci.com/gh/mgajda/json-autotype.svg?style=shield)](https://circleci.com/gh/mgajda/json-autotype)-[![Hackage](https://img.shields.io/hackage/v/lens.svg)](https://hackage.haskell.org/package/json-autotype)+[![Build matrix across GHC compiler versions](https://img.shields.io/travis/mgajda/json-autotype.svg)](https://travis-ci.org/mgajda/json-autotype)+[![Release build](https://gitlab.com/migamake/json-autotype/badges/master/pipeline.svg)](https://gitlab.com/migamake/json-autotype/commits/master)+[![Hackage](https://img.shields.io/hackage/v/json-autotype.svg)](https://hackage.haskell.org/package/json-autotype) [![Hackage Dependencies](https://img.shields.io/hackage-deps/v/json-autotype.svg?style=flat)](http://packdeps.haskellers.com/feed?needle=json-autotype)+[![Docker Automated build](https://img.shields.io/docker/automated/migamake/json-autotype.svg)](https://hub.docker.com/r/migamake/json-autotype/)+[![Docker image size](https://img.shields.io/microbadger/image-size/migamake/json-autotype.svg)](https://hub.docker.com/r/migamake/json-autotype/)  Details on official releases are on [Hackage](https://hackage.haskell.org/package/json-autotype) We currently support code generation to [Haskell](https://www.haskell.org), and [Elm](https://elm-lang.org). -_Please [volunteer help](https://gitter.im/dataHaskell/json-autotype) or [financial support](https://paypal.me/MichalJan), if you want your favourite language supported too!_-Expression of interest may be filed as [GitHub issue](https://github.com/mgajda/json-autotype/issues/new).+_Please [volunteer help](https://gitter.im/dataHaskell/json-autotype) or [provide financial support](https://paypal.me/MichalJan), if you want your favourite language supported too!_+Expression of interest in particular feature may be filed as [GitHub issue](https://github.com/mgajda/json-autotype/issues/new).   USAGE:@@ -47,6 +50,11 @@ You may either edit the resulting file _and_ send it to the author as a test case for future release.  Patches and suggestions are welcome.++You can run [with Docker](https://hub.docker.com/r/migamake/json-autotype/):+```+docker run -it migamake/json-autotype+```  EXAMPLES: =========

@@ -0,0 +1,193 @@+{-# 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 $+      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")

@@ -1,5 +1,21 @@ Changelog =========+    3.0.0  Nov 2018+        * Distinguishing integers and floats.+        * Hide all API beside Alternative (as unused outside generator).+        * Add fixity for alt (#20)+        * Use `eitherDecode` instead of `decode` to get better error messages.+        * Split Data.Aeson.AutoType.Alternative to `json-alt`.++    2.0.2  Nov 2018+        * Clean up the tests.+        * Remove compatibility with Aeson versions earlier than 1.2.1.+        * Removed all CPP macros+        * Add --version++    2.0.1  Nov 2018+        * Better error reporting when parsing JSON.+     2.0.0  Jun 2018         * Elm support completed with untagged unions         * Add HaskellStrict option for running tests with -Werror, -Wall by default.

@@ -0,0 +1,39 @@+module CommonCLI(TypeOpts(..), unflag, tyOptParser) where+++import           Data.Monoid                    ((<>))+import           Options.Applicative+import           System.Process                 (system)+import qualified System.Environment             (lookupEnv)+import           System.Exit                    (ExitCode)++import           Data.Aeson.AutoType.CodeGen    (Lang(..))++data TypeOpts = TyOptions {+                  autounify :: Bool+                , toplevel  :: String+                , debug     :: Bool+                , test      :: Bool+                , suggest   :: Bool+                , lang      :: Lang+                }++unflag :: Mod FlagFields Bool -> Parser Bool+unflag  = flag True False++tyOptParser :: Parser TypeOpts+tyOptParser  = TyOptions+            <$> unflag (long "no-autounify" <> help "Do not automatically unify suggested candidates")+            <*> strOption (short 't'        <>+                           long "toplevel"  <> value "TopLevel"+                                            <> help "Name for toplevel data type")+            <*> switch (long "debug"        <> help "Set this flag to see more debugging info"       )+            <*> unflag (long "no-test"      <> help "Do not run generated parser afterwards"         )+            <*> unflag (long "no-suggest"   <> help "Do not suggest candidates for unification"      )+            <*> langOpts+++langOpts :: Parser Lang+langOpts  =  flag Haskell Haskell (long "haskell")+         <|> flag Haskell Elm     (long "elm")+

@@ -0,0 +1,15 @@+{+    "colorsArray":[{+            "colorName":"red",+            "hexValue":"#f00"+        },+        {+            "colorName":"green",+            "hexValue":"#0f0"+        },+        {+            "colorName":"blue",+            "hexValue":"#00f"+        }+    ]+}

@@ -0,0 +1,14 @@+{+    "parameter":[{+            "parameterName":"apiVersion",+            "parameterValue":1+        },+        {+            "parameterName":"failOnWarnings",+            "parameterValue":false+        },+        {+            "parameterName":"caller",+            "parameterValue":"site API"+        }]+}

@@ -1,8 +1,8 @@ -- Build information for the package. name:                json-autotype-version:             2.0.0+version:             3.0.0 synopsis:            Automatic type declaration for JSON input data-description:         Generates datatype declarations with Aeson's "FromJSON" instances+description:         Generates datatype declarations with Aeson's `FromJSON` instances                      from a set of example ".json" files.                      .                      To get started you need to install the package,@@ -12,7 +12,7 @@                      "$ json-autotype input.json -o JSONTypes.hs"                      .                      Feel free to tweak the by changing types of the fields-                      - any field type that is instance of "FromJSON" should work.+                      - any field type that is instance of `FromJSON` should work.                      .                      You may immediately test the parser by calling it as a script:                      .@@ -33,26 +33,52 @@ author:              Michal J. Gajda maintainer:          simons@cryp.to                      mjgajda@gmail.com-copyright:           Copyright by Michal J. Gajda '2014-'2017+copyright:           Copyright by Michal J. Gajda '2014-'2018 category:            Data, Tools build-type:          Simple-extra-source-files:  README.md changelog.md+extra-source-files:  README.md changelog.md examples/union.json examples/colors.json cabal-version:       >=1.10 bug-reports:         https://github.com/mgajda/json-autotype/issues-tested-with:         GHC==7.8.4, GHC==7.10.3, GHC==7.6.3, GHC==8.0.1, GHC==8.2.2, GHC==8.4.1+tested-with:         GHC==7.6.1+                   , GHC==7.6.2+                   , GHC==7.6.3+                   , GHC==7.8.1+                   , GHC==7.8.2+                   , GHC==7.8.3+                   , GHC==7.8.4+                   , GHC==7.10.1+                   , GHC==7.10.2+                   , GHC==7.10.3+                   , GHC==8.0.1+                   , GHC==8.0.2+                   , GHC==8.2.2+                   , GHC==8.4.1+                   , GHC==8.4.2+                   , GHC==8.4.3+                   , GHC==8.4.4+                   , GHC==8.6.2+                   , GHC==8.6.1+ source-repository head   type:     git   location: https://github.com/mgajda/json-autotype.git  library-  exposed-modules:     Data.Aeson.AutoType.Type+  exposed-modules:     Data.Aeson.AutoType.CodeGen+                       Data.Aeson.AutoType.CodeGen.Generic+                       Data.Aeson.AutoType.CodeGen.Haskell+                       Data.Aeson.AutoType.CodeGen.Elm+                       Data.Aeson.AutoType.CodeGen.HaskellFormat+                       Data.Aeson.AutoType.CodeGen.ElmFormat                        Data.Aeson.AutoType.Extract                        Data.Aeson.AutoType.Format                        Data.Aeson.AutoType.Pretty-                       Data.Aeson.AutoType.CodeGen-                       Data.Aeson.AutoType.Alternative-                       -- Data.Aeson.AutoType.Plugin.Subtype-                       -- Data.Aeson.AutoType.Plugin.Loader+                       Data.Aeson.AutoType.Split+                       Data.Aeson.AutoType.Type+                       Data.Aeson.AutoType.Test+                       Data.Aeson.AutoType.Util+  hs-source-dirs:      src+   other-extensions:    TemplateHaskell,                        ScopedTypeVariables,                        OverloadedStrings,@@ -61,23 +87,13 @@                        DeriveDataTypeable,                        DeriveGeneric,                        RecordWildCards-  other-modules:-                       -- internal module-                       Data.Aeson.AutoType.Util-                       Data.Aeson.AutoType.Split-                       Data.Aeson.AutoType.CodeGen.Haskell-                       Data.Aeson.AutoType.CodeGen.Elm-                       Data.Aeson.AutoType.CodeGen.HaskellFormat-                       Data.Aeson.AutoType.CodeGen.ElmFormat-  build-depends:       base                 >=4.3  && <4.12,+  build-depends:       base                 >=4.3  && <5,                        GenericPretty        >=1.2  && <1.3,-                       aeson                >=0.11.2 && <1.5,+                       aeson                >=1.2.1 && <1.5,                        containers           >=0.3  && <0.7,                        filepath             >=1.3  && <1.5,                        hashable             >=1.2  && <1.3,-                       ---hint                 >=0.4  && <0.6,-                       lens                 >=4.1  && <4.17,-                       --mmap                 >=0.5  && <0.6,+                       lens                 >=4.1  && <4.18,                        mtl                  >=2.1  && <2.3,                        pretty               >=1.1  && <1.3,                        process              >=1.1  && <1.7,@@ -85,26 +101,18 @@                        text                 >=1.1  && <1.4,                        uniplate             >=1.6  && <1.7,                        unordered-containers >=0.2  && <0.3,-                       vector               >=0.9  && <0.13+                       vector               >=0.9  && <0.13,+                       smallcheck           >=1.0  && <1.2,+                       QuickCheck           >=2.4  && <3.0,+                       json-alt,+                       template-haskell   default-language:    Haskell2010  executable json-autotype   main-is:             GenerateJSONParser.hs-  other-modules:       Data.Aeson.AutoType.Type-                       Data.Aeson.AutoType.Extract-                       Data.Aeson.AutoType.Format-                       Data.Aeson.AutoType.Pretty-                       Data.Aeson.AutoType.Split-                       Data.Aeson.AutoType.CodeGen-                       Data.Aeson.AutoType.CodeGen.Haskell-                       Data.Aeson.AutoType.CodeGen.Elm-                       Data.Aeson.AutoType.CodeGen.HaskellFormat-                       Data.Aeson.AutoType.CodeGen.ElmFormat-                       Data.Aeson.AutoType.Alternative-                       -- Data.Aeson.AutoType.Plugin.Subtype-                       -- Data.Aeson.AutoType.Plugin.Loader-                       Data.Aeson.AutoType.Util-                       CommonCLI+  hs-source-dirs:      app common+  other-modules:       CommonCLI+                       Paths_json_autotype   other-extensions:    TemplateHaskell,                        ScopedTypeVariables,                        OverloadedStrings,@@ -113,15 +121,14 @@                        DeriveDataTypeable,                        DeriveGeneric,                        RecordWildCards-  build-depends:       base                 >=4.3  && <4.12,+  build-depends:       base                 >=4.3  && <5,                        GenericPretty        >=1.2  && <1.3,-                       aeson                >=0.11.2  && <1.5,+                       aeson                >=1.2.1  && <1.5,                        bytestring           >=0.9  && <0.11,                        containers           >=0.3  && <0.7,                        filepath             >=1.3  && <1.5,                        hashable             >=1.2  && <1.3,-                       --hint                 >=0.4  && <0.6,-                       lens                 >=4.1  && <4.17,+                       lens                 >=4.1  && <4.18,                        mtl                  >=2.1  && <2.3,                        optparse-applicative >=0.12 && <1.0,                        pretty               >=1.1  && <1.3,@@ -131,22 +138,21 @@                        uniplate             >=1.6  && <1.7,                        unordered-containers >=0.2  && <0.3,                        vector               >=0.9  && <0.13,-                       yaml                 >=0.8  && <0.9-  -- hs-source-dirs:+                       yaml                 >=0.8  && <0.12,+                       template-haskell,+                       json-autotype,+                       json-alt   default-language:    Haskell2010+  ld-options: -static+  ghc-options: -fPIC  -- * Test suites -- Test suite with QuickCheck on random values, -- and extracted types. test-suite json-autotype-qc-test   type:                exitcode-stdio-1.0-  main-is:             test/TestQC.hs-  other-modules:       Data.Aeson.AutoType.Util-                       Data.Aeson.AutoType.Extract-                       Data.Aeson.AutoType.Format-                       Data.Aeson.AutoType.Test-                       Data.Aeson.AutoType.Type-                       Data.Aeson.AutoType.Pretty+  main-is:             TestQC.hs+  hs-source-dirs:      test common   other-extensions:    TemplateHaskell,                        ScopedTypeVariables,                        OverloadedStrings,@@ -155,12 +161,12 @@                        DeriveDataTypeable,                        DeriveGeneric,                        RecordWildCards-  build-depends:       base                 >=4.3  && <4.12,+  build-depends:       base                 >=4.3  && <5,                        GenericPretty        >=1.2  && <1.3,-                       aeson                >=0.11.2  && <1.5,+                       aeson                >=1.2.1   && <1.5,                        containers           >=0.3  && <0.7,                        hashable             >=1.2  && <1.3,-                       lens                 >=4.1  && <4.17,+                       lens                 >=4.1  && <4.18,                        mtl                  >=2.1  && <2.3,                        pretty               >=1.1  && <1.3,                        scientific           >=0.3  && <0.5,@@ -169,26 +175,17 @@                        uniplate             >=1.6  && <1.7,                        unordered-containers >=0.2  && <0.3,                        vector               >=0.9  && <0.13,-                       QuickCheck           >=2.4  && <3.0-  -- hs-source-dirs:+                       QuickCheck           >=2.4  && <3.0,+                       json-autotype,+                       json-alt   default-language:    Haskell2010  test-suite json-autotype-examples   type:                exitcode-stdio-1.0-  main-is:             test/TestExamples.hs-  other-modules:       Data.Aeson.AutoType.Util-                       Data.Aeson.AutoType.CodeGen-                       Data.Aeson.AutoType.CodeGen.Elm-                       Data.Aeson.AutoType.CodeGen.ElmFormat-                       Data.Aeson.AutoType.CodeGen.Haskell-                       Data.Aeson.AutoType.CodeGen.HaskellFormat-                       Data.Aeson.AutoType.Extract-                       Data.Aeson.AutoType.Format-                       Data.Aeson.AutoType.Pretty-                       Data.Aeson.AutoType.Split-                       Data.Aeson.AutoType.Test-                       Data.Aeson.AutoType.Type-                       CommonCLI+  main-is:             TestExamples.hs+  other-modules:       CommonCLI+  hs-source-dirs:      test common+   other-extensions:    TemplateHaskell,                        ScopedTypeVariables,                        OverloadedStrings,@@ -197,14 +194,14 @@                        DeriveDataTypeable,                        DeriveGeneric,                        RecordWildCards-  build-depends:       base                 >=4.3  && <4.12,+  build-depends:       base                 >=4.3  && <5,                        GenericPretty        >=1.2  && <1.3,-                       aeson                >=0.11.2  && <1.5,+                       aeson                >=1.2.1 && <1.5,                        containers           >=0.3  && <0.7,                        directory            >=1.1  && <1.4,                        filepath             >=1.3  && <1.5,                        hashable             >=1.2  && <1.3,-                       lens                 >=4.1  && <4.17,+                       lens                 >=4.1  && <4.18,                        mtl                  >=2.1  && <2.3,                        optparse-applicative >=0.11 && <1.0,                        pretty               >=1.1  && <1.3,@@ -215,27 +212,19 @@                        unordered-containers >=0.2  && <0.3,                        uniplate             >=1.6  && <1.7,                        vector               >=0.9  && <0.13,-                       QuickCheck           >=2.4  && <3.0-  -- hs-source-dirs:+                       QuickCheck           >=2.4  && <3.0,+                       template-haskell,+                       json-autotype,+                       json-alt   default-language:    Haskell2010  -- Test suite with Haskell code generation and compilation test-suite json-autotype-gen-test   type:                exitcode-stdio-1.0   main-is:             GenerateTestJSON.hs-  other-modules:       Data.Aeson.AutoType.Util-                       Data.Aeson.AutoType.Pretty-                       Data.Aeson.AutoType.Type-                       Data.Aeson.AutoType.Split-                       Data.Aeson.AutoType.Extract-                       Data.Aeson.AutoType.Format-                       Data.Aeson.AutoType.CodeGen-                       Data.Aeson.AutoType.CodeGen.Haskell-                       Data.Aeson.AutoType.CodeGen.Elm-                       Data.Aeson.AutoType.CodeGen.HaskellFormat-                       Data.Aeson.AutoType.CodeGen.ElmFormat-                       Data.Aeson.AutoType.Test-                       CommonCLI+  hs-source-dirs:      test common+  other-modules:       CommonCLI+   other-extensions:    TemplateHaskell,                        ScopedTypeVariables,                        OverloadedStrings,@@ -244,16 +233,16 @@                        DeriveDataTypeable,                        DeriveGeneric,                        RecordWildCards-  build-depends:       base                 >=4.3  && <4.12,+  build-depends:       base                 >=4.3  && <5,                        GenericPretty        >=1.2  && <1.3,-                       aeson                >=0.11.2  && <1.5,+                       aeson                >=1.2.1  && <1.5,                        bytestring           >=0.9  && <0.11,                        containers           >=0.3  && <0.7,                        directory            >=1.1  && <1.4,                        filepath             >=1.3  && <1.5,                        hashable             >=1.2  && <1.3,                        optparse-applicative >=0.12 && <1.0,-                       lens                 >=4.1  && <4.17,+                       lens                 >=4.1  && <4.18,                        mtl                  >=2.1  && <2.3,                        pretty               >=1.1  && <1.3,                        process              >=1.1  && <1.7,@@ -263,6 +252,8 @@                        uniplate             >=1.6  && <1.7,                        unordered-containers >=0.2  && <0.3,                        vector               >=0.9  && <0.13,-                       QuickCheck           >=2.4  && <3.0-  -- hs-source-dirs:+                       QuickCheck           >=2.4  && <3.0,+                       template-haskell,+                       json-autotype,+                       json-alt   default-language:    Haskell2010

@@ -0,0 +1,39 @@+{-# LANGUAGE CPP               #-}+{-# LANGUAGE OverloadedStrings #-}+-- | Code generation and test running in different languages. (Switchbox.)+module Data.Aeson.AutoType.CodeGen(+    Lang(..)+  , writeModule+  , runModule+  , defaultOutputFilename+  ) where++import           Data.Text(Text)+import qualified Data.HashMap.Strict as Map+import           Data.Aeson.AutoType.Type++import           Data.Aeson.AutoType.CodeGen.Haskell+import           Data.Aeson.AutoType.CodeGen.Elm++-- | Available output languages.+data Lang = Haskell+          | HaskellStrict+          | Elm++-- | Default output filname is used, when there is no explicit output file path, or it is "-" (stdout).+-- Default module name is consistent with it.+defaultOutputFilename :: Lang -> FilePath+defaultOutputFilename Haskell       = defaultHaskellFilename+defaultOutputFilename HaskellStrict = defaultHaskellFilename+defaultOutputFilename Elm           = defaultElmFilename++-- | Write a Haskell module to an output file, or stdout if `-` filename is given.+writeModule :: Lang -> FilePath -> Text -> Map.HashMap Text Type -> IO ()+writeModule Haskell       = writeHaskellModule+writeModule HaskellStrict = writeHaskellModule+writeModule Elm           = writeElmModule++-- | Run module in a given language.+runModule Haskell       = runHaskellModule+runModule HaskellStrict = runHaskellModuleStrict+runModule Elm           = runElmModule

@@ -0,0 +1,67 @@+{-# LANGUAGE CPP               #-}+{-# LANGUAGE OverloadedStrings #-}+-- | Wrappers for generating prologue and epilogue code in Haskell.+module Data.Aeson.AutoType.CodeGen.Elm(+    defaultElmFilename+  , writeElmModule+  , runElmModule+  ) where++import qualified Data.Text           as Text+import qualified Data.Text.IO        as Text+import           Data.Text+import qualified Data.HashMap.Strict as Map+import           Control.Arrow               (first)+import           Control.Exception (assert)+import           Data.Monoid                 ((<>))+import           System.FilePath+import           System.IO+import           System.Process                 (system)+import           System.Exit                    (ExitCode)++import           Data.Aeson.AutoType.Format+import           Data.Aeson.AutoType.Type+import           Data.Aeson.AutoType.Util+import           Data.Aeson.AutoType.CodeGen.ElmFormat++import Debug.Trace(trace)++defaultElmFilename = "JSONTypes.elm"++header :: Text -> Text+header moduleName = Text.unlines [+   Text.unwords ["module ", capitalize moduleName, " exposing(..)"]+  ,""+  ,"-- elm-package install toastal/either"+  ,"-- elm-package install NoRedInk/elm-decode-pipeline"+  ,"import Either               exposing (Either, unpack)"+  ,"import Json.Encode          exposing (..)"+  ,"import Json.Decode          exposing (..)"+  ,"import Json.Decode.Pipeline exposing (..)"+  ,""]++epilogue :: Text -> Text+epilogue toplevelName = Text.unlines []++-- | Write a Haskell module to an output file, or stdout if `-` filename is given.+writeElmModule :: FilePath -> Text -> Map.HashMap Text Type -> IO ()+writeElmModule outputFilename toplevelName types =+    withFileOrHandle outputFilename WriteMode stdout $ \hOut ->+      assert (trace extension extension == ".elm") $ do+        Text.hPutStrLn hOut $ header $ Text.pack moduleName+        -- We write types as Haskell type declarations to output handle+        Text.hPutStrLn hOut $ displaySplitTypes types+        Text.hPutStrLn hOut $ epilogue toplevelName+  where+    (moduleName, extension) =+       first normalizeTypeName'     $+       splitExtension               $+       if     outputFilename == "-"+         then defaultElmFilename+         else outputFilename+    normalizeTypeName' = Text.unpack . normalizeTypeName . Text.pack++runElmModule :: [String] -> IO ExitCode+runElmModule arguments = do+    hPutStrLn stderr "Compiling *not* running Elm module for a test."+    system $ Prelude.unwords $ ["elm", "make", Prelude.head arguments] -- ignore parsing args

@@ -0,0 +1,316 @@+{-# LANGUAGE CPP                 #-}+{-# LANGUAGE TemplateHaskell     #-}+{-# LANGuaGE ScopedTypeVariables #-}+{-# LANGUAGE ViewPatterns        #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGuaGE DeriveGeneric       #-}+{-# LANGuaGE FlexibleContexts    #-}+-- | Formatting type declarations and class instances for inferred types.+module Data.Aeson.AutoType.CodeGen.ElmFormat(+  displaySplitTypes,+  normalizeTypeName) where++import           Control.Arrow             ((&&&))+import           Control.Applicative       ((<$>), (<*>))+import           Control.Lens.TH+import           Control.Lens+import           Control.Monad             (forM)+import           Control.Exception(assert)+import qualified Data.HashMap.Strict        as Map+import           Data.Monoid+import qualified Data.Set                   as Set+import qualified Data.Text                  as Text+import           Data.Text                 (Text)+import           Data.Set                  (Set, toList)+import           Data.List                 (foldl1')+import           Data.Char                 (isAlpha, isDigit)+import           Control.Monad.State.Class+import           Control.Monad.State.Strict(State, runState)+import           GHC.Generics              (Generic)++import           Data.Aeson.AutoType.Type+import           Data.Aeson.AutoType.Extract+import           Data.Aeson.AutoType.Split+import           Data.Aeson.AutoType.Format+import           Data.Aeson.AutoType.Util  ()++--import           Debug.Trace -- DEBUG+trace _ x = x++fst3 ::  (t, t1, t2) -> t+fst3 (a, _b, _c) = a++data DeclState = DeclState { _decls   :: [Text]+                           , _counter :: Int+                           }+  deriving (Eq, Show, Ord, Generic)++makeLenses ''DeclState++type DeclM = State DeclState++type Map k v = Map.HashMap k v++stepM :: DeclM Int+stepM = counter %%= (\i -> (i, i+1))++tShow :: (Show a) => a -> Text+tShow = Text.pack . show++-- | Wrap a type alias.+wrapAlias :: Text -> Text -> Text+wrapAlias identifier contents = Text.unwords ["type alias ", identifier, "=", contents]++-- | Wrap a data type declaration+wrapDecl ::  Text -> Text -> Text+wrapDecl identifier contents = Text.unlines [header, contents, "  }"]+                                            --,"\nderiveJSON defaultOptions ''" `Text.append` identifier]+  where+    header = Text.concat ["type alias ", identifier, " = ", " { "]++-- | Explanatory type alias for making declarations+-- First element of the triple is original JSON identifier,+-- second element of the triple is the mapped identifier name in Haskell.+-- third element of the triple shows the type in a formatted way+type MappedKey = (Text, Text, Text, Type, Bool)++-- | Make Decoder declaration, given identifier (object name in Haskell) and mapping of its keys+-- from JSON to Haskell identifiers *in the same order* as in *data type declaration*.+makeDecoder ::  Text -> [MappedKey] -> Text+makeDecoder identifier contents =+  Text.unlines [+      Text.concat  [decodeIdentifier, " : Json.Decode.Decoder ", identifier]+    , Text.concat  [decodeIdentifier, " ="]+    , Text.unwords ["    Json.Decode.Pipeline.decode", identifier]+    , Text.unlines (makeParser identifier <$> contents) ]+  where+    decodeIdentifier         = decoderIdent identifier+    makeParser identifier (jsonId, _, _, ty, isOptional) = Text.unwords [+          "  |>"+        , if isOptional+             then "Json.Decode.Pipeline.optional"+             else "Json.Decode.Pipeline.required"+        , Text.concat ["\"", jsonId, "\""]+        , "(" <> getDecoder ty <> ")"] -- quote++getDecoder  TString    = "Json.Decode.string"+getDecoder  TInt       = "Json.Decode.int"+getDecoder  TDouble    = "Json.Decode.float"+getDecoder  TBool      = "Json.Decode.bool"+getDecoder (TArray  t) = "Json.Decode.list (" <> getDecoder t <> ")"+getDecoder (TLabel  l) = decoderIdent l+getDecoder (TObj    o) = error   "getDecoder cannot handle complex object types!"+getDecoder (TUnion  u) = case nonNull of+                           []  -> "Json.Decode.value"+                           [x] -> getDecoder x+                           _   -> foldl1' altDecoder $ map getDecoder nonNull+  where+    nonNull = nonNullComponents u+--error $ "getDecoder cannot yet handle union types:" <> show u++altDecoder a b = "(Json.Decode.oneOf [Json.Decode.map Either.Left ("+              <> a <> "), Json.Decode.map Either.Right ("+              <> b <> ")])"+{-Json.Decode.Pipeline.decode Something+"Json.Decode.Pipeline " <>-}+                     ++decoderIdent ident = "decode" <> capitalize (normalizeTypeName ident)+-- Contents example for wrapFromJSON:+-- " <$>+--"                           v .: "hexValue"  <*>+--"                           v .: "colorName\""++encoderIdent ident = "encode" <> capitalize (normalizeTypeName ident)++-- | Make Encoder declaration, given identifier (object name in Haskell) and mapping of its keys+-- from JSON to Haskell identifiers in the same order as in declaration+makeEncoder :: Text -> [MappedKey] -> Text+makeEncoder identifier contents =+    Text.unlines [+        Text.unwords [encoderIdent identifier, ":", identifier, "->", "Json.Encode.Value"]+      , encoderIdent identifier <> " record ="+      , "    Json.Encode.object ["+      , "        " <> (joinWith "\n      , " (makeEncoder <$> contents))+      , "    ]"+      ]+  where+    makeEncoder (jsonId, haskellId, _typeText, ty, _nullable) = Text.concat [+            "(", tShow jsonId, ", (", getEncoder ty, ") record.", normalizeFieldName identifier jsonId, ")"+        ]+    --"answers",  Json.Encode.list <| List.map encodeAnswer <| record.answers+    escapeText = Text.pack . show . Text.unpack++getEncoder :: Type -> Text+getEncoder  TString   = "Json.Encode.string"+getEncoder  TDouble   = "Json.Encode.float"+getEncoder  TInt      = "Json.Encode.int"+getEncoder  TBool     = "Json.Encode.bool"+getEncoder  TNull     = "identity"+getEncoder (TLabel l) = encoderIdent l+getEncoder (TArray e) = "Json.Encode.list << List.map (" <> getEncoder e <> ")"+getEncoder (TObj   o) = error $ "Seeing direct object encoder: "         <> show o+getEncoder (TUnion u) = case nonNull of+                           []  -> "identity"+                           [x] -> getDecoder x+                           _   -> foldl1' altEncoder $ map getEncoder nonNull+  where+    nonNull = nonNullComponents u++altEncoder a b = "Either.unpack (" <> a <> ") (" <> b <> ")"++-- Contents example for wrapToJSON+--"hexValue"  .= hexValue+--                                        ,"colorName" .= colorName]+-- | Join text with other as separator.+joinWith :: Text -> [Text] -> Text+joinWith _      []            = ""+joinWith joiner (aFirst:rest) = aFirst <> Text.concat (map (joiner <>) rest)++-- | Makes a generic identifier name.+genericIdentifier :: DeclM Text+genericIdentifier = do+  i <- stepM+  return $! "Obj" `Text.append` tShow i++-- * Printing a single data type declaration+newDecl :: Text -> [(Text, Type)] -> DeclM Text+newDecl identifier kvs = do attrs <- forM kvs $ \(k, v) -> do+                              formatted <- formatType v+                              return (k, normalizeFieldName identifier k, formatted, v, isNullable v)+                            let decl = Text.unlines [wrapDecl    identifier $ fieldDecls attrs+                                                    ,""+                                                    ,makeDecoder identifier              attrs+                                                    ,""+                                                    ,makeEncoder identifier              attrs]+                            addDecl decl+                            return identifier+  where+    fieldDecls attrList = Text.intercalate ",\n" $ map fieldDecl attrList+    fieldDecl :: (Text, Text, Text, Type, Bool) -> Text+    fieldDecl (_jsonName, haskellName, fType, _type, _nullable) = Text.concat [+                                                                    "    ", haskellName, " : ", fType]++addDecl decl = decls %%= (\ds -> ((), decl:ds))++-- | Add new type alias for Array type+newAlias :: Text -> Type -> DeclM Text+newAlias identifier content = do formatted <- formatType content+                                 addDecl $ Text.unlines [wrapAlias identifier formatted]+                                 return identifier++-- | Convert a JSON key name given by second argument,+-- from within a dictionary keyed with first argument,+-- into a name of Haskell record field (hopefully distinct from other such selectors.)+normalizeFieldName ::  Text -> Text -> Text+normalizeFieldName identifier = escapeKeywords             .+                                uncapitalize               .+                                (normalizeTypeName identifier `Text.append`) .+                                normalizeTypeName++keywords ::  Set Text+keywords = Set.fromList ["type", "alias", "exposing", "module", "class",+                         "where", "let", "do"]++escapeKeywords ::  Text -> Text+escapeKeywords k | k `Set.member` keywords = k `Text.append` "_"+escapeKeywords k                           = k++nonNullComponents = Set.toList . Set.filter (TNull /=)+-- | Format the type within DeclM monad, that records+-- the separate declarations on which this one is dependent.+formatType :: Type -> DeclM Text+formatType  TString                          = return "String"+formatType  TDouble                          = return "Float"+formatType  TInt                             = return "Int"+formatType  TBool                            = return "Bool"+formatType (TLabel l)                        = return $ normalizeTypeName l+formatType (TUnion u)                        = wrap <$> case length nonNull of+                                                          0 -> return emptyTypeRepr+                                                          1 -> formatType $ head nonNull+                                                          _ -> foldl1' join <$> mapM formatType nonNull+  where+    nonNull = nonNullComponents u+    wrap                                :: Text -> Text+    wrap   inner  | TNull `Set.member` u = Text.concat ["(Maybe (", inner, "))"]+                  | otherwise            =                          inner+    join fAlt fOthers = Text.concat ["Either (", fAlt, ") (", fOthers, ")"]+formatType (TArray a)                        = do inner <- formatType a+                                                  return $ Text.concat ["List (", inner, ")"]+formatType (TObj   o)                        = do ident <- genericIdentifier+                                                  newDecl ident d+  where+    d = Map.toList $ unDict o+formatType  e | e `Set.member` emptySetLikes = return emptyTypeRepr+formatType  t                                = return $ "ERROR: Don't know how to handle: " `Text.append` tShow t++emptyTypeRepr :: Text+emptyTypeRepr = "Json.Decode.Value" -- default, accepts future extension where we found no data++runDecl ::  DeclM a -> Text+runDecl decl = Text.unlines $ finalState ^. decls+  where+    initialState    = DeclState [] 1+    (_, finalState) = runState decl initialState++-- * Splitting object types by label for unification.+type TypeTree    = Map Text [Type]++type TypeTreeM a = State TypeTree a++addType :: Text -> Type -> TypeTreeM ()+addType label typ = modify $ Map.insertWith (++) label [typ]++formatObjectType ::  Text -> Type -> DeclM Text+formatObjectType identifier (TObj o) = newDecl  identifier d+  where+    d = Map.toList $ unDict o+formatObjectType identifier  other   = newAlias identifier other++-- | Display an environment of types split by name.+displaySplitTypes ::  Map Text Type -> Text+displaySplitTypes dict = trace ("displaySplitTypes: " ++ show (toposort dict)) $ runDecl declarations+  where+    declarations =+      forM (toposort dict) $ \(name, typ) ->+        formatObjectType (normalizeTypeName name) typ++-- | Normalize type name by:+-- 1. Treating all characters that are not acceptable in Haskell variable name as end of word.+-- 2. Capitalizing each word, but a first (camelCase).+-- 3. Adding underscore if first character is non-alphabetic.+-- 4. Escaping Haskell keywords if the whole identifier is such keyword.+-- 5. If identifier is empty, then substituting "JsonEmptyKey" for its name.+normalizeTypeName :: Text -> Text+normalizeTypeName s  = ifEmpty "JsonEmptyKey"                  .+                       escapeKeywords                          .+                       escapeFirstNonAlpha                     .+                       Text.concat                             .+                       map capitalize                          .+                       filter     (not . Text.null)            .+                       Text.split (not . acceptableInVariable) $ s+  where+    ifEmpty x ""       = x+    ifEmpty _ nonEmpty = nonEmpty+    acceptableInVariable c = isAlpha c || isDigit c+    escapeFirstNonAlpha cs                  | Text.null cs =                   cs+    escapeFirstNonAlpha cs@(Text.head -> c) | isAlpha   c  =                   cs+    escapeFirstNonAlpha cs                                 = "_" `Text.append` cs++-- | Computes all type labels referenced by a given type.+allLabels :: Type -> [Text]+allLabels = flip go []+  where+    go (TLabel l) ls = l:ls+    go (TArray t) ls = go t ls+    go (TUnion u) ls = Set.foldr go ls          u+    go (TObj   o) ls = Map.foldr go ls $ unDict o+    go _other     ls = ls++-- | Remaps type labels according to a `Map`.+remapLabels :: Map Text Text -> Type -> Type+remapLabels ls (TObj   o) = TObj   $ Dict $ Map.map (remapLabels ls) $ unDict o+remapLabels ls (TArray t) = TArray $                 remapLabels ls  t+remapLabels ls (TUnion u) = TUnion $        Set.map (remapLabels ls) u+remapLabels ls (TLabel l) = TLabel $ Map.lookupDefault l l ls+remapLabels _  other      = other

@@ -0,0 +1,13 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE QuasiQuotes     #-}+module Data.Aeson.AutoType.CodeGen.Generic(src) where++import Language.Haskell.TH+import Language.Haskell.TH.Quote++-- | Multiline source string+src = QuasiQuoter (\src -> [|src|])+                  (error "Cannot use src as pattern")+                  (error "Cannot use src as type"   )+                  (error "Cannot use src as dec"    )+

@@ -0,0 +1,116 @@+{-# 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+  ) 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.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++-- | 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 = "JSONTypes.hs"++header :: Text -> Text+header moduleName = [src|+{-# LANGUAGE TemplateHaskell     #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE RecordWildCards     #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE TypeOperators       #-}+{-# LANGUAGE DeriveGeneric       #-}++module |] <> capitalize moduleName <> [src| where++import           System.Exit        (exitFailure, exitSuccess)+import           System.IO          (stderr, hPutStrLn)+import qualified Data.ByteString.Lazy.Char8 as BSL+import           System.Environment (getArgs)+import           Control.Monad      (forM_, mzero, join)+import           Control.Applicative+import           Data.Aeson.AutoType.Alternative+import           Data.Aeson(eitherDecode, Value(..), FromJSON(..), ToJSON(..),+                            pairs,+                            (.:), (.:?), (.=), object)+import           Data.Monoid((<>))+import           Data.Text (Text)+import qualified GHC.Generics+|]++epilogue :: Text -> Text+epilogue toplevelName = [src|+parse :: FilePath -> IO |] <> toplevelName <> [src|+parse filename = do+    input <- BSL.readFile filename+    case eitherDecode input of+      Left  err -> fatal $ case (eitherDecode input :: Either String Value) of+                           Left  err -> "Invalid JSON file: " ++ filename ++ " ++ err"+                           Right _   -> "Mismatched JSON value from file: " ++ filename+                                     ++ "\n" ++ err+      Right r   -> return (r :: |] <> toplevelName <> ")" <> [src|+  where+    fatal :: String -> IO a+    fatal msg = do hPutStrLn stderr msg+                   exitFailure++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 outputFilename toplevelName types =+    withFileOrHandle outputFilename WriteMode stdout $ \hOut ->+      assert (extension == ".hs") $ do+        Text.hPutStrLn hOut $ header $ Text.pack moduleName+        -- We write types as Haskell type declarations to output handle+        Text.hPutStrLn hOut $ displaySplitTypes types+        Text.hPutStrLn hOut $ epilogue toplevelName+  where+    (moduleName, extension) =+       first normalizeTypeName'     $+       splitExtension               $+       if     outputFilename == "-"+         then defaultHaskellFilename+         else outputFilename+    normalizeTypeName' = Text.unpack . normalizeTypeName . Text.pack++runHaskellModule :: [String] -> IO ExitCode+runHaskellModule arguments = do+    maybeStack <- System.Environment.lookupEnv "STACK_EXEC"+    maybeCabal <- System.Environment.lookupEnv "CABAL_SANDBOX_CONFIG"+    let execPrefix | Just stackExec <- maybeStack = [stackExec, "runghc"]+                   | Just _         <- maybeCabal = ["cabal",   "exec", "runghc"]+                   | otherwise                    = ["runghc"]+    putStrLn $ "Running Haskell module: " ++ show execPrefix ++ show arguments+    system $ Prelude.unwords $ execPrefix ++ arguments+-- Add: -i`stack path --dist-dir`/build/autogen+runHaskellModuleStrict :: [String] -> IO ExitCode+runHaskellModuleStrict  = runHaskellModule . ("-Wall":) . ("-Werror":)+

@@ -0,0 +1,284 @@+{-# LANGUAGE CPP                 #-}+{-# LANGUAGE TemplateHaskell     #-}+{-# LANGuaGE ScopedTypeVariables #-}+{-# LANGUAGE ViewPatterns        #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGuaGE DeriveGeneric       #-}+{-# LANGuaGE FlexibleContexts    #-}+-- | Formatting type declarations and class instances for inferred types. +module Data.Aeson.AutoType.CodeGen.HaskellFormat(+  displaySplitTypes, normalizeTypeName+) where++import           Control.Arrow             ((&&&))+import           Control.Applicative       ((<$>), (<*>))+import           Control.Lens.TH+import           Control.Lens+import           Control.Monad             (forM)+import           Control.Exception(assert)+import qualified Data.HashMap.Strict        as Map+import           Data.Monoid+import qualified Data.Set                   as Set+import qualified Data.Text                  as Text+import           Data.Text                 (Text)+import           Data.Set                  (Set )+import           Data.List                 (foldl1')+import           Data.Char                 (isAlpha, isDigit)+import           Control.Monad.State.Class+import           Control.Monad.State.Strict(State, runState)+import qualified Data.Graph          as Graph+import           GHC.Generics              (Generic)++import           Data.Aeson.AutoType.Type+import           Data.Aeson.AutoType.Extract+import           Data.Aeson.AutoType.Format+import           Data.Aeson.AutoType.Split (toposort)+import           Data.Aeson.AutoType.Util  ()++--import           Debug.Trace -- DEBUG+trace _ x = x++fst3 ::  (t, t1, t2) -> t+fst3 (a, _b, _c) = a++data DeclState = DeclState { _decls   :: [Text]+                           , _counter :: Int+                           }+  deriving (Eq, Show, Ord, Generic)++makeLenses ''DeclState++type DeclM = State DeclState++type Map k v = Map.HashMap k v ++stepM :: DeclM Int+stepM = counter %%= (\i -> (i, i+1))++tShow :: (Show a) => a -> Text+tShow = Text.pack . show ++-- | Wrap a type alias.+wrapAlias :: Text -> Text -> Text+wrapAlias identifier contents = Text.unwords ["type", identifier, "=", contents]++-- | Wrap a data type declaration+wrapDecl ::  Text -> Text -> Text+wrapDecl identifier contents = Text.unlines [header, contents, "  } deriving (Show,Eq,GHC.Generics.Generic)"]+                                            --,"\nderiveJSON defaultOptions ''" `Text.append` identifier]+  where+    header = Text.concat ["data ", identifier, " = ", identifier, " { "]++-- | Explanatory type alias for making declarations+-- First element of the triple is original JSON identifier,+-- second element of the triple is the mapped identifier name in Haskell.+-- third element of the triple shows the type in a formatted way+type MappedKey = (Text, Text, Text, Bool)++-- | Make ToJSON declaration, given identifier (object name in Haskell) and mapping of its keys+-- from JSON to Haskell identifiers *in the same order* as in *data type declaration*.+makeFromJSON ::  Text -> [MappedKey] -> Text+makeFromJSON identifier contents =+  Text.unlines [+      Text.unwords ["instance FromJSON", identifier, "where"]+    , Text.unwords ["  parseJSON (Object v) =", makeParser identifier contents]+    , "  parseJSON _          = mzero" ]+  where+    makeParser identifier [] = Text.unwords ["return ", identifier]+    makeParser identifier _  = Text.unwords [identifier, "<$>", inner]+    inner                    = " <*> " `Text.intercalate`+                                  map takeValue contents+    takeValue (jsonId, _, ty, True ) = Text.concat ["v .:? \"", jsonId, "\""] -- nullable types+    takeValue (jsonId, _, _ , False) = Text.concat ["v .:  \"", jsonId, "\""]+-- Contents example for wrapFromJSON:+-- " <$>+--"                           v .: "hexValue"  <*>+--"                           v .: "colorName\""++-- | Make ToJSON declaration, given identifier (object name in Haskell) and mapping of its keys+-- from JSON to Haskell identifiers in the same order as in declaration+makeToJSON :: Text -> [MappedKey] -> Text+makeToJSON identifier contents =+    Text.unlines [+        Text.concat ["instance ToJSON ", identifier, " where"]+      , Text.concat ["  toJSON     (", identifier, " {", wildcard, "}) = object [", inner ", ", "]"]+      , maybeToEncoding+      ]+  where+    maybeToEncoding | null contents = ""+                    | otherwise     =+                        Text.concat ["  toEncoding (", identifier, " {", wildcard, "}) = pairs  (", inner "<>", ")"]+    wildcard | null contents = ""+             | otherwise     = ".."+    inner separator = separator `Text.intercalate`+                      map putValue contents+    putValue (jsonId, haskellId, _typeText, _nullable) = Text.unwords [escapeText jsonId, ".=", haskellId]+    escapeText = Text.pack . show . Text.unpack+-- Contents example for wrapToJSON+--"hexValue"  .= hexValue+--                                        ,"colorName" .= colorName]+++-- | Makes a generic identifier name.+genericIdentifier :: DeclM Text+genericIdentifier = do+  i <- stepM+  return $! "Obj" `Text.append` tShow i++-- * Printing a single data type declaration+newDecl :: Text -> [(Text, Type)] -> DeclM Text+newDecl identifier kvs = do attrs <- forM kvs $ \(k, v) -> do+                              formatted <- formatType v+                              return (k, normalizeFieldName identifier k, formatted, isNullable v)+                            let decl = Text.unlines [wrapDecl     identifier $ fieldDecls attrs+                                                    ,""+                                                    ,makeFromJSON identifier              attrs+                                                    ,""+                                                    ,makeToJSON   identifier              attrs]+                            addDecl decl+                            return identifier+  where+    fieldDecls attrList = Text.intercalate ",\n" $ map fieldDecl attrList+    fieldDecl :: (Text, Text, Text, Bool) -> Text+    fieldDecl (_jsonName, haskellName, fType, _nullable) = Text.concat [+                                                             "    ", haskellName, " :: ", fType]++addDecl decl = decls %%= (\ds -> ((), decl:ds))++-- | Add new type alias for Array type+newAlias :: Text -> Type -> DeclM Text+newAlias identifier content = do formatted <- formatType content+                                 addDecl $ Text.unlines [wrapAlias identifier formatted]+                                 return identifier++-- | Convert a JSON key name given by second argument,+-- from within a dictionary keyed with first argument,+-- into a name of Haskell record field (hopefully distinct from other such selectors.)+normalizeFieldName ::  Text -> Text -> Text+normalizeFieldName identifier = escapeKeywords             .+                                uncapitalize               .+                                (normalizeTypeName identifier `Text.append`) .+                                normalizeTypeName++keywords ::  Set Text+keywords = Set.fromList ["type", "data", "module", "class", "where", "let", "do"]++escapeKeywords ::  Text -> Text+escapeKeywords k | k `Set.member` keywords = k `Text.append` "_"+escapeKeywords k                           = k++-- | Format the type within DeclM monad, that records+-- the separate declarations on which this one is dependent.+formatType :: Type -> DeclM Text+formatType  TString                          = return "Text"+formatType  TInt                             = return "Int"+formatType  TDouble                          = return "Double"+formatType  TBool                            = return "Bool"+formatType (TLabel l)                        = return $ normalizeTypeName l+formatType (TUnion u)                        = wrap <$> case length nonNull of+                                                          0 -> return emptyTypeRepr+                                                          1 -> formatType $ head nonNull+                                                          _ -> Text.intercalate ":|:" <$> mapM formatType nonNull+  where+    nonNull       = Set.toList $ Set.filter (TNull /=) u+    wrap                                :: Text -> Text+    wrap   inner  | TNull `Set.member` u = Text.concat ["(Maybe (", inner, "))"]+                  | otherwise            =                          inner+formatType (TArray a)                        = do inner <- formatType a+                                                  return $ Text.concat ["[", inner, "]"]+formatType (TObj   o)                        = do ident <- genericIdentifier+                                                  newDecl ident d+  where+    d = Map.toList $ unDict o +formatType  e | e `Set.member` emptySetLikes = return emptyTypeRepr+formatType  t                                = return $ "ERROR: Don't know how to handle: " `Text.append` tShow t++emptyTypeRepr :: Text+emptyTypeRepr = "(Maybe Value)" -- default, accepts future extension where we found no data++runDecl ::  DeclM a -> Text+runDecl decl = Text.unlines $ finalState ^. decls+  where+    initialState    = DeclState [] 1+    (_, finalState) = runState decl initialState++-- * Splitting object types by label for unification.+type TypeTree    = Map Text [Type]++type TypeTreeM a = State TypeTree a++addType :: Text -> Type -> TypeTreeM ()+addType label typ = modify $ Map.insertWith (++) label [typ]++splitTypeByLabel' :: Text -> Type -> TypeTreeM Type+splitTypeByLabel' _  TString   = return TString+splitTypeByLabel' _  TInt      = return TInt+splitTypeByLabel' _  TDouble   = return TDouble+splitTypeByLabel' _  TBool     = return TBool+splitTypeByLabel' _  TNull     = return TNull+splitTypeByLabel' _ (TLabel r) = assert False $ return $ TLabel r -- unnecessary?+splitTypeByLabel' l (TUnion u) = do m <- mapM (splitTypeByLabel' l) $ Set.toList u+                                    return $! TUnion $! Set.fromList m+splitTypeByLabel' l (TArray a) = do m <- splitTypeByLabel' (l `Text.append` "Elt") a+                                    return $! TArray m+splitTypeByLabel' l (TObj   o) = do kvs <- forM (Map.toList $ unDict o) $ \(k, v) -> do+                                       component <- splitTypeByLabel' k v+                                       return (k, component)+                                    addType l (TObj $ Dict $ Map.fromList kvs)+                                    return $! TLabel l++-- | Splits initial type with a given label, into a mapping of object type names and object type structures.+splitTypeByLabel :: Text -> Type -> Map Text Type+splitTypeByLabel topLabel t = Map.map (foldl1' unifyTypes) finalState+  where+    finalize (TLabel l) = assert (l == topLabel) $ return ()+    finalize  topLevel  = addType topLabel topLevel+    initialState    = Map.empty+    (_, finalState) = runState (splitTypeByLabel' topLabel t >>= finalize) initialState++formatObjectType ::  Text -> Type -> DeclM Text+formatObjectType identifier (TObj o) = newDecl  identifier d+  where+    d = Map.toList $ unDict o+formatObjectType identifier  other   = newAlias identifier other++-- | Display an environment of types split by name.+displaySplitTypes ::  Map Text Type -> Text+displaySplitTypes dict = trace ("displaySplitTypes: " ++ show (toposort dict)) $ runDecl declarations+  where+    declarations =+      forM (toposort dict) $ \(name, typ) ->+        formatObjectType (normalizeTypeName name) typ++-- | Normalize type name by:+-- 1. Treating all characters that are not acceptable in Haskell variable name as end of word.+-- 2. Capitalizing each word, but a first (camelCase).+-- 3. Adding underscore if first character is non-alphabetic.+-- 4. Escaping Haskell keywords if the whole identifier is such keyword.+-- 5. If identifier is empty, then substituting "JsonEmptyKey" for its name.+normalizeTypeName :: Text -> Text+normalizeTypeName = ifEmpty "JsonEmptyKey"                  .+                    escapeKeywords                          .+                    escapeFirstNonAlpha                     .+                    Text.concat                             .+                    map capitalize                          .+                    filter     (not . Text.null)            .+                    Text.split (not . acceptableInVariable)+  where+    ifEmpty x ""       = x+    ifEmpty _ nonEmpty = nonEmpty+    acceptableInVariable c = isAlpha c || isDigit c+    escapeFirstNonAlpha cs                  | Text.null cs =                   cs+    escapeFirstNonAlpha cs@(Text.head -> c) | isAlpha   c  =                   cs+    escapeFirstNonAlpha cs                                 = "_" `Text.append` cs++-- | Computes all type labels referenced by a given type.+allLabels :: Type -> [Text]+allLabels = flip go []+  where+    go (TLabel l) ls = l:ls+    go (TArray t) ls = go t ls+    go (TUnion u) ls = Set.foldr go ls          u+    go (TObj   o) ls = Map.foldr go ls $ unDict o+    go _other     ls = ls+

@@ -0,0 +1,164 @@+-- | Extraction and unification of AutoType's @Type@ from Aeson @Value@.+module Data.Aeson.AutoType.Extract(valueSize, valueTypeSize,+                                   valueDepth, Dict(..),+                                   Type(..), emptyType,+                                   extractType, unifyTypes,+                                   typeCheck) where++import           Control.Arrow ((&&&))+import           Control.Exception               (assert)+import           Data.Aeson.AutoType.Type+import qualified Data.Graph          as Graph+import qualified Data.HashMap.Strict      as Map+import           Data.HashMap.Strict             (HashMap)+import qualified Data.Set                 as Set+import qualified Data.Vector              as V+import           Data.Aeson+import           Data.Text                       (Text)+import           Data.Set                        (Set )+import           Data.List                       (foldl1')+import           Data.Scientific                 (isInteger)++--import           Debug.Trace++-- | Compute total number of nodes (and leaves) within the value tree.+-- Each simple JavaScript type (including String) is counted as of size 1,+-- whereas both Array or object types are counted as 1+sum of the sizes+-- of their member values.+valueSize :: Value -> Int+valueSize  Null      = 1+valueSize (Bool   _) = 1+valueSize (Number _) = 1+valueSize (String _) = 1+valueSize (Array  a) = V.foldl' (+) 1 $ V.map valueSize a+valueSize (Object o) = (1+) . sum . map valueSize . Map.elems $ o++-- | Compute total size of the type of the @Value@.+-- For:+-- * simple types it is always 1,+-- * for arrays it is just 1+_maximum_ size of the (single) element type,+-- * for objects it is _sum_ of the sizes of fields (since each field type+--   is assumed to be different.)+valueTypeSize :: Value -> Int+valueTypeSize  Null      = 1+valueTypeSize (Bool   _) = 1+valueTypeSize (Number _) = 1+valueTypeSize (String _) = 1+valueTypeSize (Array  a) = (1+) . V.foldl' max 0 $ V.map valueTypeSize a+valueTypeSize (Object o) = (1+) . sum . map valueTypeSize . Map.elems $ o++-- | Compute total depth of the value.+-- For:+-- * simple types it is 1+-- * for either Array or Object, it is 1 + maximum of depths of their members+valueDepth :: Value -> Int+valueDepth  Null      = 1+valueDepth (Bool   _) = 1+valueDepth (Number _) = 1+valueDepth (String _) = 1+valueDepth (Array  a) = (1+) . V.foldl' max 0 $ V.map valueDepth a+valueDepth (Object o) = (1+) . maximum . (0:) . map valueDepth . Map.elems $ o++-- | Check if a number is integral, or floating point+-- | Extract @Type@ from the JSON @Value@.+-- Unifying types of array elements, if necessary.+extractType                            :: Value -> Type+extractType (Object o)                  = TObj $ Dict $ Map.map extractType o+extractType  Null                       = TNull+extractType (Bool   _)                  = TBool+extractType (Number n) | isInteger n    = TInt+extractType (Number _)                  = TDouble+extractType (String _)                  = TString+extractType (Array  a) | V.null a       = TArray   emptyType+extractType (Array  a)                  = TArray $ V.foldl1' unifyTypes $ traceShow $ V.map extractType a+  where+    --traceShow a = trace (show a) a+    traceShow = id++-- | Type check the value with the derived type.+typeCheck :: Value -> Type -> Bool+typeCheck  Null          TNull            = True+typeCheck  v            (TUnion  u)       = typeCheck v `any` Set.toList u+typeCheck (Bool   _)     TBool            = True+typeCheck (String _)     TString          = True+typeCheck (Number n)     TInt             = isInteger n+typeCheck (Number _)     TDouble          = True+typeCheck (Array  elts) (TArray  eltType) = (`typeCheck` eltType) `all` V.toList elts+typeCheck (Object d)    (TObj    e      ) = typeCheckKey `all` keysOfBoth+  where+    typeCheckKey k = getValue k d `typeCheck` get k e+    getValue   :: Text -> HashMap Text Value -> Value+    getValue    = Map.lookupDefault Null+    keysOfBoth :: [Text]+    keysOfBoth  =  Set.toList $ Set.fromList (Map.keys d) `Set.union` keys e+typeCheck         _     (TLabel  _      ) = error "Cannot typecheck labels without environment!"+typeCheck   {-a-} _      _ {-b-}          = {-trace msg $-} False+  where+    -- msg = "Mismatch: " ++ show a ++ " :: " ++ show b++allKeys :: Dict -> Dict -> [Text]+d `allKeys` e = Set.toList (keys d `Set.union` keys e)++-- | Standard unification procedure on @Type@s,+-- with inclusion of @Type@ unions.+unifyTypes :: Type -> Type -> Type+unifyTypes  TBool      TBool     = TBool+unifyTypes  TInt       TInt      = TInt+unifyTypes  TDouble    TInt      = TDouble+unifyTypes  TInt       TDouble   = TDouble+unifyTypes  TDouble    TDouble   = TDouble+unifyTypes  TString    TString   = TString+unifyTypes  TNull      TNull     = TNull+unifyTypes (TObj   d) (TObj   e) = TObj newDict+  where+    newDict :: Dict+    newDict = Dict $ Map.fromList [(k, get k d `unifyTypes`+                                        get k e) | k <- allKeys d e ]+unifyTypes (TArray u) (TArray v) = TArray $ u `unifyTypes` v+unifyTypes t           s         = typeAsSet t `unifyUnion` typeAsSet s++-- | Unify sets of types (sets are union types of alternatives).+unifyUnion :: Set Type -> Set Type -> Type+unifyUnion u v = assertions $+                   union $ uSimple        `Set.union`+                           vSimple        `Set.union`+                           unifiedObjects `Set.union`+                           Set.singleton unifiedArray+  where+    -- We partition our types for easier unification into simple and compound+    (uSimple, uCompound) = Set.partition isSimple u+    (vSimple, vCompound) = Set.partition isSimple v+    assertions = assert (Set.null $ Set.filter (not . isArray) uArr) .+                 assert (Set.null $ Set.filter (not . isArray) vArr)+    -- then we partition compound typs into objects and arrays.+    -- Note that there should be no TUnion here, since we are inside a TUnion already.+    -- (That is reduced by @union@ smart costructor as superfluous.)+    (uObj, uArr)   = Set.partition isObject uCompound+    (vObj, vArr)   = Set.partition isObject vCompound+    unifiedObjects = Set.fromList $ if null objects+                                       then []+                                       else [foldl1' unifyTypes objects]+    objects = Set.toList $ uObj `Set.union` vObj+    arrayElts :: [Type]+    arrayElts  = map (\(TArray ty) -> ty) $+                   Set.toList $+                     uArr `Set.union` vArr+    unifiedArray = TArray $ if null arrayElts+                               then emptyType+                               else foldl1' unifyTypes arrayElts++-- | Smart constructor for union types.+union ::  Set Type -> Type+union = simplifyUnion . TUnion++-- | Simplify TUnion's so there is no TUnion directly inside TUnion.+-- If there is only one element of the set, then return this single+-- element as a type.+simplifyUnion :: Type -> Type+simplifyUnion (TUnion s) | Set.size s == 1 = head $ Set.toList s+simplifyUnion (TUnion s)                   = TUnion $ Set.unions $ map elements $ Set.toList s+  where+    elements (TUnion elems) = elems+    elements sing           = Set.singleton sing+simplifyUnion unexpected                   = error ("simplifyUnion: unexpected argument " ++ show unexpected)+

@@ -0,0 +1,17 @@+-- | Formatting tools for code generation.+module Data.Aeson.AutoType.Format(capitalize, uncapitalize) where++import Data.Text(Text)+import qualified Data.Text as Text++-- | Make the first letter of a Text upper case.+capitalize :: Text -> Text+capitalize word = Text.toUpper first `Text.append` rest+  where+    (first, rest) = Text.splitAt 1 word++-- | Make the first letter of a Text lower case.+uncapitalize :: Text -> Text+uncapitalize word = Text.toLower first `Text.append` rest+  where+    (first, rest) = Text.splitAt 1 word

@@ -0,0 +1,48 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE DeriveGeneric       #-}+{-# LANGUAGE StandaloneDeriving  #-}+{-# LANGUAGE ViewPatterns        #-}+{-# LANGUAGE CPP                 #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++-- | Instances of @Text.PrettyPrint.Out@ class to visualize+-- Aeson @Value@ data structure.+module Data.Aeson.AutoType.Pretty() where++import qualified Data.HashMap.Strict as Hash+import           Data.HashMap.Strict(HashMap)+import           Data.Aeson+import qualified Data.Text                  as Text+import           Data.Text                 (Text)+import           Data.Set                   as Set(Set, toList)+import           Data.Scientific+import           Data.Vector                as V(Vector, toList)+import           Text.PrettyPrint.GenericPretty+import           Text.PrettyPrint++formatPair :: (Out a, Out b) => (a, b) -> Doc+formatPair (a, b) = nest 1 (doc a <+> ": " <+> doc b <+> ",")++-- * This is to make prettyprinting possible for Aeson @Value@ type.+instance Out Scientific where+  doc = doc . show+  docPrec _ = doc++instance (Out a) => Out (Vector a) where+  doc (V.toList -> v) = "<" <+> doc v <+> ">"+  docPrec _ = doc++instance Out Value++instance (Out a) => Out (Set a) where+  doc     (Set.toList -> s) = "{" <+> doc s <+> "}"+  docPrec _                 = doc++instance (Out a, Out b) => Out (HashMap a b) where+  doc (Hash.toList -> dict) = foldl ($$) "{" (map formatPair dict) $$ nest 1 "}"+  docPrec _ = doc++instance Out Text where+  doc       = text . Text.unpack -- TODO: check if there may be direct way?+  docPrec _ = doc

@@ -0,0 +1,144 @@+{-# LANGUAGE CPP                 #-}+{-# LANGUAGE TemplateHaskell     #-}+{-# LANGuaGE ScopedTypeVariables #-}+{-# LANGUAGE ViewPatterns        #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGuaGE DeriveGeneric       #-}+{-# LANGuaGE FlexibleContexts    #-}+-- | Formatting type declarations and class instances for inferred types. +module Data.Aeson.AutoType.Split(+  splitTypeByLabel, unificationCandidates,+  unifyCandidates, toposort+) where++import           Control.Arrow             ((&&&))+import           Control.Applicative       ((<$>), (<*>))+import           Control.Lens.TH+import           Control.Lens+import           Control.Monad             (forM)+import           Control.Exception(assert)+import qualified Data.HashMap.Strict        as Map+import           Data.Monoid+import qualified Data.Set                   as Set+import qualified Data.Text                  as Text+import           Data.Text                 (Text)+import           Data.Set                  (Set )+import           Data.List                 (foldl1')+import           Data.Char                 (isAlpha, isDigit)+import           Control.Monad.State.Class+import           Control.Monad.State.Strict(State, runState)+import qualified Data.Graph          as Graph+import           GHC.Generics              (Generic)++import           Data.Aeson.AutoType.Type+import           Data.Aeson.AutoType.Extract+import           Data.Aeson.AutoType.Util  ()++--import           Debug.Trace -- DEBUG+trace _ x = x++fst3 ::  (t, t1, t2) -> t+fst3 (a, _b, _c) = a++type Map k v = Map.HashMap k v ++-- | Explanatory type alias for making declarations+-- First element of the triple is original JSON identifier,+-- second element of the triple is the mapped identifier name in Haskell.+-- third element of the triple shows the type in a formatted way+type MappedKey = (Text, Text, Text, Bool)++-- * Splitting object types by label for unification.+type TypeTree    = Map Text [Type]++type TypeTreeM a = State TypeTree a++addType :: Text -> Type -> TypeTreeM ()+addType label typ = modify $ Map.insertWith (++) label [typ]++splitTypeByLabel' :: Text -> Type -> TypeTreeM Type+splitTypeByLabel' _  TString   = return TString+splitTypeByLabel' _  TInt      = return TInt+splitTypeByLabel' _  TDouble   = return TDouble+splitTypeByLabel' _  TBool     = return TBool+splitTypeByLabel' _  TNull     = return TNull+splitTypeByLabel' _ (TLabel r) = assert False $ return $ TLabel r -- unnecessary?+splitTypeByLabel' l (TUnion u) = do m <- mapM (splitTypeByLabel' l) $ Set.toList u+                                    return $! TUnion $! Set.fromList m+splitTypeByLabel' l (TArray a) = do m <- splitTypeByLabel' (l `Text.append` "Elt") a+                                    return $! TArray m+splitTypeByLabel' l (TObj   o) = do kvs <- forM (Map.toList $ unDict o) $ \(k, v) -> do+                                       component <- splitTypeByLabel' k v+                                       return (k, component)+                                    addType l (TObj $ Dict $ Map.fromList kvs)+                                    return $! TLabel l++-- | Splits initial type with a given label, into a mapping of object type names and object type structures.+splitTypeByLabel :: Text -> Type -> Map Text Type+splitTypeByLabel topLabel t = Map.map (foldl1' unifyTypes) finalState+  where+    finalize (TLabel l) = assert (l == topLabel) $ return ()+    finalize  topLevel  = addType topLabel topLevel+    initialState    = Map.empty+    (_, finalState) = runState (splitTypeByLabel' topLabel t >>= finalize) initialState++-- | Topological sorting of splitted types so that it is accepted declaration order.+toposort :: Map Text Type -> [(Text, Type)]  +toposort splitted = map ((id &&& (splitted Map.!)) . fst3 . graphKey) $ Graph.topSort graph+  where+    (graph, graphKey) = Graph.graphFromEdges' $ map makeEntry $ Map.toList splitted+    makeEntry (k, v) = (k, k, allLabels v)++-- | Computes all type labels referenced by a given type.+allLabels :: Type -> [Text]+allLabels = flip go []+  where+    go (TLabel l) ls = l:ls+    go (TArray t) ls = go t ls+    go (TUnion u) ls = Set.foldr go ls          u+    go (TObj   o) ls = Map.foldr go ls $ unDict o+    go _other     ls = ls++-- * Finding candidates for extra unifications+-- | For a given splitted types, it returns candidates for extra+-- unifications.+unificationCandidates :: Map.HashMap t Type -> [[t]]+unificationCandidates = Map.elems             .+                        Map.filter candidates .+                        Map.fromListWith (++) .+                        concatMap entry       .+                        Map.toList+  where+    -- | Candidate entry has to have at least two candidates, so that unification makes sense+    candidates [ ] = False+    candidates [_] = False+    candidates _   = True+    -- | Make a candidate entry for each object type, which points from its keys to its label.+    entry (k, TObj o)                 = [(Set.fromList $ Map.keys $ unDict o, [k])]+    entry  _                          = [] -- ignore array elements and toplevel type if it is Array++-- | Unifies candidates on a give input list.+unifyCandidates :: [[Text]] -> Map Text Type -> Map Text Type+unifyCandidates candidates splitted = Map.map (remapLabels labelMapping) $ replacements splitted+  where+    unifiedType  :: [Text] -> Type+    unifiedType cset      = foldr1 unifyTypes         $ +                            map (splitted Map.!) cset+    replace      :: [Text] -> Map Text Type -> Map Text Type+    replace  cset@(c:_) s = Map.insert c (unifiedType cset) (foldr Map.delete s cset)+    replace  []         _ = error "Empty candidate set in replace"+    replacements :: Map Text Type -> Map Text Type+    replacements        s = foldr replace s candidates+    labelMapping :: Map Text Text+    labelMapping          = Map.fromList $ concatMap mapEntry candidates+    mapEntry cset@(c:_)   = [(x, c) | x <- cset]+    mapEntry []           = error "Empty candidate set in mapEntry"++-- | Remaps type labels according to a `Map`.+remapLabels :: Map Text Text -> Type -> Type+remapLabels ls (TObj   o) = TObj   $ Dict $ Map.map (remapLabels ls) $ unDict o+remapLabels ls (TArray t) = TArray $                 remapLabels ls  t+remapLabels ls (TUnion u) = TUnion $        Set.map (remapLabels ls) u+remapLabels ls (TLabel l) = TLabel $ Map.lookupDefault l l ls+remapLabels _  other      = other+

@@ -0,0 +1,92 @@+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+-- | Arbitrary instances for the JSON @Value@.+module Data.Aeson.AutoType.Test (+    arbitraryTopValue+  ) where++import           Data.Aeson.AutoType.Pretty          () -- Generic instance for Value++import           Control.Applicative                 ((<$>), (<*>))+import           Data.Aeson+import           Data.Function                       (on)+import           Data.Hashable                       (Hashable)+import           Data.Generics.Uniplate.Data+import           Data.List+import           Data.Scientific+import qualified Data.Text                   as Text+import           Data.Text                           (Text)+import qualified Data.Vector                 as V+import qualified Data.HashMap.Strict         as Map+import           GHC.Generics++import           Test.QuickCheck.Arbitrary+import           Test.QuickCheck+import           Test.SmallCheck.Series++instance Arbitrary Text where+  arbitrary = Text.pack  <$> sized (`vectorOf` alphabetic)+    where+      alphabetic = choose ('a', 'z')++instance (Arbitrary a) => Arbitrary (V.Vector a) where+  arbitrary = V.fromList <$> arbitrary++instance (Arbitrary v) => Arbitrary (Map.HashMap Text v) where+  arbitrary = makeMap <$> arbitrary++-- | Helper function for generating Arbitrary and Series instances+-- for @Data.HashMap.Strict.Map@ from lists of pairs.+makeMap :: (Ord a, Hashable a) =>[(a, b)] -> Map.HashMap a b+makeMap  = Map.fromList+         . nubBy  ((==)    `on` fst)+         . sortBy (compare `on` fst)++instance Arbitrary Scientific where+  arbitrary = scientific <$> arbitrary <*> arbitrary++-- TODO: top value has to be complex: Object or Array+-- TODO: how to accumulate cost when generating the series?+instance Arbitrary Value where+  arbitrary = sized arb+    where+      arb n | n < 0 = error "Negative size!"+      arb 0         = return Null+      arb 1         = oneof                          simpleGens+      arb i         = oneof $ complexGens (i - 1) ++ simpleGens+      simpleGens    = [Number <$> arbitrary+                      ,Bool   <$> arbitrary+                      ,String <$> arbitrary]+  shrink = concatMap simpleShrink+         . universe++-- | Transformation to shrink top level of @Value@, doesn't consider nested sub-@Value@s.+simpleShrink           :: Value -> [Value]+simpleShrink (Array  a) = map (Array  .   V.fromList) $ shrink $ V.toList   a+simpleShrink (Object o) = map (Object . Map.fromList) $ shrink $ Map.toList o+simpleShrink _          = [] -- Nothing for simple objects++-- | Generator for compound @Value@s+complexGens ::  Int -> [Gen Value]+complexGens i = [Object . Map.fromList <$> resize i arbitrary,+                 Array                 <$> resize i arbitrary]++-- | Arbitrary JSON (must start with Object or Array.)+arbitraryTopValue :: Gen Value+arbitraryTopValue  = sized $ oneof . complexGens++-- * SmallCheck Serial instances+instance Monad m => Serial m Text where+  series = newtypeCons Text.pack++instance Monad m => Serial m Scientific where+  series = cons2 scientific++instance Serial m a => Serial m (V.Vector a) where+  series = newtypeCons V.fromList++instance Serial m v => Serial m (Map.HashMap Text v) where+  series = newtypeCons makeMap++-- This one is generated with Generics and instances above+instance Monad m => Serial m Value

@@ -0,0 +1,157 @@+{-# LANGUAGE DeriveDataTypeable    #-}+{-# LANGUAGE DeriveGeneric         #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings     #-}+-- | Union types describing JSON objects, and operations for querying these types.+module Data.Aeson.AutoType.Type(typeSize,+                                Dict(..), keys, get, withDict,+                                Type(..), emptyType,+                                isSimple, isArray, isObject, typeAsSet,+                                hasNonTopTObj,+                                hasTObj,+                                isNullable,+                                emptySetLikes+  ) where++import           Prelude             hiding (any)+import qualified Data.HashMap.Strict as Hash+import qualified Data.Set            as Set+import           Data.Data          (Data(..))+import           Data.Typeable      (Typeable)+import           Data.Foldable      (any)+import           Data.Text          (Text)+import           Data.Set           (Set )+import           Data.HashMap.Strict(HashMap)+import           Data.List          (sort)+import           Data.Ord           (comparing)+import           Data.Generics.Uniplate+import           Text.PrettyPrint.GenericPretty++import           Data.Aeson.AutoType.Pretty ()++-- * Dictionary types for overloading of usual class instances.+-- | Type alias for HashMap+type Map = HashMap++-- | Dictionary of types indexed by names.+newtype Dict = Dict { unDict :: Map Text Type }+  deriving (Eq, Data, Typeable, Generic)++instance Out Dict where+  doc       = doc       . unDict+  docPrec p = docPrec p . unDict++instance Show Dict where+  show = show . sort . Hash.toList . unDict++instance Ord Dict where+  compare = comparing $ sort . Hash.toList . unDict++-- | Make operation on a map to an operation on a Dict.+withDict :: (Map Text Type -> Map Text Type) -> Dict -> Dict+f `withDict` (Dict m) = Dict $ f m++-- | Take all keys from dictionary.+keys :: Dict -> Set Text+keys = Set.fromList . Hash.keys . unDict++-- | Union types for JSON values.+data Type = TNull | TBool | TString        |+            TInt  | TDouble                |+            TUnion (Set      Type)         |+            TLabel  Text                   |+            TObj    Dict                   |+            TArray  Type+  deriving (Show,Eq, Ord, Data, Typeable, Generic)++instance Out Type++-- These are missing Uniplate instances...+{-+instance Biplate (Set a) a where+  biplate s = (Set.toList s, Set.fromList)++instance Biplate (HashMap k v) v where+  biplate m = (Hash.elems m, Hash.fromList . zip (Hash.keys m))+ -}++instance Uniplate Type where+  uniplate (TUnion s) = (Set.toList s, TUnion .        Set.fromList                     )+  uniplate (TObj   d) = (Hash.elems m, TObj   . Dict . Hash.fromList . zip (Hash.keys m))+    where+      m = unDict d+  uniplate (TArray t) = ([t],          TArray . head  )+  uniplate s          = ([],           const s        )++-- | Empty type+emptyType :: Type+emptyType = TUnion Set.empty++-- | Lookup the Type within the dictionary.+get :: Text -> Dict -> Type+get key = Hash.lookupDefault TNull key . unDict++-- $derive makeUniplateDirect ''Type++-- | Size of the `Type` term.+typeSize           :: Type -> Int+typeSize TNull      = 1+typeSize TBool      = 1+typeSize TString    = 1+typeSize TInt       = 1+typeSize TDouble    = 1+typeSize (TObj   o) = (1+) . sum     . map typeSize . Hash.elems . unDict $ o+typeSize (TArray a) = 1 + typeSize a+typeSize (TUnion u) = (1+) . sum . (0:) . map typeSize . Set.toList $ u+typeSize (TLabel _) = error "Don't know how to compute typeSize of TLabel."++-- | Check if this is nullable (Maybe) type, or not.+-- Nullable type will always accept TNull or missing key that contains it.+isNullable :: Type -> Bool+isNullable  TNull     = True+isNullable (TUnion u) = isNullable `any` u+isNullable  _         = False++-- | "Null-ish" types+emptySetLikes ::  Set Type+emptySetLikes = Set.fromList [TNull, TArray $ TUnion $ Set.fromList []]+-- Q: and TObj $ Map.fromList []?+{-# INLINE emptySetLikes #-}++-- | Convert any type into union type (even if just singleton).+typeAsSet :: Type -> Set Type+typeAsSet (TUnion s) = s+typeAsSet t          = Set.singleton t++-- | Is the top-level constructor a TObj?+isObject         :: Type -> Bool+isObject (TObj _) = True+isObject _        = False++-- | Is it a simple (non-compound) Type?+isSimple  :: Type -> Bool+isSimple x = not (isObject x) && not (isArray x) && not (isUnion x)++-- | Is the top-level constructor a TUnion?+isUnion           :: Type -> Bool+isUnion (TUnion _) = True+isUnion _          = False++-- | Is the top-level constructor a TArray?+-- | Check if the given type has non-top TObj.+isArray           :: Type -> Bool+isArray (TArray _) = True+isArray _          = False++-- | Check if the given type has non-top TObj.+hasNonTopTObj         :: Type -> Bool+hasNonTopTObj (TObj o) = any hasTObj $ Hash.elems $ unDict o+hasNonTopTObj _        = False++-- | Check if the given type has TObj on top or within array..+hasTObj           :: Type -> Bool+hasTObj (TObj   _) = True+hasTObj (TArray a) = hasTObj a+hasTObj (TUnion u) = any hasTObj u+hasTObj _          = False

@@ -0,0 +1,34 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}++-- | Utility functions that may be ultimately moved to some library.+module Data.Aeson.AutoType.Util( withFileOrHandle+                               , withFileOrDefaultHandle+                               ) where++import           Data.Hashable+import qualified Data.Set as Set+import           System.IO                 (withFile, IOMode(..), Handle, stdin, stdout)++-- | Generic function for opening file if the filename is not empty nor "-",+--   or using given handle otherwise (probably stdout, stderr, or stdin).+-- TODO: Should it become utility function?+withFileOrHandle :: FilePath -> IOMode -> Handle -> (Handle -> IO r) -> IO r+withFileOrHandle        ""       _         handle action =                      action handle+withFileOrHandle        "-"      _         handle action =                      action handle+withFileOrHandle        name     ioMode    _      action = withFile name ioMode action++-- | Generic function for choosing either file with given name or stdin/stdout as input/output.+-- It accepts the function that takes the corresponding handle.+-- Stdin/stdout is selected by "-".+withFileOrDefaultHandle :: FilePath -> IOMode -> (Handle -> IO r) -> IO r+withFileOrDefaultHandle "-"      ReadMode         action = action stdin+withFileOrDefaultHandle "-"      WriteMode        action = action stdout+withFileOrDefaultHandle "-"      otherMode        _      = error $ "Incompatible io mode ("+                                                                ++ show otherMode+                                                                ++ ") for `-` in withFileOrDefaultHandle."+withFileOrDefaultHandle filename ioMode           action = withFile filename ioMode action++-- Missing instances+instance Hashable a => Hashable (Set.Set a) where+  hashWithSalt = Set.foldr (flip hashWithSalt)+

@@ -0,0 +1,191 @@+{-# LANGUAGE ScopedTypeVariables  #-}+{-# LANGUAGE OverloadedStrings    #-}+{-# LANGUAGE NamedFieldPuns       #-}+{-# LANGUAGE RecordWildCards      #-}+{-# LANGUAGE FlexibleInstances    #-}+{-# LANGUAGE FlexibleContexts     #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Main where++import           Control.Applicative+import           Control.Monad.State        as State+import           Data.Maybe+import           System.Exit+import           System.IO                 (stdin, stderr, stdout, IOMode(..))+import           System.FilePath           (splitExtension, (<.>), (</>))+import           System.Directory          (removeFile, createDirectoryIfMissing)+import           System.Process            (system)+import           Control.Monad             (forM_, forM, when)+import           Control.Exception         (assert)+import qualified Data.ByteString.Lazy.Char8 as BSL+import qualified Data.HashMap.Strict        as Map+import qualified Data.Set                   as Set+import           Data.Monoid               ((<>))+import           Data.Aeson                (Value(..), eitherDecode, encode, FromJSON(..), ToJSON(..))+import           Data.Function             (on)+import           Data.List+import qualified Data.Text                  as Text+import qualified Data.Text.IO               as Text+import           Data.Text                 (Text)+import qualified Data.Vector                as V+import           Data.Scientific           (scientific, Scientific)+import           Text.PrettyPrint.GenericPretty (pretty)+import           Test.QuickCheck++import           Data.Aeson.AutoType.CodeGen(writeModule, runModule, Lang(..))+import           Data.Aeson.AutoType.Extract+import           Data.Aeson.AutoType.Format+import           Data.Aeson.AutoType.Pretty+import           Data.Aeson.AutoType.Split+import           Data.Aeson.AutoType.Test+import           Data.Aeson.AutoType.Type+import           Data.Aeson.AutoType.Util+import           Options.Applicative++import           CommonCLI++data Options = Options {+                 tyOpts    :: TypeOpts+               , keep      :: Bool+               , stem      :: FilePath+               , count     :: Int+               , size      :: Int+               }++optParser :: Parser Options+optParser  =+    Options  <$> tyOptParser+             <*> switch    (long "keep"                  <> help "Also keep successful tests"  )+             <*> strOption (long "stem"  <> value "Test" <> help "Output filename stem"        )+             <*> intOpt    (long "count" <> value 100    <> help "Number of tests to perform"  )+             <*> intOpt    (long "size"  <> value 10     <> help "size of generated test cases")+             -- <*> some (argument str (metavar "FILES..."))+  where+    intOpt = option auto++-- | 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++-- | Read JSON and extract @Type@ information from it.+extractTypeFromJSONFile :: (String -> IO ()) -> FilePath -> IO (Maybe Type)+extractTypeFromJSONFile myTrace inputFilename =+      withFileOrHandle inputFilename ReadMode stdin $ \hIn ->+        -- First we decode JSON input into Aeson's Value type+        do bs <- BSL.hGetContents hIn+           Text.hPutStrLn stderr $ "Processing " `Text.append` Text.pack (show inputFilename)+           case eitherDecode bs of+             Left  err -> do+               report $ Text.concat ["Cannot decode JSON input from "+                                    ,Text.pack (show inputFilename)+                                    ,"\n"+                                    , Text.pack err]+               return Nothing+             Right v   -> do -- If decoding JSON was successful...+               -- We extract type structure from the JSON value.+               let t        = extractType v+               --myTrace $ "Type: " ++ pretty t+               return $ Just t+++vectorWithoutDuplicates ::  Ord b => Int -> Gen b -> Gen [b]+vectorWithoutDuplicates i gen = take i+                              .  removeDuplicates+                             <$> infiniteListOf gen++removeDuplicates ::  Ord a => [a] -> [a]+removeDuplicates list = filterM checkDup list `evalState` Set.empty+  where+    checkDup x = do seen <- State.get+                    if x `Set.member` seen+                      then+                        return False+                      else do+                        State.put $ x `Set.insert` seen+                        return True++-- TODO: check for generic Ord?+instance Ord Value where+  Null       `compare`  Null      = EQ+  Null       `compare`  _         = LT+  _          `compare`  Null      = GT+  (Bool   a) `compare` (Bool   b) = a `compare` b+  (Bool   a) `compare`  _         = LT+  _          `compare` (Bool   b) = GT+  (Number a) `compare` (Number b) = a `compare` b+  (Number _) `compare`  _         = LT+  _          `compare` (Number _) = GT+  (String a) `compare` (String b) = a `compare` b+  (String a) `compare` _          = LT+  _          `compare` (String b) = GT+  (Array  a) `compare` (Array  b) = a `compare` b+  (Array  a) `compare` _          = LT+  _          `compare` (Array  b) = GT+  (Object a) `compare` (Object b) = Map.toList a `compare` Map.toList b++-- | Take a set of JSON input filenames, Haskell output filename, and generate module parsing these JSON files.+generateTestJSONs :: Options -> IO ()+generateTestJSONs Options {tyOpts=TyOptions {..},+                           ..}= do+    createDirectoryIfMissing True "output"+    testValues :: [Value] <- generate $+                               resize size $+                                 vectorWithoutDuplicates 100 arbitraryTopValue+    results               <- forM (zip3 inputFilenames outputFilenames testValues) $+      \(inputFilename, outputFilename, jsonValue) -> do+        BSL.writeFile inputFilename $ encode jsonValue+        -- Read type from each file+        typeForEachFile  <- catMaybes <$> mapM (extractTypeFromJSONFile myTrace) [inputFilename]+        -- Unify all input types+        when (null typeForEachFile) $ do+          report "No valid JSON input file..."+          exitFailure+        let finalType = foldr1 unifyTypes typeForEachFile+        -- 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 $ 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+                          then unifyCandidates uCands splitted+                          else splitted+          myTrace $ "UNIFIED:\n" ++ pretty unified+          -- We start by writing module header+          writeModule lang outputFilename toplevelName unified+          if test+            then do+              r <- (==ExitSuccess) <$> runModule lang [outputFilename, inputFilename]+              when r $ mapM_ removeFile [inputFilename, outputFilename]+              return r+            else+              return True+    putStrLn $ "Successfully generated "      ++ show (length results) +++               " JSON files, out of planned " ++ show count  ++ " cases."+  where+    makeInputFilename  = (<.>".json") . (stem ++) . show+    makeOutputFilename = ("output"</>) . (<.>".hs")   . (stem ++) . show+    inputFilenames     = map makeInputFilename  [1..count]+    outputFilenames    = map makeOutputFilename [1..count]+    myTrace :: String -> IO ()+    myTrace msg = debug `when` putStrLn msg+    toplevelName = capitalize $ Text.pack toplevel++main :: IO ()+main = do opts <- execParser optInfo+          generateTestJSONs opts+    where+      optInfo = info (optParser <**> helper)+        ( fullDesc+       <> progDesc "Generate a number of JSON test files, and generate type and parser for each."+       <> header   "Self-test for json-autotype" )

@@ -1,21 +1,22 @@ -- Test over all files in examples/ directory module Main(main) where -import Control.Monad(forM, forM_, unless)+import Control.Monad(forM, forM_, unless, join) import Data.Char(toUpper) import Data.Functor ((<$>)) import Data.List(isPrefixOf, isSuffixOf)-import System.Directory(doesDirectoryExist, getDirectoryContents)+import System.Directory(doesDirectoryExist, getDirectoryContents, createDirectoryIfMissing) import System.FilePath((</>), (<.>), takeBaseName, replaceFileName) import System.Exit(ExitCode(..))+import System.Environment as Env+import System.Process             (rawSystem) import Data.Aeson.AutoType.CodeGen(runModule, Lang(Haskell))+import Data.Aeson ( Result,  Object, FromJSON, Value(Null,Number), (.:?) )+import Data.Aeson.Types ( Parser, parse )+import Data.Text ( Text, pack )+import Data.HashMap.Lazy ( singleton, empty ) ---import CommonCLI -runghc :: [String] -> IO ExitCode-runghc = runModule Haskell--- runModule HaskellStrict -- for compiling with -Wall -Werror- -- |  <http://book.realworldhaskell.org/read/io-case-study-a-library-for-searching-the-filesystem.html> getRecursiveContents :: FilePath -> IO [FilePath] getRecursiveContents topdir = do@@ -39,13 +40,44 @@  main :: IO () main  = do+  verifyAesonOperators   filenames <-  filter (isSuffixOf ".json")             <$> getRecursiveContents "examples"+  createDirectoryIfMissing True "output"   forM_ filenames $ \filename -> do-    let outputFilename = filename `replaceFileName` capitalize (takeBaseName filename <.> "hs")-    genResult <- runghc ["GenerateJSONParser.hs", filename, "--outputFilename", outputFilename]+    let outputFilename = ("output" </> capitalize (takeBaseName filename <.> "hs"))+    genResult <- runAutotype [filename, "--outputFilename", outputFilename]     unless (genResult == ExitSuccess) $       fail (unwords ["test case", show filename, "failed with", show genResult])-    parserResult <- runghc [outputFilename, filename]+    parserResult <- runModule Haskell [outputFilename, filename]+    --            ^ runModule HaskellStrict -- for compiling with -Wall -Werror     unless (parserResult == ExitSuccess) $       fail (unwords ["generated parser", show outputFilename, "failed with", show parserResult])++runAutotype :: [String] -> IO ExitCode+runAutotype arguments = do+    stackEnv <- doesDirectoryExist ".stack-work"+    cabalEnv <- doesDirectoryExist "dist/build/autogen"+    maybeStack <- Env.lookupEnv "STACK_EXEC"+    let (exec, args) | Just stackExec <- maybeStack = (stackExec, ["run","--"             ])+                     | stackEnv                     = ("stack",   ["run","--"             ])+                     | cabalEnv                     = ("cabal",   ["run","--"             ])+                     | otherwise                    = error "This test must be run either in Stack or Cabal environment."+    putStrLn $ concat ["Running json-autotype with executable ", show exec, " and arguments ", show args]+    rawSystem exec $ args ++ arguments++verifyAesonOperators :: IO ()+verifyAesonOperators = do+  parseTest (singleton (pack "foo") (Number 1))+  parseTest (singleton (pack "foo")  Null     )+  parseTest (singleton (pack "bar")  Null     )+  parseTest empty++(.:??) :: FromJSON a => Object -> Text -> Parser (Maybe a)+o .:?? val = fmap join (o .:? val)++parseTest :: Object -> IO ()+parseTest o = unless (r1 == r2) (fail (show r1 ++ " /= " ++ show r2))+  where r1, r2 :: Result (Maybe Int)+        r1 = parse (.:? (pack "foo")) o+        r2 = parse (.:?? (pack "foo")) o

@@ -10,6 +10,7 @@ import           Data.Aeson.AutoType.Test() -- Arbitrary instance for Value  import           Test.QuickCheck+--import           Test.QuickCheck.Parallel import           Test.SmallCheck --import           Test.QuickCheck.Arbitrary