Initial prototype working :)

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
+

hie.yaml

@@ -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"

json-to-haskell.cabal

@@ -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

package.yaml

@@ -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

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 ()

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