diff --git a/CommonCLI.hs b/CommonCLI.hs --- a/CommonCLI.hs +++ b/CommonCLI.hs @@ -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) 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,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 diff --git a/Data/Aeson/AutoType/CodeGen/Elm.hs b/Data/Aeson/AutoType/CodeGen/Elm.hs new file mode 100644 --- /dev/null +++ b/Data/Aeson/AutoType/CodeGen/Elm.hs @@ -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!" diff --git a/Data/Aeson/AutoType/CodeGen/ElmFormat.hs b/Data/Aeson/AutoType/CodeGen/ElmFormat.hs new file mode 100644 --- /dev/null +++ b/Data/Aeson/AutoType/CodeGen/ElmFormat.hs @@ -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 diff --git a/Data/Aeson/AutoType/CodeGen/Haskell.hs b/Data/Aeson/AutoType/CodeGen/Haskell.hs new file mode 100644 --- /dev/null +++ b/Data/Aeson/AutoType/CodeGen/Haskell.hs @@ -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) diff --git a/Data/Aeson/AutoType/CodeGen/HaskellFormat.hs b/Data/Aeson/AutoType/CodeGen/HaskellFormat.hs new file mode 100644 --- /dev/null +++ b/Data/Aeson/AutoType/CodeGen/HaskellFormat.hs @@ -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 + diff --git a/Data/Aeson/AutoType/Extract.hs b/Data/Aeson/AutoType/Extract.hs --- a/Data/Aeson/AutoType/Extract.hs +++ b/Data/Aeson/AutoType/Extract.hs @@ -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` 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 @@ -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 - diff --git a/Data/Aeson/AutoType/Pretty.hs b/Data/Aeson/AutoType/Pretty.hs --- a/Data/Aeson/AutoType/Pretty.hs +++ b/Data/Aeson/AutoType/Pretty.hs @@ -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 - diff --git a/Data/Aeson/AutoType/Split.hs b/Data/Aeson/AutoType/Split.hs new file mode 100644 --- /dev/null +++ b/Data/Aeson/AutoType/Split.hs @@ -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 + 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 @@ -90,4 +90,3 @@ -- This one is generated with Generics and instances above instance Monad m => Serial m Value - 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 @@ -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 - diff --git a/Data/Aeson/AutoType/Util.hs b/Data/Aeson/AutoType/Util.hs --- a/Data/Aeson/AutoType/Util.hs +++ b/Data/Aeson/AutoType/Util.hs @@ -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) - - - diff --git a/GenerateJSONParser.hs b/GenerateJSONParser.hs --- a/GenerateJSONParser.hs +++ b/GenerateJSONParser.hs @@ -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") diff --git a/GenerateTestJSON.hs b/GenerateTestJSON.hs --- a/GenerateTestJSON.hs +++ b/GenerateTestJSON.hs @@ -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 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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 preferred type shapes 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 guess 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 arbitrary 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. diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -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. - 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: 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 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 - diff --git a/test/TestExamples.hs b/test/TestExamples.hs --- a/test/TestExamples.hs +++ b/test/TestExamples.hs @@ -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])