mirror of
https://github.com/ChrisPenner/json-to-haskell.git
synced 2024-10-26 22:13:42 +03:00
Clean up package
This commit is contained in:
parent
0ad0230d19
commit
5b8a48ffca
16
app/Main.hs
16
app/Main.hs
@ -3,13 +3,17 @@
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
module Main where
|
||||
|
||||
import Lib
|
||||
import JsonToHaskell
|
||||
import Data.Aeson hiding (defaultOptions)
|
||||
import Text.RawString.QQ (r)
|
||||
import Data.Text.IO as T
|
||||
import Data.ByteString.Lazy as BS
|
||||
|
||||
value :: Either String Value
|
||||
value = eitherDecode ([r|
|
||||
value = eitherDecode valueStr
|
||||
|
||||
valueStr :: BS.ByteString
|
||||
valueStr = [r|
|
||||
{
|
||||
"name": "jon",
|
||||
"age and stuff": 37,
|
||||
@ -30,15 +34,9 @@ value = eitherDecode ([r|
|
||||
}
|
||||
}
|
||||
}
|
||||
|])
|
||||
|]
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
v <- either fail pure value
|
||||
T.putStrLn $ json2Haskell defaultOptions v
|
||||
-- putStrLn "Type"
|
||||
-- print a
|
||||
-- putStrLn ""
|
||||
-- putStrLn "SavedRecords"
|
||||
-- print b
|
||||
|
||||
|
@ -4,7 +4,7 @@ cabal-version: 1.12
|
||||
--
|
||||
-- see: https://github.com/sol/hpack
|
||||
--
|
||||
-- hash: e053adad71ecec8bce550314e66eea9ce8febba4bed55931d2649776b8e405de
|
||||
-- hash: 0a966560be78a0a2c37da436b51cb78bd3cce5d7e8b629d4372b13ad6276280f
|
||||
|
||||
name: json-to-haskell
|
||||
version: 0.1.0.0
|
||||
@ -27,7 +27,10 @@ source-repository head
|
||||
|
||||
library
|
||||
exposed-modules:
|
||||
Lib
|
||||
JsonToHaskell
|
||||
JsonToHaskell.Internal.Options
|
||||
JsonToHaskell.Internal.Parser
|
||||
JsonToHaskell.Internal.Printer
|
||||
other-modules:
|
||||
Paths_json_to_haskell
|
||||
hs-source-dirs:
|
||||
@ -52,6 +55,7 @@ library
|
||||
executable json-to-haskell-exe
|
||||
main-is: Main.hs
|
||||
other-modules:
|
||||
Model
|
||||
Paths_json_to_haskell
|
||||
hs-source-dirs:
|
||||
app
|
||||
@ -61,6 +65,7 @@ executable json-to-haskell-exe
|
||||
, aeson-extra
|
||||
, base >=4.7 && <5
|
||||
, bimap
|
||||
, bytestring
|
||||
, casing
|
||||
, containers
|
||||
, json-to-haskell
|
||||
|
@ -53,6 +53,7 @@ executables:
|
||||
dependencies:
|
||||
- json-to-haskell
|
||||
- raw-strings-qq
|
||||
- bytestring
|
||||
|
||||
tests:
|
||||
json-to-haskell-test:
|
||||
|
32
src/JsonToHaskell.hs
Normal file
32
src/JsonToHaskell.hs
Normal file
@ -0,0 +1,32 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE StandaloneDeriving #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE KindSignatures #-}
|
||||
{-# LANGUAGE ViewPatterns #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
module JsonToHaskell
|
||||
( json2Haskell
|
||||
, Options(..)
|
||||
, defaultOptions
|
||||
) where
|
||||
|
||||
import JsonToHaskell.Internal.Options
|
||||
import JsonToHaskell.Internal.Printer
|
||||
import JsonToHaskell.Internal.Parser
|
||||
import Data.Aeson (Value)
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Bimap as BM
|
||||
import Control.Monad.State
|
||||
|
||||
json2Haskell :: Options -> Value -> T.Text
|
||||
json2Haskell opts v = do
|
||||
let struct = analyze v
|
||||
allStructs = flip execState mempty $ normalize (nameRecord "model") struct
|
||||
namedStructs = nameAllRecords allStructs
|
||||
referencedStructs = BM.mapR (fmap (dereference namedStructs)) namedStructs
|
||||
in buildAllStructs opts referencedStructs
|
78
src/JsonToHaskell/Internal/Options.hs
Normal file
78
src/JsonToHaskell/Internal/Options.hs
Normal file
@ -0,0 +1,78 @@
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
module JsonToHaskell.Internal.Options where
|
||||
|
||||
import Lens.Micro.Platform (makeLenses)
|
||||
|
||||
data NumberPreference =
|
||||
SmartFloats
|
||||
| SmartDoubles
|
||||
| FloatNumbers
|
||||
| DoubleNumbers
|
||||
| ScientificNumbers
|
||||
deriving (Show, Eq)
|
||||
|
||||
data TextType =
|
||||
UseString
|
||||
| UseText
|
||||
| UseByteString
|
||||
deriving (Show, Eq)
|
||||
|
||||
data MapType =
|
||||
UseMap
|
||||
| UseHashMap
|
||||
deriving (Show, Eq)
|
||||
|
||||
data ListType =
|
||||
UseList
|
||||
| UseVector
|
||||
deriving (Show, Eq)
|
||||
|
||||
data Options = Options
|
||||
{ _tabStop :: Int
|
||||
, _numberPreference :: NumberPreference
|
||||
, _textType :: TextType
|
||||
, _mapType :: MapType
|
||||
, _listType :: ListType
|
||||
, _includeImports :: Bool
|
||||
, _stronglyNormalize :: Bool
|
||||
, _strictData :: Bool
|
||||
}
|
||||
|
||||
|
||||
data Env = Env
|
||||
{ _options :: Options
|
||||
, _indentationLevel :: Int
|
||||
}
|
||||
|
||||
makeLenses ''Options
|
||||
makeLenses ''Env
|
||||
|
||||
defaultOptions :: Options
|
||||
defaultOptions = Options
|
||||
{ _tabStop = 2
|
||||
, _numberPreference = DoubleNumbers
|
||||
, _textType = UseText
|
||||
, _mapType = UseMap
|
||||
, _listType = UseList
|
||||
, _includeImports = False
|
||||
, _stronglyNormalize = True
|
||||
, _strictData = False
|
||||
}
|
||||
|
||||
performantOptions :: Options
|
||||
performantOptions = Options
|
||||
{ _tabStop = 2
|
||||
, _numberPreference = DoubleNumbers
|
||||
, _textType = UseText
|
||||
, _mapType = UseMap
|
||||
, _listType = UseList
|
||||
, _includeImports = False
|
||||
, _stronglyNormalize = True
|
||||
-- TODO
|
||||
, _strictData = True
|
||||
}
|
||||
|
||||
|
||||
data NumberType = Fractional | Whole
|
||||
deriving (Show, Eq, Ord)
|
||||
|
123
src/JsonToHaskell/Internal/Parser.hs
Normal file
123
src/JsonToHaskell/Internal/Parser.hs
Normal file
@ -0,0 +1,123 @@
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE KindSignatures #-}
|
||||
{-# LANGUAGE StandaloneDeriving #-}
|
||||
{-# LANGUAGE ViewPatterns #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
module JsonToHaskell.Internal.Parser where
|
||||
|
||||
import JsonToHaskell.Internal.Options
|
||||
import Control.Monad.State
|
||||
import Data.Aeson (Value)
|
||||
import Data.Aeson.Extra.Recursive (ValueF(..))
|
||||
import Data.Char (isAlpha, isAlphaNum)
|
||||
import Data.Functor.Foldable (cata)
|
||||
import Data.Foldable (for_)
|
||||
import Data.Maybe (catMaybes)
|
||||
import Data.Either (fromRight)
|
||||
import Text.Casing (toPascal, toCamel, fromAny)
|
||||
import qualified Data.List as L
|
||||
import qualified Data.Bimap as BM
|
||||
import qualified Data.HashMap.Strict as HM
|
||||
import qualified Data.List.NonEmpty as NE
|
||||
import qualified Data.Map as M
|
||||
import qualified Data.Set.NonEmpty as NES
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Vector as V
|
||||
|
||||
type StructName = T.Text
|
||||
data RecordType = Ref | Structure
|
||||
type RecordFields r = HM.HashMap T.Text (Struct r)
|
||||
data Struct (r :: RecordType) where
|
||||
SArray :: Struct r -> Struct r
|
||||
SRecord :: (RecordFields 'Structure) -> Struct 'Structure
|
||||
SRecordRef :: StructName -> Struct 'Ref
|
||||
SMap :: Struct r -> Struct r
|
||||
SBool :: Struct r
|
||||
SNumber :: NumberType -> Struct r
|
||||
SNull :: Struct r
|
||||
SString :: Struct r
|
||||
SValue :: Struct r
|
||||
deriving instance Show (Struct r)
|
||||
deriving instance Eq (Struct r)
|
||||
deriving instance Ord (Struct r)
|
||||
|
||||
-- Need to track the structs we "invent" along the way
|
||||
analyze :: Value -> Struct 'Structure
|
||||
analyze = cata alg
|
||||
where
|
||||
alg :: ValueF (Struct 'Structure) -> Struct 'Structure
|
||||
alg = \case
|
||||
ObjectF m -> SRecord m
|
||||
ArrayF v -> case (v V.!? 0) of
|
||||
Just s -> SArray s
|
||||
Nothing -> SArray SValue
|
||||
StringF _ -> SString
|
||||
NumberF n ->
|
||||
SNumber $ if (ceiling n == (floor n :: Int)) then Whole
|
||||
else Fractional
|
||||
BoolF _ -> SBool
|
||||
NullF -> SNull
|
||||
|
||||
type Normalizer a = State (M.Map (HM.HashMap T.Text (Struct 'Structure)) (NES.NESet T.Text)) a
|
||||
|
||||
nameAllRecords :: M.Map (RecordFields 'Structure) (NES.NESet T.Text) -> BM.Bimap T.Text (RecordFields 'Structure)
|
||||
nameAllRecords m =
|
||||
flip execState BM.empty $ do
|
||||
for_ (L.sortOn (NES.size . snd) . M.toList $ m) $ \(struct, names) -> do
|
||||
existingNames <- get
|
||||
let bestName = chooseBestName (NES.toList names) existingNames
|
||||
modify (BM.insert bestName struct)
|
||||
|
||||
dereference :: BM.Bimap T.Text (RecordFields 'Structure) -> Struct 'Structure -> Struct 'Ref
|
||||
dereference m =
|
||||
\case
|
||||
SNull -> SNull
|
||||
SString -> SString
|
||||
SNumber t -> SNumber t
|
||||
SBool -> SBool
|
||||
SValue -> SValue
|
||||
SMap s -> SMap (dereference m s)
|
||||
SArray s -> SArray (dereference m s)
|
||||
SRecord s -> SRecordRef . fromRight (error "Expected record name but wasn't found") $ BM.lookupR s m
|
||||
|
||||
chooseBestName :: Ord a => NE.NonEmpty T.Text -> BM.Bimap T.Text a -> T.Text
|
||||
chooseBestName (x NE.:| y : ys) m =
|
||||
case BM.lookup x m of
|
||||
Nothing -> x
|
||||
Just _ -> chooseBestName (y NE.:| ys) m
|
||||
chooseBestName (x NE.:| []) m =
|
||||
head . catMaybes . fmap (go . (x <>)) $ ("" : fmap (T.pack . show) [(1 :: Int)..])
|
||||
where
|
||||
go k = case BM.lookup k m of
|
||||
Nothing -> Just k
|
||||
Just _ -> Nothing
|
||||
|
||||
|
||||
nameRecord :: T.Text -> RecordFields 'Structure -> Normalizer ()
|
||||
nameRecord (toRecordName -> name) record = do
|
||||
modify $ \m -> M.alter (Just . maybe (NES.singleton name) (NES.insert name)) record m
|
||||
|
||||
toRecordName :: T.Text -> T.Text
|
||||
toRecordName = T.filter (isAlphaNum) . T.pack . toPascal . fromAny . T.unpack . T.dropWhile (not . isAlpha)
|
||||
|
||||
toFieldName :: T.Text -> T.Text
|
||||
toFieldName = T.filter (isAlphaNum) . T.pack . toCamel . fromAny . T.unpack . T.dropWhile (not . isAlpha)
|
||||
|
||||
|
||||
normalize :: (RecordFields 'Structure -> Normalizer ()) -> Struct 'Structure -> Normalizer (Struct 'Structure)
|
||||
normalize register = \case
|
||||
SRecord m -> do
|
||||
m' <- flip HM.traverseWithKey m $ \k v -> do
|
||||
normalize (nameRecord k) v
|
||||
register $ m'
|
||||
return $ SRecord m'
|
||||
SArray s -> SArray <$> normalize register s
|
||||
SMap m -> do
|
||||
SMap <$> normalize register m
|
||||
SBool -> pure SBool
|
||||
SNumber t -> pure $ SNumber t
|
||||
SNull -> pure SNull
|
||||
SString -> pure SString
|
||||
SValue -> pure SValue
|
158
src/JsonToHaskell/Internal/Printer.hs
Normal file
158
src/JsonToHaskell/Internal/Printer.hs
Normal file
@ -0,0 +1,158 @@
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE ViewPatterns #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
module JsonToHaskell.Internal.Printer where
|
||||
|
||||
import JsonToHaskell.Internal.Parser
|
||||
import JsonToHaskell.Internal.Options
|
||||
import Control.Monad.State
|
||||
import Control.Monad.Reader
|
||||
import Control.Monad.Writer
|
||||
import Data.Foldable (for_, fold)
|
||||
import qualified Data.Bimap as BM
|
||||
import qualified Data.HashMap.Strict as HM
|
||||
import qualified Data.Map as M
|
||||
import qualified Data.Text as T
|
||||
import Lens.Micro.Platform (view, (+~), (<&>))
|
||||
|
||||
|
||||
parens :: MonadWriter T.Text m => m a -> m a
|
||||
parens m =
|
||||
tell "(" *> m <* tell ")"
|
||||
|
||||
line :: (MonadReader Env m, MonadWriter T.Text m) => m a -> m a
|
||||
line m = do
|
||||
n <- view indentationLevel
|
||||
tell $ T.replicate n " "
|
||||
a <- m
|
||||
newline
|
||||
return a
|
||||
|
||||
newline :: MonadWriter T.Text m => m ()
|
||||
newline = tell "\n"
|
||||
|
||||
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 Env (Writer T.Text) ()
|
||||
|
||||
buildRecordDef :: StructName -> RecordFields 'Ref -> Builder ()
|
||||
buildRecordDef name struct = do
|
||||
line . tell . fold $ ["data ", name, " = ", name]
|
||||
|
||||
indented $ do
|
||||
when (HM.null struct) . line $ tell "{"
|
||||
for_ (zip [0 :: Int ..] $ HM.toList struct) $ \(i, (k, v)) -> do
|
||||
line $ do
|
||||
if (i == 0) then tell "{ "
|
||||
else tell ", "
|
||||
tell $ toFieldName k
|
||||
tell " :: "
|
||||
buildType v
|
||||
indented . line $ do
|
||||
tell "} "
|
||||
tell "deriving (Show, Eq, Ord)"
|
||||
|
||||
buildToJSONInstance :: StructName -> RecordFields 'Ref -> Builder ()
|
||||
buildToJSONInstance name struct = do
|
||||
line $ tell $ "instance ToJSON " <> name <> " where"
|
||||
indented $ do
|
||||
line $ do
|
||||
tell $ "toJSON " <> name
|
||||
when (not . HM.null $ struct) $ tell "{..}"
|
||||
tell " = object"
|
||||
indented $ do
|
||||
when (HM.null struct) . line $ tell "["
|
||||
for_ (zip [0 :: Int ..] $ HM.keys struct) $ \(i, k) -> do
|
||||
line $ do
|
||||
if (i == 0) then tell "[ "
|
||||
else tell ", "
|
||||
tell $ "\"" <> escapeQuotes k <> "\""
|
||||
tell " .= "
|
||||
tell $ toFieldName k
|
||||
line . tell $ "] "
|
||||
|
||||
buildFromJSONInstance :: StructName -> RecordFields 'Ref -> Builder ()
|
||||
buildFromJSONInstance name struct = do
|
||||
line $ tell $ "instance FromJSON " <> name <> " where"
|
||||
indented $ do
|
||||
line $ tell $ "parseJSON (Object v) = do"
|
||||
indented $ do
|
||||
for_ (HM.keys struct) $ \k -> do
|
||||
line $ do
|
||||
tell $ toFieldName k
|
||||
tell " <- v .: "
|
||||
tell $ "\"" <> escapeQuotes k <> "\""
|
||||
line $ do
|
||||
tell $ "pure $ " <> name
|
||||
when (not . HM.null $ struct) $ tell "{..}"
|
||||
line $ tell $ "parseJSON invalid = do"
|
||||
indented $ do
|
||||
line . tell $ "prependFailure \"parsing " <> name <> " failed, \""
|
||||
indented . line . tell $ "(typeMismatch \"Object\" invalid)"
|
||||
|
||||
|
||||
buildType :: Struct 'Ref -> Builder ()
|
||||
buildType =
|
||||
\case
|
||||
SNull -> tell "()"
|
||||
SString -> do
|
||||
getTextType >>= tell
|
||||
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 -> do
|
||||
txtType <- getTextType
|
||||
tell ("Map " <> txtType <> " ") >> parens (buildType s)
|
||||
SArray s -> tell "Vector " >> parens (buildType s)
|
||||
SRecordRef n -> tell n
|
||||
where
|
||||
getTextType = do
|
||||
view (options . textType) <&> \case
|
||||
UseString -> "String"
|
||||
UseByteString -> "ByteString"
|
||||
UseText -> "Text"
|
||||
|
||||
buildAllStructs :: Options -> BM.Bimap T.Text (RecordFields 'Ref) -> T.Text
|
||||
buildAllStructs opts (BM.toMap -> m) = execWriter . flip runReaderT (Env opts 0) $ do
|
||||
tell . T.unlines $
|
||||
[ "{-# LANGUAGE DuplicateRecordFields #-}"
|
||||
, "{-# LANGUAGE RecordWildCards #-}"
|
||||
, "{-# LANGUAGE OverloadedStrings #-}"
|
||||
, "module Model where"
|
||||
, ""
|
||||
, "import Prelude (Double, Bool, Show, Eq, Ord, ($), pure)"
|
||||
, "import Data.Aeson (ToJSON(..), FromJSON(..), Value(..), (.:), (.=), object)"
|
||||
, "import Data.Aeson.Types (prependFailure, typeMismatch)"
|
||||
, "import Data.Text (Text)"
|
||||
, "import Data.Vector (Vector)"
|
||||
]
|
||||
|
||||
newline
|
||||
void . flip M.traverseWithKey m $ \k v -> do
|
||||
buildRecordDef k v
|
||||
newline
|
||||
void . flip M.traverseWithKey m $ \k v -> do
|
||||
buildToJSONInstance k v
|
||||
newline
|
||||
void . flip M.traverseWithKey m $ \k v -> do
|
||||
buildFromJSONInstance k v
|
||||
newline
|
||||
|
||||
escapeQuotes :: T.Text -> T.Text
|
||||
escapeQuotes = T.replace "\"" "\\\""
|
351
src/Lib.hs
351
src/Lib.hs
@ -1,351 +0,0 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE StandaloneDeriving #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE KindSignatures #-}
|
||||
{-# LANGUAGE ViewPatterns #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
module Lib where
|
||||
|
||||
import Control.Monad.Reader
|
||||
import Control.Monad.State
|
||||
import Control.Monad.Writer
|
||||
import Data.Aeson (Value)
|
||||
import Data.Aeson.Extra.Recursive (ValueF(..))
|
||||
import Data.Char (isAlpha, isAlphaNum)
|
||||
import Data.Foldable (for_, fold)
|
||||
import Data.Functor.Foldable (cata)
|
||||
import Data.Maybe (catMaybes)
|
||||
import Data.Either (fromRight)
|
||||
import Lens.Micro.Platform (makeLenses, (<&>), (+~), view)
|
||||
import Text.Casing (toPascal, toCamel, fromAny)
|
||||
import qualified Data.Bimap as BM
|
||||
import qualified Data.HashMap.Strict as HM
|
||||
import qualified Data.List as L
|
||||
import qualified Data.List.NonEmpty as NE
|
||||
import qualified Data.Map as M
|
||||
import qualified Data.Set.NonEmpty as NES
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Vector as V
|
||||
|
||||
data NumberPreference =
|
||||
SmartFloats
|
||||
| SmartDoubles
|
||||
| FloatNumbers
|
||||
| DoubleNumbers
|
||||
| ScientificNumbers
|
||||
deriving (Show, Eq)
|
||||
|
||||
data TextType =
|
||||
UseString
|
||||
| UseText
|
||||
| UseByteString
|
||||
deriving (Show, Eq)
|
||||
|
||||
data MapType =
|
||||
UseMap
|
||||
| UseHashMap
|
||||
deriving (Show, Eq)
|
||||
|
||||
data ListType =
|
||||
UseList
|
||||
| UseVector
|
||||
deriving (Show, Eq)
|
||||
|
||||
data Options = Options
|
||||
{ _tabStop :: Int
|
||||
, _numberPreference :: NumberPreference
|
||||
, _textType :: TextType
|
||||
, _mapType :: MapType
|
||||
, _listType :: ListType
|
||||
, _includeImports :: Bool
|
||||
, _stronglyNormalize :: Bool
|
||||
, _strictData :: Bool
|
||||
}
|
||||
|
||||
|
||||
data Env = Env
|
||||
{ _options :: Options
|
||||
, _indentationLevel :: Int
|
||||
}
|
||||
|
||||
makeLenses ''Options
|
||||
makeLenses ''Env
|
||||
|
||||
defaultOptions :: Options
|
||||
defaultOptions = Options
|
||||
{ _tabStop = 2
|
||||
, _numberPreference = DoubleNumbers
|
||||
, _textType = UseText
|
||||
, _mapType = UseMap
|
||||
, _listType = UseList
|
||||
, _includeImports = False
|
||||
, _stronglyNormalize = True
|
||||
, _strictData = False
|
||||
}
|
||||
|
||||
performantOptions :: Options
|
||||
performantOptions = Options
|
||||
{ _tabStop = 2
|
||||
, _numberPreference = DoubleNumbers
|
||||
, _textType = UseText
|
||||
, _mapType = UseMap
|
||||
, _listType = UseList
|
||||
, _includeImports = False
|
||||
, _stronglyNormalize = True
|
||||
-- TODO
|
||||
, _strictData = True
|
||||
}
|
||||
|
||||
|
||||
data NumberType = Fractional | Whole
|
||||
deriving (Show, Eq, Ord)
|
||||
|
||||
type StructName = T.Text
|
||||
data RecordType = Ref | Structure
|
||||
data Struct (r :: RecordType) where
|
||||
SArray :: Struct r -> Struct r
|
||||
SRecord :: (HM.HashMap T.Text (Struct 'Structure)) -> Struct 'Structure
|
||||
SRecordRef :: StructName -> Struct 'Ref
|
||||
SMap :: Struct r -> Struct r
|
||||
SBool :: Struct r
|
||||
SNumber :: NumberType -> Struct r
|
||||
SNull :: Struct r
|
||||
SString :: Struct r
|
||||
SValue :: Struct r
|
||||
deriving instance Show (Struct r)
|
||||
deriving instance Eq (Struct r)
|
||||
deriving instance Ord (Struct r)
|
||||
|
||||
|
||||
-- data Blah = Blah { one :: a
|
||||
-- ,
|
||||
-- }
|
||||
|
||||
type RecordRep r = HM.HashMap T.Text (Struct r)
|
||||
-- Need to track the structs we "invent" along the way
|
||||
analyze :: Value -> Struct 'Structure
|
||||
analyze = cata alg
|
||||
where
|
||||
alg :: ValueF (Struct 'Structure) -> Struct 'Structure
|
||||
alg = \case
|
||||
ObjectF m -> SRecord m
|
||||
ArrayF v -> case (v V.!? 0) of
|
||||
Just s -> SArray s
|
||||
Nothing -> SArray SValue
|
||||
StringF _ -> SString
|
||||
NumberF n ->
|
||||
SNumber $ if (ceiling n == (floor n :: Int)) then Whole
|
||||
else Fractional
|
||||
BoolF _ -> SBool
|
||||
NullF -> SNull
|
||||
|
||||
type Normalizer a = State (M.Map (HM.HashMap T.Text (Struct 'Structure)) (NES.NESet T.Text)) a
|
||||
|
||||
json2Haskell :: Options -> Value -> T.Text
|
||||
json2Haskell opts v = do
|
||||
let struct = analyze v
|
||||
allStructs = flip execState mempty $ normalize (nameRecord "model") struct
|
||||
namedStructs = nameAllRecords allStructs
|
||||
referencedStructs = BM.mapR (fmap (dereference namedStructs)) namedStructs
|
||||
in buildAllStructs opts referencedStructs
|
||||
|
||||
nameAllRecords :: M.Map (RecordRep 'Structure) (NES.NESet T.Text) -> BM.Bimap T.Text (RecordRep 'Structure)
|
||||
nameAllRecords m =
|
||||
flip execState BM.empty $ do
|
||||
for_ (L.sortOn (NES.size . snd) . M.toList $ m) $ \(struct, names) -> do
|
||||
existingNames <- get
|
||||
let bestName = chooseBestName (NES.toList names) existingNames
|
||||
modify (BM.insert bestName struct)
|
||||
|
||||
dereference :: BM.Bimap T.Text (RecordRep 'Structure) -> Struct 'Structure -> Struct 'Ref
|
||||
dereference m =
|
||||
\case
|
||||
SNull -> SNull
|
||||
SString -> SString
|
||||
SNumber t -> SNumber t
|
||||
SBool -> SBool
|
||||
SValue -> SValue
|
||||
SMap s -> SMap (dereference m s)
|
||||
SArray s -> SArray (dereference m s)
|
||||
SRecord s -> SRecordRef . fromRight (error "Expected record name but wasn't found") $ BM.lookupR s m
|
||||
|
||||
chooseBestName :: Ord a => NE.NonEmpty T.Text -> BM.Bimap T.Text a -> T.Text
|
||||
chooseBestName (x NE.:| y : ys) m =
|
||||
case BM.lookup x m of
|
||||
Nothing -> x
|
||||
Just _ -> chooseBestName (y NE.:| ys) m
|
||||
chooseBestName (x NE.:| []) m =
|
||||
head . catMaybes . fmap (go . (x <>)) $ ("" : fmap (T.pack . show) [(1 :: Int)..])
|
||||
where
|
||||
go k = case BM.lookup k m of
|
||||
Nothing -> Just k
|
||||
Just _ -> Nothing
|
||||
|
||||
|
||||
nameRecord :: T.Text -> RecordRep 'Structure -> Normalizer ()
|
||||
nameRecord (toRecordName -> name) record = do
|
||||
modify $ \m -> M.alter (Just . maybe (NES.singleton name) (NES.insert name)) record m
|
||||
|
||||
toRecordName :: T.Text -> T.Text
|
||||
toRecordName = T.filter (isAlphaNum) . T.pack . toPascal . fromAny . T.unpack . T.dropWhile (not . isAlpha)
|
||||
|
||||
toFieldName :: T.Text -> T.Text
|
||||
toFieldName = T.filter (isAlphaNum) . T.pack . toCamel . fromAny . T.unpack . T.dropWhile (not . isAlpha)
|
||||
|
||||
|
||||
normalize :: (RecordRep 'Structure -> Normalizer ()) -> Struct 'Structure -> Normalizer (Struct 'Structure)
|
||||
normalize register = \case
|
||||
SRecord m -> do
|
||||
m' <- flip HM.traverseWithKey m $ \k v -> do
|
||||
normalize (nameRecord k) v
|
||||
register $ m'
|
||||
return $ SRecord m'
|
||||
SArray s -> SArray <$> normalize register s
|
||||
SMap m -> do
|
||||
SMap <$> normalize register m
|
||||
SBool -> pure SBool
|
||||
SNumber t -> pure $ SNumber t
|
||||
SNull -> pure SNull
|
||||
SString -> pure SString
|
||||
SValue -> pure SValue
|
||||
|
||||
parens :: MonadWriter T.Text m => m a -> m a
|
||||
parens m =
|
||||
tell "(" *> m <* tell ")"
|
||||
|
||||
line :: (MonadReader Env m, MonadWriter T.Text m) => m a -> m a
|
||||
line m = do
|
||||
n <- view indentationLevel
|
||||
tell $ T.replicate n " "
|
||||
a <- m
|
||||
newline
|
||||
return a
|
||||
|
||||
newline :: MonadWriter T.Text m => m ()
|
||||
newline = tell "\n"
|
||||
|
||||
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 Env (Writer T.Text) ()
|
||||
|
||||
buildRecordDef :: StructName -> HM.HashMap T.Text (Struct 'Ref) -> Builder ()
|
||||
buildRecordDef name struct = do
|
||||
line . tell . fold $ ["data ", name, " = ", name]
|
||||
|
||||
indented $ do
|
||||
when (HM.null struct) . line $ tell "{"
|
||||
for_ (zip [0 :: Int ..] $ HM.toList struct) $ \(i, (k, v)) -> do
|
||||
line $ do
|
||||
if (i == 0) then tell "{ "
|
||||
else tell ", "
|
||||
tell $ toFieldName k
|
||||
tell " :: "
|
||||
buildType v
|
||||
indented . line $ do
|
||||
tell "} "
|
||||
tell "deriving (Show, Eq, Ord)"
|
||||
|
||||
buildToJSONInstance :: StructName -> HM.HashMap T.Text (Struct 'Ref) -> Builder ()
|
||||
buildToJSONInstance name struct = do
|
||||
line $ tell $ "instance ToJSON " <> name <> " where"
|
||||
indented $ do
|
||||
line $ do
|
||||
tell $ "toJSON " <> name
|
||||
when (not . HM.null $ struct) $ tell "{..}"
|
||||
tell " = object"
|
||||
indented $ do
|
||||
when (HM.null struct) . line $ tell "["
|
||||
for_ (zip [0 :: Int ..] $ HM.keys struct) $ \(i, k) -> do
|
||||
line $ do
|
||||
if (i == 0) then tell "[ "
|
||||
else tell ", "
|
||||
tell $ "\"" <> escapeQuotes k <> "\""
|
||||
tell " .= "
|
||||
tell $ toFieldName k
|
||||
line . tell $ "] "
|
||||
|
||||
buildFromJSONInstance :: StructName -> HM.HashMap T.Text (Struct 'Ref) -> Builder ()
|
||||
buildFromJSONInstance name struct = do
|
||||
line $ tell $ "instance FromJSON " <> name <> " where"
|
||||
indented $ do
|
||||
line $ tell $ "parseJSON (Object v) = do"
|
||||
indented $ do
|
||||
for_ (HM.keys struct) $ \k -> do
|
||||
line $ do
|
||||
tell $ toFieldName k
|
||||
tell " <- v .: "
|
||||
tell $ "\"" <> escapeQuotes k <> "\""
|
||||
line $ do
|
||||
tell $ "pure $ " <> name
|
||||
when (not . HM.null $ struct) $ tell "{..}"
|
||||
line $ tell $ "parseJSON invalid = do"
|
||||
indented $ do
|
||||
line . tell $ "prependFailure \"parsing " <> name <> " failed, \""
|
||||
indented . line . tell $ "(typeMismatch \"Object\" invalid)"
|
||||
|
||||
|
||||
buildType :: Struct 'Ref -> Builder ()
|
||||
buildType =
|
||||
\case
|
||||
SNull -> tell "()"
|
||||
SString -> do
|
||||
getTextType >>= tell
|
||||
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 -> do
|
||||
txtType <- getTextType
|
||||
tell ("Map " <> txtType <> " ") >> parens (buildType s)
|
||||
SArray s -> tell "Vector " >> parens (buildType s)
|
||||
SRecordRef n -> tell n
|
||||
where
|
||||
getTextType = do
|
||||
view (options . textType) <&> \case
|
||||
UseString -> "String"
|
||||
UseByteString -> "ByteString"
|
||||
UseText -> "Text"
|
||||
|
||||
buildAllStructs :: Options -> BM.Bimap T.Text (RecordRep 'Ref) -> T.Text
|
||||
buildAllStructs opts (BM.toMap -> m) = execWriter . flip runReaderT (Env opts 0) $ do
|
||||
tell . T.unlines $
|
||||
[ "{-# LANGUAGE DuplicateRecordFields #-}"
|
||||
, "{-# LANGUAGE RecordWildCards #-}"
|
||||
, "{-# LANGUAGE OverloadedStrings #-}"
|
||||
, "module Model where"
|
||||
, ""
|
||||
, "import Prelude (Double, Bool, Show, Eq, Ord)"
|
||||
, "import Data.Aeson (ToJSON)"
|
||||
, "import Data.Text (Text)"
|
||||
, "import Data.Vector (Vector)"
|
||||
]
|
||||
newline
|
||||
void . flip M.traverseWithKey m $ \k v -> do
|
||||
buildRecordDef k v
|
||||
newline
|
||||
void . flip M.traverseWithKey m $ \k v -> do
|
||||
buildToJSONInstance k v
|
||||
newline
|
||||
void . flip M.traverseWithKey m $ \k v -> do
|
||||
buildFromJSONInstance k v
|
||||
newline
|
||||
|
||||
escapeQuotes :: T.Text -> T.Text
|
||||
escapeQuotes = T.replace "\"" "\\\""
|
Loading…
Reference in New Issue
Block a user