diff --git a/CommonCLI.hs b/CommonCLI.hs deleted file mode 100644 --- a/CommonCLI.hs +++ /dev/null @@ -1,39 +0,0 @@ -module CommonCLI(TypeOpts(..), unflag, tyOptParser) where - - -import Data.Monoid ((<>)) -import Options.Applicative -import System.Process (system) -import qualified System.Environment (lookupEnv) -import System.Exit (ExitCode) - -import Data.Aeson.AutoType.CodeGen (Lang(..)) - -data TypeOpts = TyOptions { - autounify :: Bool - , toplevel :: String - , debug :: Bool - , test :: Bool - , suggest :: Bool - , lang :: Lang - } - -unflag :: Mod FlagFields Bool -> Parser Bool -unflag = flag True False - -tyOptParser :: Parser TypeOpts -tyOptParser = TyOptions - <$> unflag (long "no-autounify" <> help "Do not automatically unify suggested candidates") - <*> strOption (short 't' <> - long "toplevel" <> value "TopLevel" - <> help "Name for toplevel data type") - <*> switch (long "debug" <> help "Set this flag to see more debugging info" ) - <*> unflag (long "no-test" <> help "Do not run generated parser afterwards" ) - <*> unflag (long "no-suggest" <> help "Do not suggest candidates for unification" ) - <*> langOpts - - -langOpts :: Parser Lang -langOpts = flag Haskell Haskell (long "haskell") - <|> flag Haskell Elm (long "elm") - diff --git a/Data/Aeson/AutoType/Alternative.hs b/Data/Aeson/AutoType/Alternative.hs deleted file mode 100644 --- a/Data/Aeson/AutoType/Alternative.hs +++ /dev/null @@ -1,47 +0,0 @@ -{-# LANGUAGE TypeOperators #-} --- | This module defines data type (a :|: b) that behaves all like @Either@, --- except that has no tag in JSON representation as used by @FromJSON@ and @ToJSON@. -module Data.Aeson.AutoType.Alternative( - (:|:)(..) - , toEither, fromEither - , alt - ) where - -import Data.Aeson -import Control.Applicative - --- | Data type (a :|: b) that behaves all like @Either@, --- except that has no tag in JSON representation as used by @FromJSON@ and @ToJSON@. -data a :|: b = AltLeft a - | AltRight b - deriving(Show,Eq,Ord) -infixr 5 :|: - --- | Convert to @Either@ datatype. -toEither :: a :|: b -> Either a b -toEither (AltLeft a) = Left a -toEither (AltRight b) = Right b -{-# INLINE toEither #-} - --- | Convert from @Either@ datatype. -fromEither :: Either a b -> a :|: b -fromEither (Left a) = AltLeft a -fromEither (Right b) = AltRight b -{-# INLINE fromEither #-} - --- | Deconstruct the type with two functions corresponding to constructors. --- This is like @either@. -alt :: (a -> c) -> (b -> c) -> a :|: b -> c -alt f _ (AltLeft a) = f a -alt _ g (AltRight b) = g b - -instance (ToJSON a, ToJSON b) => ToJSON (a :|: b) where - toJSON (AltLeft a) = toJSON a - toJSON (AltRight b) = toJSON b - {-# INLINE toJSON #-} - -instance (FromJSON a, FromJSON b) => FromJSON (a :|: b) where - parseJSON input = (AltLeft <$> parseJSON input) <|> - (AltRight <$> parseJSON input) <|> - fail ("Neither alternative was found for: " ++ show input) - {-# INLINE parseJSON #-} diff --git a/Data/Aeson/AutoType/CodeGen.hs b/Data/Aeson/AutoType/CodeGen.hs deleted file mode 100644 --- a/Data/Aeson/AutoType/CodeGen.hs +++ /dev/null @@ -1,39 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE OverloadedStrings #-} --- | Code generation and test running in different languages. (Switchbox.) -module Data.Aeson.AutoType.CodeGen( - Lang(..) - , writeModule - , runModule - , defaultOutputFilename - ) where - -import Data.Text(Text) -import qualified Data.HashMap.Strict as Map -import Data.Aeson.AutoType.Type - -import Data.Aeson.AutoType.CodeGen.Haskell -import Data.Aeson.AutoType.CodeGen.Elm - --- | Available output languages. -data Lang = Haskell - | HaskellStrict - | Elm - --- | Default output filname is used, when there is no explicit output file path, or it is "-" (stdout). --- Default module name is consistent with it. -defaultOutputFilename :: Lang -> FilePath -defaultOutputFilename Haskell = defaultHaskellFilename -defaultOutputFilename HaskellStrict = defaultHaskellFilename -defaultOutputFilename Elm = defaultElmFilename - --- | Write a Haskell module to an output file, or stdout if `-` filename is given. -writeModule :: Lang -> FilePath -> Text -> Map.HashMap Text Type -> IO () -writeModule Haskell = writeHaskellModule -writeModule HaskellStrict = writeHaskellModule -writeModule Elm = writeElmModule - --- | Run module in a given language. -runModule Haskell = runHaskellModule -runModule HaskellStrict = runHaskellModuleStrict -runModule Elm = runElmModule diff --git a/Data/Aeson/AutoType/CodeGen/Elm.hs b/Data/Aeson/AutoType/CodeGen/Elm.hs deleted file mode 100644 --- a/Data/Aeson/AutoType/CodeGen/Elm.hs +++ /dev/null @@ -1,67 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE OverloadedStrings #-} --- | Wrappers for generating prologue and epilogue code in Haskell. -module Data.Aeson.AutoType.CodeGen.Elm( - defaultElmFilename - , writeElmModule - , runElmModule - ) where - -import qualified Data.Text as Text -import qualified Data.Text.IO as Text -import Data.Text -import qualified Data.HashMap.Strict as Map -import Control.Arrow (first) -import Control.Exception (assert) -import Data.Monoid ((<>)) -import System.FilePath -import System.IO -import System.Process (system) -import System.Exit (ExitCode) - -import Data.Aeson.AutoType.Format -import Data.Aeson.AutoType.Type -import Data.Aeson.AutoType.Util -import Data.Aeson.AutoType.CodeGen.ElmFormat - -import Debug.Trace(trace) - -defaultElmFilename = "JSONTypes.elm" - -header :: Text -> Text -header moduleName = Text.unlines [ - Text.unwords ["module ", capitalize moduleName, " exposing(..)"] - ,"" - ,"-- elm-package install toastal/either" - ,"-- elm-package install NoRedInk/elm-decode-pipeline" - ,"import Either exposing (Either, unpack)" - ,"import Json.Encode exposing (..)" - ,"import Json.Decode exposing (..)" - ,"import Json.Decode.Pipeline exposing (..)" - ,""] - -epilogue :: Text -> Text -epilogue toplevelName = Text.unlines [] - --- | Write a Haskell module to an output file, or stdout if `-` filename is given. -writeElmModule :: FilePath -> Text -> Map.HashMap Text Type -> IO () -writeElmModule outputFilename toplevelName types = - withFileOrHandle outputFilename WriteMode stdout $ \hOut -> - assert (trace extension extension == ".elm") $ do - Text.hPutStrLn hOut $ header $ Text.pack moduleName - -- We write types as Haskell type declarations to output handle - Text.hPutStrLn hOut $ displaySplitTypes types - Text.hPutStrLn hOut $ epilogue toplevelName - where - (moduleName, extension) = - first normalizeTypeName' $ - splitExtension $ - if outputFilename == "-" - then defaultElmFilename - else outputFilename - normalizeTypeName' = Text.unpack . normalizeTypeName . Text.pack - -runElmModule :: [String] -> IO ExitCode -runElmModule arguments = do - hPutStrLn stderr "Compiling *not* running Elm module for a test." - system $ Prelude.unwords $ ["elm", "make", Prelude.head arguments] -- ignore parsing args diff --git a/Data/Aeson/AutoType/CodeGen/ElmFormat.hs b/Data/Aeson/AutoType/CodeGen/ElmFormat.hs deleted file mode 100644 --- a/Data/Aeson/AutoType/CodeGen/ElmFormat.hs +++ /dev/null @@ -1,313 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGuaGE ScopedTypeVariables #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGuaGE DeriveGeneric #-} -{-# LANGuaGE FlexibleContexts #-} --- | Formatting type declarations and class instances for inferred types. -module Data.Aeson.AutoType.CodeGen.ElmFormat( - displaySplitTypes, - normalizeTypeName) where - -import Control.Arrow ((&&&)) -import Control.Applicative ((<$>), (<*>)) -import Control.Lens.TH -import Control.Lens -import Control.Monad (forM) -import Control.Exception(assert) -import qualified Data.HashMap.Strict as Map -import Data.Monoid -import qualified Data.Set as Set -import qualified Data.Text as Text -import Data.Text (Text) -import Data.Set (Set, toList) -import Data.List (foldl1') -import Data.Char (isAlpha, isDigit) -import Control.Monad.State.Class -import Control.Monad.State.Strict(State, runState) -import GHC.Generics (Generic) - -import Data.Aeson.AutoType.Type -import Data.Aeson.AutoType.Extract -import Data.Aeson.AutoType.Split -import Data.Aeson.AutoType.Format -import Data.Aeson.AutoType.Util () - ---import Debug.Trace -- DEBUG -trace _ x = x - -fst3 :: (t, t1, t2) -> t -fst3 (a, _b, _c) = a - -data DeclState = DeclState { _decls :: [Text] - , _counter :: Int - } - deriving (Eq, Show, Ord, Generic) - -makeLenses ''DeclState - -type DeclM = State DeclState - -type Map k v = Map.HashMap k v - -stepM :: DeclM Int -stepM = counter %%= (\i -> (i, i+1)) - -tShow :: (Show a) => a -> Text -tShow = Text.pack . show - --- | Wrap a type alias. -wrapAlias :: Text -> Text -> Text -wrapAlias identifier contents = Text.unwords ["type alias ", identifier, "=", contents] - --- | Wrap a data type declaration -wrapDecl :: Text -> Text -> Text -wrapDecl identifier contents = Text.unlines [header, contents, " }"] - --,"\nderiveJSON defaultOptions ''" `Text.append` identifier] - where - header = Text.concat ["type alias ", identifier, " = ", " { "] - --- | Explanatory type alias for making declarations --- First element of the triple is original JSON identifier, --- second element of the triple is the mapped identifier name in Haskell. --- third element of the triple shows the type in a formatted way -type MappedKey = (Text, Text, Text, Type, Bool) - --- | Make Decoder declaration, given identifier (object name in Haskell) and mapping of its keys --- from JSON to Haskell identifiers *in the same order* as in *data type declaration*. -makeDecoder :: Text -> [MappedKey] -> Text -makeDecoder identifier contents = - Text.unlines [ - Text.concat [decodeIdentifier, " : Json.Decode.Decoder ", identifier] - , Text.concat [decodeIdentifier, " ="] - , Text.unwords [" Json.Decode.Pipeline.decode", identifier] - , Text.unlines (makeParser identifier <$> contents) ] - where - decodeIdentifier = decoderIdent identifier - makeParser identifier (jsonId, _, _, ty, isOptional) = Text.unwords [ - " |>" - , if isOptional - then "Json.Decode.Pipeline.optional" - else "Json.Decode.Pipeline.required" - , Text.concat ["\"", jsonId, "\""] - , "(" <> getDecoder ty <> ")"] -- quote - -getDecoder TString = "Json.Decode.string" -getDecoder TNum = "Json.Decode.float" -getDecoder TBool = "Json.Decode.bool" -getDecoder (TArray t) = "Json.Decode.list (" <> getDecoder t <> ")" -getDecoder (TLabel l) = decoderIdent l -getDecoder (TObj o) = error "getDecoder cannot handle complex object types!" -getDecoder (TUnion u) = case nonNull of - [] -> "Json.Decode.value" - [x] -> getDecoder x - _ -> foldl1' altDecoder $ map getDecoder nonNull - where - nonNull = nonNullComponents u ---error $ "getDecoder cannot yet handle union types:" <> show u - -altDecoder a b = "(Json.Decode.oneOf [Json.Decode.map Either.Left (" - <> a <> "), Json.Decode.map Either.Right (" - <> b <> ")])" -{-Json.Decode.Pipeline.decode Something -"Json.Decode.Pipeline " <>-} - - -decoderIdent ident = "decode" <> capitalize (normalizeTypeName ident) --- Contents example for wrapFromJSON: --- " <$> ---" v .: "hexValue" <*> ---" v .: "colorName\"" - -encoderIdent ident = "encode" <> capitalize (normalizeTypeName ident) - --- | Make Encoder declaration, given identifier (object name in Haskell) and mapping of its keys --- from JSON to Haskell identifiers in the same order as in declaration -makeEncoder :: Text -> [MappedKey] -> Text -makeEncoder identifier contents = - Text.unlines [ - Text.unwords [encoderIdent identifier, ":", identifier, "->", "Json.Encode.Value"] - , encoderIdent identifier <> " record =" - , " Json.Encode.object [" - , " " <> (joinWith "\n , " (makeEncoder <$> contents)) - , " ]" - ] - where - makeEncoder (jsonId, haskellId, _typeText, ty, _nullable) = Text.concat [ - "(", tShow jsonId, ", (", getEncoder ty, ") record.", normalizeFieldName identifier jsonId, ")" - ] - --"answers", Json.Encode.list <| List.map encodeAnswer <| record.answers - escapeText = Text.pack . show . Text.unpack - -getEncoder :: Type -> Text -getEncoder TString = "Json.Encode.string" -getEncoder TNum = "Json.Encode.float" -getEncoder TBool = "Json.Encode.bool" -getEncoder TNull = "identity" -getEncoder (TLabel l) = encoderIdent l -getEncoder (TArray e) = "Json.Encode.list << List.map (" <> getEncoder e <> ")" -getEncoder (TObj o) = error $ "Seeing direct object encoder: " <> show o -getEncoder (TUnion u) = case nonNull of - [] -> "identity" - [x] -> getDecoder x - _ -> foldl1' altEncoder $ map getEncoder nonNull - where - nonNull = nonNullComponents u - -altEncoder a b = "Either.unpack (" <> a <> ") (" <> b <> ")" - --- Contents example for wrapToJSON ---"hexValue" .= hexValue --- ,"colorName" .= colorName] --- | Join text with other as separator. -joinWith :: Text -> [Text] -> Text -joinWith _ [] = "" -joinWith joiner (aFirst:rest) = aFirst <> Text.concat (map (joiner <>) rest) - --- | Makes a generic identifier name. -genericIdentifier :: DeclM Text -genericIdentifier = do - i <- stepM - return $! "Obj" `Text.append` tShow i - --- * Printing a single data type declaration -newDecl :: Text -> [(Text, Type)] -> DeclM Text -newDecl identifier kvs = do attrs <- forM kvs $ \(k, v) -> do - formatted <- formatType v - return (k, normalizeFieldName identifier k, formatted, v, isNullable v) - let decl = Text.unlines [wrapDecl identifier $ fieldDecls attrs - ,"" - ,makeDecoder identifier attrs - ,"" - ,makeEncoder identifier attrs] - addDecl decl - return identifier - where - fieldDecls attrList = Text.intercalate ",\n" $ map fieldDecl attrList - fieldDecl :: (Text, Text, Text, Type, Bool) -> Text - fieldDecl (_jsonName, haskellName, fType, _type, _nullable) = Text.concat [ - " ", haskellName, " : ", fType] - -addDecl decl = decls %%= (\ds -> ((), decl:ds)) - --- | Add new type alias for Array type -newAlias :: Text -> Type -> DeclM Text -newAlias identifier content = do formatted <- formatType content - addDecl $ Text.unlines [wrapAlias identifier formatted] - return identifier - --- | Convert a JSON key name given by second argument, --- from within a dictionary keyed with first argument, --- into a name of Haskell record field (hopefully distinct from other such selectors.) -normalizeFieldName :: Text -> Text -> Text -normalizeFieldName identifier = escapeKeywords . - uncapitalize . - (normalizeTypeName identifier `Text.append`) . - normalizeTypeName - -keywords :: Set Text -keywords = Set.fromList ["type", "alias", "exposing", "module", "class", - "where", "let", "do"] - -escapeKeywords :: Text -> Text -escapeKeywords k | k `Set.member` keywords = k `Text.append` "_" -escapeKeywords k = k - -nonNullComponents = Set.toList . Set.filter (TNull /=) --- | Format the type within DeclM monad, that records --- the separate declarations on which this one is dependent. -formatType :: Type -> DeclM Text -formatType TString = return "String" -formatType TNum = return "Float" -formatType TBool = return "Bool" -formatType (TLabel l) = return $ normalizeTypeName l -formatType (TUnion u) = wrap <$> case length nonNull of - 0 -> return emptyTypeRepr - 1 -> formatType $ head nonNull - _ -> foldl1' join <$> mapM formatType nonNull - where - nonNull = nonNullComponents u - wrap :: Text -> Text - wrap inner | TNull `Set.member` u = Text.concat ["(Maybe (", inner, "))"] - | otherwise = inner - join fAlt fOthers = Text.concat ["Either (", fAlt, ") (", fOthers, ")"] -formatType (TArray a) = do inner <- formatType a - return $ Text.concat ["List (", inner, ")"] -formatType (TObj o) = do ident <- genericIdentifier - newDecl ident d - where - d = Map.toList $ unDict o -formatType e | e `Set.member` emptySetLikes = return emptyTypeRepr -formatType t = return $ "ERROR: Don't know how to handle: " `Text.append` tShow t - -emptyTypeRepr :: Text -emptyTypeRepr = "Json.Decode.Value" -- default, accepts future extension where we found no data - -runDecl :: DeclM a -> Text -runDecl decl = Text.unlines $ finalState ^. decls - where - initialState = DeclState [] 1 - (_, finalState) = runState decl initialState - --- * Splitting object types by label for unification. -type TypeTree = Map Text [Type] - -type TypeTreeM a = State TypeTree a - -addType :: Text -> Type -> TypeTreeM () -addType label typ = modify $ Map.insertWith (++) label [typ] - -formatObjectType :: Text -> Type -> DeclM Text -formatObjectType identifier (TObj o) = newDecl identifier d - where - d = Map.toList $ unDict o -formatObjectType identifier other = newAlias identifier other - --- | Display an environment of types split by name. -displaySplitTypes :: Map Text Type -> Text -displaySplitTypes dict = trace ("displaySplitTypes: " ++ show (toposort dict)) $ runDecl declarations - where - declarations = - forM (toposort dict) $ \(name, typ) -> - formatObjectType (normalizeTypeName name) typ - --- | Normalize type name by: --- 1. Treating all characters that are not acceptable in Haskell variable name as end of word. --- 2. Capitalizing each word, but a first (camelCase). --- 3. Adding underscore if first character is non-alphabetic. --- 4. Escaping Haskell keywords if the whole identifier is such keyword. --- 5. If identifier is empty, then substituting "JsonEmptyKey" for its name. -normalizeTypeName :: Text -> Text -normalizeTypeName s = ifEmpty "JsonEmptyKey" . - escapeKeywords . - escapeFirstNonAlpha . - Text.concat . - map capitalize . - filter (not . Text.null) . - Text.split (not . acceptableInVariable) $ s - where - ifEmpty x "" = x - ifEmpty _ nonEmpty = nonEmpty - acceptableInVariable c = isAlpha c || isDigit c - escapeFirstNonAlpha cs | Text.null cs = cs - escapeFirstNonAlpha cs@(Text.head -> c) | isAlpha c = cs - escapeFirstNonAlpha cs = "_" `Text.append` cs - --- | Computes all type labels referenced by a given type. -allLabels :: Type -> [Text] -allLabels = flip go [] - where - go (TLabel l) ls = l:ls - go (TArray t) ls = go t ls - go (TUnion u) ls = Set.foldr go ls u - go (TObj o) ls = Map.foldr go ls $ unDict o - go _other ls = ls - --- | Remaps type labels according to a `Map`. -remapLabels :: Map Text Text -> Type -> Type -remapLabels ls (TObj o) = TObj $ Dict $ Map.map (remapLabels ls) $ unDict o -remapLabels ls (TArray t) = TArray $ remapLabels ls t -remapLabels ls (TUnion u) = TUnion $ Set.map (remapLabels ls) u -remapLabels ls (TLabel l) = TLabel $ Map.lookupDefault l l ls -remapLabels _ other = other diff --git a/Data/Aeson/AutoType/CodeGen/Haskell.hs b/Data/Aeson/AutoType/CodeGen/Haskell.hs deleted file mode 100644 --- a/Data/Aeson/AutoType/CodeGen/Haskell.hs +++ /dev/null @@ -1,116 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE OverloadedStrings #-} --- | Wrappers for generating prologue and epilogue code in Haskell. -module Data.Aeson.AutoType.CodeGen.Haskell( - writeHaskellModule - , runHaskellModule - , runHaskellModuleStrict - , defaultHaskellFilename - ) where - -import qualified Data.Text as Text -import qualified Data.Text.IO as Text -import Data.Text hiding (unwords) -import qualified Data.HashMap.Strict as Map -import Control.Arrow (first) -import Control.Exception (assert) -import Data.Monoid ((<>)) -import System.FilePath -import System.IO -import System.Process (system) -import qualified System.Environment (lookupEnv) -import System.Exit (ExitCode) - -import Data.Aeson.AutoType.Format -import Data.Aeson.AutoType.Type -import Data.Aeson.AutoType.CodeGen.HaskellFormat -import Data.Aeson.AutoType.Util - --- | Default output filname is used, when there is no explicit output file path, or it is "-" (stdout). --- Default module name is consistent with it. -defaultHaskellFilename :: FilePath -defaultHaskellFilename = "JSONTypes.hs" - -header :: Text -> Text -header moduleName = Text.unlines [ - "{-# LANGUAGE TemplateHaskell #-}" - ,"{-# LANGUAGE ScopedTypeVariables #-}" - ,"{-# LANGUAGE RecordWildCards #-}" - ,"{-# LANGUAGE OverloadedStrings #-}" - ,"{-# LANGUAGE TypeOperators #-}" - ,"{-# LANGUAGE DeriveGeneric #-}" - ,"" - ,Text.concat ["module ", capitalize moduleName, " where"] - ,"" - ,"import System.Exit (exitFailure, exitSuccess)" - ,"import System.IO (stderr, hPutStrLn)" - ,"import qualified Data.ByteString.Lazy.Char8 as BSL" - ,"import System.Environment (getArgs)" - ,"import Control.Monad (forM_, mzero, join)" - ,"import Control.Applicative" - ,"import Data.Aeson.AutoType.Alternative" - ,"import Data.Aeson(decode, Value(..), FromJSON(..), ToJSON(..)," -#if MIN_VERSION_aeson(0,11,0) - ," pairs," -#endif - ," (.:), (.:?), (.=), object)" - ,"import Data.Monoid" - ,"import Data.Text (Text)" - ,"import qualified GHC.Generics" - ,"" - ,"-- | Workaround for https://github.com/bos/aeson/issues/287." - ,"o .:?? val = fmap join (o .:? val)" - ,""] - -epilogue :: Text -> Text -epilogue toplevelName = Text.unlines - ["" - ,"parse :: FilePath -> IO " <> toplevelName - ,"parse filename = do input <- BSL.readFile filename" - ," case decode input of" - ," Nothing -> fatal $ case (decode input :: Maybe Value) of" - ," Nothing -> \"Invalid JSON file: \" ++ filename" - ," Just _ -> \"Mismatched JSON value from file: \" ++ filename" - ," Just r -> return (r :: " <> toplevelName <> ")" - ," where" - ," fatal :: String -> IO a" - ," fatal msg = do hPutStrLn stderr msg" - ," exitFailure" - ,"" - ,"main :: IO ()" - ,"main = do" - ," filenames <- getArgs" - ," forM_ filenames (\\f -> parse f >>= (\\p -> p `seq` putStrLn $ \"Successfully parsed \" ++ f))" - ," exitSuccess" - ,""] - --- | Write a Haskell module to an output file, or stdout if `-` filename is given. -writeHaskellModule :: FilePath -> Text -> Map.HashMap Text Type -> IO () -writeHaskellModule outputFilename toplevelName types = - withFileOrHandle outputFilename WriteMode stdout $ \hOut -> - assert (extension == ".hs") $ do - Text.hPutStrLn hOut $ header $ Text.pack moduleName - -- We write types as Haskell type declarations to output handle - Text.hPutStrLn hOut $ displaySplitTypes types - Text.hPutStrLn hOut $ epilogue toplevelName - where - (moduleName, extension) = - first normalizeTypeName' $ - splitExtension $ - if outputFilename == "-" - then defaultHaskellFilename - else outputFilename - normalizeTypeName' = Text.unpack . normalizeTypeName . Text.pack - -runHaskellModule :: [String] -> IO ExitCode -runHaskellModule arguments = do - maybeStack <- System.Environment.lookupEnv "STACK_EXEC" - maybeCabal <- System.Environment.lookupEnv "CABAL_SANDBOX_CONFIG" - let execPrefix | Just stackExec <- maybeStack = [stackExec, "exec", "--"] - | Just _ <- maybeCabal = ["cabal", "exec", "--"] - | otherwise = [] - system $ Prelude.unwords $ execPrefix ++ ["runghc"] ++ arguments - -runHaskellModuleStrict :: [String] -> IO ExitCode -runHaskellModuleStrict = runHaskellModule . ("-Wall":) . ("-Werror":) - diff --git a/Data/Aeson/AutoType/CodeGen/HaskellFormat.hs b/Data/Aeson/AutoType/CodeGen/HaskellFormat.hs deleted file mode 100644 --- a/Data/Aeson/AutoType/CodeGen/HaskellFormat.hs +++ /dev/null @@ -1,284 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGuaGE ScopedTypeVariables #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGuaGE DeriveGeneric #-} -{-# LANGuaGE FlexibleContexts #-} --- | Formatting type declarations and class instances for inferred types. -module Data.Aeson.AutoType.CodeGen.HaskellFormat( - displaySplitTypes, normalizeTypeName -) where - -import Control.Arrow ((&&&)) -import Control.Applicative ((<$>), (<*>)) -import Control.Lens.TH -import Control.Lens -import Control.Monad (forM) -import Control.Exception(assert) -import qualified Data.HashMap.Strict as Map -import Data.Monoid -import qualified Data.Set as Set -import qualified Data.Text as Text -import Data.Text (Text) -import Data.Set (Set ) -import Data.List (foldl1') -import Data.Char (isAlpha, isDigit) -import Control.Monad.State.Class -import Control.Monad.State.Strict(State, runState) -import qualified Data.Graph as Graph -import GHC.Generics (Generic) - -import Data.Aeson.AutoType.Type -import Data.Aeson.AutoType.Extract -import Data.Aeson.AutoType.Format -import Data.Aeson.AutoType.Split (toposort) -import Data.Aeson.AutoType.Util () - ---import Debug.Trace -- DEBUG -trace _ x = x - -fst3 :: (t, t1, t2) -> t -fst3 (a, _b, _c) = a - -data DeclState = DeclState { _decls :: [Text] - , _counter :: Int - } - deriving (Eq, Show, Ord, Generic) - -makeLenses ''DeclState - -type DeclM = State DeclState - -type Map k v = Map.HashMap k v - -stepM :: DeclM Int -stepM = counter %%= (\i -> (i, i+1)) - -tShow :: (Show a) => a -> Text -tShow = Text.pack . show - --- | Wrap a type alias. -wrapAlias :: Text -> Text -> Text -wrapAlias identifier contents = Text.unwords ["type", identifier, "=", contents] - --- | Wrap a data type declaration -wrapDecl :: Text -> Text -> Text -wrapDecl identifier contents = Text.unlines [header, contents, " } deriving (Show,Eq,GHC.Generics.Generic)"] - --,"\nderiveJSON defaultOptions ''" `Text.append` identifier] - where - header = Text.concat ["data ", identifier, " = ", identifier, " { "] - --- | Explanatory type alias for making declarations --- First element of the triple is original JSON identifier, --- second element of the triple is the mapped identifier name in Haskell. --- third element of the triple shows the type in a formatted way -type MappedKey = (Text, Text, Text, Bool) - --- | Make ToJSON declaration, given identifier (object name in Haskell) and mapping of its keys --- from JSON to Haskell identifiers *in the same order* as in *data type declaration*. -makeFromJSON :: Text -> [MappedKey] -> Text -makeFromJSON identifier contents = - Text.unlines [ - Text.unwords ["instance FromJSON", identifier, "where"] - , Text.unwords [" parseJSON (Object v) =", makeParser identifier contents] - , " parseJSON _ = mzero" ] - where - makeParser identifier [] = Text.unwords ["return ", identifier] - makeParser identifier _ = Text.unwords [identifier, "<$>", inner] - inner = " <*> " `Text.intercalate` - map takeValue contents - takeValue (jsonId, _, ty, True ) = Text.concat ["v .:?? \"", jsonId, "\""] -- nullable types - takeValue (jsonId, _, _ , False) = Text.concat ["v .: \"", jsonId, "\""] --- Contents example for wrapFromJSON: --- " <$> ---" v .: "hexValue" <*> ---" v .: "colorName\"" - --- | Make ToJSON declaration, given identifier (object name in Haskell) and mapping of its keys --- from JSON to Haskell identifiers in the same order as in declaration -makeToJSON :: Text -> [MappedKey] -> Text -makeToJSON identifier contents = - Text.unlines [ - Text.concat ["instance ToJSON ", identifier, " where"] - , Text.concat [" toJSON (", identifier, " {", wildcard, "}) = object [", inner ", ", "]"] -#if MIN_VERSION_aeson(0,11,0) - , maybeToEncoding -#endif - ] - where - maybeToEncoding | null contents = "" - | otherwise = - Text.concat [" toEncoding (", identifier, " {", wildcard, "}) = pairs (", inner "<>", ")"] - wildcard | null contents = "" - | otherwise = ".." - inner separator = separator `Text.intercalate` - map putValue contents - putValue (jsonId, haskellId, _typeText, _nullable) = Text.unwords [escapeText jsonId, ".=", haskellId] - escapeText = Text.pack . show . Text.unpack --- Contents example for wrapToJSON ---"hexValue" .= hexValue --- ,"colorName" .= colorName] - - --- | Makes a generic identifier name. -genericIdentifier :: DeclM Text -genericIdentifier = do - i <- stepM - return $! "Obj" `Text.append` tShow i - --- * Printing a single data type declaration -newDecl :: Text -> [(Text, Type)] -> DeclM Text -newDecl identifier kvs = do attrs <- forM kvs $ \(k, v) -> do - formatted <- formatType v - return (k, normalizeFieldName identifier k, formatted, isNullable v) - let decl = Text.unlines [wrapDecl identifier $ fieldDecls attrs - ,"" - ,makeFromJSON identifier attrs - ,"" - ,makeToJSON identifier attrs] - addDecl decl - return identifier - where - fieldDecls attrList = Text.intercalate ",\n" $ map fieldDecl attrList - fieldDecl :: (Text, Text, Text, Bool) -> Text - fieldDecl (_jsonName, haskellName, fType, _nullable) = Text.concat [ - " ", haskellName, " :: ", fType] - -addDecl decl = decls %%= (\ds -> ((), decl:ds)) - --- | Add new type alias for Array type -newAlias :: Text -> Type -> DeclM Text -newAlias identifier content = do formatted <- formatType content - addDecl $ Text.unlines [wrapAlias identifier formatted] - return identifier - --- | Convert a JSON key name given by second argument, --- from within a dictionary keyed with first argument, --- into a name of Haskell record field (hopefully distinct from other such selectors.) -normalizeFieldName :: Text -> Text -> Text -normalizeFieldName identifier = escapeKeywords . - uncapitalize . - (normalizeTypeName identifier `Text.append`) . - normalizeTypeName - -keywords :: Set Text -keywords = Set.fromList ["type", "data", "module", "class", "where", "let", "do"] - -escapeKeywords :: Text -> Text -escapeKeywords k | k `Set.member` keywords = k `Text.append` "_" -escapeKeywords k = k - --- | Format the type within DeclM monad, that records --- the separate declarations on which this one is dependent. -formatType :: Type -> DeclM Text -formatType TString = return "Text" -formatType TNum = return "Double" -formatType TBool = return "Bool" -formatType (TLabel l) = return $ normalizeTypeName l -formatType (TUnion u) = wrap <$> case length nonNull of - 0 -> return emptyTypeRepr - 1 -> formatType $ head nonNull - _ -> Text.intercalate ":|:" <$> mapM formatType nonNull - where - nonNull = Set.toList $ Set.filter (TNull /=) u - wrap :: Text -> Text - wrap inner | TNull `Set.member` u = Text.concat ["(Maybe (", inner, "))"] - | otherwise = inner -formatType (TArray a) = do inner <- formatType a - return $ Text.concat ["[", inner, "]"] -formatType (TObj o) = do ident <- genericIdentifier - newDecl ident d - where - d = Map.toList $ unDict o -formatType e | e `Set.member` emptySetLikes = return emptyTypeRepr -formatType t = return $ "ERROR: Don't know how to handle: " `Text.append` tShow t - -emptyTypeRepr :: Text -emptyTypeRepr = "(Maybe Value)" -- default, accepts future extension where we found no data - -runDecl :: DeclM a -> Text -runDecl decl = Text.unlines $ finalState ^. decls - where - initialState = DeclState [] 1 - (_, finalState) = runState decl initialState - --- * Splitting object types by label for unification. -type TypeTree = Map Text [Type] - -type TypeTreeM a = State TypeTree a - -addType :: Text -> Type -> TypeTreeM () -addType label typ = modify $ Map.insertWith (++) label [typ] - -splitTypeByLabel' :: Text -> Type -> TypeTreeM Type -splitTypeByLabel' _ TString = return TString -splitTypeByLabel' _ TNum = return TNum -splitTypeByLabel' _ TBool = return TBool -splitTypeByLabel' _ TNull = return TNull -splitTypeByLabel' _ (TLabel r) = assert False $ return $ TLabel r -- unnecessary? -splitTypeByLabel' l (TUnion u) = do m <- mapM (splitTypeByLabel' l) $ Set.toList u - return $! TUnion $! Set.fromList m -splitTypeByLabel' l (TArray a) = do m <- splitTypeByLabel' (l `Text.append` "Elt") a - return $! TArray m -splitTypeByLabel' l (TObj o) = do kvs <- forM (Map.toList $ unDict o) $ \(k, v) -> do - component <- splitTypeByLabel' k v - return (k, component) - addType l (TObj $ Dict $ Map.fromList kvs) - return $! TLabel l - --- | Splits initial type with a given label, into a mapping of object type names and object type structures. -splitTypeByLabel :: Text -> Type -> Map Text Type -splitTypeByLabel topLabel t = Map.map (foldl1' unifyTypes) finalState - where - finalize (TLabel l) = assert (l == topLabel) $ return () - finalize topLevel = addType topLabel topLevel - initialState = Map.empty - (_, finalState) = runState (splitTypeByLabel' topLabel t >>= finalize) initialState - -formatObjectType :: Text -> Type -> DeclM Text -formatObjectType identifier (TObj o) = newDecl identifier d - where - d = Map.toList $ unDict o -formatObjectType identifier other = newAlias identifier other - --- | Display an environment of types split by name. -displaySplitTypes :: Map Text Type -> Text -displaySplitTypes dict = trace ("displaySplitTypes: " ++ show (toposort dict)) $ runDecl declarations - where - declarations = - forM (toposort dict) $ \(name, typ) -> - formatObjectType (normalizeTypeName name) typ - --- | Normalize type name by: --- 1. Treating all characters that are not acceptable in Haskell variable name as end of word. --- 2. Capitalizing each word, but a first (camelCase). --- 3. Adding underscore if first character is non-alphabetic. --- 4. Escaping Haskell keywords if the whole identifier is such keyword. --- 5. If identifier is empty, then substituting "JsonEmptyKey" for its name. -normalizeTypeName :: Text -> Text -normalizeTypeName = ifEmpty "JsonEmptyKey" . - escapeKeywords . - escapeFirstNonAlpha . - Text.concat . - map capitalize . - filter (not . Text.null) . - Text.split (not . acceptableInVariable) - where - ifEmpty x "" = x - ifEmpty _ nonEmpty = nonEmpty - acceptableInVariable c = isAlpha c || isDigit c - escapeFirstNonAlpha cs | Text.null cs = cs - escapeFirstNonAlpha cs@(Text.head -> c) | isAlpha c = cs - escapeFirstNonAlpha cs = "_" `Text.append` cs - --- | Computes all type labels referenced by a given type. -allLabels :: Type -> [Text] -allLabels = flip go [] - where - go (TLabel l) ls = l:ls - go (TArray t) ls = go t ls - go (TUnion u) ls = Set.foldr go ls u - go (TObj o) ls = Map.foldr go ls $ unDict o - go _other ls = ls - diff --git a/Data/Aeson/AutoType/Extract.hs b/Data/Aeson/AutoType/Extract.hs deleted file mode 100644 --- a/Data/Aeson/AutoType/Extract.hs +++ /dev/null @@ -1,157 +0,0 @@ --- | Extraction and unification of AutoType's @Type@ from Aeson @Value@. -module Data.Aeson.AutoType.Extract(valueSize, valueTypeSize, - valueDepth, Dict(..), - Type(..), emptyType, - extractType, unifyTypes, - typeCheck) where - -import Control.Arrow ((&&&)) -import Control.Exception (assert) -import Data.Aeson.AutoType.Type -import qualified Data.Graph as Graph -import qualified Data.HashMap.Strict as Map -import Data.HashMap.Strict (HashMap) -import qualified Data.Set as Set -import qualified Data.Vector as V -import Data.Aeson -import Data.Text (Text) -import Data.Set (Set ) -import Data.List (foldl1') - ---import Debug.Trace - --- | Compute total number of nodes (and leaves) within the value tree. --- Each simple JavaScript type (including String) is counted as of size 1, --- whereas both Array or object types are counted as 1+sum of the sizes --- of their member values. -valueSize :: Value -> Int -valueSize Null = 1 -valueSize (Bool _) = 1 -valueSize (Number _) = 1 -valueSize (String _) = 1 -valueSize (Array a) = V.foldl' (+) 1 $ V.map valueSize a -valueSize (Object o) = (1+) . sum . map valueSize . Map.elems $ o - --- | Compute total size of the type of the @Value@. --- For: --- * simple types it is always 1, --- * for arrays it is just 1+_maximum_ size of the (single) element type, --- * for objects it is _sum_ of the sizes of fields (since each field type --- is assumed to be different.) -valueTypeSize :: Value -> Int -valueTypeSize Null = 1 -valueTypeSize (Bool _) = 1 -valueTypeSize (Number _) = 1 -valueTypeSize (String _) = 1 -valueTypeSize (Array a) = (1+) . V.foldl' max 0 $ V.map valueTypeSize a -valueTypeSize (Object o) = (1+) . sum . map valueTypeSize . Map.elems $ o - --- | Compute total depth of the value. --- For: --- * simple types it is 1 --- * for either Array or Object, it is 1 + maximum of depths of their members -valueDepth :: Value -> Int -valueDepth Null = 1 -valueDepth (Bool _) = 1 -valueDepth (Number _) = 1 -valueDepth (String _) = 1 -valueDepth (Array a) = (1+) . V.foldl' max 0 $ V.map valueDepth a -valueDepth (Object o) = (1+) . maximum . (0:) . map valueDepth . Map.elems $ o - --- | Extract @Type@ from the JSON @Value@. --- Unifying types of array elements, if necessary. -extractType :: Value -> Type -extractType (Object o) = TObj $ Dict $ Map.map extractType o -extractType Null = TNull -extractType (Bool _) = TBool -extractType (Number _) = TNum -extractType (String _) = TString -extractType (Array a) | V.null a = TArray emptyType -extractType (Array a) = TArray $ V.foldl1' unifyTypes $ traceShow $ V.map extractType a - where - --traceShow a = trace (show a) a - traceShow = id - --- | Type check the value with the derived type. -typeCheck :: Value -> Type -> Bool -typeCheck Null TNull = True -typeCheck v (TUnion u) = typeCheck v `any` Set.toList u -typeCheck (Bool _) TBool = True -typeCheck (Number _) TNum = True -typeCheck (String _) TString = True -typeCheck (Array elts) (TArray eltType) = (`typeCheck` eltType) `all` V.toList elts -typeCheck (Object d) (TObj e ) = typeCheckKey `all` keysOfBoth - where - typeCheckKey k = getValue k d `typeCheck` get k e - getValue :: Text -> HashMap Text Value -> Value - getValue = Map.lookupDefault Null - keysOfBoth :: [Text] - keysOfBoth = Set.toList $ Set.fromList (Map.keys d) `Set.union` keys e -typeCheck _ (TLabel _ ) = error "Cannot typecheck labels without environment!" -typeCheck {-a-} _ _ {-b-} = {-trace msg $-} False - where - -- msg = "Mismatch: " ++ show a ++ " :: " ++ show b - -allKeys :: Dict -> Dict -> [Text] -d `allKeys` e = Set.toList (keys d `Set.union` keys e) - --- | Standard unification procedure on @Type@s, --- with inclusion of @Type@ unions. -unifyTypes :: Type -> Type -> Type -unifyTypes TBool TBool = TBool -unifyTypes TNum TNum = TNum -unifyTypes TString TString = TString -unifyTypes TNull TNull = TNull -unifyTypes (TObj d) (TObj e) = TObj newDict - where - newDict :: Dict - newDict = Dict $ Map.fromList [(k, get k d `unifyTypes` - get k e) | k <- allKeys d e ] -unifyTypes (TArray u) (TArray v) = TArray $ u `unifyTypes` v -unifyTypes t s = typeAsSet t `unifyUnion` typeAsSet s - --- | Unify sets of types (sets are union types of alternatives). -unifyUnion :: Set Type -> Set Type -> Type -unifyUnion u v = assertions $ - union $ uSimple `Set.union` - vSimple `Set.union` - unifiedObjects `Set.union` - Set.singleton unifiedArray - where - -- We partition our types for easier unification into simple and compound - (uSimple, uCompound) = Set.partition isSimple u - (vSimple, vCompound) = Set.partition isSimple v - assertions = assert (Set.null $ Set.filter (not . isArray) uArr) . - assert (Set.null $ Set.filter (not . isArray) vArr) - -- then we partition compound typs into objects and arrays. - -- Note that there should be no TUnion here, since we are inside a TUnion already. - -- (That is reduced by @union@ smart costructor as superfluous.) - (uObj, uArr) = Set.partition isObject uCompound - (vObj, vArr) = Set.partition isObject vCompound - unifiedObjects = Set.fromList $ if null objects - then [] - else [foldl1' unifyTypes objects] - objects = Set.toList $ uObj `Set.union` vObj - arrayElts :: [Type] - arrayElts = map (\(TArray ty) -> ty) $ - Set.toList $ - uArr `Set.union` vArr - unifiedArray = TArray $ if null arrayElts - then emptyType - else foldl1' unifyTypes arrayElts - --- | Smart constructor for union types. -union :: Set Type -> Type -union = simplifyUnion . TUnion - --- | Simplify TUnion's so there is no TUnion directly inside TUnion. --- If there is only one element of the set, then return this single --- element as a type. -simplifyUnion :: Type -> Type -simplifyUnion (TUnion s) | Set.size s == 1 = head $ Set.toList s -simplifyUnion (TUnion s) = TUnion $ Set.unions $ map elements $ Set.toList s - where - elements (TUnion elems) = elems - elements sing = Set.singleton sing -simplifyUnion unexpected = error ("simplifyUnion: unexpected argument " ++ show unexpected) - diff --git a/Data/Aeson/AutoType/Format.hs b/Data/Aeson/AutoType/Format.hs deleted file mode 100644 --- a/Data/Aeson/AutoType/Format.hs +++ /dev/null @@ -1,17 +0,0 @@ --- | Formatting tools for code generation. -module Data.Aeson.AutoType.Format(capitalize, uncapitalize) where - -import Data.Text(Text) -import qualified Data.Text as Text - --- | Make the first letter of a Text upper case. -capitalize :: Text -> Text -capitalize word = Text.toUpper first `Text.append` rest - where - (first, rest) = Text.splitAt 1 word - --- | Make the first letter of a Text lower case. -uncapitalize :: Text -> Text -uncapitalize word = Text.toLower first `Text.append` rest - where - (first, rest) = Text.splitAt 1 word diff --git a/Data/Aeson/AutoType/Pretty.hs b/Data/Aeson/AutoType/Pretty.hs deleted file mode 100644 --- a/Data/Aeson/AutoType/Pretty.hs +++ /dev/null @@ -1,53 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE CPP #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - --- | Instances of @Text.PrettyPrint.Out@ class to visualize --- Aeson @Value@ data structure. -module Data.Aeson.AutoType.Pretty() where - -import qualified Data.HashMap.Strict as Hash -import Data.HashMap.Strict(HashMap) -import Data.Aeson -import qualified Data.Text as Text -import Data.Text (Text) -import Data.Set as Set(Set, toList) -import Data.Scientific -import Data.Vector as V(Vector, toList) -import Text.PrettyPrint.GenericPretty -import Text.PrettyPrint - -formatPair :: (Out a, Out b) => (a, b) -> Doc -formatPair (a, b) = nest 1 (doc a <+> ": " <+> doc b <+> ",") - --- * This is to make prettyprinting possible for Aeson @Value@ type. -instance Out Scientific where - doc = doc . show - docPrec _ = doc - -instance (Out a) => Out (Vector a) where - doc (V.toList -> v) = "<" <+> doc v <+> ">" - docPrec _ = doc - -#if MIN_VERSION_aeson(1,2,1) -#else -deriving instance Generic Value -#endif - -instance Out Value -- orphan instance - -instance (Out a) => Out (Set a) where - doc (Set.toList -> s) = "{" <+> doc s <+> "}" - docPrec _ = doc - -instance (Out a, Out b) => Out (HashMap a b) where - doc (Hash.toList -> dict) = foldl ($$) "{" (map formatPair dict) $$ nest 1 "}" - docPrec _ = doc - -instance Out Text where - doc = text . Text.unpack -- TODO: check if there may be direct way? - docPrec _ = doc diff --git a/Data/Aeson/AutoType/Split.hs b/Data/Aeson/AutoType/Split.hs deleted file mode 100644 --- a/Data/Aeson/AutoType/Split.hs +++ /dev/null @@ -1,143 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGuaGE ScopedTypeVariables #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGuaGE DeriveGeneric #-} -{-# LANGuaGE FlexibleContexts #-} --- | Formatting type declarations and class instances for inferred types. -module Data.Aeson.AutoType.Split( - splitTypeByLabel, unificationCandidates, - unifyCandidates, toposort -) where - -import Control.Arrow ((&&&)) -import Control.Applicative ((<$>), (<*>)) -import Control.Lens.TH -import Control.Lens -import Control.Monad (forM) -import Control.Exception(assert) -import qualified Data.HashMap.Strict as Map -import Data.Monoid -import qualified Data.Set as Set -import qualified Data.Text as Text -import Data.Text (Text) -import Data.Set (Set ) -import Data.List (foldl1') -import Data.Char (isAlpha, isDigit) -import Control.Monad.State.Class -import Control.Monad.State.Strict(State, runState) -import qualified Data.Graph as Graph -import GHC.Generics (Generic) - -import Data.Aeson.AutoType.Type -import Data.Aeson.AutoType.Extract -import Data.Aeson.AutoType.Util () - ---import Debug.Trace -- DEBUG -trace _ x = x - -fst3 :: (t, t1, t2) -> t -fst3 (a, _b, _c) = a - -type Map k v = Map.HashMap k v - --- | Explanatory type alias for making declarations --- First element of the triple is original JSON identifier, --- second element of the triple is the mapped identifier name in Haskell. --- third element of the triple shows the type in a formatted way -type MappedKey = (Text, Text, Text, Bool) - --- * Splitting object types by label for unification. -type TypeTree = Map Text [Type] - -type TypeTreeM a = State TypeTree a - -addType :: Text -> Type -> TypeTreeM () -addType label typ = modify $ Map.insertWith (++) label [typ] - -splitTypeByLabel' :: Text -> Type -> TypeTreeM Type -splitTypeByLabel' _ TString = return TString -splitTypeByLabel' _ TNum = return TNum -splitTypeByLabel' _ TBool = return TBool -splitTypeByLabel' _ TNull = return TNull -splitTypeByLabel' _ (TLabel r) = assert False $ return $ TLabel r -- unnecessary? -splitTypeByLabel' l (TUnion u) = do m <- mapM (splitTypeByLabel' l) $ Set.toList u - return $! TUnion $! Set.fromList m -splitTypeByLabel' l (TArray a) = do m <- splitTypeByLabel' (l `Text.append` "Elt") a - return $! TArray m -splitTypeByLabel' l (TObj o) = do kvs <- forM (Map.toList $ unDict o) $ \(k, v) -> do - component <- splitTypeByLabel' k v - return (k, component) - addType l (TObj $ Dict $ Map.fromList kvs) - return $! TLabel l - --- | Splits initial type with a given label, into a mapping of object type names and object type structures. -splitTypeByLabel :: Text -> Type -> Map Text Type -splitTypeByLabel topLabel t = Map.map (foldl1' unifyTypes) finalState - where - finalize (TLabel l) = assert (l == topLabel) $ return () - finalize topLevel = addType topLabel topLevel - initialState = Map.empty - (_, finalState) = runState (splitTypeByLabel' topLabel t >>= finalize) initialState - --- | Topological sorting of splitted types so that it is accepted declaration order. -toposort :: Map Text Type -> [(Text, Type)] -toposort splitted = map ((id &&& (splitted Map.!)) . fst3 . graphKey) $ Graph.topSort graph - where - (graph, graphKey) = Graph.graphFromEdges' $ map makeEntry $ Map.toList splitted - makeEntry (k, v) = (k, k, allLabels v) - --- | Computes all type labels referenced by a given type. -allLabels :: Type -> [Text] -allLabels = flip go [] - where - go (TLabel l) ls = l:ls - go (TArray t) ls = go t ls - go (TUnion u) ls = Set.foldr go ls u - go (TObj o) ls = Map.foldr go ls $ unDict o - go _other ls = ls - --- * Finding candidates for extra unifications --- | For a given splitted types, it returns candidates for extra --- unifications. -unificationCandidates :: Map.HashMap t Type -> [[t]] -unificationCandidates = Map.elems . - Map.filter candidates . - Map.fromListWith (++) . - concatMap entry . - Map.toList - where - -- | Candidate entry has to have at least two candidates, so that unification makes sense - candidates [ ] = False - candidates [_] = False - candidates _ = True - -- | Make a candidate entry for each object type, which points from its keys to its label. - entry (k, TObj o) = [(Set.fromList $ Map.keys $ unDict o, [k])] - entry _ = [] -- ignore array elements and toplevel type if it is Array - --- | Unifies candidates on a give input list. -unifyCandidates :: [[Text]] -> Map Text Type -> Map Text Type -unifyCandidates candidates splitted = Map.map (remapLabels labelMapping) $ replacements splitted - where - unifiedType :: [Text] -> Type - unifiedType cset = foldr1 unifyTypes $ - map (splitted Map.!) cset - replace :: [Text] -> Map Text Type -> Map Text Type - replace cset@(c:_) s = Map.insert c (unifiedType cset) (foldr Map.delete s cset) - replace [] _ = error "Empty candidate set in replace" - replacements :: Map Text Type -> Map Text Type - replacements s = foldr replace s candidates - labelMapping :: Map Text Text - labelMapping = Map.fromList $ concatMap mapEntry candidates - mapEntry cset@(c:_) = [(x, c) | x <- cset] - mapEntry [] = error "Empty candidate set in mapEntry" - --- | Remaps type labels according to a `Map`. -remapLabels :: Map Text Text -> Type -> Type -remapLabels ls (TObj o) = TObj $ Dict $ Map.map (remapLabels ls) $ unDict o -remapLabels ls (TArray t) = TArray $ remapLabels ls t -remapLabels ls (TUnion u) = TUnion $ Set.map (remapLabels ls) u -remapLabels ls (TLabel l) = TLabel $ Map.lookupDefault l l ls -remapLabels _ other = other - diff --git a/Data/Aeson/AutoType/Test.hs b/Data/Aeson/AutoType/Test.hs deleted file mode 100644 --- a/Data/Aeson/AutoType/Test.hs +++ /dev/null @@ -1,92 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} --- | Arbitrary instances for the JSON @Value@. -module Data.Aeson.AutoType.Test ( - arbitraryTopValue - ) where - -import Data.Aeson.AutoType.Pretty () -- Generic instance for Value - -import Control.Applicative ((<$>), (<*>)) -import Data.Aeson -import Data.Function (on) -import Data.Hashable (Hashable) -import Data.Generics.Uniplate.Data -import Data.List -import Data.Scientific -import qualified Data.Text as Text -import Data.Text (Text) -import qualified Data.Vector as V -import qualified Data.HashMap.Strict as Map -import GHC.Generics - -import Test.QuickCheck.Arbitrary -import Test.QuickCheck -import Test.SmallCheck.Series - -instance Arbitrary Text where - arbitrary = Text.pack <$> sized (`vectorOf` alphabetic) - where - alphabetic = choose ('a', 'z') - -instance (Arbitrary a) => Arbitrary (V.Vector a) where - arbitrary = V.fromList <$> arbitrary - -instance (Arbitrary v) => Arbitrary (Map.HashMap Text v) where - arbitrary = makeMap <$> arbitrary - --- | Helper function for generating Arbitrary and Series instances --- for @Data.HashMap.Strict.Map@ from lists of pairs. -makeMap :: (Ord a, Hashable a) =>[(a, b)] -> Map.HashMap a b -makeMap = Map.fromList - . nubBy ((==) `on` fst) - . sortBy (compare `on` fst) - -instance Arbitrary Scientific where - arbitrary = scientific <$> arbitrary <*> arbitrary - --- TODO: top value has to be complex: Object or Array --- TODO: how to accumulate cost when generating the series? -instance Arbitrary Value where - arbitrary = sized arb - where - arb n | n < 0 = error "Negative size!" - arb 0 = return Null - arb 1 = oneof simpleGens - arb i = oneof $ complexGens (i - 1) ++ simpleGens - simpleGens = [Number <$> arbitrary - ,Bool <$> arbitrary - ,String <$> arbitrary] - shrink = concatMap simpleShrink - . universe - --- | Transformation to shrink top level of @Value@, doesn't consider nested sub-@Value@s. -simpleShrink :: Value -> [Value] -simpleShrink (Array a) = map (Array . V.fromList) $ shrink $ V.toList a -simpleShrink (Object o) = map (Object . Map.fromList) $ shrink $ Map.toList o -simpleShrink _ = [] -- Nothing for simple objects - --- | Generator for compound @Value@s -complexGens :: Int -> [Gen Value] -complexGens i = [Object . Map.fromList <$> resize i arbitrary, - Array <$> resize i arbitrary] - --- | Arbitrary JSON (must start with Object or Array.) -arbitraryTopValue :: Gen Value -arbitraryTopValue = sized $ oneof . complexGens - --- * SmallCheck Serial instances -instance Monad m => Serial m Text where - series = newtypeCons Text.pack - -instance Monad m => Serial m Scientific where - series = cons2 scientific - -instance Serial m a => Serial m (V.Vector a) where - series = newtypeCons V.fromList - -instance Serial m v => Serial m (Map.HashMap Text v) where - series = newtypeCons makeMap - --- This one is generated with Generics and instances above -instance Monad m => Serial m Value diff --git a/Data/Aeson/AutoType/Type.hs b/Data/Aeson/AutoType/Type.hs deleted file mode 100644 --- a/Data/Aeson/AutoType/Type.hs +++ /dev/null @@ -1,155 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} --- | Union types describing JSON objects, and operations for querying these types. -module Data.Aeson.AutoType.Type(typeSize, - Dict(..), keys, get, withDict, - Type(..), emptyType, - isSimple, isArray, isObject, typeAsSet, - hasNonTopTObj, - hasTObj, - isNullable, - emptySetLikes - ) where - -import Prelude hiding (any) -import qualified Data.HashMap.Strict as Hash -import qualified Data.Set as Set -import Data.Data (Data(..)) -import Data.Typeable (Typeable) -import Data.Foldable (any) -import Data.Text (Text) -import Data.Set (Set ) -import Data.HashMap.Strict(HashMap) -import Data.List (sort) -import Data.Ord (comparing) -import Data.Generics.Uniplate -import Text.PrettyPrint.GenericPretty - -import Data.Aeson.AutoType.Pretty () - --- * Dictionary types for overloading of usual class instances. --- | Type alias for HashMap -type Map = HashMap - --- | Dictionary of types indexed by names. -newtype Dict = Dict { unDict :: Map Text Type } - deriving (Eq, Data, Typeable, Generic) - -instance Out Dict where - doc = doc . unDict - docPrec p = docPrec p . unDict - -instance Show Dict where - show = show . sort . Hash.toList . unDict - -instance Ord Dict where - compare = comparing $ sort . Hash.toList . unDict - --- | Make operation on a map to an operation on a Dict. -withDict :: (Map Text Type -> Map Text Type) -> Dict -> Dict -f `withDict` (Dict m) = Dict $ f m - --- | Take all keys from dictionary. -keys :: Dict -> Set Text -keys = Set.fromList . Hash.keys . unDict - --- | Union types for JSON values. -data Type = TNull | TBool | TNum | TString | - TUnion (Set Type) | - TLabel Text | - TObj Dict | - TArray Type - deriving (Show,Eq, Ord, Data, Typeable, Generic) - -instance Out Type - --- These are missing Uniplate instances... -{- -instance Biplate (Set a) a where - biplate s = (Set.toList s, Set.fromList) - -instance Biplate (HashMap k v) v where - biplate m = (Hash.elems m, Hash.fromList . zip (Hash.keys m)) - -} - -instance Uniplate Type where - uniplate (TUnion s) = (Set.toList s, TUnion . Set.fromList ) - uniplate (TObj d) = (Hash.elems m, TObj . Dict . Hash.fromList . zip (Hash.keys m)) - where - m = unDict d - uniplate (TArray t) = ([t], TArray . head ) - uniplate s = ([], const s ) - --- | Empty type -emptyType :: Type -emptyType = TUnion Set.empty - --- | Lookup the Type within the dictionary. -get :: Text -> Dict -> Type -get key = Hash.lookupDefault TNull key . unDict - --- $derive makeUniplateDirect ''Type - --- | Size of the `Type` term. -typeSize :: Type -> Int -typeSize TNull = 1 -typeSize TBool = 1 -typeSize TNum = 1 -typeSize TString = 1 -typeSize (TObj o) = (1+) . sum . map typeSize . Hash.elems . unDict $ o -typeSize (TArray a) = 1 + typeSize a -typeSize (TUnion u) = (1+) . sum . (0:) . map typeSize . Set.toList $ u -typeSize (TLabel _) = error "Don't know how to compute typeSize of TLabel." - --- | Check if this is nullable (Maybe) type, or not. --- Nullable type will always accept TNull or missing key that contains it. -isNullable :: Type -> Bool -isNullable TNull = True -isNullable (TUnion u) = isNullable `any` u -isNullable _ = False - --- | "Null-ish" types -emptySetLikes :: Set Type -emptySetLikes = Set.fromList [TNull, TArray $ TUnion $ Set.fromList []] --- Q: and TObj $ Map.fromList []? -{-# INLINE emptySetLikes #-} - --- | Convert any type into union type (even if just singleton). -typeAsSet :: Type -> Set Type -typeAsSet (TUnion s) = s -typeAsSet t = Set.singleton t - --- | Is the top-level constructor a TObj? -isObject :: Type -> Bool -isObject (TObj _) = True -isObject _ = False - --- | Is it a simple (non-compound) Type? -isSimple :: Type -> Bool -isSimple x = not (isObject x) && not (isArray x) && not (isUnion x) - --- | Is the top-level constructor a TUnion? -isUnion :: Type -> Bool -isUnion (TUnion _) = True -isUnion _ = False - --- | Is the top-level constructor a TArray? --- | Check if the given type has non-top TObj. -isArray :: Type -> Bool -isArray (TArray _) = True -isArray _ = False - --- | Check if the given type has non-top TObj. -hasNonTopTObj :: Type -> Bool -hasNonTopTObj (TObj o) = any hasTObj $ Hash.elems $ unDict o -hasNonTopTObj _ = False - --- | Check if the given type has TObj on top or within array.. -hasTObj :: Type -> Bool -hasTObj (TObj _) = True -hasTObj (TArray a) = hasTObj a -hasTObj (TUnion u) = any hasTObj u -hasTObj _ = False diff --git a/Data/Aeson/AutoType/Util.hs b/Data/Aeson/AutoType/Util.hs deleted file mode 100644 --- a/Data/Aeson/AutoType/Util.hs +++ /dev/null @@ -1,34 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} - --- | Utility functions that may be ultimately moved to some library. -module Data.Aeson.AutoType.Util( withFileOrHandle - , withFileOrDefaultHandle - ) where - -import Data.Hashable -import qualified Data.Set as Set -import System.IO (withFile, IOMode(..), Handle, stdin, stdout) - --- | Generic function for opening file if the filename is not empty nor "-", --- or using given handle otherwise (probably stdout, stderr, or stdin). --- TODO: Should it become utility function? -withFileOrHandle :: FilePath -> IOMode -> Handle -> (Handle -> IO r) -> IO r -withFileOrHandle "" _ handle action = action handle -withFileOrHandle "-" _ handle action = action handle -withFileOrHandle name ioMode _ action = withFile name ioMode action - --- | Generic function for choosing either file with given name or stdin/stdout as input/output. --- It accepts the function that takes the corresponding handle. --- Stdin/stdout is selected by "-". -withFileOrDefaultHandle :: FilePath -> IOMode -> (Handle -> IO r) -> IO r -withFileOrDefaultHandle "-" ReadMode action = action stdin -withFileOrDefaultHandle "-" WriteMode action = action stdout -withFileOrDefaultHandle "-" otherMode _ = error $ "Incompatible io mode (" - ++ show otherMode - ++ ") for `-` in withFileOrDefaultHandle." -withFileOrDefaultHandle filename ioMode action = withFile filename ioMode action - --- Missing instances -instance Hashable a => Hashable (Set.Set a) where - hashWithSalt = Set.foldr (flip hashWithSalt) - diff --git a/GenerateJSONParser.hs b/GenerateJSONParser.hs deleted file mode 100644 --- a/GenerateJSONParser.hs +++ /dev/null @@ -1,175 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE ViewPatterns #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -module Main where - -import Control.Applicative -import Control.Exception (assert) -import Control.Monad (forM_, when, unless) -import Data.Maybe -import Data.Monoid -import Data.List (partition) -import System.Exit -import System.IO (stdin, stderr, IOMode(..)) ---import System.IO.Posix.MMap (mmapFileByteString) -import System.FilePath (splitExtension) -import System.Process (system) -import qualified Data.ByteString.Lazy.Char8 as BSL -import qualified Data.HashMap.Strict as Map -import Data.Aeson(Value(..), decode, encode, FromJSON(..), ToJSON(..)) -import qualified Data.Text as Text -import qualified Data.Text.IO as Text -import Data.Text (Text) -import Text.PrettyPrint.GenericPretty (pretty) - -import Data.Aeson.AutoType.CodeGen -import Data.Aeson.AutoType.Extract -import Data.Aeson.AutoType.Format -import Data.Aeson.AutoType.Split -import Data.Aeson.AutoType.Type -import Data.Aeson.AutoType.Util -import qualified Data.Yaml as Yaml - -import Options.Applicative -import CommonCLI - --- * Command line flags -data Options = Options { - tyOpts :: TypeOpts - , outputFilename :: FilePath - , typecheck :: Bool - , yaml :: Bool - , preprocessor :: Bool - , filenames :: [FilePath] - } - -optParser :: Parser Options -optParser = - Options <$> tyOptParser - <*> strOption (short 'o' <> - long "output" <> - long "outputFilename" <> value "") - <*> unflag (short 'n' <> - long "no-typecheck" <> help "Do not typecheck after unification") - <*> switch (long "yaml" <> help "Parse inputs as YAML instead of JSON") - <*> switch (short 'p' <> - long "preprocessor" <> - help "Work as GHC preprocessor (and skip preprocessor pragma)") - <*> some (argument str (metavar "FILES...")) - --- | Report an error to error output. -report :: Text -> IO () -report = Text.hPutStrLn stderr - --- | Report an error and terminate the program. -fatal :: Text -> IO () -fatal msg = do report msg - exitFailure - --- | Extracts type from JSON file, along with the original @Value@. --- In order to facilitate dealing with failures, it returns a triple of --- @FilePath@, extracted @Type@, and a JSON @Value@. -extractTypeFromJSONFile :: Options -> FilePath -> IO (Maybe (FilePath, Type, Value)) -extractTypeFromJSONFile opts inputFilename = - withFileOrHandle inputFilename ReadMode stdin $ \hInput -> - -- First we decode JSON input into Aeson's Value type - do Text.hPutStrLn stderr $ "Processing " `Text.append` Text.pack (show inputFilename) - decodedJSON :: Maybe Value <- decoder <$> BSL.hGetContents hInput - --let decodedJSON :: Maybe Value = decodeValue input - -- myTrace ("Decoded JSON: " ++ pretty decoded) - case decodedJSON of - Nothing -> do report $ "Cannot decode JSON input from " `Text.append` Text.pack (show inputFilename) - return Nothing - Just v -> do -- If decoding JSON was successful... - -- We extract type structure from the JSON value. - let t :: Type = extractType v - myTrace $ "Type: " ++ pretty t - (v `typeCheck` t) `unless` fatal ("Typecheck against base type failed for " - `Text.append` Text.pack inputFilename) - return $ Just (inputFilename, t, v) - where - decoder | yaml opts = Yaml.decode . BSL.toStrict - | otherwise = decode - -- | Works like @Debug.trace@ when the --debug flag is enabled, and does nothing otherwise. - myTrace :: String -> IO () - myTrace msg = debug (tyOpts opts) `when` putStrLn msg - -- | Perform preprocessing of JSON input to drop initial pragma. - preprocess :: BSL.ByteString -> BSL.ByteString - preprocess | preprocessor opts = dropPragma - | otherwise = id - - --- | Type checking all input files with given type, --- and return a list of filenames for files that passed the check. -typeChecking :: Type -> [FilePath] -> [Value] -> IO [FilePath] -typeChecking ty inputFilenames values = do - unless (null failures) $ report $ Text.unwords $ "Failed to typecheck with unified type: ": - (Text.pack `map` failures) - when ( null successes) $ fatal "No files passed the typecheck." - return successes - where - checkedFiles = zip inputFilenames $ map (`typeCheck` ty) values - (map fst -> successes, - map fst -> failures) = partition snd checkedFiles - --- | Take a set of JSON input filenames, Haskell output filename, and generate module parsing these JSON files. -generateHaskellFromJSONs :: Options -> [FilePath] -> FilePath -> IO () -generateHaskellFromJSONs opts@Options { tyOpts=TyOptions { toplevel - , lang - , test } - } - inputFilenames outputFilename = do - -- Read type from each file - (filenames, - typeForEachFile, - valueForEachFile) <- unzip3 . catMaybes <$> mapM (extractTypeFromJSONFile opts) inputFilenames - -- Unify all input types - when (null typeForEachFile) $ do - report "No valid JSON input file..." - exitFailure - let finalType = foldr1 unifyTypes typeForEachFile - passedTypeCheck <- if typecheck opts - then typeChecking finalType filenames valueForEachFile - else return filenames - -- We split different dictionary labels to become different type trees (and thus different declarations.) - let splitted = splitTypeByLabel toplevelName finalType - myTrace $ "SPLITTED: " ++ pretty splitted - assert (not $ any hasNonTopTObj $ Map.elems splitted) $ do - -- We compute which type labels are candidates for unification - let uCands = unificationCandidates splitted - myTrace $ "CANDIDATES:\n" ++ pretty uCands - when (suggest $ tyOpts opts) $ forM_ uCands $ \cs -> do - putStr "-- " - Text.putStrLn $ "=" `Text.intercalate` cs - -- We unify the all candidates or only those that have been given as command-line flags. - let unified = if autounify $ tyOpts opts - then unifyCandidates uCands splitted - else splitted - myTrace $ "UNIFIED:\n" ++ pretty unified - -- We start by writing module header - writeModule lang outputFilename toplevelName unified - when test $ - exitWith =<< runModule lang (outputFilename:passedTypeCheck) - where - -- | Works like @Debug.trace@ when the --debug flag is enabled, and does nothing otherwise. - myTrace :: String -> IO () - myTrace msg = debug (tyOpts opts) `when` putStrLn msg - toplevelName = capitalize $ Text.pack toplevel - --- | Drop initial pragma. -dropPragma :: BSL.ByteString -> BSL.ByteString -dropPragma input | "{-#" `BSL.isPrefixOf` input = BSL.dropWhile (/='\n') input - | otherwise = input - - --- | Initialize flags, and run @generateHaskellFromJSONs@. -main :: IO () -main = do opts <- execParser optInfo - generateHaskellFromJSONs opts (filenames opts) (outputFilename opts) - where - optInfo = info (optParser <**> helper) - ( fullDesc - <> progDesc "Parser JSON or YAML, get its type, and generate appropriate parser." - <> header "json-autotype -- automatic type and parser generation from JSON") diff --git a/GenerateTestJSON.hs b/GenerateTestJSON.hs deleted file mode 100644 --- a/GenerateTestJSON.hs +++ /dev/null @@ -1,200 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FlexibleContexts #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -module Main where - -import Control.Applicative -import Control.Monad.State as State -import Data.Maybe -import System.Exit -import System.IO (stdin, stderr, stdout, IOMode(..)) -import System.FilePath (splitExtension, (<.>)) -import System.Directory (removeFile) -import System.Process (system) -import Control.Monad (forM_, forM, when) -import Control.Exception (assert) -import qualified Data.ByteString.Lazy.Char8 as BSL -import qualified Data.HashMap.Strict as Map -import qualified Data.Set as Set -import Data.Monoid ((<>)) -import Data.Aeson (Value(..), decode, encode, FromJSON(..), ToJSON(..)) -import Data.Function (on) -import Data.List -import qualified Data.Text as Text -import qualified Data.Text.IO as Text -import Data.Text (Text) -import qualified Data.Vector as V -import Data.Scientific (scientific, Scientific) -import Text.PrettyPrint.GenericPretty (pretty) -import Test.QuickCheck - -import Data.Aeson.AutoType.CodeGen(writeModule, runModule, Lang(..)) -import Data.Aeson.AutoType.Extract -import Data.Aeson.AutoType.Format -import Data.Aeson.AutoType.Pretty -import Data.Aeson.AutoType.Split -import Data.Aeson.AutoType.Test -import Data.Aeson.AutoType.Type -import Data.Aeson.AutoType.Util -import Options.Applicative - -import CommonCLI - --- * Command line flags ---defineFlag "z:size" (10 :: Int) "Size of generated elements" ---defineFlag "s:stem" ("Test" :: FilePath) "Test filename stem" ---defineFlag "c:count" (100 :: Int) "Number of test cases to generate." ---defineFlag "o:outputFilename" defaultOutputFilename "Write output to the given file" ---flags_suggest = True ---defineFlag "suggest" True "Suggest candidates for unification" ---defineFlag "autounify" True "Automatically unify suggested candidates" ---defineFlag "t:test" True "Try to run generated parser after" ---defineFlag "d:debug" False "Set this flag to see more debugging info" ---defineFlag "keep" False "Keep also the successful tests" ---defineFlag "fakeFlag" True "Ignore this flag - it doesn't exist!!! It is workaround for a library problem." - -data Options = Options { - tyOpts :: TypeOpts - , keep :: Bool - , stem :: FilePath - , count :: Int - , size :: Int - } - -optParser :: Parser Options -optParser = - Options <$> tyOptParser - <*> switch (long "keep" <> help "Also keep successful tests" ) - <*> strOption (long "stem" <> value "Test" <> help "Output filename stem" ) - <*> intOpt (long "count" <> value 100 <> help "Number of tests to perform" ) - <*> intOpt (long "size" <> value 10 <> help "size of generated test cases") - -- <*> some (argument str (metavar "FILES...")) - where - intOpt = option auto - --- | Report an error to error output. -report :: Text -> IO () -report = Text.hPutStrLn stderr - --- | Report an error and terminate the program. -fatal :: Text -> IO () -fatal msg = do report msg - exitFailure - --- | Read JSON and extract @Type@ information from it. -extractTypeFromJSONFile :: (String -> IO ()) -> FilePath -> IO (Maybe Type) -extractTypeFromJSONFile myTrace inputFilename = - withFileOrHandle inputFilename ReadMode stdin $ \hIn -> - -- First we decode JSON input into Aeson's Value type - do bs <- BSL.hGetContents hIn - Text.hPutStrLn stderr $ "Processing " `Text.append` Text.pack (show inputFilename) - myTrace ("Decoded JSON: " ++ pretty (decode bs :: Maybe Value)) - case decode bs of - Nothing -> do report $ "Cannot decode JSON input from " `Text.append` Text.pack (show inputFilename) - return Nothing - Just v -> do -- If decoding JSON was successful... - -- We extract type structure from the JSON value. - let t = extractType v - myTrace $ "Type: " ++ pretty t - return $ Just t - - -vectorWithoutDuplicates :: Ord b => Int -> Gen b -> Gen [b] -vectorWithoutDuplicates i gen = take i - . removeDuplicates - <$> infiniteListOf gen - -removeDuplicates :: Ord a => [a] -> [a] -removeDuplicates list = filterM checkDup list `evalState` Set.empty - where - checkDup x = do seen <- State.get - if x `Set.member` seen - then - return False - else do - State.put $ x `Set.insert` seen - return True - --- TODO: check for generic Ord? -instance Ord Value where - Null `compare` Null = EQ - Null `compare` _ = LT - _ `compare` Null = GT - (Bool a) `compare` (Bool b) = a `compare` b - (Bool a) `compare` _ = LT - _ `compare` (Bool b) = GT - (Number a) `compare` (Number b) = a `compare` b - (Number _) `compare` _ = LT - _ `compare` (Number _) = GT - (String a) `compare` (String b) = a `compare` b - (String a) `compare` _ = LT - _ `compare` (String b) = GT - (Array a) `compare` (Array b) = a `compare` b - (Array a) `compare` _ = LT - _ `compare` (Array b) = GT - (Object a) `compare` (Object b) = Map.toList a `compare` Map.toList b - --- | Take a set of JSON input filenames, Haskell output filename, and generate module parsing these JSON files. -generateTestJSONs :: Options -> IO () -generateTestJSONs Options {tyOpts=TyOptions {..}, - ..}= do - testValues :: [Value] <- generate $ - resize size $ - vectorWithoutDuplicates 100 arbitraryTopValue - results <- forM (zip3 inputFilenames outputFilenames testValues) $ - \(inputFilename, outputFilename, jsonValue) -> do - BSL.writeFile inputFilename $ encode jsonValue - -- Read type from each file - typeForEachFile <- catMaybes <$> mapM (extractTypeFromJSONFile myTrace) [inputFilename] - -- Unify all input types - when (null typeForEachFile) $ do - report "No valid JSON input file..." - exitFailure - let finalType = foldr1 unifyTypes typeForEachFile - -- We split different dictionary labels to become different type trees (and thus different declarations.) - let splitted = splitTypeByLabel toplevelName finalType - --myTrace $ "SPLITTED: " ++ pretty splitted - assert (not $ any hasNonTopTObj $ Map.elems splitted) $ do - -- We compute which type labels are candidates for unification - let uCands = unificationCandidates splitted - myTrace $ "CANDIDATES:\n" ++ pretty uCands - when suggest $ forM_ uCands $ \cs -> do - putStr "-- " - Text.putStrLn $ "=" `Text.intercalate` cs - -- We unify the all candidates or only those that have been given as command-line flags. - let unified = if autounify - then unifyCandidates uCands splitted - else splitted - myTrace $ "UNIFIED:\n" ++ pretty unified - -- We start by writing module header - writeModule lang outputFilename toplevelName unified - if test - then do - r <- (==ExitSuccess) <$> runModule lang [outputFilename, inputFilename] - when r $ mapM_ removeFile [inputFilename, outputFilename] - return r - else - return True - putStrLn $ "Successfully generated " ++ show (length results) ++ - " JSON files, out of planned " ++ show count ++ " cases." - where - makeInputFilename = (<.>".json") . (stem ++) . show - makeOutputFilename = (<.>".hs") . (stem ++) . show - inputFilenames = map makeInputFilename [1..count] - outputFilenames = map makeOutputFilename [1..count] - myTrace :: String -> IO () - myTrace msg = debug `when` putStrLn msg - toplevelName = capitalize $ Text.pack toplevel - -main :: IO () -main = do opts <- execParser optInfo - generateTestJSONs opts - where - optInfo = info (optParser <**> helper) - ( fullDesc - <> progDesc "Generate a number of JSON test files, and generate type and parser for each." - <> header "Self-test for json-autotype" ) diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -8,15 +8,18 @@ I should probably write a short paper to explain the methodology. -[![Build Status](https://circleci.com/gh/mgajda/json-autotype.svg?style=shield)](https://circleci.com/gh/mgajda/json-autotype) -[![Hackage](https://img.shields.io/hackage/v/lens.svg)](https://hackage.haskell.org/package/json-autotype) +[![Build matrix across GHC compiler versions](https://img.shields.io/travis/mgajda/json-autotype.svg)](https://travis-ci.org/mgajda/json-autotype) +[![Release build](https://gitlab.com/migamake/json-autotype/badges/master/pipeline.svg)](https://gitlab.com/migamake/json-autotype/commits/master) +[![Hackage](https://img.shields.io/hackage/v/json-autotype.svg)](https://hackage.haskell.org/package/json-autotype) [![Hackage Dependencies](https://img.shields.io/hackage-deps/v/json-autotype.svg?style=flat)](http://packdeps.haskellers.com/feed?needle=json-autotype) +[![Docker Automated build](https://img.shields.io/docker/automated/migamake/json-autotype.svg)](https://hub.docker.com/r/migamake/json-autotype/) +[![Docker image size](https://img.shields.io/microbadger/image-size/migamake/json-autotype.svg)](https://hub.docker.com/r/migamake/json-autotype/) Details on official releases are on [Hackage](https://hackage.haskell.org/package/json-autotype) We currently support code generation to [Haskell](https://www.haskell.org), and [Elm](https://elm-lang.org). -_Please [volunteer help](https://gitter.im/dataHaskell/json-autotype) or [financial support](https://paypal.me/MichalJan), if you want your favourite language supported too!_ -Expression of interest may be filed as [GitHub issue](https://github.com/mgajda/json-autotype/issues/new). +_Please [volunteer help](https://gitter.im/dataHaskell/json-autotype) or [provide financial support](https://paypal.me/MichalJan), if you want your favourite language supported too!_ +Expression of interest in particular feature may be filed as [GitHub issue](https://github.com/mgajda/json-autotype/issues/new). USAGE: @@ -47,6 +50,11 @@ You may either edit the resulting file _and_ send it to the author as a test case for future release. Patches and suggestions are welcome. + +You can run [with Docker](https://hub.docker.com/r/migamake/json-autotype/): +``` +docker run -it migamake/json-autotype +``` EXAMPLES: ========= diff --git a/app/GenerateJSONParser.hs b/app/GenerateJSONParser.hs new file mode 100644 --- /dev/null +++ b/app/GenerateJSONParser.hs @@ -0,0 +1,193 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Main where + +import Control.Applicative +import Control.Exception (assert) +import Control.Monad (forM_, when, unless) +import Data.Maybe +import Data.Monoid +import Data.List (partition) +import System.Exit +import System.IO (stdin, stderr, IOMode(..)) +--import System.IO.Posix.MMap (mmapFileByteString) +import System.FilePath (splitExtension) +import System.Process (system) +import qualified Data.ByteString.Lazy.Char8 as BSL +import qualified Data.HashMap.Strict as Map +import Data.Aeson(Value(..), eitherDecode, encode, FromJSON(..), ToJSON(..)) +import qualified Data.Text as Text +import qualified Data.Text.IO as Text +import qualified Data.Text.Encoding as Text(decodeUtf8) +import Data.Text (Text) +import Text.PrettyPrint.GenericPretty (pretty) +import Data.Version(showVersion) + +import Data.Aeson.AutoType.CodeGen +import Data.Aeson.AutoType.Extract +import Data.Aeson.AutoType.Format +import Data.Aeson.AutoType.Split +import Data.Aeson.AutoType.Type +import Data.Aeson.AutoType.Util +import qualified Data.Yaml as Yaml + +import Options.Applicative +import CommonCLI +import Paths_json_autotype + +-- * Command line flags +data Options = Options { + tyOpts :: TypeOpts + , outputFilename :: FilePath + , typecheck :: Bool + , yaml :: Bool + , preprocessor :: Bool + , filenames :: [FilePath] + } + +versionOption = + infoOption + (showVersion version) + (long "version" <> help "Show version") + +optParser :: Parser Options +optParser = + versionOption <*> ( + Options <$> tyOptParser + <*> strOption (short 'o' <> + long "output" <> + long "outputFilename" <> value "") + <*> unflag (short 'n' <> + long "no-typecheck" <> help "Do not typecheck after unification") + <*> switch (long "yaml" <> help "Parse inputs as YAML instead of JSON") + <*> switch (short 'p' <> + long "preprocessor" <> + help "Work as GHC preprocessor (and skip preprocessor pragma)") + <*> some (argument str (metavar "FILES...")) + ) + +-- | Report an error to error output. +report :: Text -> IO () +report = Text.hPutStrLn stderr + +-- | Report an error and terminate the program. +fatal :: Text -> IO () +fatal msg = do report msg + exitFailure + +-- | Extracts type from JSON file, along with the original @Value@. +-- In order to facilitate dealing with failures, it returns a triple of +-- @FilePath@, extracted @Type@, and a JSON @Value@. +extractTypeFromJSONFile :: Options -> FilePath -> IO (Maybe (FilePath, Type, Value)) +extractTypeFromJSONFile opts inputFilename = + withFileOrHandle inputFilename ReadMode stdin $ \hInput -> + -- First we decode JSON input into Aeson's Value type + do Text.hPutStrLn stderr $ "Processing " `Text.append` Text.pack (show inputFilename) + decodedJSON :: Either Text Value <- decoder <$> BSL.hGetContents hInput + --let decodedJSON :: Maybe Value = decodeValue input + -- myTrace ("Decoded JSON: " ++ pretty decoded) + case decodedJSON of + Left err -> do report $ Text.concat ["Cannot decode JSON input from " + , Text.pack (show inputFilename) + , err + ] + return Nothing + Right v -> do -- If decoding JSON was successful... + -- We extract type structure from the JSON value. + let t :: Type = extractType v + myTrace $ "Type: " ++ pretty t + (v `typeCheck` t) `unless` fatal ("Typecheck against base type failed for " + `Text.append` Text.pack inputFilename) + return $ Just (inputFilename, t, v) + where + decoder :: FromJSON v => BSL.ByteString -> Either Text v + decoder input | yaml opts = case Yaml.decodeEither' $ BSL.toStrict input of + Left exc -> Left $ Text.pack $ Yaml.prettyPrintParseException exc + Right r -> Right r + | otherwise = case eitherDecode input of + Left e -> Left $ Text.pack e + Right r -> Right r + -- | Works like @Debug.trace@ when the --debug flag is enabled, and does nothing otherwise. + myTrace :: String -> IO () + myTrace msg = debug (tyOpts opts) `when` putStrLn msg + -- | Perform preprocessing of JSON input to drop initial pragma. + preprocess :: BSL.ByteString -> BSL.ByteString + preprocess | preprocessor opts = dropPragma + | otherwise = id + + +-- | Type checking all input files with given type, +-- and return a list of filenames for files that passed the check. +typeChecking :: Type -> [FilePath] -> [Value] -> IO [FilePath] +typeChecking ty inputFilenames values = do + unless (null failures) $ report $ Text.unwords $ "Failed to typecheck with unified type: ": + (Text.pack `map` failures) + when ( null successes) $ fatal "No files passed the typecheck." + return successes + where + checkedFiles = zip inputFilenames $ map (`typeCheck` ty) values + (map fst -> successes, + map fst -> failures) = partition snd checkedFiles + +-- | Take a set of JSON input filenames, Haskell output filename, and generate module parsing these JSON files. +generateHaskellFromJSONs :: Options -> [FilePath] -> FilePath -> IO () +generateHaskellFromJSONs opts@Options { tyOpts=TyOptions { toplevel + , lang + , test } + } + inputFilenames outputFilename = do + -- Read type from each file + (filenames, + typeForEachFile, + valueForEachFile) <- unzip3 . catMaybes <$> mapM (extractTypeFromJSONFile opts) inputFilenames + -- Unify all input types + when (null typeForEachFile) $ do + report "No valid JSON input file..." + exitFailure + let finalType = foldr1 unifyTypes typeForEachFile + passedTypeCheck <- if typecheck opts + then typeChecking finalType filenames valueForEachFile + else return filenames + -- We split different dictionary labels to become different type trees (and thus different declarations.) + let splitted = splitTypeByLabel toplevelName finalType + myTrace $ "SPLITTED: " ++ pretty splitted + assert (not $ any hasNonTopTObj $ Map.elems splitted) $ do + -- We compute which type labels are candidates for unification + let uCands = unificationCandidates splitted + myTrace $ "CANDIDATES:\n" ++ pretty uCands + when (suggest $ tyOpts opts) $ forM_ uCands $ \cs -> do + putStr "-- " + Text.putStrLn $ "=" `Text.intercalate` cs + -- We unify the all candidates or only those that have been given as command-line flags. + let unified = if autounify $ tyOpts opts + then unifyCandidates uCands splitted + else splitted + myTrace $ "UNIFIED:\n" ++ pretty unified + -- We start by writing module header + writeModule lang outputFilename toplevelName unified + when test $ + exitWith =<< runModule lang (outputFilename:passedTypeCheck) + where + -- | Works like @Debug.trace@ when the --debug flag is enabled, and does nothing otherwise. + myTrace :: String -> IO () + myTrace msg = debug (tyOpts opts) `when` putStrLn msg + toplevelName = capitalize $ Text.pack toplevel + +-- | Drop initial pragma. +dropPragma :: BSL.ByteString -> BSL.ByteString +dropPragma input | "{-#" `BSL.isPrefixOf` input = BSL.dropWhile (/='\n') input + | otherwise = input + + +-- | Initialize flags, and run @generateHaskellFromJSONs@. +main :: IO () +main = do opts <- execParser optInfo + generateHaskellFromJSONs opts (filenames opts) (outputFilename opts) + where + optInfo = info (optParser <**> helper) + ( fullDesc + <> progDesc "Parser JSON or YAML, get its type, and generate appropriate parser." + <> header "json-autotype -- automatic type and parser generation from JSON") diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,5 +1,21 @@ Changelog ========= + 3.0.0 Nov 2018 + * Distinguishing integers and floats. + * Hide all API beside Alternative (as unused outside generator). + * Add fixity for alt (#20) + * Use `eitherDecode` instead of `decode` to get better error messages. + * Split Data.Aeson.AutoType.Alternative to `json-alt`. + + 2.0.2 Nov 2018 + * Clean up the tests. + * Remove compatibility with Aeson versions earlier than 1.2.1. + * Removed all CPP macros + * Add --version + + 2.0.1 Nov 2018 + * Better error reporting when parsing JSON. + 2.0.0 Jun 2018 * Elm support completed with untagged unions * Add HaskellStrict option for running tests with -Werror, -Wall by default. diff --git a/common/CommonCLI.hs b/common/CommonCLI.hs new file mode 100644 --- /dev/null +++ b/common/CommonCLI.hs @@ -0,0 +1,39 @@ +module CommonCLI(TypeOpts(..), unflag, tyOptParser) where + + +import Data.Monoid ((<>)) +import Options.Applicative +import System.Process (system) +import qualified System.Environment (lookupEnv) +import System.Exit (ExitCode) + +import Data.Aeson.AutoType.CodeGen (Lang(..)) + +data TypeOpts = TyOptions { + autounify :: Bool + , toplevel :: String + , debug :: Bool + , test :: Bool + , suggest :: Bool + , lang :: Lang + } + +unflag :: Mod FlagFields Bool -> Parser Bool +unflag = flag True False + +tyOptParser :: Parser TypeOpts +tyOptParser = TyOptions + <$> unflag (long "no-autounify" <> help "Do not automatically unify suggested candidates") + <*> strOption (short 't' <> + long "toplevel" <> value "TopLevel" + <> help "Name for toplevel data type") + <*> switch (long "debug" <> help "Set this flag to see more debugging info" ) + <*> unflag (long "no-test" <> help "Do not run generated parser afterwards" ) + <*> unflag (long "no-suggest" <> help "Do not suggest candidates for unification" ) + <*> langOpts + + +langOpts :: Parser Lang +langOpts = flag Haskell Haskell (long "haskell") + <|> flag Haskell Elm (long "elm") + diff --git a/examples/colors.json b/examples/colors.json new file mode 100644 --- /dev/null +++ b/examples/colors.json @@ -0,0 +1,15 @@ +{ + "colorsArray":[{ + "colorName":"red", + "hexValue":"#f00" + }, + { + "colorName":"green", + "hexValue":"#0f0" + }, + { + "colorName":"blue", + "hexValue":"#00f" + } + ] +} diff --git a/examples/union.json b/examples/union.json new file mode 100644 --- /dev/null +++ b/examples/union.json @@ -0,0 +1,14 @@ +{ + "parameter":[{ + "parameterName":"apiVersion", + "parameterValue":1 + }, + { + "parameterName":"failOnWarnings", + "parameterValue":false + }, + { + "parameterName":"caller", + "parameterValue":"site API" + }] +} diff --git a/json-autotype.cabal b/json-autotype.cabal --- a/json-autotype.cabal +++ b/json-autotype.cabal @@ -1,8 +1,8 @@ -- Build information for the package. name: json-autotype -version: 2.0.0 +version: 3.0.0 synopsis: Automatic type declaration for JSON input data -description: Generates datatype declarations with Aeson's "FromJSON" instances +description: Generates datatype declarations with Aeson's `FromJSON` instances from a set of example ".json" files. . To get started you need to install the package, @@ -12,7 +12,7 @@ "$ json-autotype input.json -o JSONTypes.hs" . Feel free to tweak the by changing types of the fields - - any field type that is instance of "FromJSON" should work. + - any field type that is instance of `FromJSON` should work. . You may immediately test the parser by calling it as a script: . @@ -33,26 +33,52 @@ author: Michal J. Gajda maintainer: simons@cryp.to mjgajda@gmail.com -copyright: Copyright by Michal J. Gajda '2014-'2017 +copyright: Copyright by Michal J. Gajda '2014-'2018 category: Data, Tools build-type: Simple -extra-source-files: README.md changelog.md +extra-source-files: README.md changelog.md examples/union.json examples/colors.json cabal-version: >=1.10 bug-reports: https://github.com/mgajda/json-autotype/issues -tested-with: GHC==7.8.4, GHC==7.10.3, GHC==7.6.3, GHC==8.0.1, GHC==8.2.2, GHC==8.4.1 +tested-with: GHC==7.6.1 + , GHC==7.6.2 + , GHC==7.6.3 + , GHC==7.8.1 + , GHC==7.8.2 + , GHC==7.8.3 + , GHC==7.8.4 + , GHC==7.10.1 + , GHC==7.10.2 + , GHC==7.10.3 + , GHC==8.0.1 + , GHC==8.0.2 + , GHC==8.2.2 + , GHC==8.4.1 + , GHC==8.4.2 + , GHC==8.4.3 + , GHC==8.4.4 + , GHC==8.6.2 + , GHC==8.6.1 + source-repository head type: git location: https://github.com/mgajda/json-autotype.git library - exposed-modules: Data.Aeson.AutoType.Type + exposed-modules: Data.Aeson.AutoType.CodeGen + Data.Aeson.AutoType.CodeGen.Generic + Data.Aeson.AutoType.CodeGen.Haskell + Data.Aeson.AutoType.CodeGen.Elm + Data.Aeson.AutoType.CodeGen.HaskellFormat + Data.Aeson.AutoType.CodeGen.ElmFormat Data.Aeson.AutoType.Extract Data.Aeson.AutoType.Format Data.Aeson.AutoType.Pretty - Data.Aeson.AutoType.CodeGen - Data.Aeson.AutoType.Alternative - -- Data.Aeson.AutoType.Plugin.Subtype - -- Data.Aeson.AutoType.Plugin.Loader + Data.Aeson.AutoType.Split + Data.Aeson.AutoType.Type + Data.Aeson.AutoType.Test + Data.Aeson.AutoType.Util + hs-source-dirs: src + other-extensions: TemplateHaskell, ScopedTypeVariables, OverloadedStrings, @@ -61,23 +87,13 @@ DeriveDataTypeable, DeriveGeneric, RecordWildCards - other-modules: - -- internal module - Data.Aeson.AutoType.Util - Data.Aeson.AutoType.Split - Data.Aeson.AutoType.CodeGen.Haskell - Data.Aeson.AutoType.CodeGen.Elm - Data.Aeson.AutoType.CodeGen.HaskellFormat - Data.Aeson.AutoType.CodeGen.ElmFormat - build-depends: base >=4.3 && <4.12, + build-depends: base >=4.3 && <5, GenericPretty >=1.2 && <1.3, - aeson >=0.11.2 && <1.5, + aeson >=1.2.1 && <1.5, containers >=0.3 && <0.7, filepath >=1.3 && <1.5, hashable >=1.2 && <1.3, - ---hint >=0.4 && <0.6, - lens >=4.1 && <4.17, - --mmap >=0.5 && <0.6, + lens >=4.1 && <4.18, mtl >=2.1 && <2.3, pretty >=1.1 && <1.3, process >=1.1 && <1.7, @@ -85,26 +101,18 @@ text >=1.1 && <1.4, uniplate >=1.6 && <1.7, unordered-containers >=0.2 && <0.3, - vector >=0.9 && <0.13 + vector >=0.9 && <0.13, + smallcheck >=1.0 && <1.2, + QuickCheck >=2.4 && <3.0, + json-alt, + template-haskell default-language: Haskell2010 executable json-autotype main-is: GenerateJSONParser.hs - other-modules: Data.Aeson.AutoType.Type - Data.Aeson.AutoType.Extract - Data.Aeson.AutoType.Format - Data.Aeson.AutoType.Pretty - Data.Aeson.AutoType.Split - Data.Aeson.AutoType.CodeGen - Data.Aeson.AutoType.CodeGen.Haskell - Data.Aeson.AutoType.CodeGen.Elm - Data.Aeson.AutoType.CodeGen.HaskellFormat - Data.Aeson.AutoType.CodeGen.ElmFormat - Data.Aeson.AutoType.Alternative - -- Data.Aeson.AutoType.Plugin.Subtype - -- Data.Aeson.AutoType.Plugin.Loader - Data.Aeson.AutoType.Util - CommonCLI + hs-source-dirs: app common + other-modules: CommonCLI + Paths_json_autotype other-extensions: TemplateHaskell, ScopedTypeVariables, OverloadedStrings, @@ -113,15 +121,14 @@ DeriveDataTypeable, DeriveGeneric, RecordWildCards - build-depends: base >=4.3 && <4.12, + build-depends: base >=4.3 && <5, GenericPretty >=1.2 && <1.3, - aeson >=0.11.2 && <1.5, + aeson >=1.2.1 && <1.5, bytestring >=0.9 && <0.11, containers >=0.3 && <0.7, filepath >=1.3 && <1.5, hashable >=1.2 && <1.3, - --hint >=0.4 && <0.6, - lens >=4.1 && <4.17, + lens >=4.1 && <4.18, mtl >=2.1 && <2.3, optparse-applicative >=0.12 && <1.0, pretty >=1.1 && <1.3, @@ -131,22 +138,21 @@ uniplate >=1.6 && <1.7, unordered-containers >=0.2 && <0.3, vector >=0.9 && <0.13, - yaml >=0.8 && <0.9 - -- hs-source-dirs: + yaml >=0.8 && <0.12, + template-haskell, + json-autotype, + json-alt default-language: Haskell2010 + ld-options: -static + ghc-options: -fPIC -- * Test suites -- Test suite with QuickCheck on random values, -- and extracted types. test-suite json-autotype-qc-test type: exitcode-stdio-1.0 - main-is: test/TestQC.hs - other-modules: Data.Aeson.AutoType.Util - Data.Aeson.AutoType.Extract - Data.Aeson.AutoType.Format - Data.Aeson.AutoType.Test - Data.Aeson.AutoType.Type - Data.Aeson.AutoType.Pretty + main-is: TestQC.hs + hs-source-dirs: test common other-extensions: TemplateHaskell, ScopedTypeVariables, OverloadedStrings, @@ -155,12 +161,12 @@ DeriveDataTypeable, DeriveGeneric, RecordWildCards - build-depends: base >=4.3 && <4.12, + build-depends: base >=4.3 && <5, GenericPretty >=1.2 && <1.3, - aeson >=0.11.2 && <1.5, + aeson >=1.2.1 && <1.5, containers >=0.3 && <0.7, hashable >=1.2 && <1.3, - lens >=4.1 && <4.17, + lens >=4.1 && <4.18, mtl >=2.1 && <2.3, pretty >=1.1 && <1.3, scientific >=0.3 && <0.5, @@ -169,26 +175,17 @@ uniplate >=1.6 && <1.7, unordered-containers >=0.2 && <0.3, vector >=0.9 && <0.13, - QuickCheck >=2.4 && <3.0 - -- hs-source-dirs: + QuickCheck >=2.4 && <3.0, + json-autotype, + json-alt default-language: Haskell2010 test-suite json-autotype-examples type: exitcode-stdio-1.0 - main-is: test/TestExamples.hs - other-modules: Data.Aeson.AutoType.Util - Data.Aeson.AutoType.CodeGen - Data.Aeson.AutoType.CodeGen.Elm - Data.Aeson.AutoType.CodeGen.ElmFormat - Data.Aeson.AutoType.CodeGen.Haskell - Data.Aeson.AutoType.CodeGen.HaskellFormat - Data.Aeson.AutoType.Extract - Data.Aeson.AutoType.Format - Data.Aeson.AutoType.Pretty - Data.Aeson.AutoType.Split - Data.Aeson.AutoType.Test - Data.Aeson.AutoType.Type - CommonCLI + main-is: TestExamples.hs + other-modules: CommonCLI + hs-source-dirs: test common + other-extensions: TemplateHaskell, ScopedTypeVariables, OverloadedStrings, @@ -197,14 +194,14 @@ DeriveDataTypeable, DeriveGeneric, RecordWildCards - build-depends: base >=4.3 && <4.12, + build-depends: base >=4.3 && <5, GenericPretty >=1.2 && <1.3, - aeson >=0.11.2 && <1.5, + aeson >=1.2.1 && <1.5, containers >=0.3 && <0.7, directory >=1.1 && <1.4, filepath >=1.3 && <1.5, hashable >=1.2 && <1.3, - lens >=4.1 && <4.17, + lens >=4.1 && <4.18, mtl >=2.1 && <2.3, optparse-applicative >=0.11 && <1.0, pretty >=1.1 && <1.3, @@ -215,27 +212,19 @@ unordered-containers >=0.2 && <0.3, uniplate >=1.6 && <1.7, vector >=0.9 && <0.13, - QuickCheck >=2.4 && <3.0 - -- hs-source-dirs: + QuickCheck >=2.4 && <3.0, + template-haskell, + json-autotype, + json-alt default-language: Haskell2010 -- Test suite with Haskell code generation and compilation test-suite json-autotype-gen-test type: exitcode-stdio-1.0 main-is: GenerateTestJSON.hs - other-modules: Data.Aeson.AutoType.Util - Data.Aeson.AutoType.Pretty - Data.Aeson.AutoType.Type - Data.Aeson.AutoType.Split - Data.Aeson.AutoType.Extract - Data.Aeson.AutoType.Format - Data.Aeson.AutoType.CodeGen - Data.Aeson.AutoType.CodeGen.Haskell - Data.Aeson.AutoType.CodeGen.Elm - Data.Aeson.AutoType.CodeGen.HaskellFormat - Data.Aeson.AutoType.CodeGen.ElmFormat - Data.Aeson.AutoType.Test - CommonCLI + hs-source-dirs: test common + other-modules: CommonCLI + other-extensions: TemplateHaskell, ScopedTypeVariables, OverloadedStrings, @@ -244,16 +233,16 @@ DeriveDataTypeable, DeriveGeneric, RecordWildCards - build-depends: base >=4.3 && <4.12, + build-depends: base >=4.3 && <5, GenericPretty >=1.2 && <1.3, - aeson >=0.11.2 && <1.5, + aeson >=1.2.1 && <1.5, bytestring >=0.9 && <0.11, containers >=0.3 && <0.7, directory >=1.1 && <1.4, filepath >=1.3 && <1.5, hashable >=1.2 && <1.3, optparse-applicative >=0.12 && <1.0, - lens >=4.1 && <4.17, + lens >=4.1 && <4.18, mtl >=2.1 && <2.3, pretty >=1.1 && <1.3, process >=1.1 && <1.7, @@ -263,6 +252,8 @@ uniplate >=1.6 && <1.7, unordered-containers >=0.2 && <0.3, vector >=0.9 && <0.13, - QuickCheck >=2.4 && <3.0 - -- hs-source-dirs: + QuickCheck >=2.4 && <3.0, + template-haskell, + json-autotype, + json-alt default-language: Haskell2010 diff --git a/src/Data/Aeson/AutoType/CodeGen.hs b/src/Data/Aeson/AutoType/CodeGen.hs new file mode 100644 --- /dev/null +++ b/src/Data/Aeson/AutoType/CodeGen.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +-- | Code generation and test running in different languages. (Switchbox.) +module Data.Aeson.AutoType.CodeGen( + Lang(..) + , writeModule + , runModule + , defaultOutputFilename + ) where + +import Data.Text(Text) +import qualified Data.HashMap.Strict as Map +import Data.Aeson.AutoType.Type + +import Data.Aeson.AutoType.CodeGen.Haskell +import Data.Aeson.AutoType.CodeGen.Elm + +-- | Available output languages. +data Lang = Haskell + | HaskellStrict + | Elm + +-- | Default output filname is used, when there is no explicit output file path, or it is "-" (stdout). +-- Default module name is consistent with it. +defaultOutputFilename :: Lang -> FilePath +defaultOutputFilename Haskell = defaultHaskellFilename +defaultOutputFilename HaskellStrict = defaultHaskellFilename +defaultOutputFilename Elm = defaultElmFilename + +-- | Write a Haskell module to an output file, or stdout if `-` filename is given. +writeModule :: Lang -> FilePath -> Text -> Map.HashMap Text Type -> IO () +writeModule Haskell = writeHaskellModule +writeModule HaskellStrict = writeHaskellModule +writeModule Elm = writeElmModule + +-- | Run module in a given language. +runModule Haskell = runHaskellModule +runModule HaskellStrict = runHaskellModuleStrict +runModule Elm = runElmModule diff --git a/src/Data/Aeson/AutoType/CodeGen/Elm.hs b/src/Data/Aeson/AutoType/CodeGen/Elm.hs new file mode 100644 --- /dev/null +++ b/src/Data/Aeson/AutoType/CodeGen/Elm.hs @@ -0,0 +1,67 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +-- | Wrappers for generating prologue and epilogue code in Haskell. +module Data.Aeson.AutoType.CodeGen.Elm( + defaultElmFilename + , writeElmModule + , runElmModule + ) where + +import qualified Data.Text as Text +import qualified Data.Text.IO as Text +import Data.Text +import qualified Data.HashMap.Strict as Map +import Control.Arrow (first) +import Control.Exception (assert) +import Data.Monoid ((<>)) +import System.FilePath +import System.IO +import System.Process (system) +import System.Exit (ExitCode) + +import Data.Aeson.AutoType.Format +import Data.Aeson.AutoType.Type +import Data.Aeson.AutoType.Util +import Data.Aeson.AutoType.CodeGen.ElmFormat + +import Debug.Trace(trace) + +defaultElmFilename = "JSONTypes.elm" + +header :: Text -> Text +header moduleName = Text.unlines [ + Text.unwords ["module ", capitalize moduleName, " exposing(..)"] + ,"" + ,"-- elm-package install toastal/either" + ,"-- elm-package install NoRedInk/elm-decode-pipeline" + ,"import Either exposing (Either, unpack)" + ,"import Json.Encode exposing (..)" + ,"import Json.Decode exposing (..)" + ,"import Json.Decode.Pipeline exposing (..)" + ,""] + +epilogue :: Text -> Text +epilogue toplevelName = Text.unlines [] + +-- | Write a Haskell module to an output file, or stdout if `-` filename is given. +writeElmModule :: FilePath -> Text -> Map.HashMap Text Type -> IO () +writeElmModule outputFilename toplevelName types = + withFileOrHandle outputFilename WriteMode stdout $ \hOut -> + assert (trace extension extension == ".elm") $ do + Text.hPutStrLn hOut $ header $ Text.pack moduleName + -- We write types as Haskell type declarations to output handle + Text.hPutStrLn hOut $ displaySplitTypes types + Text.hPutStrLn hOut $ epilogue toplevelName + where + (moduleName, extension) = + first normalizeTypeName' $ + splitExtension $ + if outputFilename == "-" + then defaultElmFilename + else outputFilename + normalizeTypeName' = Text.unpack . normalizeTypeName . Text.pack + +runElmModule :: [String] -> IO ExitCode +runElmModule arguments = do + hPutStrLn stderr "Compiling *not* running Elm module for a test." + system $ Prelude.unwords $ ["elm", "make", Prelude.head arguments] -- ignore parsing args diff --git a/src/Data/Aeson/AutoType/CodeGen/ElmFormat.hs b/src/Data/Aeson/AutoType/CodeGen/ElmFormat.hs new file mode 100644 --- /dev/null +++ b/src/Data/Aeson/AutoType/CodeGen/ElmFormat.hs @@ -0,0 +1,316 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGuaGE ScopedTypeVariables #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGuaGE DeriveGeneric #-} +{-# LANGuaGE FlexibleContexts #-} +-- | Formatting type declarations and class instances for inferred types. +module Data.Aeson.AutoType.CodeGen.ElmFormat( + displaySplitTypes, + normalizeTypeName) where + +import Control.Arrow ((&&&)) +import Control.Applicative ((<$>), (<*>)) +import Control.Lens.TH +import Control.Lens +import Control.Monad (forM) +import Control.Exception(assert) +import qualified Data.HashMap.Strict as Map +import Data.Monoid +import qualified Data.Set as Set +import qualified Data.Text as Text +import Data.Text (Text) +import Data.Set (Set, toList) +import Data.List (foldl1') +import Data.Char (isAlpha, isDigit) +import Control.Monad.State.Class +import Control.Monad.State.Strict(State, runState) +import GHC.Generics (Generic) + +import Data.Aeson.AutoType.Type +import Data.Aeson.AutoType.Extract +import Data.Aeson.AutoType.Split +import Data.Aeson.AutoType.Format +import Data.Aeson.AutoType.Util () + +--import Debug.Trace -- DEBUG +trace _ x = x + +fst3 :: (t, t1, t2) -> t +fst3 (a, _b, _c) = a + +data DeclState = DeclState { _decls :: [Text] + , _counter :: Int + } + deriving (Eq, Show, Ord, Generic) + +makeLenses ''DeclState + +type DeclM = State DeclState + +type Map k v = Map.HashMap k v + +stepM :: DeclM Int +stepM = counter %%= (\i -> (i, i+1)) + +tShow :: (Show a) => a -> Text +tShow = Text.pack . show + +-- | Wrap a type alias. +wrapAlias :: Text -> Text -> Text +wrapAlias identifier contents = Text.unwords ["type alias ", identifier, "=", contents] + +-- | Wrap a data type declaration +wrapDecl :: Text -> Text -> Text +wrapDecl identifier contents = Text.unlines [header, contents, " }"] + --,"\nderiveJSON defaultOptions ''" `Text.append` identifier] + where + header = Text.concat ["type alias ", identifier, " = ", " { "] + +-- | Explanatory type alias for making declarations +-- First element of the triple is original JSON identifier, +-- second element of the triple is the mapped identifier name in Haskell. +-- third element of the triple shows the type in a formatted way +type MappedKey = (Text, Text, Text, Type, Bool) + +-- | Make Decoder declaration, given identifier (object name in Haskell) and mapping of its keys +-- from JSON to Haskell identifiers *in the same order* as in *data type declaration*. +makeDecoder :: Text -> [MappedKey] -> Text +makeDecoder identifier contents = + Text.unlines [ + Text.concat [decodeIdentifier, " : Json.Decode.Decoder ", identifier] + , Text.concat [decodeIdentifier, " ="] + , Text.unwords [" Json.Decode.Pipeline.decode", identifier] + , Text.unlines (makeParser identifier <$> contents) ] + where + decodeIdentifier = decoderIdent identifier + makeParser identifier (jsonId, _, _, ty, isOptional) = Text.unwords [ + " |>" + , if isOptional + then "Json.Decode.Pipeline.optional" + else "Json.Decode.Pipeline.required" + , Text.concat ["\"", jsonId, "\""] + , "(" <> getDecoder ty <> ")"] -- quote + +getDecoder TString = "Json.Decode.string" +getDecoder TInt = "Json.Decode.int" +getDecoder TDouble = "Json.Decode.float" +getDecoder TBool = "Json.Decode.bool" +getDecoder (TArray t) = "Json.Decode.list (" <> getDecoder t <> ")" +getDecoder (TLabel l) = decoderIdent l +getDecoder (TObj o) = error "getDecoder cannot handle complex object types!" +getDecoder (TUnion u) = case nonNull of + [] -> "Json.Decode.value" + [x] -> getDecoder x + _ -> foldl1' altDecoder $ map getDecoder nonNull + where + nonNull = nonNullComponents u +--error $ "getDecoder cannot yet handle union types:" <> show u + +altDecoder a b = "(Json.Decode.oneOf [Json.Decode.map Either.Left (" + <> a <> "), Json.Decode.map Either.Right (" + <> b <> ")])" +{-Json.Decode.Pipeline.decode Something +"Json.Decode.Pipeline " <>-} + + +decoderIdent ident = "decode" <> capitalize (normalizeTypeName ident) +-- Contents example for wrapFromJSON: +-- " <$> +--" v .: "hexValue" <*> +--" v .: "colorName\"" + +encoderIdent ident = "encode" <> capitalize (normalizeTypeName ident) + +-- | Make Encoder declaration, given identifier (object name in Haskell) and mapping of its keys +-- from JSON to Haskell identifiers in the same order as in declaration +makeEncoder :: Text -> [MappedKey] -> Text +makeEncoder identifier contents = + Text.unlines [ + Text.unwords [encoderIdent identifier, ":", identifier, "->", "Json.Encode.Value"] + , encoderIdent identifier <> " record =" + , " Json.Encode.object [" + , " " <> (joinWith "\n , " (makeEncoder <$> contents)) + , " ]" + ] + where + makeEncoder (jsonId, haskellId, _typeText, ty, _nullable) = Text.concat [ + "(", tShow jsonId, ", (", getEncoder ty, ") record.", normalizeFieldName identifier jsonId, ")" + ] + --"answers", Json.Encode.list <| List.map encodeAnswer <| record.answers + escapeText = Text.pack . show . Text.unpack + +getEncoder :: Type -> Text +getEncoder TString = "Json.Encode.string" +getEncoder TDouble = "Json.Encode.float" +getEncoder TInt = "Json.Encode.int" +getEncoder TBool = "Json.Encode.bool" +getEncoder TNull = "identity" +getEncoder (TLabel l) = encoderIdent l +getEncoder (TArray e) = "Json.Encode.list << List.map (" <> getEncoder e <> ")" +getEncoder (TObj o) = error $ "Seeing direct object encoder: " <> show o +getEncoder (TUnion u) = case nonNull of + [] -> "identity" + [x] -> getDecoder x + _ -> foldl1' altEncoder $ map getEncoder nonNull + where + nonNull = nonNullComponents u + +altEncoder a b = "Either.unpack (" <> a <> ") (" <> b <> ")" + +-- Contents example for wrapToJSON +--"hexValue" .= hexValue +-- ,"colorName" .= colorName] +-- | Join text with other as separator. +joinWith :: Text -> [Text] -> Text +joinWith _ [] = "" +joinWith joiner (aFirst:rest) = aFirst <> Text.concat (map (joiner <>) rest) + +-- | Makes a generic identifier name. +genericIdentifier :: DeclM Text +genericIdentifier = do + i <- stepM + return $! "Obj" `Text.append` tShow i + +-- * Printing a single data type declaration +newDecl :: Text -> [(Text, Type)] -> DeclM Text +newDecl identifier kvs = do attrs <- forM kvs $ \(k, v) -> do + formatted <- formatType v + return (k, normalizeFieldName identifier k, formatted, v, isNullable v) + let decl = Text.unlines [wrapDecl identifier $ fieldDecls attrs + ,"" + ,makeDecoder identifier attrs + ,"" + ,makeEncoder identifier attrs] + addDecl decl + return identifier + where + fieldDecls attrList = Text.intercalate ",\n" $ map fieldDecl attrList + fieldDecl :: (Text, Text, Text, Type, Bool) -> Text + fieldDecl (_jsonName, haskellName, fType, _type, _nullable) = Text.concat [ + " ", haskellName, " : ", fType] + +addDecl decl = decls %%= (\ds -> ((), decl:ds)) + +-- | Add new type alias for Array type +newAlias :: Text -> Type -> DeclM Text +newAlias identifier content = do formatted <- formatType content + addDecl $ Text.unlines [wrapAlias identifier formatted] + return identifier + +-- | Convert a JSON key name given by second argument, +-- from within a dictionary keyed with first argument, +-- into a name of Haskell record field (hopefully distinct from other such selectors.) +normalizeFieldName :: Text -> Text -> Text +normalizeFieldName identifier = escapeKeywords . + uncapitalize . + (normalizeTypeName identifier `Text.append`) . + normalizeTypeName + +keywords :: Set Text +keywords = Set.fromList ["type", "alias", "exposing", "module", "class", + "where", "let", "do"] + +escapeKeywords :: Text -> Text +escapeKeywords k | k `Set.member` keywords = k `Text.append` "_" +escapeKeywords k = k + +nonNullComponents = Set.toList . Set.filter (TNull /=) +-- | Format the type within DeclM monad, that records +-- the separate declarations on which this one is dependent. +formatType :: Type -> DeclM Text +formatType TString = return "String" +formatType TDouble = return "Float" +formatType TInt = return "Int" +formatType TBool = return "Bool" +formatType (TLabel l) = return $ normalizeTypeName l +formatType (TUnion u) = wrap <$> case length nonNull of + 0 -> return emptyTypeRepr + 1 -> formatType $ head nonNull + _ -> foldl1' join <$> mapM formatType nonNull + where + nonNull = nonNullComponents u + wrap :: Text -> Text + wrap inner | TNull `Set.member` u = Text.concat ["(Maybe (", inner, "))"] + | otherwise = inner + join fAlt fOthers = Text.concat ["Either (", fAlt, ") (", fOthers, ")"] +formatType (TArray a) = do inner <- formatType a + return $ Text.concat ["List (", inner, ")"] +formatType (TObj o) = do ident <- genericIdentifier + newDecl ident d + where + d = Map.toList $ unDict o +formatType e | e `Set.member` emptySetLikes = return emptyTypeRepr +formatType t = return $ "ERROR: Don't know how to handle: " `Text.append` tShow t + +emptyTypeRepr :: Text +emptyTypeRepr = "Json.Decode.Value" -- default, accepts future extension where we found no data + +runDecl :: DeclM a -> Text +runDecl decl = Text.unlines $ finalState ^. decls + where + initialState = DeclState [] 1 + (_, finalState) = runState decl initialState + +-- * Splitting object types by label for unification. +type TypeTree = Map Text [Type] + +type TypeTreeM a = State TypeTree a + +addType :: Text -> Type -> TypeTreeM () +addType label typ = modify $ Map.insertWith (++) label [typ] + +formatObjectType :: Text -> Type -> DeclM Text +formatObjectType identifier (TObj o) = newDecl identifier d + where + d = Map.toList $ unDict o +formatObjectType identifier other = newAlias identifier other + +-- | Display an environment of types split by name. +displaySplitTypes :: Map Text Type -> Text +displaySplitTypes dict = trace ("displaySplitTypes: " ++ show (toposort dict)) $ runDecl declarations + where + declarations = + forM (toposort dict) $ \(name, typ) -> + formatObjectType (normalizeTypeName name) typ + +-- | Normalize type name by: +-- 1. Treating all characters that are not acceptable in Haskell variable name as end of word. +-- 2. Capitalizing each word, but a first (camelCase). +-- 3. Adding underscore if first character is non-alphabetic. +-- 4. Escaping Haskell keywords if the whole identifier is such keyword. +-- 5. If identifier is empty, then substituting "JsonEmptyKey" for its name. +normalizeTypeName :: Text -> Text +normalizeTypeName s = ifEmpty "JsonEmptyKey" . + escapeKeywords . + escapeFirstNonAlpha . + Text.concat . + map capitalize . + filter (not . Text.null) . + Text.split (not . acceptableInVariable) $ s + where + ifEmpty x "" = x + ifEmpty _ nonEmpty = nonEmpty + acceptableInVariable c = isAlpha c || isDigit c + escapeFirstNonAlpha cs | Text.null cs = cs + escapeFirstNonAlpha cs@(Text.head -> c) | isAlpha c = cs + escapeFirstNonAlpha cs = "_" `Text.append` cs + +-- | Computes all type labels referenced by a given type. +allLabels :: Type -> [Text] +allLabels = flip go [] + where + go (TLabel l) ls = l:ls + go (TArray t) ls = go t ls + go (TUnion u) ls = Set.foldr go ls u + go (TObj o) ls = Map.foldr go ls $ unDict o + go _other ls = ls + +-- | Remaps type labels according to a `Map`. +remapLabels :: Map Text Text -> Type -> Type +remapLabels ls (TObj o) = TObj $ Dict $ Map.map (remapLabels ls) $ unDict o +remapLabels ls (TArray t) = TArray $ remapLabels ls t +remapLabels ls (TUnion u) = TUnion $ Set.map (remapLabels ls) u +remapLabels ls (TLabel l) = TLabel $ Map.lookupDefault l l ls +remapLabels _ other = other diff --git a/src/Data/Aeson/AutoType/CodeGen/Generic.hs b/src/Data/Aeson/AutoType/CodeGen/Generic.hs new file mode 100644 --- /dev/null +++ b/src/Data/Aeson/AutoType/CodeGen/Generic.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE QuasiQuotes #-} +module Data.Aeson.AutoType.CodeGen.Generic(src) where + +import Language.Haskell.TH +import Language.Haskell.TH.Quote + +-- | Multiline source string +src = QuasiQuoter (\src -> [|src|]) + (error "Cannot use src as pattern") + (error "Cannot use src as type" ) + (error "Cannot use src as dec" ) + diff --git a/src/Data/Aeson/AutoType/CodeGen/Haskell.hs b/src/Data/Aeson/AutoType/CodeGen/Haskell.hs new file mode 100644 --- /dev/null +++ b/src/Data/Aeson/AutoType/CodeGen/Haskell.hs @@ -0,0 +1,116 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE OverloadedStrings #-} +-- | Wrappers for generating prologue and epilogue code in Haskell. +module Data.Aeson.AutoType.CodeGen.Haskell( + writeHaskellModule + , runHaskellModule + , runHaskellModuleStrict + , defaultHaskellFilename + ) where + +import qualified Data.Text as Text +import qualified Data.Text.IO as Text +import Data.Text hiding (unwords) +import qualified Data.HashMap.Strict as Map +import Control.Arrow (first) +import Control.Exception (assert) +import Data.Monoid ((<>)) +import System.FilePath +import System.IO +import System.Process (system) +import qualified System.Environment (lookupEnv) +import System.Exit (ExitCode) + +import Data.Aeson.AutoType.Format +import Data.Aeson.AutoType.Type +import Data.Aeson.AutoType.CodeGen.Generic(src) +import Data.Aeson.AutoType.CodeGen.HaskellFormat +import Data.Aeson.AutoType.Util + +-- | Default output filname is used, when there is no explicit output file path, or it is "-" (stdout). +-- Default module name is consistent with it. +defaultHaskellFilename :: FilePath +defaultHaskellFilename = "JSONTypes.hs" + +header :: Text -> Text +header moduleName = [src| +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE DeriveGeneric #-} + +module |] <> capitalize moduleName <> [src| where + +import System.Exit (exitFailure, exitSuccess) +import System.IO (stderr, hPutStrLn) +import qualified Data.ByteString.Lazy.Char8 as BSL +import System.Environment (getArgs) +import Control.Monad (forM_, mzero, join) +import Control.Applicative +import Data.Aeson.AutoType.Alternative +import Data.Aeson(eitherDecode, Value(..), FromJSON(..), ToJSON(..), + pairs, + (.:), (.:?), (.=), object) +import Data.Monoid((<>)) +import Data.Text (Text) +import qualified GHC.Generics +|] + +epilogue :: Text -> Text +epilogue toplevelName = [src| +parse :: FilePath -> IO |] <> toplevelName <> [src| +parse filename = do + input <- BSL.readFile filename + case eitherDecode input of + Left err -> fatal $ case (eitherDecode input :: Either String Value) of + Left err -> "Invalid JSON file: " ++ filename ++ " ++ err" + Right _ -> "Mismatched JSON value from file: " ++ filename + ++ "\n" ++ err + Right r -> return (r :: |] <> toplevelName <> ")" <> [src| + where + fatal :: String -> IO a + fatal msg = do hPutStrLn stderr msg + exitFailure + +main :: IO () +main = do + filenames <- getArgs + forM_ filenames (\f -> parse f >>= (\p -> p `seq` putStrLn $ "Successfully parsed " ++ f)) + exitSuccess +|] + +-- | Write a Haskell module to an output file, or stdout if `-` filename is given. +writeHaskellModule :: FilePath -> Text -> Map.HashMap Text Type -> IO () +writeHaskellModule outputFilename toplevelName types = + withFileOrHandle outputFilename WriteMode stdout $ \hOut -> + assert (extension == ".hs") $ do + Text.hPutStrLn hOut $ header $ Text.pack moduleName + -- We write types as Haskell type declarations to output handle + Text.hPutStrLn hOut $ displaySplitTypes types + Text.hPutStrLn hOut $ epilogue toplevelName + where + (moduleName, extension) = + first normalizeTypeName' $ + splitExtension $ + if outputFilename == "-" + then defaultHaskellFilename + else outputFilename + normalizeTypeName' = Text.unpack . normalizeTypeName . Text.pack + +runHaskellModule :: [String] -> IO ExitCode +runHaskellModule arguments = do + maybeStack <- System.Environment.lookupEnv "STACK_EXEC" + maybeCabal <- System.Environment.lookupEnv "CABAL_SANDBOX_CONFIG" + let execPrefix | Just stackExec <- maybeStack = [stackExec, "runghc"] + | Just _ <- maybeCabal = ["cabal", "exec", "runghc"] + | otherwise = ["runghc"] + putStrLn $ "Running Haskell module: " ++ show execPrefix ++ show arguments + system $ Prelude.unwords $ execPrefix ++ arguments +-- Add: -i`stack path --dist-dir`/build/autogen +runHaskellModuleStrict :: [String] -> IO ExitCode +runHaskellModuleStrict = runHaskellModule . ("-Wall":) . ("-Werror":) + diff --git a/src/Data/Aeson/AutoType/CodeGen/HaskellFormat.hs b/src/Data/Aeson/AutoType/CodeGen/HaskellFormat.hs new file mode 100644 --- /dev/null +++ b/src/Data/Aeson/AutoType/CodeGen/HaskellFormat.hs @@ -0,0 +1,284 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGuaGE ScopedTypeVariables #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGuaGE DeriveGeneric #-} +{-# LANGuaGE FlexibleContexts #-} +-- | Formatting type declarations and class instances for inferred types. +module Data.Aeson.AutoType.CodeGen.HaskellFormat( + displaySplitTypes, normalizeTypeName +) where + +import Control.Arrow ((&&&)) +import Control.Applicative ((<$>), (<*>)) +import Control.Lens.TH +import Control.Lens +import Control.Monad (forM) +import Control.Exception(assert) +import qualified Data.HashMap.Strict as Map +import Data.Monoid +import qualified Data.Set as Set +import qualified Data.Text as Text +import Data.Text (Text) +import Data.Set (Set ) +import Data.List (foldl1') +import Data.Char (isAlpha, isDigit) +import Control.Monad.State.Class +import Control.Monad.State.Strict(State, runState) +import qualified Data.Graph as Graph +import GHC.Generics (Generic) + +import Data.Aeson.AutoType.Type +import Data.Aeson.AutoType.Extract +import Data.Aeson.AutoType.Format +import Data.Aeson.AutoType.Split (toposort) +import Data.Aeson.AutoType.Util () + +--import Debug.Trace -- DEBUG +trace _ x = x + +fst3 :: (t, t1, t2) -> t +fst3 (a, _b, _c) = a + +data DeclState = DeclState { _decls :: [Text] + , _counter :: Int + } + deriving (Eq, Show, Ord, Generic) + +makeLenses ''DeclState + +type DeclM = State DeclState + +type Map k v = Map.HashMap k v + +stepM :: DeclM Int +stepM = counter %%= (\i -> (i, i+1)) + +tShow :: (Show a) => a -> Text +tShow = Text.pack . show + +-- | Wrap a type alias. +wrapAlias :: Text -> Text -> Text +wrapAlias identifier contents = Text.unwords ["type", identifier, "=", contents] + +-- | Wrap a data type declaration +wrapDecl :: Text -> Text -> Text +wrapDecl identifier contents = Text.unlines [header, contents, " } deriving (Show,Eq,GHC.Generics.Generic)"] + --,"\nderiveJSON defaultOptions ''" `Text.append` identifier] + where + header = Text.concat ["data ", identifier, " = ", identifier, " { "] + +-- | Explanatory type alias for making declarations +-- First element of the triple is original JSON identifier, +-- second element of the triple is the mapped identifier name in Haskell. +-- third element of the triple shows the type in a formatted way +type MappedKey = (Text, Text, Text, Bool) + +-- | Make ToJSON declaration, given identifier (object name in Haskell) and mapping of its keys +-- from JSON to Haskell identifiers *in the same order* as in *data type declaration*. +makeFromJSON :: Text -> [MappedKey] -> Text +makeFromJSON identifier contents = + Text.unlines [ + Text.unwords ["instance FromJSON", identifier, "where"] + , Text.unwords [" parseJSON (Object v) =", makeParser identifier contents] + , " parseJSON _ = mzero" ] + where + makeParser identifier [] = Text.unwords ["return ", identifier] + makeParser identifier _ = Text.unwords [identifier, "<$>", inner] + inner = " <*> " `Text.intercalate` + map takeValue contents + takeValue (jsonId, _, ty, True ) = Text.concat ["v .:? \"", jsonId, "\""] -- nullable types + takeValue (jsonId, _, _ , False) = Text.concat ["v .: \"", jsonId, "\""] +-- Contents example for wrapFromJSON: +-- " <$> +--" v .: "hexValue" <*> +--" v .: "colorName\"" + +-- | Make ToJSON declaration, given identifier (object name in Haskell) and mapping of its keys +-- from JSON to Haskell identifiers in the same order as in declaration +makeToJSON :: Text -> [MappedKey] -> Text +makeToJSON identifier contents = + Text.unlines [ + Text.concat ["instance ToJSON ", identifier, " where"] + , Text.concat [" toJSON (", identifier, " {", wildcard, "}) = object [", inner ", ", "]"] + , maybeToEncoding + ] + where + maybeToEncoding | null contents = "" + | otherwise = + Text.concat [" toEncoding (", identifier, " {", wildcard, "}) = pairs (", inner "<>", ")"] + wildcard | null contents = "" + | otherwise = ".." + inner separator = separator `Text.intercalate` + map putValue contents + putValue (jsonId, haskellId, _typeText, _nullable) = Text.unwords [escapeText jsonId, ".=", haskellId] + escapeText = Text.pack . show . Text.unpack +-- Contents example for wrapToJSON +--"hexValue" .= hexValue +-- ,"colorName" .= colorName] + + +-- | Makes a generic identifier name. +genericIdentifier :: DeclM Text +genericIdentifier = do + i <- stepM + return $! "Obj" `Text.append` tShow i + +-- * Printing a single data type declaration +newDecl :: Text -> [(Text, Type)] -> DeclM Text +newDecl identifier kvs = do attrs <- forM kvs $ \(k, v) -> do + formatted <- formatType v + return (k, normalizeFieldName identifier k, formatted, isNullable v) + let decl = Text.unlines [wrapDecl identifier $ fieldDecls attrs + ,"" + ,makeFromJSON identifier attrs + ,"" + ,makeToJSON identifier attrs] + addDecl decl + return identifier + where + fieldDecls attrList = Text.intercalate ",\n" $ map fieldDecl attrList + fieldDecl :: (Text, Text, Text, Bool) -> Text + fieldDecl (_jsonName, haskellName, fType, _nullable) = Text.concat [ + " ", haskellName, " :: ", fType] + +addDecl decl = decls %%= (\ds -> ((), decl:ds)) + +-- | Add new type alias for Array type +newAlias :: Text -> Type -> DeclM Text +newAlias identifier content = do formatted <- formatType content + addDecl $ Text.unlines [wrapAlias identifier formatted] + return identifier + +-- | Convert a JSON key name given by second argument, +-- from within a dictionary keyed with first argument, +-- into a name of Haskell record field (hopefully distinct from other such selectors.) +normalizeFieldName :: Text -> Text -> Text +normalizeFieldName identifier = escapeKeywords . + uncapitalize . + (normalizeTypeName identifier `Text.append`) . + normalizeTypeName + +keywords :: Set Text +keywords = Set.fromList ["type", "data", "module", "class", "where", "let", "do"] + +escapeKeywords :: Text -> Text +escapeKeywords k | k `Set.member` keywords = k `Text.append` "_" +escapeKeywords k = k + +-- | Format the type within DeclM monad, that records +-- the separate declarations on which this one is dependent. +formatType :: Type -> DeclM Text +formatType TString = return "Text" +formatType TInt = return "Int" +formatType TDouble = return "Double" +formatType TBool = return "Bool" +formatType (TLabel l) = return $ normalizeTypeName l +formatType (TUnion u) = wrap <$> case length nonNull of + 0 -> return emptyTypeRepr + 1 -> formatType $ head nonNull + _ -> Text.intercalate ":|:" <$> mapM formatType nonNull + where + nonNull = Set.toList $ Set.filter (TNull /=) u + wrap :: Text -> Text + wrap inner | TNull `Set.member` u = Text.concat ["(Maybe (", inner, "))"] + | otherwise = inner +formatType (TArray a) = do inner <- formatType a + return $ Text.concat ["[", inner, "]"] +formatType (TObj o) = do ident <- genericIdentifier + newDecl ident d + where + d = Map.toList $ unDict o +formatType e | e `Set.member` emptySetLikes = return emptyTypeRepr +formatType t = return $ "ERROR: Don't know how to handle: " `Text.append` tShow t + +emptyTypeRepr :: Text +emptyTypeRepr = "(Maybe Value)" -- default, accepts future extension where we found no data + +runDecl :: DeclM a -> Text +runDecl decl = Text.unlines $ finalState ^. decls + where + initialState = DeclState [] 1 + (_, finalState) = runState decl initialState + +-- * Splitting object types by label for unification. +type TypeTree = Map Text [Type] + +type TypeTreeM a = State TypeTree a + +addType :: Text -> Type -> TypeTreeM () +addType label typ = modify $ Map.insertWith (++) label [typ] + +splitTypeByLabel' :: Text -> Type -> TypeTreeM Type +splitTypeByLabel' _ TString = return TString +splitTypeByLabel' _ TInt = return TInt +splitTypeByLabel' _ TDouble = return TDouble +splitTypeByLabel' _ TBool = return TBool +splitTypeByLabel' _ TNull = return TNull +splitTypeByLabel' _ (TLabel r) = assert False $ return $ TLabel r -- unnecessary? +splitTypeByLabel' l (TUnion u) = do m <- mapM (splitTypeByLabel' l) $ Set.toList u + return $! TUnion $! Set.fromList m +splitTypeByLabel' l (TArray a) = do m <- splitTypeByLabel' (l `Text.append` "Elt") a + return $! TArray m +splitTypeByLabel' l (TObj o) = do kvs <- forM (Map.toList $ unDict o) $ \(k, v) -> do + component <- splitTypeByLabel' k v + return (k, component) + addType l (TObj $ Dict $ Map.fromList kvs) + return $! TLabel l + +-- | Splits initial type with a given label, into a mapping of object type names and object type structures. +splitTypeByLabel :: Text -> Type -> Map Text Type +splitTypeByLabel topLabel t = Map.map (foldl1' unifyTypes) finalState + where + finalize (TLabel l) = assert (l == topLabel) $ return () + finalize topLevel = addType topLabel topLevel + initialState = Map.empty + (_, finalState) = runState (splitTypeByLabel' topLabel t >>= finalize) initialState + +formatObjectType :: Text -> Type -> DeclM Text +formatObjectType identifier (TObj o) = newDecl identifier d + where + d = Map.toList $ unDict o +formatObjectType identifier other = newAlias identifier other + +-- | Display an environment of types split by name. +displaySplitTypes :: Map Text Type -> Text +displaySplitTypes dict = trace ("displaySplitTypes: " ++ show (toposort dict)) $ runDecl declarations + where + declarations = + forM (toposort dict) $ \(name, typ) -> + formatObjectType (normalizeTypeName name) typ + +-- | Normalize type name by: +-- 1. Treating all characters that are not acceptable in Haskell variable name as end of word. +-- 2. Capitalizing each word, but a first (camelCase). +-- 3. Adding underscore if first character is non-alphabetic. +-- 4. Escaping Haskell keywords if the whole identifier is such keyword. +-- 5. If identifier is empty, then substituting "JsonEmptyKey" for its name. +normalizeTypeName :: Text -> Text +normalizeTypeName = ifEmpty "JsonEmptyKey" . + escapeKeywords . + escapeFirstNonAlpha . + Text.concat . + map capitalize . + filter (not . Text.null) . + Text.split (not . acceptableInVariable) + where + ifEmpty x "" = x + ifEmpty _ nonEmpty = nonEmpty + acceptableInVariable c = isAlpha c || isDigit c + escapeFirstNonAlpha cs | Text.null cs = cs + escapeFirstNonAlpha cs@(Text.head -> c) | isAlpha c = cs + escapeFirstNonAlpha cs = "_" `Text.append` cs + +-- | Computes all type labels referenced by a given type. +allLabels :: Type -> [Text] +allLabels = flip go [] + where + go (TLabel l) ls = l:ls + go (TArray t) ls = go t ls + go (TUnion u) ls = Set.foldr go ls u + go (TObj o) ls = Map.foldr go ls $ unDict o + go _other ls = ls + diff --git a/src/Data/Aeson/AutoType/Extract.hs b/src/Data/Aeson/AutoType/Extract.hs new file mode 100644 --- /dev/null +++ b/src/Data/Aeson/AutoType/Extract.hs @@ -0,0 +1,164 @@ +-- | Extraction and unification of AutoType's @Type@ from Aeson @Value@. +module Data.Aeson.AutoType.Extract(valueSize, valueTypeSize, + valueDepth, Dict(..), + Type(..), emptyType, + extractType, unifyTypes, + typeCheck) where + +import Control.Arrow ((&&&)) +import Control.Exception (assert) +import Data.Aeson.AutoType.Type +import qualified Data.Graph as Graph +import qualified Data.HashMap.Strict as Map +import Data.HashMap.Strict (HashMap) +import qualified Data.Set as Set +import qualified Data.Vector as V +import Data.Aeson +import Data.Text (Text) +import Data.Set (Set ) +import Data.List (foldl1') +import Data.Scientific (isInteger) + +--import Debug.Trace + +-- | Compute total number of nodes (and leaves) within the value tree. +-- Each simple JavaScript type (including String) is counted as of size 1, +-- whereas both Array or object types are counted as 1+sum of the sizes +-- of their member values. +valueSize :: Value -> Int +valueSize Null = 1 +valueSize (Bool _) = 1 +valueSize (Number _) = 1 +valueSize (String _) = 1 +valueSize (Array a) = V.foldl' (+) 1 $ V.map valueSize a +valueSize (Object o) = (1+) . sum . map valueSize . Map.elems $ o + +-- | Compute total size of the type of the @Value@. +-- For: +-- * simple types it is always 1, +-- * for arrays it is just 1+_maximum_ size of the (single) element type, +-- * for objects it is _sum_ of the sizes of fields (since each field type +-- is assumed to be different.) +valueTypeSize :: Value -> Int +valueTypeSize Null = 1 +valueTypeSize (Bool _) = 1 +valueTypeSize (Number _) = 1 +valueTypeSize (String _) = 1 +valueTypeSize (Array a) = (1+) . V.foldl' max 0 $ V.map valueTypeSize a +valueTypeSize (Object o) = (1+) . sum . map valueTypeSize . Map.elems $ o + +-- | Compute total depth of the value. +-- For: +-- * simple types it is 1 +-- * for either Array or Object, it is 1 + maximum of depths of their members +valueDepth :: Value -> Int +valueDepth Null = 1 +valueDepth (Bool _) = 1 +valueDepth (Number _) = 1 +valueDepth (String _) = 1 +valueDepth (Array a) = (1+) . V.foldl' max 0 $ V.map valueDepth a +valueDepth (Object o) = (1+) . maximum . (0:) . map valueDepth . Map.elems $ o + +-- | Check if a number is integral, or floating point +-- | Extract @Type@ from the JSON @Value@. +-- Unifying types of array elements, if necessary. +extractType :: Value -> Type +extractType (Object o) = TObj $ Dict $ Map.map extractType o +extractType Null = TNull +extractType (Bool _) = TBool +extractType (Number n) | isInteger n = TInt +extractType (Number _) = TDouble +extractType (String _) = TString +extractType (Array a) | V.null a = TArray emptyType +extractType (Array a) = TArray $ V.foldl1' unifyTypes $ traceShow $ V.map extractType a + where + --traceShow a = trace (show a) a + traceShow = id + +-- | Type check the value with the derived type. +typeCheck :: Value -> Type -> Bool +typeCheck Null TNull = True +typeCheck v (TUnion u) = typeCheck v `any` Set.toList u +typeCheck (Bool _) TBool = True +typeCheck (String _) TString = True +typeCheck (Number n) TInt = isInteger n +typeCheck (Number _) TDouble = True +typeCheck (Array elts) (TArray eltType) = (`typeCheck` eltType) `all` V.toList elts +typeCheck (Object d) (TObj e ) = typeCheckKey `all` keysOfBoth + where + typeCheckKey k = getValue k d `typeCheck` get k e + getValue :: Text -> HashMap Text Value -> Value + getValue = Map.lookupDefault Null + keysOfBoth :: [Text] + keysOfBoth = Set.toList $ Set.fromList (Map.keys d) `Set.union` keys e +typeCheck _ (TLabel _ ) = error "Cannot typecheck labels without environment!" +typeCheck {-a-} _ _ {-b-} = {-trace msg $-} False + where + -- msg = "Mismatch: " ++ show a ++ " :: " ++ show b + +allKeys :: Dict -> Dict -> [Text] +d `allKeys` e = Set.toList (keys d `Set.union` keys e) + +-- | Standard unification procedure on @Type@s, +-- with inclusion of @Type@ unions. +unifyTypes :: Type -> Type -> Type +unifyTypes TBool TBool = TBool +unifyTypes TInt TInt = TInt +unifyTypes TDouble TInt = TDouble +unifyTypes TInt TDouble = TDouble +unifyTypes TDouble TDouble = TDouble +unifyTypes TString TString = TString +unifyTypes TNull TNull = TNull +unifyTypes (TObj d) (TObj e) = TObj newDict + where + newDict :: Dict + newDict = Dict $ Map.fromList [(k, get k d `unifyTypes` + get k e) | k <- allKeys d e ] +unifyTypes (TArray u) (TArray v) = TArray $ u `unifyTypes` v +unifyTypes t s = typeAsSet t `unifyUnion` typeAsSet s + +-- | Unify sets of types (sets are union types of alternatives). +unifyUnion :: Set Type -> Set Type -> Type +unifyUnion u v = assertions $ + union $ uSimple `Set.union` + vSimple `Set.union` + unifiedObjects `Set.union` + Set.singleton unifiedArray + where + -- We partition our types for easier unification into simple and compound + (uSimple, uCompound) = Set.partition isSimple u + (vSimple, vCompound) = Set.partition isSimple v + assertions = assert (Set.null $ Set.filter (not . isArray) uArr) . + assert (Set.null $ Set.filter (not . isArray) vArr) + -- then we partition compound typs into objects and arrays. + -- Note that there should be no TUnion here, since we are inside a TUnion already. + -- (That is reduced by @union@ smart costructor as superfluous.) + (uObj, uArr) = Set.partition isObject uCompound + (vObj, vArr) = Set.partition isObject vCompound + unifiedObjects = Set.fromList $ if null objects + then [] + else [foldl1' unifyTypes objects] + objects = Set.toList $ uObj `Set.union` vObj + arrayElts :: [Type] + arrayElts = map (\(TArray ty) -> ty) $ + Set.toList $ + uArr `Set.union` vArr + unifiedArray = TArray $ if null arrayElts + then emptyType + else foldl1' unifyTypes arrayElts + +-- | Smart constructor for union types. +union :: Set Type -> Type +union = simplifyUnion . TUnion + +-- | Simplify TUnion's so there is no TUnion directly inside TUnion. +-- If there is only one element of the set, then return this single +-- element as a type. +simplifyUnion :: Type -> Type +simplifyUnion (TUnion s) | Set.size s == 1 = head $ Set.toList s +simplifyUnion (TUnion s) = TUnion $ Set.unions $ map elements $ Set.toList s + where + elements (TUnion elems) = elems + elements sing = Set.singleton sing +simplifyUnion unexpected = error ("simplifyUnion: unexpected argument " ++ show unexpected) + diff --git a/src/Data/Aeson/AutoType/Format.hs b/src/Data/Aeson/AutoType/Format.hs new file mode 100644 --- /dev/null +++ b/src/Data/Aeson/AutoType/Format.hs @@ -0,0 +1,17 @@ +-- | Formatting tools for code generation. +module Data.Aeson.AutoType.Format(capitalize, uncapitalize) where + +import Data.Text(Text) +import qualified Data.Text as Text + +-- | Make the first letter of a Text upper case. +capitalize :: Text -> Text +capitalize word = Text.toUpper first `Text.append` rest + where + (first, rest) = Text.splitAt 1 word + +-- | Make the first letter of a Text lower case. +uncapitalize :: Text -> Text +uncapitalize word = Text.toLower first `Text.append` rest + where + (first, rest) = Text.splitAt 1 word diff --git a/src/Data/Aeson/AutoType/Pretty.hs b/src/Data/Aeson/AutoType/Pretty.hs new file mode 100644 --- /dev/null +++ b/src/Data/Aeson/AutoType/Pretty.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +-- | Instances of @Text.PrettyPrint.Out@ class to visualize +-- Aeson @Value@ data structure. +module Data.Aeson.AutoType.Pretty() where + +import qualified Data.HashMap.Strict as Hash +import Data.HashMap.Strict(HashMap) +import Data.Aeson +import qualified Data.Text as Text +import Data.Text (Text) +import Data.Set as Set(Set, toList) +import Data.Scientific +import Data.Vector as V(Vector, toList) +import Text.PrettyPrint.GenericPretty +import Text.PrettyPrint + +formatPair :: (Out a, Out b) => (a, b) -> Doc +formatPair (a, b) = nest 1 (doc a <+> ": " <+> doc b <+> ",") + +-- * This is to make prettyprinting possible for Aeson @Value@ type. +instance Out Scientific where + doc = doc . show + docPrec _ = doc + +instance (Out a) => Out (Vector a) where + doc (V.toList -> v) = "<" <+> doc v <+> ">" + docPrec _ = doc + +instance Out Value + +instance (Out a) => Out (Set a) where + doc (Set.toList -> s) = "{" <+> doc s <+> "}" + docPrec _ = doc + +instance (Out a, Out b) => Out (HashMap a b) where + doc (Hash.toList -> dict) = foldl ($$) "{" (map formatPair dict) $$ nest 1 "}" + docPrec _ = doc + +instance Out Text where + doc = text . Text.unpack -- TODO: check if there may be direct way? + docPrec _ = doc diff --git a/src/Data/Aeson/AutoType/Split.hs b/src/Data/Aeson/AutoType/Split.hs new file mode 100644 --- /dev/null +++ b/src/Data/Aeson/AutoType/Split.hs @@ -0,0 +1,144 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGuaGE ScopedTypeVariables #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGuaGE DeriveGeneric #-} +{-# LANGuaGE FlexibleContexts #-} +-- | Formatting type declarations and class instances for inferred types. +module Data.Aeson.AutoType.Split( + splitTypeByLabel, unificationCandidates, + unifyCandidates, toposort +) where + +import Control.Arrow ((&&&)) +import Control.Applicative ((<$>), (<*>)) +import Control.Lens.TH +import Control.Lens +import Control.Monad (forM) +import Control.Exception(assert) +import qualified Data.HashMap.Strict as Map +import Data.Monoid +import qualified Data.Set as Set +import qualified Data.Text as Text +import Data.Text (Text) +import Data.Set (Set ) +import Data.List (foldl1') +import Data.Char (isAlpha, isDigit) +import Control.Monad.State.Class +import Control.Monad.State.Strict(State, runState) +import qualified Data.Graph as Graph +import GHC.Generics (Generic) + +import Data.Aeson.AutoType.Type +import Data.Aeson.AutoType.Extract +import Data.Aeson.AutoType.Util () + +--import Debug.Trace -- DEBUG +trace _ x = x + +fst3 :: (t, t1, t2) -> t +fst3 (a, _b, _c) = a + +type Map k v = Map.HashMap k v + +-- | Explanatory type alias for making declarations +-- First element of the triple is original JSON identifier, +-- second element of the triple is the mapped identifier name in Haskell. +-- third element of the triple shows the type in a formatted way +type MappedKey = (Text, Text, Text, Bool) + +-- * Splitting object types by label for unification. +type TypeTree = Map Text [Type] + +type TypeTreeM a = State TypeTree a + +addType :: Text -> Type -> TypeTreeM () +addType label typ = modify $ Map.insertWith (++) label [typ] + +splitTypeByLabel' :: Text -> Type -> TypeTreeM Type +splitTypeByLabel' _ TString = return TString +splitTypeByLabel' _ TInt = return TInt +splitTypeByLabel' _ TDouble = return TDouble +splitTypeByLabel' _ TBool = return TBool +splitTypeByLabel' _ TNull = return TNull +splitTypeByLabel' _ (TLabel r) = assert False $ return $ TLabel r -- unnecessary? +splitTypeByLabel' l (TUnion u) = do m <- mapM (splitTypeByLabel' l) $ Set.toList u + return $! TUnion $! Set.fromList m +splitTypeByLabel' l (TArray a) = do m <- splitTypeByLabel' (l `Text.append` "Elt") a + return $! TArray m +splitTypeByLabel' l (TObj o) = do kvs <- forM (Map.toList $ unDict o) $ \(k, v) -> do + component <- splitTypeByLabel' k v + return (k, component) + addType l (TObj $ Dict $ Map.fromList kvs) + return $! TLabel l + +-- | Splits initial type with a given label, into a mapping of object type names and object type structures. +splitTypeByLabel :: Text -> Type -> Map Text Type +splitTypeByLabel topLabel t = Map.map (foldl1' unifyTypes) finalState + where + finalize (TLabel l) = assert (l == topLabel) $ return () + finalize topLevel = addType topLabel topLevel + initialState = Map.empty + (_, finalState) = runState (splitTypeByLabel' topLabel t >>= finalize) initialState + +-- | Topological sorting of splitted types so that it is accepted declaration order. +toposort :: Map Text Type -> [(Text, Type)] +toposort splitted = map ((id &&& (splitted Map.!)) . fst3 . graphKey) $ Graph.topSort graph + where + (graph, graphKey) = Graph.graphFromEdges' $ map makeEntry $ Map.toList splitted + makeEntry (k, v) = (k, k, allLabels v) + +-- | Computes all type labels referenced by a given type. +allLabels :: Type -> [Text] +allLabels = flip go [] + where + go (TLabel l) ls = l:ls + go (TArray t) ls = go t ls + go (TUnion u) ls = Set.foldr go ls u + go (TObj o) ls = Map.foldr go ls $ unDict o + go _other ls = ls + +-- * Finding candidates for extra unifications +-- | For a given splitted types, it returns candidates for extra +-- unifications. +unificationCandidates :: Map.HashMap t Type -> [[t]] +unificationCandidates = Map.elems . + Map.filter candidates . + Map.fromListWith (++) . + concatMap entry . + Map.toList + where + -- | Candidate entry has to have at least two candidates, so that unification makes sense + candidates [ ] = False + candidates [_] = False + candidates _ = True + -- | Make a candidate entry for each object type, which points from its keys to its label. + entry (k, TObj o) = [(Set.fromList $ Map.keys $ unDict o, [k])] + entry _ = [] -- ignore array elements and toplevel type if it is Array + +-- | Unifies candidates on a give input list. +unifyCandidates :: [[Text]] -> Map Text Type -> Map Text Type +unifyCandidates candidates splitted = Map.map (remapLabels labelMapping) $ replacements splitted + where + unifiedType :: [Text] -> Type + unifiedType cset = foldr1 unifyTypes $ + map (splitted Map.!) cset + replace :: [Text] -> Map Text Type -> Map Text Type + replace cset@(c:_) s = Map.insert c (unifiedType cset) (foldr Map.delete s cset) + replace [] _ = error "Empty candidate set in replace" + replacements :: Map Text Type -> Map Text Type + replacements s = foldr replace s candidates + labelMapping :: Map Text Text + labelMapping = Map.fromList $ concatMap mapEntry candidates + mapEntry cset@(c:_) = [(x, c) | x <- cset] + mapEntry [] = error "Empty candidate set in mapEntry" + +-- | Remaps type labels according to a `Map`. +remapLabels :: Map Text Text -> Type -> Type +remapLabels ls (TObj o) = TObj $ Dict $ Map.map (remapLabels ls) $ unDict o +remapLabels ls (TArray t) = TArray $ remapLabels ls t +remapLabels ls (TUnion u) = TUnion $ Set.map (remapLabels ls) u +remapLabels ls (TLabel l) = TLabel $ Map.lookupDefault l l ls +remapLabels _ other = other + diff --git a/src/Data/Aeson/AutoType/Test.hs b/src/Data/Aeson/AutoType/Test.hs new file mode 100644 --- /dev/null +++ b/src/Data/Aeson/AutoType/Test.hs @@ -0,0 +1,92 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +-- | Arbitrary instances for the JSON @Value@. +module Data.Aeson.AutoType.Test ( + arbitraryTopValue + ) where + +import Data.Aeson.AutoType.Pretty () -- Generic instance for Value + +import Control.Applicative ((<$>), (<*>)) +import Data.Aeson +import Data.Function (on) +import Data.Hashable (Hashable) +import Data.Generics.Uniplate.Data +import Data.List +import Data.Scientific +import qualified Data.Text as Text +import Data.Text (Text) +import qualified Data.Vector as V +import qualified Data.HashMap.Strict as Map +import GHC.Generics + +import Test.QuickCheck.Arbitrary +import Test.QuickCheck +import Test.SmallCheck.Series + +instance Arbitrary Text where + arbitrary = Text.pack <$> sized (`vectorOf` alphabetic) + where + alphabetic = choose ('a', 'z') + +instance (Arbitrary a) => Arbitrary (V.Vector a) where + arbitrary = V.fromList <$> arbitrary + +instance (Arbitrary v) => Arbitrary (Map.HashMap Text v) where + arbitrary = makeMap <$> arbitrary + +-- | Helper function for generating Arbitrary and Series instances +-- for @Data.HashMap.Strict.Map@ from lists of pairs. +makeMap :: (Ord a, Hashable a) =>[(a, b)] -> Map.HashMap a b +makeMap = Map.fromList + . nubBy ((==) `on` fst) + . sortBy (compare `on` fst) + +instance Arbitrary Scientific where + arbitrary = scientific <$> arbitrary <*> arbitrary + +-- TODO: top value has to be complex: Object or Array +-- TODO: how to accumulate cost when generating the series? +instance Arbitrary Value where + arbitrary = sized arb + where + arb n | n < 0 = error "Negative size!" + arb 0 = return Null + arb 1 = oneof simpleGens + arb i = oneof $ complexGens (i - 1) ++ simpleGens + simpleGens = [Number <$> arbitrary + ,Bool <$> arbitrary + ,String <$> arbitrary] + shrink = concatMap simpleShrink + . universe + +-- | Transformation to shrink top level of @Value@, doesn't consider nested sub-@Value@s. +simpleShrink :: Value -> [Value] +simpleShrink (Array a) = map (Array . V.fromList) $ shrink $ V.toList a +simpleShrink (Object o) = map (Object . Map.fromList) $ shrink $ Map.toList o +simpleShrink _ = [] -- Nothing for simple objects + +-- | Generator for compound @Value@s +complexGens :: Int -> [Gen Value] +complexGens i = [Object . Map.fromList <$> resize i arbitrary, + Array <$> resize i arbitrary] + +-- | Arbitrary JSON (must start with Object or Array.) +arbitraryTopValue :: Gen Value +arbitraryTopValue = sized $ oneof . complexGens + +-- * SmallCheck Serial instances +instance Monad m => Serial m Text where + series = newtypeCons Text.pack + +instance Monad m => Serial m Scientific where + series = cons2 scientific + +instance Serial m a => Serial m (V.Vector a) where + series = newtypeCons V.fromList + +instance Serial m v => Serial m (Map.HashMap Text v) where + series = newtypeCons makeMap + +-- This one is generated with Generics and instances above +instance Monad m => Serial m Value diff --git a/src/Data/Aeson/AutoType/Type.hs b/src/Data/Aeson/AutoType/Type.hs new file mode 100644 --- /dev/null +++ b/src/Data/Aeson/AutoType/Type.hs @@ -0,0 +1,157 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +-- | Union types describing JSON objects, and operations for querying these types. +module Data.Aeson.AutoType.Type(typeSize, + Dict(..), keys, get, withDict, + Type(..), emptyType, + isSimple, isArray, isObject, typeAsSet, + hasNonTopTObj, + hasTObj, + isNullable, + emptySetLikes + ) where + +import Prelude hiding (any) +import qualified Data.HashMap.Strict as Hash +import qualified Data.Set as Set +import Data.Data (Data(..)) +import Data.Typeable (Typeable) +import Data.Foldable (any) +import Data.Text (Text) +import Data.Set (Set ) +import Data.HashMap.Strict(HashMap) +import Data.List (sort) +import Data.Ord (comparing) +import Data.Generics.Uniplate +import Text.PrettyPrint.GenericPretty + +import Data.Aeson.AutoType.Pretty () + +-- * Dictionary types for overloading of usual class instances. +-- | Type alias for HashMap +type Map = HashMap + +-- | Dictionary of types indexed by names. +newtype Dict = Dict { unDict :: Map Text Type } + deriving (Eq, Data, Typeable, Generic) + +instance Out Dict where + doc = doc . unDict + docPrec p = docPrec p . unDict + +instance Show Dict where + show = show . sort . Hash.toList . unDict + +instance Ord Dict where + compare = comparing $ sort . Hash.toList . unDict + +-- | Make operation on a map to an operation on a Dict. +withDict :: (Map Text Type -> Map Text Type) -> Dict -> Dict +f `withDict` (Dict m) = Dict $ f m + +-- | Take all keys from dictionary. +keys :: Dict -> Set Text +keys = Set.fromList . Hash.keys . unDict + +-- | Union types for JSON values. +data Type = TNull | TBool | TString | + TInt | TDouble | + TUnion (Set Type) | + TLabel Text | + TObj Dict | + TArray Type + deriving (Show,Eq, Ord, Data, Typeable, Generic) + +instance Out Type + +-- These are missing Uniplate instances... +{- +instance Biplate (Set a) a where + biplate s = (Set.toList s, Set.fromList) + +instance Biplate (HashMap k v) v where + biplate m = (Hash.elems m, Hash.fromList . zip (Hash.keys m)) + -} + +instance Uniplate Type where + uniplate (TUnion s) = (Set.toList s, TUnion . Set.fromList ) + uniplate (TObj d) = (Hash.elems m, TObj . Dict . Hash.fromList . zip (Hash.keys m)) + where + m = unDict d + uniplate (TArray t) = ([t], TArray . head ) + uniplate s = ([], const s ) + +-- | Empty type +emptyType :: Type +emptyType = TUnion Set.empty + +-- | Lookup the Type within the dictionary. +get :: Text -> Dict -> Type +get key = Hash.lookupDefault TNull key . unDict + +-- $derive makeUniplateDirect ''Type + +-- | Size of the `Type` term. +typeSize :: Type -> Int +typeSize TNull = 1 +typeSize TBool = 1 +typeSize TString = 1 +typeSize TInt = 1 +typeSize TDouble = 1 +typeSize (TObj o) = (1+) . sum . map typeSize . Hash.elems . unDict $ o +typeSize (TArray a) = 1 + typeSize a +typeSize (TUnion u) = (1+) . sum . (0:) . map typeSize . Set.toList $ u +typeSize (TLabel _) = error "Don't know how to compute typeSize of TLabel." + +-- | Check if this is nullable (Maybe) type, or not. +-- Nullable type will always accept TNull or missing key that contains it. +isNullable :: Type -> Bool +isNullable TNull = True +isNullable (TUnion u) = isNullable `any` u +isNullable _ = False + +-- | "Null-ish" types +emptySetLikes :: Set Type +emptySetLikes = Set.fromList [TNull, TArray $ TUnion $ Set.fromList []] +-- Q: and TObj $ Map.fromList []? +{-# INLINE emptySetLikes #-} + +-- | Convert any type into union type (even if just singleton). +typeAsSet :: Type -> Set Type +typeAsSet (TUnion s) = s +typeAsSet t = Set.singleton t + +-- | Is the top-level constructor a TObj? +isObject :: Type -> Bool +isObject (TObj _) = True +isObject _ = False + +-- | Is it a simple (non-compound) Type? +isSimple :: Type -> Bool +isSimple x = not (isObject x) && not (isArray x) && not (isUnion x) + +-- | Is the top-level constructor a TUnion? +isUnion :: Type -> Bool +isUnion (TUnion _) = True +isUnion _ = False + +-- | Is the top-level constructor a TArray? +-- | Check if the given type has non-top TObj. +isArray :: Type -> Bool +isArray (TArray _) = True +isArray _ = False + +-- | Check if the given type has non-top TObj. +hasNonTopTObj :: Type -> Bool +hasNonTopTObj (TObj o) = any hasTObj $ Hash.elems $ unDict o +hasNonTopTObj _ = False + +-- | Check if the given type has TObj on top or within array.. +hasTObj :: Type -> Bool +hasTObj (TObj _) = True +hasTObj (TArray a) = hasTObj a +hasTObj (TUnion u) = any hasTObj u +hasTObj _ = False diff --git a/src/Data/Aeson/AutoType/Util.hs b/src/Data/Aeson/AutoType/Util.hs new file mode 100644 --- /dev/null +++ b/src/Data/Aeson/AutoType/Util.hs @@ -0,0 +1,34 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +-- | Utility functions that may be ultimately moved to some library. +module Data.Aeson.AutoType.Util( withFileOrHandle + , withFileOrDefaultHandle + ) where + +import Data.Hashable +import qualified Data.Set as Set +import System.IO (withFile, IOMode(..), Handle, stdin, stdout) + +-- | Generic function for opening file if the filename is not empty nor "-", +-- or using given handle otherwise (probably stdout, stderr, or stdin). +-- TODO: Should it become utility function? +withFileOrHandle :: FilePath -> IOMode -> Handle -> (Handle -> IO r) -> IO r +withFileOrHandle "" _ handle action = action handle +withFileOrHandle "-" _ handle action = action handle +withFileOrHandle name ioMode _ action = withFile name ioMode action + +-- | Generic function for choosing either file with given name or stdin/stdout as input/output. +-- It accepts the function that takes the corresponding handle. +-- Stdin/stdout is selected by "-". +withFileOrDefaultHandle :: FilePath -> IOMode -> (Handle -> IO r) -> IO r +withFileOrDefaultHandle "-" ReadMode action = action stdin +withFileOrDefaultHandle "-" WriteMode action = action stdout +withFileOrDefaultHandle "-" otherMode _ = error $ "Incompatible io mode (" + ++ show otherMode + ++ ") for `-` in withFileOrDefaultHandle." +withFileOrDefaultHandle filename ioMode action = withFile filename ioMode action + +-- Missing instances +instance Hashable a => Hashable (Set.Set a) where + hashWithSalt = Set.foldr (flip hashWithSalt) + diff --git a/test/GenerateTestJSON.hs b/test/GenerateTestJSON.hs new file mode 100644 --- /dev/null +++ b/test/GenerateTestJSON.hs @@ -0,0 +1,191 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Main where + +import Control.Applicative +import Control.Monad.State as State +import Data.Maybe +import System.Exit +import System.IO (stdin, stderr, stdout, IOMode(..)) +import System.FilePath (splitExtension, (<.>), ()) +import System.Directory (removeFile, createDirectoryIfMissing) +import System.Process (system) +import Control.Monad (forM_, forM, when) +import Control.Exception (assert) +import qualified Data.ByteString.Lazy.Char8 as BSL +import qualified Data.HashMap.Strict as Map +import qualified Data.Set as Set +import Data.Monoid ((<>)) +import Data.Aeson (Value(..), eitherDecode, encode, FromJSON(..), ToJSON(..)) +import Data.Function (on) +import Data.List +import qualified Data.Text as Text +import qualified Data.Text.IO as Text +import Data.Text (Text) +import qualified Data.Vector as V +import Data.Scientific (scientific, Scientific) +import Text.PrettyPrint.GenericPretty (pretty) +import Test.QuickCheck + +import Data.Aeson.AutoType.CodeGen(writeModule, runModule, Lang(..)) +import Data.Aeson.AutoType.Extract +import Data.Aeson.AutoType.Format +import Data.Aeson.AutoType.Pretty +import Data.Aeson.AutoType.Split +import Data.Aeson.AutoType.Test +import Data.Aeson.AutoType.Type +import Data.Aeson.AutoType.Util +import Options.Applicative + +import CommonCLI + +data Options = Options { + tyOpts :: TypeOpts + , keep :: Bool + , stem :: FilePath + , count :: Int + , size :: Int + } + +optParser :: Parser Options +optParser = + Options <$> tyOptParser + <*> switch (long "keep" <> help "Also keep successful tests" ) + <*> strOption (long "stem" <> value "Test" <> help "Output filename stem" ) + <*> intOpt (long "count" <> value 100 <> help "Number of tests to perform" ) + <*> intOpt (long "size" <> value 10 <> help "size of generated test cases") + -- <*> some (argument str (metavar "FILES...")) + where + intOpt = option auto + +-- | Report an error to error output. +report :: Text -> IO () +report = Text.hPutStrLn stderr + +-- | Report an error and terminate the program. +fatal :: Text -> IO () +fatal msg = do report msg + exitFailure + +-- | Read JSON and extract @Type@ information from it. +extractTypeFromJSONFile :: (String -> IO ()) -> FilePath -> IO (Maybe Type) +extractTypeFromJSONFile myTrace inputFilename = + withFileOrHandle inputFilename ReadMode stdin $ \hIn -> + -- First we decode JSON input into Aeson's Value type + do bs <- BSL.hGetContents hIn + Text.hPutStrLn stderr $ "Processing " `Text.append` Text.pack (show inputFilename) + case eitherDecode bs of + Left err -> do + report $ Text.concat ["Cannot decode JSON input from " + ,Text.pack (show inputFilename) + ,"\n" + , Text.pack err] + return Nothing + Right v -> do -- If decoding JSON was successful... + -- We extract type structure from the JSON value. + let t = extractType v + --myTrace $ "Type: " ++ pretty t + return $ Just t + + +vectorWithoutDuplicates :: Ord b => Int -> Gen b -> Gen [b] +vectorWithoutDuplicates i gen = take i + . removeDuplicates + <$> infiniteListOf gen + +removeDuplicates :: Ord a => [a] -> [a] +removeDuplicates list = filterM checkDup list `evalState` Set.empty + where + checkDup x = do seen <- State.get + if x `Set.member` seen + then + return False + else do + State.put $ x `Set.insert` seen + return True + +-- TODO: check for generic Ord? +instance Ord Value where + Null `compare` Null = EQ + Null `compare` _ = LT + _ `compare` Null = GT + (Bool a) `compare` (Bool b) = a `compare` b + (Bool a) `compare` _ = LT + _ `compare` (Bool b) = GT + (Number a) `compare` (Number b) = a `compare` b + (Number _) `compare` _ = LT + _ `compare` (Number _) = GT + (String a) `compare` (String b) = a `compare` b + (String a) `compare` _ = LT + _ `compare` (String b) = GT + (Array a) `compare` (Array b) = a `compare` b + (Array a) `compare` _ = LT + _ `compare` (Array b) = GT + (Object a) `compare` (Object b) = Map.toList a `compare` Map.toList b + +-- | Take a set of JSON input filenames, Haskell output filename, and generate module parsing these JSON files. +generateTestJSONs :: Options -> IO () +generateTestJSONs Options {tyOpts=TyOptions {..}, + ..}= do + createDirectoryIfMissing True "output" + testValues :: [Value] <- generate $ + resize size $ + vectorWithoutDuplicates 100 arbitraryTopValue + results <- forM (zip3 inputFilenames outputFilenames testValues) $ + \(inputFilename, outputFilename, jsonValue) -> do + BSL.writeFile inputFilename $ encode jsonValue + -- Read type from each file + typeForEachFile <- catMaybes <$> mapM (extractTypeFromJSONFile myTrace) [inputFilename] + -- Unify all input types + when (null typeForEachFile) $ do + report "No valid JSON input file..." + exitFailure + let finalType = foldr1 unifyTypes typeForEachFile + -- We split different dictionary labels to become different type trees (and thus different declarations.) + let splitted = splitTypeByLabel toplevelName finalType + --myTrace $ "SPLITTED: " ++ pretty splitted + assert (not $ any hasNonTopTObj $ Map.elems splitted) $ do + -- We compute which type labels are candidates for unification + let uCands = unificationCandidates splitted + myTrace $ "CANDIDATES:\n" ++ pretty uCands + when suggest $ forM_ uCands $ \cs -> do + putStr "-- " + Text.putStrLn $ "=" `Text.intercalate` cs + -- We unify the all candidates or only those that have been given as command-line flags. + let unified = if autounify + then unifyCandidates uCands splitted + else splitted + myTrace $ "UNIFIED:\n" ++ pretty unified + -- We start by writing module header + writeModule lang outputFilename toplevelName unified + if test + then do + r <- (==ExitSuccess) <$> runModule lang [outputFilename, inputFilename] + when r $ mapM_ removeFile [inputFilename, outputFilename] + return r + else + return True + putStrLn $ "Successfully generated " ++ show (length results) ++ + " JSON files, out of planned " ++ show count ++ " cases." + where + makeInputFilename = (<.>".json") . (stem ++) . show + makeOutputFilename = ("output") . (<.>".hs") . (stem ++) . show + inputFilenames = map makeInputFilename [1..count] + outputFilenames = map makeOutputFilename [1..count] + myTrace :: String -> IO () + myTrace msg = debug `when` putStrLn msg + toplevelName = capitalize $ Text.pack toplevel + +main :: IO () +main = do opts <- execParser optInfo + generateTestJSONs opts + where + optInfo = info (optParser <**> helper) + ( fullDesc + <> progDesc "Generate a number of JSON test files, and generate type and parser for each." + <> header "Self-test for json-autotype" ) diff --git a/test/TestExamples.hs b/test/TestExamples.hs --- a/test/TestExamples.hs +++ b/test/TestExamples.hs @@ -1,21 +1,22 @@ -- Test over all files in examples/ directory module Main(main) where -import Control.Monad(forM, forM_, unless) +import Control.Monad(forM, forM_, unless, join) import Data.Char(toUpper) import Data.Functor ((<$>)) import Data.List(isPrefixOf, isSuffixOf) -import System.Directory(doesDirectoryExist, getDirectoryContents) +import System.Directory(doesDirectoryExist, getDirectoryContents, createDirectoryIfMissing) import System.FilePath((), (<.>), takeBaseName, replaceFileName) import System.Exit(ExitCode(..)) +import System.Environment as Env +import System.Process (rawSystem) import Data.Aeson.AutoType.CodeGen(runModule, Lang(Haskell)) +import Data.Aeson ( Result, Object, FromJSON, Value(Null,Number), (.:?) ) +import Data.Aeson.Types ( Parser, parse ) +import Data.Text ( Text, pack ) +import Data.HashMap.Lazy ( singleton, empty ) ---import CommonCLI -runghc :: [String] -> IO ExitCode -runghc = runModule Haskell --- runModule HaskellStrict -- for compiling with -Wall -Werror - -- | getRecursiveContents :: FilePath -> IO [FilePath] getRecursiveContents topdir = do @@ -39,13 +40,44 @@ main :: IO () main = do + verifyAesonOperators filenames <- filter (isSuffixOf ".json") <$> getRecursiveContents "examples" + createDirectoryIfMissing True "output" forM_ filenames $ \filename -> do - let outputFilename = filename `replaceFileName` capitalize (takeBaseName filename <.> "hs") - genResult <- runghc ["GenerateJSONParser.hs", filename, "--outputFilename", outputFilename] + let outputFilename = ("output" capitalize (takeBaseName filename <.> "hs")) + genResult <- runAutotype [filename, "--outputFilename", outputFilename] unless (genResult == ExitSuccess) $ fail (unwords ["test case", show filename, "failed with", show genResult]) - parserResult <- runghc [outputFilename, filename] + parserResult <- runModule Haskell [outputFilename, filename] + -- ^ runModule HaskellStrict -- for compiling with -Wall -Werror unless (parserResult == ExitSuccess) $ fail (unwords ["generated parser", show outputFilename, "failed with", show parserResult]) + +runAutotype :: [String] -> IO ExitCode +runAutotype arguments = do + stackEnv <- doesDirectoryExist ".stack-work" + cabalEnv <- doesDirectoryExist "dist/build/autogen" + maybeStack <- Env.lookupEnv "STACK_EXEC" + let (exec, args) | Just stackExec <- maybeStack = (stackExec, ["run","--" ]) + | stackEnv = ("stack", ["run","--" ]) + | cabalEnv = ("cabal", ["run","--" ]) + | otherwise = error "This test must be run either in Stack or Cabal environment." + putStrLn $ concat ["Running json-autotype with executable ", show exec, " and arguments ", show args] + rawSystem exec $ args ++ arguments + +verifyAesonOperators :: IO () +verifyAesonOperators = do + parseTest (singleton (pack "foo") (Number 1)) + parseTest (singleton (pack "foo") Null ) + parseTest (singleton (pack "bar") Null ) + parseTest empty + +(.:??) :: FromJSON a => Object -> Text -> Parser (Maybe a) +o .:?? val = fmap join (o .:? val) + +parseTest :: Object -> IO () +parseTest o = unless (r1 == r2) (fail (show r1 ++ " /= " ++ show r2)) + where r1, r2 :: Result (Maybe Int) + r1 = parse (.:? (pack "foo")) o + r2 = parse (.:?? (pack "foo")) o diff --git a/test/TestQC.hs b/test/TestQC.hs --- a/test/TestQC.hs +++ b/test/TestQC.hs @@ -10,6 +10,7 @@ import Data.Aeson.AutoType.Test() -- Arbitrary instance for Value import Test.QuickCheck +--import Test.QuickCheck.Parallel import Test.SmallCheck --import Test.QuickCheck.Arbitrary