mirror of
https://github.com/ChrisPenner/json-to-haskell.git
synced 2024-10-26 22:13:42 +03:00
Add docs to Parser
This commit is contained in:
parent
5b8a48ffca
commit
efbf996f8d
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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 ")"
|
||||
|
Loading…
Reference in New Issue
Block a user