json-autotype 1.0.18 → 1.1.0

raw patch · 19 files changed

+1111/−568 lines, 19 filesdep ~optparse-applicativePVP ok

version bump matches the API change (PVP)

Dependency ranges changed: optparse-applicative

API changes (from Hackage documentation)

Files

• CommonCLI.hs +5/−10
• Data/Aeson/AutoType/CodeGen.hs +21/−86
• Data/Aeson/AutoType/CodeGen/Elm.hs +62/−0
• Data/Aeson/AutoType/CodeGen/ElmFormat.hs +332/−0
• Data/Aeson/AutoType/CodeGen/Haskell.hs +111/−0
• Data/Aeson/AutoType/CodeGen/HaskellFormat.hs +290/−0
• Data/Aeson/AutoType/Extract.hs +2/−2
• Data/Aeson/AutoType/Format.hs +6/−333
• Data/Aeson/AutoType/Pretty.hs +2/−6
• Data/Aeson/AutoType/Split.hs +143/−0
• Data/Aeson/AutoType/Test.hs +0/−1
• Data/Aeson/AutoType/Type.hs +3/−4
• Data/Aeson/AutoType/Util.hs +4/−11
• GenerateJSONParser.hs +41/−37
• GenerateTestJSON.hs +27/−27
• README.md +7/−1
• changelog.md +8/−3
• json-autotype.cabal +34/−26
• test/TestExamples.hs +13/−21

@@ -1,4 +1,4 @@-module CommonCLI(TypeOpts(..), unflag, tyOptParser, runghc) where+module CommonCLI(TypeOpts(..), unflag, tyOptParser) where  import           Data.Monoid                    ((<>)) import           Options.Applicative@@ -8,6 +8,7 @@  data TypeOpts = TyOptions {                   autounify :: Bool+                , toplevel  :: String                 , debug     :: Bool                 , test      :: Bool                 , suggest   :: Bool@@ -19,16 +20,10 @@ 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"      )--runghc :: [String] -> IO ExitCode-runghc arguments = do-    maybeStack <- System.Environment.lookupEnv "STACK_EXEC"-    maybeCabal <- System.Environment.lookupEnv "CABAL_SANDBOX_CONFIG"-    let execPrefix | Just stackExec   <- maybeStack = [stackExec, "exec", "--"]-                   | Just cabalConfig <- maybeCabal = ["cabal",   "exec", "--"]-                   | otherwise                      = []-    system (unwords $ execPrefix ++ ["runghc"] ++ arguments) 

@@ -1,100 +1,35 @@ {-# LANGUAGE CPP               #-} {-# LANGUAGE OverloadedStrings #-}--- | Wrappers for generating prologue and epilogue code in Haskell.+-- | Code generation and test running in different languages. (Switchbox.) module Data.Aeson.AutoType.CodeGen(-    writeHaskellModule+    Lang(..)+  , writeModule+  , runModule   , defaultOutputFilename   ) where -import qualified Data.Text           as Text-import qualified Data.Text.IO        as Text-import           Data.Text+import           Data.Text(Text) import qualified Data.HashMap.Strict as Map-import           Control.Arrow               (first)-import           System.FilePath-import           System.IO- import           Data.Aeson.AutoType.Type-import           Data.Aeson.AutoType.Format-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.-defaultOutputFilename :: FilePath-defaultOutputFilename = "JSONTypes.hs"--capitalize :: Text -> Text-capitalize input = Text.toUpper (Text.take 1 input)-                   `Text.append` Text.drop 1 input+import           Data.Aeson.AutoType.CodeGen.Haskell+import           Data.Aeson.AutoType.CodeGen.Elm -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)"-  ,""]+-- | Available output languages.+data Lang = Haskell+          | Elm -epilogue :: Text-epilogue          = Text.unlines-  [""-  ,"parse :: FilePath -> IO TopLevel"-  ,"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 v  -> \"Mismatched JSON value from file: \" ++ filename"-  ,"                      Just r  -> return (r :: TopLevel)"-  ,"  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"-  ,""]+-- | 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 Elm     = defaultElmFilename  -- | Write a Haskell module to an output file, or stdout if `-` filename is given.-writeHaskellModule :: FilePath -> Map.HashMap Text Type -> IO ()-writeHaskellModule outputFilename types =-    withFileOrHandle outputFilename WriteMode stdout $ \hOut -> do-      assertM (extension == ".hs")-      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-  where-    (moduleName, extension) =-       first normalizeTypeName'     $-       splitExtension               $-       if     outputFilename == "-"-         then defaultOutputFilename-         else outputFilename-    normalizeTypeName' = Text.unpack . normalizeTypeName . Text.pack+writeModule :: Lang -> FilePath -> Text -> Map.HashMap Text Type -> IO ()+writeModule Haskell = writeHaskellModule+writeModule Elm     = writeElmModule +-- | Run module in a given language.+runModule Haskell = runHaskellModule+runModule Elm     = runElmModule

@@ -0,0 +1,62 @@+{-# 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           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, mapBoth)"+  ,"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 = error "Yet undefined!"

@@ -0,0 +1,332 @@+{-# 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 )+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.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) = error $ "getDecoder cannot yet handle union types:" <> show u++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     = "Json.Encode.complexType"+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) = "oneOf [" <> joinWith ", " (makeUnionDecoder u) <> "]"++makeUnionDecoder u = error $ "Unfinished union decoding:" <> show u+-- 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+                                                          _ -> alts <$> mapM formatType nonNull+  where+    nonNull = nonNullComponents u+    wrap                                :: Text -> Text+    wrap   inner  | TNull `Set.member` u = Text.concat ["(Maybe (", inner, "))"]+                  | otherwise            =                          inner+    alts :: [Text] -> Text+    alts [alt]        =      alt+    alts (alt:others) = join alt $ alts others+      where+        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 = "(Maybe ComplexType)" -- 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 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++-- | 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++-- | 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,111 @@+{-# LANGUAGE CPP               #-}+{-# LANGUAGE OverloadedStrings #-}+-- | Wrappers for generating prologue and epilogue code in Haskell.+module Data.Aeson.AutoType.CodeGen.Haskell(+    writeHaskellModule+  , runHaskellModule+  , 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 v  -> \"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)

@@ -0,0 +1,290 @@+{-# 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.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++-- | 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+

@@ -32,7 +32,7 @@  -- | Compute total size of the type of the @Value@. -- For:--- * simple types it is always 1, +-- * 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.)@@ -99,7 +99,7 @@ unifyTypes  TNum       TNum      = TNum unifyTypes  TString    TString   = TString unifyTypes  TNull      TNull     = TNull-unifyTypes (TObj   d) (TObj   e) = TObj newDict +unifyTypes (TObj   d) (TObj   e) = TObj newDict   where     newDict :: Dict     newDict = Dict $ Map.fromList [(k, get k d `unifyTypes`

@@ -1,344 +1,17 @@-{-# 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.Format(-  displaySplitTypes, splitTypeByLabel, unificationCandidates,-  unifyCandidates,-  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.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+-- | Formatting tools for code generation.+module Data.Aeson.AutoType.Format(capitalize, uncapitalize) where --- | 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+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---- | 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-

@@ -10,7 +10,7 @@ #endif  -- | Instances of @Text.PrettyPrint.Out@ class to visualize--- Aeson @Value@ data structure. +-- Aeson @Value@ data structure. module Data.Aeson.AutoType.Pretty() where  import qualified Data.HashMap.Strict as Hash@@ -49,13 +49,9 @@   docPrec _                 = doc  instance (Out a, Out b) => Out (HashMap a b) where-  doc (Hash.toList -> dict) = (foldl ($$) "{" $-                                 map formatPair dict)-                           $$  nest 1 "}"-                      +  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,143 @@+{-# 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+) 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+

@@ -90,4 +90,3 @@  -- This one is generated with Generics and instances above instance Monad m => Serial m Value-

@@ -87,11 +87,11 @@  -- | Empty type emptyType :: Type-emptyType = TUnion Set.empty +emptyType = TUnion Set.empty  -- | Lookup the Type within the dictionary. get :: Text -> Dict -> Type-get key = Hash.lookupDefault TNull key . unDict +get key = Hash.lookupDefault TNull key . unDict  -- $derive makeUniplateDirect ''Type @@ -149,10 +149,9 @@ hasNonTopTObj (TObj o) = any hasTObj $ Hash.elems $ unDict o hasNonTopTObj _        = False --- | Check if the given type has TObj on top or within array.. +-- | 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,11 +1,11 @@ -- | Utility functions that may be ultimately moved to some library. module Data.Aeson.AutoType.Util( withFileOrHandle                                , withFileOrDefaultHandle-                               , assertM ) where+                               ) where  import           Data.Hashable import qualified Data.Set as Set-import           Control.Exception(assert)+import           Control.Exception --(assert) import           System.IO                 (withFile, IOMode(..), Handle, stdin, stdout)  -- | Generic function for opening file if the filename is not empty nor "-",@@ -14,7 +14,7 @@ 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 +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.@@ -24,16 +24,9 @@ withFileOrDefaultHandle "-"      WriteMode        action = action stdout withFileOrDefaultHandle "-"      otherMode        _      = error $ "Incompatible io mode ("                                                                 ++ show otherMode-                                                                ++ ") for `-` in withFileOrDefaultHandle." +                                                                ++ ") for `-` in withFileOrDefaultHandle." withFileOrDefaultHandle filename ioMode           action = withFile filename ioMode action --- | Check assertion within any monad.-assertM ::  Monad m => Bool -> m ()-assertM v = assert v $ return ()- -- Missing instances instance Hashable a => Hashable (Set.Set a) where   hashWithSalt = Set.foldr (flip hashWithSalt)-- - 

@@ -1,10 +1,12 @@ {-# 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@@ -22,11 +24,11 @@ import           Data.Text                      (Text) import           Text.PrettyPrint.GenericPretty (pretty) ---import           Data.Aeson.AutoType.Pretty-import           Data.Aeson.AutoType.Type+import           Data.Aeson.AutoType.CodeGen import           Data.Aeson.AutoType.Extract import           Data.Aeson.AutoType.Format-import           Data.Aeson.AutoType.CodeGen+import           Data.Aeson.AutoType.Split+import           Data.Aeson.AutoType.Type import           Data.Aeson.AutoType.Util import qualified Data.Yaml as Yaml @@ -34,34 +36,35 @@ import           CommonCLI  -- * Command line flags---defineFlag "o:outputFilename"  defaultOutputFilename "Write output to the given file"---defineFlag "suggest"           True                  "Suggest candidates for unification"---defineFlag "autounify"         True                  "Automatically unify suggested candidates"---defineFlag "t:test"            False                 "Try to run generated parser after"---defineFlag "d:debug"           False                 "Set this flag to see more debugging info"---defineFlag "y:typecheck"       True                  "Set this flag to typecheck after unification"---defineFlag "yaml"              False                 "Parse inputs as YAML instead of JSON"---defineFlag "p:preprocessor"    False                 "Work as GHC preprocessor (skip preprocessor pragma)"---defineFlag "fakeFlag"          True                  "Ignore this flag - it doesn't exist!!! It is workaround to library problem."- data Options = Options {                  tyOpts :: TypeOpts                , outputFilename :: FilePath                , typecheck :: Bool                , yaml :: Bool                , preprocessor :: Bool+               , lang :: Lang                , filenames :: [FilePath]                }  optParser :: Parser Options optParser  =     Options  <$> tyOptParser-             <*> strOption (short 'o' <> long "output" <> long "outputFilename" <> value defaultOutputFilename)-             <*> 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)"  )+             <*> 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)")+             <*> langOpts              <*> some (argument str (metavar "FILES...")) +langOpts :: Parser Lang+langOpts  =  flag Haskell Haskell (long "haskell")+         <|> flag Haskell Elm     (long "elm")+ -- | Report an error to error output. report   :: Text -> IO () report    = Text.hPutStrLn stderr@@ -119,11 +122,11 @@  -- | Take a set of JSON input filenames, Haskell output filename, and generate module parsing these JSON files. generateHaskellFromJSONs :: Options -> [FilePath] -> FilePath -> IO ()-generateHaskellFromJSONs opts inputFilenames outputFilename = do+generateHaskellFromJSONs opts@Options { tyOpts=TyOptions { toplevel } } inputFilenames outputFilename = do   -- Read type from each file   (filenames,    typeForEachFile,-   valueForEachFile) <- (unzip3 . catMaybes) <$> mapM (extractTypeFromJSONFile opts) inputFilenames+   valueForEachFile) <- unzip3 . catMaybes <$> mapM (extractTypeFromJSONFile opts) inputFilenames   -- Unify all input types   when (null typeForEachFile) $ do     report "No valid JSON input file..."@@ -133,28 +136,29 @@                         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 "TopLevel" finalType+  let splitted = splitTypeByLabel toplevelName finalType   myTrace $ "SPLITTED: " ++ pretty splitted-  assertM $ not $ any hasNonTopTObj $ Map.elems splitted-  -- 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-  writeHaskellModule outputFilename unified-  when (test $ tyOpts opts) $-    exitWith =<< runghc (outputFilename:passedTypeCheck)+  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 opts) outputFilename toplevelName unified+    when (test $ tyOpts opts) $+      exitWith =<< runModule (lang opts) (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@@ -168,6 +172,6 @@           generateHaskellFromJSONs opts (filenames opts) (outputFilename opts)   where     optInfo = info (optParser <**> helper)-            ( fullDesc+            (  fullDesc             <> progDesc "Parser JSON or YAML, get its type, and generate appropriate parser."             <> header "json-autotype -- automatic type and parser generation from JSON")

@@ -1,10 +1,7 @@-{-# LANGUAGE TemplateHaskell      #-} {-# LANGUAGE ScopedTypeVariables  #-} {-# LANGUAGE OverloadedStrings    #-}-{-# LANGUAGE DeriveGeneric        #-}-{-# LANGUAGE StandaloneDeriving   #-}+{-# LANGUAGE NamedFieldPuns       #-} {-# LANGUAGE RecordWildCards      #-}-{-# LANGUAGE ViewPatterns         #-} {-# LANGUAGE FlexibleInstances    #-} {-# LANGUAGE FlexibleContexts     #-} {-# OPTIONS_GHC -fno-warn-orphans #-}@@ -19,6 +16,7 @@ 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@@ -141,7 +139,8 @@  -- | 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+generateTestJSONs Options {tyOpts=TyOptions {..},+                           ..}= do     testValues :: [Value] <- generate $                                resize size $                                  vectorWithoutDuplicates 100 arbitraryTopValue@@ -156,29 +155,29 @@           exitFailure         let finalType = foldr1 unifyTypes typeForEachFile         -- We split different dictionary labels to become different type trees (and thus different declarations.)-        let splitted = splitTypeByLabel "TopLevel" finalType+        let splitted = splitTypeByLabel toplevelName finalType         --myTrace $ "SPLITTED: " ++ pretty splitted-        assertM $ not $ any hasNonTopTObj $ Map.elems splitted-        -- 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-        writeHaskellModule outputFilename unified-        if test-          then do-            r <- (==ExitSuccess) <$> runghc [outputFilename, inputFilename]-            when r $ mapM_ removeFile [inputFilename, outputFilename]-            return r-          else-            return True+        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+          writeHaskellModule outputFilename toplevelName unified+          if test+            then do+              r <- (==ExitSuccess) <$> runModule (lang opts) [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@@ -188,6 +187,7 @@     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

@@ -113,4 +113,10 @@ Other approaches: ================= -There is a [json-sampler](https://maxs.io/generating-types-from-json-samples/) that allows to make simpler data structure from JSON examples, but doesn't seem to perform unification, nor is it suitable for big APIs.+* There is a [TypeScript type provider](https://jvilk.com/MakeTypes/), and [PLDI 2016 paper](https://dl.acm.org/citation.cfm?id=2908115) on solving this problem using <em>preferred type shapes</em> instead of union types.+One can think about it as a alternative theory that gives very similar results, with more complicated exposition. It also does not tackle the problem of tagged records. It also does not attempt to <em>guess</em> unification candidates in order to reduce type complexity.+* There *was* a [json-sampler](https://maxs.io/generating-types-from-json-samples/) that allows to make simpler data structure from JSON examples, but doesn't seem to perform unification, nor is it suitable for big APIs.++* [PADS project](https://www.cs.princeton.edu/~dpw/papers/padsml06.pdf) is another attempt to automatically infer types to treat <em>arbitrary</em> data formats (not just JSON). It mixes type declarations, with parsing/printing information in order to have a consistent view of both. It does not handle automatic type inference though.+* [JSON Schema generator](https://www.newtonsoft.com/jsonschema/help/html/GenerateSchema.htm) uses .NET types to generate JSON Schema instead (in opposite direction.) Similar schema generation is [used here](https://sixgun.wordpress.com/2012/02/09/using-json-net-to-generate-jsonschema/)+* Microsoft Developer Network advocates use of [Data Contracts](https://docs.microsoft.com/en-us/dotnet/framework/wcf/feature-details/using-data-contracts) instead to constrain possible input data.

@@ -1,5 +1,11 @@ Changelog =========+    1.1.0  Mar 2018+        * Partial support Elm code generation.++    1.0.19  Nov 2017+        * Allow to have a custom name for toplevel data type.+     1.0.18  Nov 2017         * Fixed unit tests.         * Fixed import for inclusion in Stackage.@@ -108,11 +114,11 @@     0.2.5.7  Mar 2015          * Fixed documentation anchors, and unit test classification for failures.-    +     0.2.5.6  Mar 2015          * Relaxed upper bounds for lens 4.8.-    +     0.2.5.5  Mar 2015          * (Skipped this version number by mistake.)@@ -173,4 +179,3 @@  	* First experiments uploaded to GitHub, and discussed to 	HackerSpace.SG.-

@@ -1,6 +1,6 @@ -- Build information for the package. name:                json-autotype-version:             1.0.18+version:             1.1.0 synopsis:            Automatic type declaration for JSON input data description:         Generates datatype declarations with Aeson's "FromJSON" instances                      from a set of example ".json" files.@@ -20,6 +20,10 @@                      .                      One can now use multiple input files to generate better type description.                      .+                     Now with Elm code generation support!+                     (If you want your favourite programming language supported too -+                     name your price and mail the author.)+                     .                      See introduction on  <https://github.com/mgajda/json-autotype>                      for details. homepage:            https://github.com/mgajda/json-autotype@@ -34,8 +38,7 @@ extra-source-files:  README.md changelog.md 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-+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 source-repository head   type:     git   location: https://github.com/mgajda/json-autotype.git@@ -60,16 +63,19 @@   other-modules:                        -- internal module                        Data.Aeson.AutoType.Util-  build-depends:       base                 >=4.3  && <4.11,+                       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,                        GenericPretty        >=1.2  && <1.3,                        aeson                >=0.7  && <1.3,-                       bytestring           >=0.9  && <0.11,                        containers           >=0.3  && <0.6,                        filepath             >=1.3  && <1.5,                        hashable             >=1.2  && <1.3,                        ---hint                 >=0.4  && <0.6,-                       optparse-applicative >=0.11 && <1.0,-                       lens                 >=4.1  && <4.16,+                       lens                 >=4.1  && <4.17,                        --mmap                 >=0.5  && <0.6,                        mtl                  >=2.1  && <2.3,                        pretty               >=1.1  && <1.3,@@ -87,7 +93,12 @@                        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@@ -101,7 +112,7 @@                        DeriveDataTypeable,                        DeriveGeneric,                        RecordWildCards-  build-depends:       base                 >=4.3  && <4.11,+  build-depends:       base                 >=4.3  && <4.12,                        GenericPretty        >=1.2  && <1.3,                        aeson                >=0.7  && <1.3,                        bytestring           >=0.9  && <0.11,@@ -109,7 +120,7 @@                        filepath             >=1.3  && <1.5,                        hashable             >=1.2  && <1.3,                        --hint                 >=0.4  && <0.6,-                       lens                 >=4.1  && <4.16,+                       lens                 >=4.1  && <4.17,                        mtl                  >=2.1  && <2.3,                        optparse-applicative >=0.12 && <1.0,                        pretty               >=1.1  && <1.3,@@ -120,7 +131,7 @@                        unordered-containers >=0.2  && <0.3,                        vector               >=0.9  && <0.13,                        yaml                 >=0.8  && <0.9-  -- hs-source-dirs:      +  -- hs-source-dirs:   default-language:    Haskell2010  -- * Test suites@@ -131,6 +142,7 @@   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@@ -142,18 +154,12 @@                        DeriveDataTypeable,                        DeriveGeneric,                        RecordWildCards-  build-depends:       base                 >=4.3  && <4.11,+  build-depends:       base                 >=4.3  && <4.12,                        GenericPretty        >=1.2  && <1.3,                        aeson                >=0.7  && <1.3,-                       bytestring           >=0.9  && <0.11,                        containers           >=0.3  && <0.6,-                       directory            >=1.1  && <1.4,-                       filepath             >=1.3  && <1.5,                        hashable             >=1.2  && <1.3,-                       lens                 >=4.1  && <4.16,-                       mtl                  >=2.1  && <2.3,                        pretty               >=1.1  && <1.3,-                       process              >=1.1  && <1.7,                        scientific           >=0.3  && <0.5,                        smallcheck           >=1.0  && <1.2,                        text                 >=1.1  && <1.4,@@ -169,6 +175,7 @@   main-is:             test/TestExamples.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@@ -181,24 +188,21 @@                        DeriveDataTypeable,                        DeriveGeneric,                        RecordWildCards-  build-depends:       base                 >=4.3  && <4.11,+  build-depends:       base                 >=4.3  && <4.12,                        GenericPretty        >=1.2  && <1.3,                        aeson                >=0.7  && <1.3,-                       bytestring           >=0.9  && <0.11,                        containers           >=0.3  && <0.6,                        directory            >=1.1  && <1.4,                        filepath             >=1.3  && <1.5,                        hashable             >=1.2  && <1.3,-                       lens                 >=4.1  && <4.16,-                       mtl                  >=2.1  && <2.3,                        optparse-applicative >=0.11 && <1.0,                        pretty               >=1.1  && <1.3,                        process              >=1.1  && <1.7,                        scientific           >=0.3  && <0.5,                        smallcheck           >=1.0  && <1.2,                        text                 >=1.1  && <1.4,-                       uniplate             >=1.6  && <1.7,                        unordered-containers >=0.2  && <0.3,+                       uniplate             >=1.6  && <1.7,                        vector               >=0.9  && <0.13,                        QuickCheck           >=2.4  && <3.0   -- hs-source-dirs:@@ -211,9 +215,14 @@   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   other-extensions:    TemplateHaskell,@@ -224,7 +233,7 @@                        DeriveDataTypeable,                        DeriveGeneric,                        RecordWildCards-  build-depends:       base                 >=4.3  && <4.11,+  build-depends:       base                 >=4.3  && <4.12,                        GenericPretty        >=1.2  && <1.3,                        aeson                >=0.7  && <1.3,                        bytestring           >=0.9  && <0.11,@@ -233,7 +242,7 @@                        filepath             >=1.3  && <1.5,                        hashable             >=1.2  && <1.3,                        optparse-applicative >=0.12 && <1.0,-                       lens                 >=4.1  && <4.16,+                       lens                 >=4.1  && <4.17,                        mtl                  >=2.1  && <2.3,                        pretty               >=1.1  && <1.3,                        process              >=1.1  && <1.7,@@ -244,6 +253,5 @@                        unordered-containers >=0.2  && <0.3,                        vector               >=0.9  && <0.13,                        QuickCheck           >=2.4  && <3.0-  -- hs-source-dirs:      +  -- hs-source-dirs:   default-language:    Haskell2010-

@@ -1,13 +1,13 @@ -- Test over all files in examples/ directory module Main(main) where -import Control.Monad(forM)+import Control.Monad(forM, forM_, unless) import Data.Char(toUpper) import Data.Functor ((<$>)) import Data.List(isPrefixOf, isSuffixOf) import System.Directory(doesDirectoryExist, getDirectoryContents)-import System.FilePath(dropExtension, (</>), (<.>))-import System.Exit(exitSuccess, exitWith, ExitCode(..))+import System.FilePath((</>), (<.>), takeBaseName, replaceFileName)+import System.Exit(ExitCode(..))  import CommonCLI @@ -15,7 +15,7 @@ getRecursiveContents :: FilePath -> IO [FilePath] getRecursiveContents topdir = do   ex<-doesDirectoryExist topdir-  if ex +  if ex         then do           names <- getDirectoryContents topdir           let properNames = filter (not . isPrefixOf ".") names@@ -25,30 +25,22 @@             if isDirectory               then getRecursiveContents path               else return [path]-          return (concat paths) +          return (concat paths)         else return []  capitalize :: String -> String+capitalize [] = [] capitalize (s:ss) = toUpper s:ss  main :: IO () main  = do   filenames <-  filter (isSuffixOf ".json")             <$> getRecursiveContents "examples"-  results   <- forM filenames $ \filename -> do-    let outputFilename = capitalize (dropExtension filename) <.> "hs"+  forM_ filenames $ \filename -> do+    let outputFilename = filename `replaceFileName` capitalize (takeBaseName filename <.> "hs")     genResult <- runghc ["GenerateJSONParser.hs", filename, "--outputFilename", outputFilename]-    return 0-    if genResult == ExitSuccess-      then return 0 -- number of failures so far-      else do-        parserResult <- runghc [outputFilename, filename]-        if parserResult == ExitSuccess-           then return 0-           else return 1-  exitCode $ sum results--exitCode  :: Int -> IO ()-exitCode 0 = exitSuccess-exitCode n = exitWith $ ExitFailure n-+    unless (genResult == ExitSuccess) $+      fail (unwords ["test case", show filename, "failed with", show genResult])+    parserResult <- runghc [outputFilename, filename]+    unless (parserResult == ExitSuccess) $+      fail (unwords ["generated parser", show outputFilename, "failed with", show parserResult])