mirror of
https://github.com/ChrisPenner/json-to-haskell.git
synced 2024-09-11 20:38:48 +03:00
Implement smart number choices
This commit is contained in:
parent
4c37119968
commit
b33bc96c1f
13
app/Main.hs
13
app/Main.hs
@ -4,14 +4,13 @@
|
||||
module Main where
|
||||
|
||||
import Lib
|
||||
import Data.Aeson
|
||||
import Data.Aeson.Lens
|
||||
import Control.Lens
|
||||
import Data.Aeson hiding (defaultOptions)
|
||||
import Text.RawString.QQ (r)
|
||||
import Data.Text.IO as T
|
||||
import Data.Maybe
|
||||
|
||||
value :: Value
|
||||
value = view (singular (_JSON @String)) ([r|
|
||||
value = fromJust $ decode ([r|
|
||||
{
|
||||
"name": "jon",
|
||||
"age and stuff": 37,
|
||||
@ -20,13 +19,17 @@ value = view (singular (_JSON @String)) ([r|
|
||||
"address": {
|
||||
"street": "221B",
|
||||
"zip": 12345
|
||||
},
|
||||
"other-address": {
|
||||
"street": "221B",
|
||||
"zip2": 12345
|
||||
}
|
||||
}
|
||||
|])
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
T.putStrLn $ json2Haskell value
|
||||
T.putStrLn $ json2Haskell defaultOptions value
|
||||
-- putStrLn "Type"
|
||||
-- print a
|
||||
-- putStrLn ""
|
||||
|
@ -4,7 +4,7 @@ cabal-version: 1.12
|
||||
--
|
||||
-- see: https://github.com/sol/hpack
|
||||
--
|
||||
-- hash: 36b548099e83be4bb322a676b0f7af2713cc18459aa04159116d9297909cb53f
|
||||
-- hash: a8efce442a08cf8de2c22bceef0e18575cb7244f03829948e3091318a34c9227
|
||||
|
||||
name: json-to-haskell
|
||||
version: 0.1.0.0
|
||||
@ -40,6 +40,7 @@ library
|
||||
, bytestring
|
||||
, casing
|
||||
, containers
|
||||
, microlens-platform
|
||||
, mtl
|
||||
, recursion-schemes
|
||||
, text
|
||||
@ -62,8 +63,7 @@ executable json-to-haskell-exe
|
||||
, casing
|
||||
, containers
|
||||
, json-to-haskell
|
||||
, lens
|
||||
, lens-aeson
|
||||
, microlens-platform
|
||||
, mtl
|
||||
, raw-strings-qq
|
||||
, recursion-schemes
|
||||
@ -89,6 +89,7 @@ test-suite json-to-haskell-test
|
||||
, containers
|
||||
, hspec
|
||||
, json-to-haskell
|
||||
, microlens-platform
|
||||
, mtl
|
||||
, recursion-schemes
|
||||
, text
|
||||
|
@ -31,6 +31,7 @@ dependencies:
|
||||
- mtl
|
||||
- bytestring
|
||||
- casing
|
||||
- microlens-platform
|
||||
|
||||
ghc-options:
|
||||
- -Wall
|
||||
@ -50,8 +51,6 @@ executables:
|
||||
- -with-rtsopts=-N
|
||||
dependencies:
|
||||
- json-to-haskell
|
||||
- lens
|
||||
- lens-aeson
|
||||
- raw-strings-qq
|
||||
|
||||
tests:
|
||||
|
110
src/Lib.hs
110
src/Lib.hs
@ -7,9 +7,11 @@
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE KindSignatures #-}
|
||||
{-# LANGUAGE ViewPatterns #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
module Lib where
|
||||
|
||||
import Data.Aeson
|
||||
import Data.Aeson hiding (Options)
|
||||
import Data.Aeson.Extra.Recursive
|
||||
import Data.Functor.Foldable hiding (fold)
|
||||
import qualified Data.Text as T
|
||||
@ -17,12 +19,55 @@ import qualified Data.Vector as V
|
||||
import qualified Data.HashMap.Strict as HM
|
||||
import Control.Monad.Reader
|
||||
import Control.Monad.Writer
|
||||
import Control.Monad.State
|
||||
import Data.Foldable
|
||||
import qualified Data.Set as S
|
||||
import Text.Casing
|
||||
import Lens.Micro.Platform
|
||||
import qualified Data.Map as M
|
||||
|
||||
indentation :: Int
|
||||
indentation = 2
|
||||
data NumberPreference =
|
||||
SmartFloats
|
||||
| SmartDoubles
|
||||
| FloatNumbers
|
||||
| DoubleNumbers
|
||||
| ScientificNumbers
|
||||
deriving (Show, Eq)
|
||||
|
||||
data TextType =
|
||||
UseString
|
||||
| UseText
|
||||
| UseByteString
|
||||
deriving (Show, Eq)
|
||||
|
||||
data Options = Options
|
||||
{ _tabStop :: Int
|
||||
, _numberPreference :: NumberPreference
|
||||
, _textType :: TextType
|
||||
, _includeImports :: Bool
|
||||
, _stronglyNormalize :: Bool
|
||||
}
|
||||
|
||||
|
||||
data Env = Env
|
||||
{ _options :: Options
|
||||
, _indentationLevel :: Int
|
||||
}
|
||||
|
||||
makeLenses ''Options
|
||||
makeLenses ''Env
|
||||
|
||||
defaultOptions :: Options
|
||||
defaultOptions = Options
|
||||
{ _tabStop = 2
|
||||
, _numberPreference = DoubleNumbers
|
||||
, _textType = UseText
|
||||
, _includeImports = False
|
||||
, _stronglyNormalize = True
|
||||
}
|
||||
|
||||
data NumberType = Fractional | Whole
|
||||
deriving (Show, Eq, Ord)
|
||||
|
||||
type StructName = T.Text
|
||||
data RecordType = Ref | Structure
|
||||
@ -32,7 +77,7 @@ data Struct (r :: RecordType) where
|
||||
SRecordRef :: StructName -> Struct 'Ref
|
||||
SMap :: Struct r -> Struct r
|
||||
SBool :: Struct r
|
||||
SNumber :: Struct r
|
||||
SNumber :: NumberType -> Struct r
|
||||
SNull :: Struct r
|
||||
SString :: Struct r
|
||||
SValue :: Struct r
|
||||
@ -60,17 +105,19 @@ analyze = cata alg
|
||||
Just s -> SArray s
|
||||
Nothing -> SArray SValue
|
||||
StringF _ -> SString
|
||||
NumberF _ -> SNumber
|
||||
NumberF n ->
|
||||
SNumber $ if (ceiling n == (floor n :: Int)) then Whole
|
||||
else Fractional
|
||||
BoolF _ -> SBool
|
||||
NullF -> SNull
|
||||
|
||||
type Normalizer a = Writer (HM.HashMap T.Text (S.Set (HM.HashMap T.Text (Struct 'Ref)))) a
|
||||
|
||||
json2Haskell :: Value -> T.Text
|
||||
json2Haskell v = do
|
||||
json2Haskell :: Options -> Value -> T.Text
|
||||
json2Haskell opts v = do
|
||||
let struct = analyze v
|
||||
allStructs = execWriter $ normalize (nameRecord "model") struct
|
||||
in buildAllStructs allStructs
|
||||
in buildAllStructs opts allStructs
|
||||
|
||||
nameRecord :: T.Text -> RecordRep 'Ref -> Normalizer T.Text
|
||||
nameRecord (toRecordName -> name) record = do
|
||||
@ -96,7 +143,7 @@ normalize register = \case
|
||||
SMap m -> do
|
||||
SMap <$> normalize register m
|
||||
SBool -> pure SBool
|
||||
SNumber -> pure SNumber
|
||||
SNumber t -> pure $ SNumber t
|
||||
SNull -> pure SNull
|
||||
SString -> pure SString
|
||||
SValue -> pure SValue
|
||||
@ -105,9 +152,9 @@ parens :: MonadWriter T.Text m => m a -> m a
|
||||
parens m =
|
||||
tell "(" *> m <* tell ")"
|
||||
|
||||
line :: (MonadReader Int m, MonadWriter T.Text m) => m a -> m a
|
||||
line :: (MonadReader Env m, MonadWriter T.Text m) => m a -> m a
|
||||
line m = do
|
||||
n <- ask
|
||||
n <- view indentationLevel
|
||||
tell $ T.replicate n " "
|
||||
a <- m
|
||||
newline
|
||||
@ -116,10 +163,12 @@ line m = do
|
||||
newline :: MonadWriter T.Text m => m ()
|
||||
newline = tell "\n"
|
||||
|
||||
indented :: (MonadReader Int m, MonadWriter T.Text m) => m a -> m a
|
||||
indented = local (+indentation)
|
||||
indented :: (MonadReader Env m, MonadWriter T.Text m) => m a -> m a
|
||||
indented m = do
|
||||
n <- view (options . tabStop)
|
||||
local (indentationLevel +~ n) m
|
||||
|
||||
type Builder a = ReaderT Int (Writer T.Text) ()
|
||||
type Builder a = ReaderT Env (Writer T.Text) ()
|
||||
|
||||
buildRecordDef :: StructName -> HM.HashMap T.Text (Struct 'Ref) -> Builder ()
|
||||
buildRecordDef name struct = do
|
||||
@ -138,23 +187,38 @@ buildType =
|
||||
\case
|
||||
SNull -> tell "()"
|
||||
SString -> tell "Text"
|
||||
SNumber -> tell "Double"
|
||||
SNumber t -> do
|
||||
pref <- view (options . numberPreference)
|
||||
case (pref, t) of
|
||||
(FloatNumbers, _) -> tell "Float"
|
||||
(DoubleNumbers, _) -> tell "Double"
|
||||
(ScientificNumbers, _) -> tell "Scientific"
|
||||
(SmartFloats, Fractional) -> tell "Float"
|
||||
(SmartFloats, Whole) -> tell "Int"
|
||||
(SmartDoubles, Fractional) -> tell "Double"
|
||||
(SmartDoubles, Whole) -> tell "Int"
|
||||
|
||||
SBool -> tell "Bool"
|
||||
SValue -> tell "Value"
|
||||
SMap s -> tell "Map Text " >> parens (buildType s)
|
||||
SArray s -> tell "Vector " >> parens (buildType s)
|
||||
SRecordRef n -> tell n
|
||||
-- SOptional s -> tell "Maybe " >> parens (builder s)
|
||||
-- SRecord ss ->
|
||||
-- for_ (HM.toList ss) $ \(k, s) -> do
|
||||
-- line $ do
|
||||
-- tell (k <> " :: ")
|
||||
-- builder s
|
||||
|
||||
-- Normalize records to ensure only one name for each (structural) record as well no duplicate
|
||||
-- names
|
||||
-- normalizeStructRefs :: HM.HashMap T.Text (S.Set (RecordRep 'Ref)) -> HM.HashMap T.Text (RecordRep 'Ref)
|
||||
-- normalizeStructRefs hm = _
|
||||
-- let listOfAll = M.fromList . expand . HM.toList $ hm
|
||||
-- in _
|
||||
-- where
|
||||
-- expand xs = flip evalStateT mempty $ do
|
||||
-- (name, records) <- lift $ xs
|
||||
-- record <- lift $ S.toList records
|
||||
-- return [(name, record)]
|
||||
|
||||
|
||||
buildAllStructs :: HM.HashMap T.Text (S.Set (RecordRep 'Ref)) -> T.Text
|
||||
buildAllStructs hm = execWriter . flip runReaderT 0 $ do
|
||||
buildAllStructs :: Options -> HM.HashMap T.Text (S.Set (RecordRep 'Ref)) -> T.Text
|
||||
buildAllStructs opts hm = execWriter . flip runReaderT (Env opts 0) $ do
|
||||
flip HM.traverseWithKey hm $ \k v -> do
|
||||
buildRecordDef k (head . S.toList $ v)
|
||||
newline
|
||||
|
Loading…
Reference in New Issue
Block a user