mirror of
https://github.com/ChrisPenner/json-to-haskell.git
synced 2024-10-26 22:13:42 +03:00
Initial prototype working :)
This commit is contained in:
parent
d8f3c5a3c6
commit
e2b6544277
32
app/Main.hs
32
app/Main.hs
@ -1,6 +1,36 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
module Main where
|
||||
|
||||
import Lib
|
||||
import Data.Aeson
|
||||
import Data.Aeson.Lens
|
||||
import Control.Lens
|
||||
import Control.Monad.State
|
||||
import Text.RawString.QQ (r)
|
||||
import Data.Text.IO as T
|
||||
|
||||
value :: Value
|
||||
value = view (singular (_JSON @String)) ([r|
|
||||
{
|
||||
"name": "jon",
|
||||
"age": 37,
|
||||
"employed": true,
|
||||
"pets": ["Garfield", "Odie"],
|
||||
"address": {
|
||||
"street": "221B",
|
||||
"zip": 12345
|
||||
}
|
||||
}
|
||||
|])
|
||||
|
||||
main :: IO ()
|
||||
main = return ()
|
||||
main = do
|
||||
T.putStrLn $ json2Haskell value
|
||||
-- putStrLn "Type"
|
||||
-- print a
|
||||
-- putStrLn ""
|
||||
-- putStrLn "SavedRecords"
|
||||
-- print b
|
||||
|
||||
|
13
hie.yaml
Normal file
13
hie.yaml
Normal file
@ -0,0 +1,13 @@
|
||||
cradle:
|
||||
stack:
|
||||
- path: "./src"
|
||||
component: "json-to-haskell:lib"
|
||||
|
||||
- path: "./app/Main.hs"
|
||||
component: "json-to-haskell:exe:json-to-haskell-exe"
|
||||
|
||||
- path: "./app/Paths_json_to_haskell.hs"
|
||||
component: "json-to-haskell:exe:json-to-haskell-exe"
|
||||
|
||||
- path: "./test"
|
||||
component: "json-to-haskell:test:json-to-haskell-test"
|
@ -4,7 +4,7 @@ cabal-version: 1.12
|
||||
--
|
||||
-- see: https://github.com/sol/hpack
|
||||
--
|
||||
-- hash: b6fe0a854b5c1f554a7592a733cc7c5ddeac63de0737216739d1d773dc56de60
|
||||
-- hash: 0ec89ccbeb531be81f661a0903e9df45de27677b81c094cc03ab68e1c33c5e51
|
||||
|
||||
name: json-to-haskell
|
||||
version: 0.1.0.0
|
||||
@ -32,6 +32,7 @@ library
|
||||
Paths_json_to_haskell
|
||||
hs-source-dirs:
|
||||
src
|
||||
ghc-options: -Wall -Wincomplete-patterns
|
||||
build-depends:
|
||||
aeson
|
||||
, aeson-extra
|
||||
@ -51,7 +52,7 @@ executable json-to-haskell-exe
|
||||
Paths_json_to_haskell
|
||||
hs-source-dirs:
|
||||
app
|
||||
ghc-options: -threaded -rtsopts -with-rtsopts=-N
|
||||
ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N
|
||||
build-depends:
|
||||
aeson
|
||||
, aeson-extra
|
||||
@ -59,7 +60,10 @@ executable json-to-haskell-exe
|
||||
, bytestring
|
||||
, containers
|
||||
, json-to-haskell
|
||||
, lens
|
||||
, lens-aeson
|
||||
, mtl
|
||||
, raw-strings-qq
|
||||
, recursion-schemes
|
||||
, text
|
||||
, unordered-containers
|
||||
@ -73,13 +77,14 @@ test-suite json-to-haskell-test
|
||||
Paths_json_to_haskell
|
||||
hs-source-dirs:
|
||||
test
|
||||
ghc-options: -threaded -rtsopts -with-rtsopts=-N
|
||||
ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N
|
||||
build-depends:
|
||||
aeson
|
||||
, aeson-extra
|
||||
, base >=4.7 && <5
|
||||
, bytestring
|
||||
, containers
|
||||
, hspec
|
||||
, json-to-haskell
|
||||
, mtl
|
||||
, recursion-schemes
|
||||
|
@ -31,8 +31,13 @@ dependencies:
|
||||
- mtl
|
||||
- bytestring
|
||||
|
||||
ghc-options:
|
||||
- -Wall
|
||||
|
||||
library:
|
||||
source-dirs: src
|
||||
ghc-options:
|
||||
- -Wincomplete-patterns
|
||||
|
||||
executables:
|
||||
json-to-haskell-exe:
|
||||
@ -44,6 +49,9 @@ executables:
|
||||
- -with-rtsopts=-N
|
||||
dependencies:
|
||||
- json-to-haskell
|
||||
- lens
|
||||
- lens-aeson
|
||||
- raw-strings-qq
|
||||
|
||||
tests:
|
||||
json-to-haskell-test:
|
||||
@ -55,3 +63,4 @@ tests:
|
||||
- -with-rtsopts=-N
|
||||
dependencies:
|
||||
- json-to-haskell
|
||||
- hspec
|
||||
|
141
src/Lib.hs
141
src/Lib.hs
@ -1,75 +1,144 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE StandaloneDeriving #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE KindSignatures #-}
|
||||
module Lib where
|
||||
|
||||
import Data.Aeson
|
||||
import Data.Aeson.Extra.Recursive
|
||||
import Data.Functor.Foldable
|
||||
import qualified Data.Map as M
|
||||
import Data.Functor.Foldable hiding (fold)
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Vector as V
|
||||
import qualified Data.HashMap.Strict as HM
|
||||
import Control.Monad.Reader
|
||||
import Control.Monad.Writer
|
||||
import Data.Foldable
|
||||
import qualified Data.Set as S
|
||||
|
||||
data Struct =
|
||||
SArray Struct
|
||||
| SRecord (HM.HashMap T.Text Struct)
|
||||
| SMap Struct
|
||||
| SBool
|
||||
| SNumber
|
||||
| SNull
|
||||
| SString
|
||||
| SValue
|
||||
| SOptional Struct
|
||||
deriving (Show, Eq)
|
||||
type StructName = T.Text
|
||||
data RecordType = Ref | Structure
|
||||
data Struct (r :: RecordType) where
|
||||
SArray :: Struct r -> Struct r
|
||||
SRecord :: (HM.HashMap T.Text (Struct r)) -> Struct r
|
||||
SRecordRef :: StructName -> Struct r
|
||||
SMap :: Struct r -> Struct r
|
||||
SBool :: Struct r
|
||||
SNumber :: Struct r
|
||||
SNull :: Struct r
|
||||
SString :: Struct r
|
||||
SValue :: Struct r
|
||||
-- It's possible it's a sum of multiple possible types
|
||||
-- | SSum [Struct]
|
||||
-- SOptional :: Struct
|
||||
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
|
||||
analyze :: Value -> Struct 'Structure
|
||||
analyze = cata alg
|
||||
where
|
||||
alg :: ValueF Struct -> Struct
|
||||
alg :: ValueF (Struct 'Structure) -> Struct 'Structure
|
||||
alg = \case
|
||||
ObjectF m -> SRecord (HM.alter (fmap SMap) "*" m)
|
||||
ObjectF m -> SRecord m
|
||||
ArrayF v -> case (v V.!? 0) of
|
||||
Just a -> SArray a
|
||||
Just s -> SArray s
|
||||
Nothing -> SArray SValue
|
||||
StringF _ -> SString
|
||||
NumberF _ -> SBool
|
||||
NumberF _ -> SNumber
|
||||
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
|
||||
let struct = analyze v
|
||||
allStructs = execWriter $ normalize (nameRecord "root") struct
|
||||
in buildAllStructs allStructs
|
||||
|
||||
nameRecord :: T.Text -> RecordRep 'Ref -> Normalizer T.Text
|
||||
nameRecord name record = do
|
||||
tell . (HM.singleton name) . S.singleton $ record
|
||||
return name
|
||||
|
||||
normalize :: (RecordRep 'Ref -> Normalizer T.Text) -> Struct 'Structure -> Normalizer (Struct 'Ref)
|
||||
normalize register = \case
|
||||
SRecord m -> do
|
||||
m' <- flip HM.traverseWithKey m $ \k v -> do
|
||||
normalize (nameRecord k) v
|
||||
name <- register $ m'
|
||||
return $ SRecordRef name
|
||||
SRecordRef n -> pure (SRecordRef n)
|
||||
SArray s -> SArray <$> normalize register s
|
||||
SMap m -> do
|
||||
SMap <$> normalize register m
|
||||
SBool -> pure SBool
|
||||
SNumber -> pure SNumber
|
||||
SNull -> pure SNull
|
||||
SString -> pure SString
|
||||
SValue -> pure SValue
|
||||
|
||||
parens :: MonadWriter T.Text m => m a -> m a
|
||||
parens m =
|
||||
parens m =
|
||||
tell "(" *> m <* tell ")"
|
||||
|
||||
line :: (MonadReader Int m, MonadWriter T.Text m) => m a -> m a
|
||||
line m = do
|
||||
n <- ask
|
||||
tell $ T.replicate n " "
|
||||
m
|
||||
a <- m
|
||||
tell "\n"
|
||||
return a
|
||||
|
||||
builder :: Struct -> ReaderT Int (Writer T.Text) ()
|
||||
builder struct =
|
||||
case struct of
|
||||
SNull -> tell "()"
|
||||
SString -> tell "Text"
|
||||
SNumber -> tell "Double"
|
||||
SBool -> tell "Bool"
|
||||
SValue -> tell "Value"
|
||||
SMap s -> tell "Map Text " >> parens (builder s)
|
||||
SOptional s -> tell "Maybe " >> parens (builder s)
|
||||
SArray s -> tell "Vector " >> parens (builder s)
|
||||
SRecord ss ->
|
||||
for_ (HM.toList ss) $ \(k, s) -> do
|
||||
line $ do
|
||||
tell (k <> " :: ")
|
||||
builder s
|
||||
type Builder a = ReaderT Int (Writer T.Text) ()
|
||||
|
||||
buildRecordDef :: StructName -> HM.HashMap T.Text (Struct 'Ref) -> Builder ()
|
||||
buildRecordDef name struct = do
|
||||
line . tell . fold $ ["data ", name, " = ", name]
|
||||
for_ (zip [0 :: Int ..] $ HM.toList struct) $ \(i, (k, v)) -> do
|
||||
line $ do
|
||||
if (i == 0) then tell "{ "
|
||||
else tell ", "
|
||||
tell k
|
||||
tell " :: "
|
||||
buildType v
|
||||
tell " }"
|
||||
|
||||
buildType :: Struct 'Ref -> Builder ()
|
||||
buildType =
|
||||
\case
|
||||
SNull -> tell "()"
|
||||
SString -> tell "Text"
|
||||
SNumber -> tell "Double"
|
||||
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
|
||||
SRecord _ -> error "Record missed in normalization"
|
||||
-- SOptional s -> tell "Maybe " >> parens (builder s)
|
||||
-- SRecordRef n -> tell
|
||||
-- SRecord ss ->
|
||||
-- for_ (HM.toList ss) $ \(k, s) -> do
|
||||
-- line $ do
|
||||
-- tell (k <> " :: ")
|
||||
-- builder s
|
||||
|
||||
|
||||
|
||||
buildAllStructs :: HM.HashMap T.Text (S.Set (RecordRep 'Ref)) -> T.Text
|
||||
buildAllStructs hm = execWriter . flip runReaderT 0 $ do
|
||||
flip HM.traverseWithKey hm $ \k v -> do
|
||||
buildRecordDef k (head . S.toList $ v)
|
||||
line $ pure ()
|
||||
|
10
test/Spec.hs
10
test/Spec.hs
@ -1,2 +1,10 @@
|
||||
import Test.Hspec
|
||||
|
||||
main :: IO ()
|
||||
main = putStrLn "Test suite not yet implemented"
|
||||
main = hspec spec
|
||||
|
||||
spec :: Spec
|
||||
spec = do
|
||||
describe "analyze" $ do
|
||||
it "should build a record" $ do
|
||||
True `shouldBe` True
|
||||
|
Loading…
Reference in New Issue
Block a user