diff --git a/Data/Aeson/AutoType/CodeGen.hs b/Data/Aeson/AutoType/CodeGen.hs --- a/Data/Aeson/AutoType/CodeGen.hs +++ b/Data/Aeson/AutoType/CodeGen.hs @@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} +-- | Wrappers for generating prologue and epilogue code in Haskell. module Data.Aeson.AutoType.CodeGen( writeHaskellModule , defaultOutputFilename diff --git a/Data/Aeson/AutoType/Format.hs b/Data/Aeson/AutoType/Format.hs --- a/Data/Aeson/AutoType/Format.hs +++ b/Data/Aeson/AutoType/Format.hs @@ -4,6 +4,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGuaGE DeriveGeneric #-} {-# LANGuaGE FlexibleContexts #-} +-- | Formatting type declarations and class instances for inferred types. module Data.Aeson.AutoType.Format( displaySplitTypes, splitTypeByLabel, unificationCandidates, unifyCandidates @@ -158,19 +159,22 @@ 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 "Int" -formatType TBool = return "Bool" -formatType (TLabel l) = return $ normalizeTypeName l -formatType (TUnion u) | (TNull==) `any` u = do fmt <- formatType $ head $ Set.toList $ Set.filter (TNull /=) u - return $ Text.concat ["Maybe (", fmt, ")"] -formatType (TUnion u) = do tys <- forM (Set.toList u) formatType - return $ mkUnion tys +formatType TString = return "Text" +formatType TNum = return "Int" +formatType TBool = return "Bool" +formatType (TLabel l) = return $ normalizeTypeName l +formatType (TUnion u) = wrap <$> case length nonNull of + 0 -> return emptyTypeRepr + 1 -> formatType $ head nonNull + _ -> Text.intercalate ":|:" <$> mapM formatType nonNull where - mkUnion [] = emptyTypeRepr - mkUnion nonEmpty = foldr1 mkEither nonEmpty - where mkEither a b = Text.concat [a, " :|: ", b] + 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 @@ -181,7 +185,7 @@ 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 +emptyTypeRepr = "(Maybe Value)" -- default, accepts future extension where we found no data runDecl :: DeclM a -> Text runDecl decl = Text.unlines $ finalState ^. decls @@ -228,6 +232,7 @@ 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 diff --git a/Data/Aeson/AutoType/Test.hs b/Data/Aeson/AutoType/Test.hs --- a/Data/Aeson/AutoType/Test.hs +++ b/Data/Aeson/AutoType/Test.hs @@ -10,6 +10,7 @@ import Control.Applicative ((<$>), (<*>)) import Data.Aeson import Data.Function (on) +import Data.Hashable (Hashable) import Data.Generics.Uniplate.Data import Data.List import Data.Scientific @@ -36,6 +37,7 @@ -- | Helper function for generating Arbitrary and Series instances -- for @Data.HashMap.Strict.Map@ from lists of pairs. +makeMap :: (Ord a, Hashable a) =>[(a, b)] -> Map.HashMap a b makeMap = Map.fromList . nubBy ((==) `on` fst) . sortBy (compare `on` fst) @@ -58,12 +60,14 @@ shrink = concatMap simpleShrink . universe -simpleShrink :: Value -> [Value] +-- | Transformation to shrink top level of @Value@, doesn't consider nested sub-@Value@s. +simpleShrink :: Value -> [Value] simpleShrink (Array a) = map (Array . V.fromList) $ shrink $ V.toList a simpleShrink (Object o) = map (Object . Map.fromList) $ shrink $ Map.toList o simpleShrink _ = [] -- Nothing for simple objects --- | Generators of compound structures: object and array. +-- | Generator for compound @Value@s +complexGens :: Int -> [Gen Value] complexGens i = [Object . Map.fromList <$> resize i arbitrary, Array <$> resize i arbitrary] diff --git a/Data/Aeson/AutoType/Type.hs b/Data/Aeson/AutoType/Type.hs --- a/Data/Aeson/AutoType/Type.hs +++ b/Data/Aeson/AutoType/Type.hs @@ -1,6 +1,10 @@ -{-# LANGUAGE DeriveDataTypeable, DeriveGeneric #-} -{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-} -{-# LANGUAGE ViewPatterns, OverloadedStrings #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE OverloadedStrings #-} +-- | Union types describing JSON objects, and operations for querying these types. module Data.Aeson.AutoType.Type(typeSize, Dict(..), keys, get, withDict, Type(..), emptyType, @@ -8,7 +12,8 @@ hasNonTopTObj, hasTObj, isNullable, - emptySetLikes) where + emptySetLikes + ) where import Prelude hiding (any) import qualified Data.HashMap.Strict as Hash @@ -28,10 +33,11 @@ import Data.Aeson.AutoType.Pretty +-- * Dictionary types for overloading of usual class instances. -- | Type alias for HashMap type Map = HashMap --- * Dictionary of types indexed by names. +-- | Dictionary of types indexed by names. newtype Dict = Dict { unDict :: Map Text Type } deriving (Eq, Data, Typeable, Generic) @@ -53,7 +59,7 @@ keys :: Dict -> Set Text keys = Set.fromList . Hash.keys . unDict --- * Type +-- | Union types for JSON values. data Type = TNull | TBool | TNum | TString | TUnion (Set Type) | TLabel Text | @@ -91,7 +97,7 @@ -- $derive makeUniplateDirect ''Type -- | Size of the `Type` term. -typeSize :: Type -> Int +typeSize :: Type -> Int typeSize TNull = 1 typeSize TBool = 1 typeSize TNum = 1 diff --git a/GenerateJSONParser.hs b/GenerateJSONParser.hs --- a/GenerateJSONParser.hs +++ b/GenerateJSONParser.hs @@ -32,9 +32,6 @@ import Data.Aeson.AutoType.Util import HFlags -fst3 :: (t, t1, t2) -> t -fst3 (a, _, _) = a - -- * Command line flags defineFlag "o:outputFilename" defaultOutputFilename "Write output to the given file" defineFlag "suggest" True "Suggest candidates for unification" @@ -44,7 +41,7 @@ defineFlag "y:typecheck" True "Set this flag to typecheck after unification" defineFlag "fakeFlag" True "Ignore this flag - it doesn't exist!!! It is workaround to library problem." --- Tracing is switched off: +-- | Works like @Debug.trace@ when the --debug flag is enabled, and does nothing otherwise. myTrace :: String -> IO () myTrace msg = if flags_debug then putStrLn msg @@ -59,6 +56,9 @@ fatal msg = do report msg exitFailure +-- | Extracts type from JSON file, along with the original @Value@. +-- In order to facilitate dealing with failures, it returns a triple of +-- @FilePath@, extracted @Type@, and a JSON @Value@. extractTypeFromJSONFile :: FilePath -> IO (Maybe (FilePath, Type, Value)) extractTypeFromJSONFile inputFilename = withFileOrHandle inputFilename ReadMode stdin $ \hIn -> @@ -125,6 +125,7 @@ when flags_test $ exitWith =<< system (unwords $ ["runghc", outputFilename] ++ passedTypeCheck) +-- | Initialize flags, and run @generateHaskellFromJSONs@. main :: IO () main = do filenames <- $initHFlags "json-autotype -- automatic type and parser generation from JSON" -- TODO: should integrate all inputs into single type set!!! diff --git a/GenerateTestJSON.hs b/GenerateTestJSON.hs --- a/GenerateTestJSON.hs +++ b/GenerateTestJSON.hs @@ -156,7 +156,7 @@ writeHaskellModule outputFilename unified if flags_test then do - r <- (==ExitSuccess) <$> system (unwords $ ["runghc", outputFilename] ++ inputFilenames) + r <- (==ExitSuccess) <$> system (unwords $ ["runghc", outputFilename, inputFilename]) when r $ mapM_ removeFile [inputFilename, outputFilename] return r else diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,5 +1,9 @@ Changelog ========= + 0.4 Apr 2015 + + * Release candidate for current functionality. + 0.3 Apr 2015 * Passed all smallcheck/quickcheck tests. diff --git a/json-autotype.cabal b/json-autotype.cabal --- a/json-autotype.cabal +++ b/json-autotype.cabal @@ -1,6 +1,6 @@ -- Build information for the package. name: json-autotype -version: 0.3 +version: 0.4 synopsis: Automatic type declaration for JSON input data description: Generates datatype declarations with Aeson's "FromJSON" instances from a set of example ".json" files. @@ -110,7 +110,8 @@ default-language: Haskell2010 -- test suites -executable json-autotype-random-test +test-suite json-autotype-random-test + type: exitcode-stdio-1.0 main-is: GenerateTestJSON.hs other-modules: Data.Aeson.AutoType.Util, Data.Aeson.AutoType.Test,