Add docs to Parser

json-to-haskell.cabal

@@ -4,7 +4,7 @@ cabal-version: 1.12
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: 0a966560be78a0a2c37da436b51cb78bd3cce5d7e8b629d4372b13ad6276280f
+-- hash: e5b08a527598792e672b6d6e4bffb7ed2604523824e1e1bd705d0be80bb53a4b
 
 name:           json-to-haskell
 version:        0.1.0.0
@@ -55,7 +55,6 @@ library
 executable json-to-haskell-exe
   main-is: Main.hs
   other-modules:
-      Model
       Paths_json_to_haskell
   hs-source-dirs:
       app

src/JsonToHaskell.hs

@@ -21,12 +21,10 @@ 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
+    let allStructs = analyze v
+        namedStructs = canonicalizeRecordNames allStructs
         referencedStructs = BM.mapR (fmap (dereference namedStructs)) namedStructs
      in buildAllStructs opts referencedStructs

src/JsonToHaskell/Internal/Parser.hs

@@ -4,35 +4,38 @@
 {-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE ViewPatterns #-}
 {-# LANGUAGE GADTs #-}
+{-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE OverloadedStrings #-}
 module JsonToHaskell.Internal.Parser where
 
 import JsonToHaskell.Internal.Options
 import Control.Monad.State
+import Control.Monad.Reader
 import Data.Aeson (Value)
 import Data.Aeson.Extra.Recursive (ValueF(..))
 import Data.Char (isAlpha, isAlphaNum)
-import Data.Functor.Foldable (cata)
+import Data.Functor.Foldable (cataA)
 import Data.Foldable (for_)
-import Data.Maybe (catMaybes)
 import Data.Either (fromRight)
-import Text.Casing (toPascal, toCamel, fromAny)
+import Text.Casing (toPascal, 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
+import qualified Data.Set as S
 
-type StructName = T.Text
+-- a DataKind for tracking whether a structure contains nested structs or Record Names
 data RecordType = Ref | Structure
+-- | The representation of a record's field types
 type RecordFields r = HM.HashMap T.Text (Struct r)
+-- | The recursive representation of the "type" of a JSON value
 data Struct (r :: RecordType) where
         SArray :: Struct r -> Struct r
         SRecord :: (RecordFields 'Structure) -> Struct 'Structure
-        SRecordRef :: StructName -> Struct 'Ref
+        SRecordRef :: T.Text -> Struct 'Ref
         SMap :: Struct r -> Struct r
         SBool :: Struct r
         SNumber :: NumberType -> Struct r
@@ -43,81 +46,96 @@ 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
+type AnalyzeM a =
+    ReaderT T.Text
+            (State (M.Map (RecordFields 'Structure)
+                          (NES.NESet T.Text)))
+            a
+
+-- | Convert a 'Value' into a Typed representation of its structure, tracking reasonable names
+-- for each subrecord along the way
+analyze :: Value
+        -> M.Map (RecordFields 'Structure) (NES.NESet T.Text)
+analyze value =
+    flip execState mempty . flip runReaderT "Model" $ cataA alg value
   where
-    alg :: ValueF (Struct 'Structure) -> Struct 'Structure
+    -- Algebra for reducing a JSON ValueF from the bottom up.
+    alg :: ValueF (AnalyzeM (Struct 'Structure))
+        -> AnalyzeM (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
+        ObjectF m     -> do
+            m' <- flip HM.traverseWithKey m
+                $ \fieldName substructM -> do
+                    -- Pass down the current field name as a heuristic for picking a
+                    -- reasonable name for records encountered at the lower levels
+                    local (const fieldName) substructM
+            nameRecord m'
+            pure $ SRecord m'
+        ArrayF itemsM -> do
+            items <- sequenceA itemsM
+            pure $ case (items V.!? 0) of
+                Just s  -> SArray s
+                Nothing -> SArray SValue
+        StringF _     -> pure SString
+        NumberF n     -> pure . SNumber
+            $ if (ceiling n == (floor n :: Int))
+                then Whole
+                else Fractional
+        BoolF _       -> pure SBool
+        NullF         -> pure SNull
 
-type Normalizer a = State (M.Map (HM.HashMap T.Text (Struct 'Structure)) (NES.NESet T.Text)) a
+    -- Pair the given record with the name in scope
+    nameRecord :: RecordFields 'Structure ->  AnalyzeM ()
+    nameRecord record = do
+        name <- asks toRecordName
+        modify . flip M.alter record $ \case
+          Nothing -> Just $ NES.singleton name
+          Just s -> Just $ NES.insert name s
 
-nameAllRecords :: M.Map (RecordFields 'Structure) (NES.NESet T.Text) -> BM.Bimap T.Text (RecordFields 'Structure)
-nameAllRecords m =
+-- | Given a mapping of structures to name candidates, pick names for each record, avoiding
+-- duplicates
+canonicalizeRecordNames :: M.Map (RecordFields 'Structure) (NES.NESet T.Text) -> BM.Bimap T.Text (RecordFields 'Structure)
+canonicalizeRecordNames m =
     flip execState BM.empty $ do
+        -- Pick names for those with the fewest candidates first
+        -- This helps give everything a "good" name
         for_ (L.sortOn (NES.size . snd) . M.toList $ m) $ \(struct, names) -> do
             existingNames <- get
-            let bestName = chooseBestName (NES.toList names) existingNames
+            let bestName = chooseBestName names (S.fromAscList . BM.keys $ existingNames)
             modify (BM.insert bestName struct)
 
-dereference :: BM.Bimap T.Text (RecordFields 'Structure) -> Struct 'Structure -> Struct 'Ref
-dereference m =
+-- | Choose a "fresh" name given a list of candidates and a map of names which have already
+-- been chosen.
+chooseBestName :: NES.NESet T.Text -> S.Set T.Text -> T.Text
+chooseBestName candidates takenNames =
+    case S.lookupMin $ S.difference (NES.toSet candidates) takenNames of
+        Nothing -> makeUnique (NES.findMin candidates) takenNames
+        Just name -> name
+
+-- | Given a name candidate, make it unique amongs the set of taken names by appending
+-- the lowest number which isn't yet taken. E.g. if "name" is taken, try "name2", "name3"
+-- ad infinitum
+makeUnique :: T.Text -> S.Set T.Text -> T.Text
+makeUnique candidate takenNames =
+    -- construct an infinite candidates list of ["name", "name2", "name3", ...]
+    let candidates = (candidate <>) <$> ("" : fmap (T.pack . show) [(2 :: Int)..])
+    -- Get the first unique name from the list.
+    -- The list is infinite, so head is safe here.
+     in head . filter (not . flip S.member takenNames) $ candidates
+
+-- | Switch literal struct definitions with their "names"
+addReferences :: BM.Bimap T.Text (RecordFields 'Structure) -> Struct 'Structure -> Struct 'Ref
+addReferences 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)
+    SMap s -> SMap (addReferences m s)
+    SArray s -> SArray (addReferences 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
-
+-- | Clean a name into a valid Haskell record name
 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

src/JsonToHaskell/Internal/Printer.hs

@@ -16,9 +16,15 @@ 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 Text.Casing (toCamel, fromAny)
+import Data.Char (isAlpha, isAlphaNum)
 import Lens.Micro.Platform (view, (+~), (<&>))
 
 
+toFieldName :: T.Text -> T.Text
+toFieldName = T.filter (isAlphaNum) . T.pack . toCamel . fromAny . T.unpack . T.dropWhile (not . isAlpha)
+
+type StructName = T.Text
 parens :: MonadWriter T.Text m => m a -> m a
 parens m =
     tell "(" *> m <* tell ")"