{-# LANGUAGE DataKinds #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
module JsonToHaskell.Internal.Parser where

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 (cataA)
import Data.Foldable (for_)
import Data.Either (fromRight)
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.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

-- | Used to track whether the value was fractional or whole.
data NumberVariant = Fractional | Whole
  deriving (Int -> NumberVariant -> ShowS
[NumberVariant] -> ShowS
NumberVariant -> String
(Int -> NumberVariant -> ShowS)
-> (NumberVariant -> String)
-> ([NumberVariant] -> ShowS)
-> Show NumberVariant
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [NumberVariant] -> ShowS
$cshowList :: [NumberVariant] -> ShowS
show :: NumberVariant -> String
$cshow :: NumberVariant -> String
showsPrec :: Int -> NumberVariant -> ShowS
$cshowsPrec :: Int -> NumberVariant -> ShowS
Show, NumberVariant -> NumberVariant -> Bool
(NumberVariant -> NumberVariant -> Bool)
-> (NumberVariant -> NumberVariant -> Bool) -> Eq NumberVariant
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: NumberVariant -> NumberVariant -> Bool
$c/= :: NumberVariant -> NumberVariant -> Bool
== :: NumberVariant -> NumberVariant -> Bool
$c== :: NumberVariant -> NumberVariant -> Bool
Eq, Eq NumberVariant
Eq NumberVariant
-> (NumberVariant -> NumberVariant -> Ordering)
-> (NumberVariant -> NumberVariant -> Bool)
-> (NumberVariant -> NumberVariant -> Bool)
-> (NumberVariant -> NumberVariant -> Bool)
-> (NumberVariant -> NumberVariant -> Bool)
-> (NumberVariant -> NumberVariant -> NumberVariant)
-> (NumberVariant -> NumberVariant -> NumberVariant)
-> Ord NumberVariant
NumberVariant -> NumberVariant -> Bool
NumberVariant -> NumberVariant -> Ordering
NumberVariant -> NumberVariant -> NumberVariant
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: NumberVariant -> NumberVariant -> NumberVariant
$cmin :: NumberVariant -> NumberVariant -> NumberVariant
max :: NumberVariant -> NumberVariant -> NumberVariant
$cmax :: NumberVariant -> NumberVariant -> NumberVariant
>= :: NumberVariant -> NumberVariant -> Bool
$c>= :: NumberVariant -> NumberVariant -> Bool
> :: NumberVariant -> NumberVariant -> Bool
$c> :: NumberVariant -> NumberVariant -> Bool
<= :: NumberVariant -> NumberVariant -> Bool
$c<= :: NumberVariant -> NumberVariant -> Bool
< :: NumberVariant -> NumberVariant -> Bool
$c< :: NumberVariant -> NumberVariant -> Bool
compare :: NumberVariant -> NumberVariant -> Ordering
$ccompare :: NumberVariant -> NumberVariant -> Ordering
$cp1Ord :: Eq NumberVariant
Ord)

-- 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 :: T.Text -> Struct 'Ref
        SMap :: Struct r -> Struct r
        SBool :: Struct r
        SNumber :: NumberVariant -> 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)

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 -> Map (RecordFields 'Structure) (NESet Text)
analyze Value
value =
    (State
   (Map (RecordFields 'Structure) (NESet Text)) (Struct 'Structure)
 -> Map (RecordFields 'Structure) (NESet Text)
 -> Map (RecordFields 'Structure) (NESet Text))
-> Map (RecordFields 'Structure) (NESet Text)
-> State
     (Map (RecordFields 'Structure) (NESet Text)) (Struct 'Structure)
-> Map (RecordFields 'Structure) (NESet Text)
forall a b c. (a -> b -> c) -> b -> a -> c
flip State
  (Map (RecordFields 'Structure) (NESet Text)) (Struct 'Structure)
-> Map (RecordFields 'Structure) (NESet Text)
-> Map (RecordFields 'Structure) (NESet Text)
forall s a. State s a -> s -> s
execState Map (RecordFields 'Structure) (NESet Text)
forall a. Monoid a => a
mempty (State
   (Map (RecordFields 'Structure) (NESet Text)) (Struct 'Structure)
 -> Map (RecordFields 'Structure) (NESet Text))
-> (ReaderT
      Text
      (StateT (Map (RecordFields 'Structure) (NESet Text)) Identity)
      (Struct 'Structure)
    -> State
         (Map (RecordFields 'Structure) (NESet Text)) (Struct 'Structure))
-> ReaderT
     Text
     (StateT (Map (RecordFields 'Structure) (NESet Text)) Identity)
     (Struct 'Structure)
-> Map (RecordFields 'Structure) (NESet Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ReaderT
   Text
   (StateT (Map (RecordFields 'Structure) (NESet Text)) Identity)
   (Struct 'Structure)
 -> Text
 -> State
      (Map (RecordFields 'Structure) (NESet Text)) (Struct 'Structure))
-> Text
-> ReaderT
     Text
     (StateT (Map (RecordFields 'Structure) (NESet Text)) Identity)
     (Struct 'Structure)
-> State
     (Map (RecordFields 'Structure) (NESet Text)) (Struct 'Structure)
forall a b c. (a -> b -> c) -> b -> a -> c
flip ReaderT
  Text
  (StateT (Map (RecordFields 'Structure) (NESet Text)) Identity)
  (Struct 'Structure)
-> Text
-> State
     (Map (RecordFields 'Structure) (NESet Text)) (Struct 'Structure)
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT Text
"Model" (ReaderT
   Text
   (StateT (Map (RecordFields 'Structure) (NESet Text)) Identity)
   (Struct 'Structure)
 -> Map (RecordFields 'Structure) (NESet Text))
-> ReaderT
     Text
     (StateT (Map (RecordFields 'Structure) (NESet Text)) Identity)
     (Struct 'Structure)
-> Map (RecordFields 'Structure) (NESet Text)
forall a b. (a -> b) -> a -> b
$ (Base
   Value
   (ReaderT
      Text
      (StateT (Map (RecordFields 'Structure) (NESet Text)) Identity)
      (Struct 'Structure))
 -> ReaderT
      Text
      (StateT (Map (RecordFields 'Structure) (NESet Text)) Identity)
      (Struct 'Structure))
-> Value
-> ReaderT
     Text
     (StateT (Map (RecordFields 'Structure) (NESet Text)) Identity)
     (Struct 'Structure)
forall t (f :: * -> *) a.
Recursive t =>
(Base t (f a) -> f a) -> t -> f a
cataA ValueF
  (ReaderT
     Text
     (StateT (Map (RecordFields 'Structure) (NESet Text)) Identity)
     (Struct 'Structure))
-> ReaderT
     Text
     (StateT (Map (RecordFields 'Structure) (NESet Text)) Identity)
     (Struct 'Structure)
Base
  Value
  (ReaderT
     Text
     (StateT (Map (RecordFields 'Structure) (NESet Text)) Identity)
     (Struct 'Structure))
-> ReaderT
     Text
     (StateT (Map (RecordFields 'Structure) (NESet Text)) Identity)
     (Struct 'Structure)
alg Value
value
  where
    -- Algebra for reducing a JSON ValueF from the bottom up.
    alg :: ValueF (AnalyzeM (Struct 'Structure))
        -> AnalyzeM (Struct 'Structure)
    alg :: ValueF
  (ReaderT
     Text
     (StateT (Map (RecordFields 'Structure) (NESet Text)) Identity)
     (Struct 'Structure))
-> ReaderT
     Text
     (StateT (Map (RecordFields 'Structure) (NESet Text)) Identity)
     (Struct 'Structure)
alg = \case
        ObjectF ObjectF
  (ReaderT
     Text
     (StateT (Map (RecordFields 'Structure) (NESet Text)) Identity)
     (Struct 'Structure))
m     -> do
            RecordFields 'Structure
m' <- ((Text
  -> ReaderT
       Text
       (StateT (Map (RecordFields 'Structure) (NESet Text)) Identity)
       (Struct 'Structure)
  -> ReaderT
       Text
       (StateT (Map (RecordFields 'Structure) (NESet Text)) Identity)
       (Struct 'Structure))
 -> ObjectF
      (ReaderT
         Text
         (StateT (Map (RecordFields 'Structure) (NESet Text)) Identity)
         (Struct 'Structure))
 -> ReaderT
      Text
      (StateT (Map (RecordFields 'Structure) (NESet Text)) Identity)
      (RecordFields 'Structure))
-> ObjectF
     (ReaderT
        Text
        (StateT (Map (RecordFields 'Structure) (NESet Text)) Identity)
        (Struct 'Structure))
-> (Text
    -> ReaderT
         Text
         (StateT (Map (RecordFields 'Structure) (NESet Text)) Identity)
         (Struct 'Structure)
    -> ReaderT
         Text
         (StateT (Map (RecordFields 'Structure) (NESet Text)) Identity)
         (Struct 'Structure))
-> ReaderT
     Text
     (StateT (Map (RecordFields 'Structure) (NESet Text)) Identity)
     (RecordFields 'Structure)
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Text
 -> ReaderT
      Text
      (StateT (Map (RecordFields 'Structure) (NESet Text)) Identity)
      (Struct 'Structure)
 -> ReaderT
      Text
      (StateT (Map (RecordFields 'Structure) (NESet Text)) Identity)
      (Struct 'Structure))
-> ObjectF
     (ReaderT
        Text
        (StateT (Map (RecordFields 'Structure) (NESet Text)) Identity)
        (Struct 'Structure))
-> ReaderT
     Text
     (StateT (Map (RecordFields 'Structure) (NESet Text)) Identity)
     (RecordFields 'Structure)
forall (f :: * -> *) k v1 v2.
Applicative f =>
(k -> v1 -> f v2) -> HashMap k v1 -> f (HashMap k v2)
HM.traverseWithKey ObjectF
  (ReaderT
     Text
     (StateT (Map (RecordFields 'Structure) (NESet Text)) Identity)
     (Struct 'Structure))
m
                ((Text
  -> ReaderT
       Text
       (StateT (Map (RecordFields 'Structure) (NESet Text)) Identity)
       (Struct 'Structure)
  -> ReaderT
       Text
       (StateT (Map (RecordFields 'Structure) (NESet Text)) Identity)
       (Struct 'Structure))
 -> ReaderT
      Text
      (StateT (Map (RecordFields 'Structure) (NESet Text)) Identity)
      (RecordFields 'Structure))
-> (Text
    -> ReaderT
         Text
         (StateT (Map (RecordFields 'Structure) (NESet Text)) Identity)
         (Struct 'Structure)
    -> ReaderT
         Text
         (StateT (Map (RecordFields 'Structure) (NESet Text)) Identity)
         (Struct 'Structure))
-> ReaderT
     Text
     (StateT (Map (RecordFields 'Structure) (NESet Text)) Identity)
     (RecordFields 'Structure)
forall a b. (a -> b) -> a -> b
$ \Text
fieldName ReaderT
  Text
  (StateT (Map (RecordFields 'Structure) (NESet Text)) Identity)
  (Struct 'Structure)
substructM -> do
                    -- Pass down the current field name as a heuristic for picking a
                    -- reasonable name for records encountered at the lower levels
                    (Text -> Text)
-> ReaderT
     Text
     (StateT (Map (RecordFields 'Structure) (NESet Text)) Identity)
     (Struct 'Structure)
-> ReaderT
     Text
     (StateT (Map (RecordFields 'Structure) (NESet Text)) Identity)
     (Struct 'Structure)
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (Text -> Text -> Text
forall a b. a -> b -> a
const Text
fieldName) ReaderT
  Text
  (StateT (Map (RecordFields 'Structure) (NESet Text)) Identity)
  (Struct 'Structure)
substructM
            RecordFields 'Structure -> AnalyzeM ()
nameRecord RecordFields 'Structure
m'
            Struct 'Structure
-> ReaderT
     Text
     (StateT (Map (RecordFields 'Structure) (NESet Text)) Identity)
     (Struct 'Structure)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Struct 'Structure
 -> ReaderT
      Text
      (StateT (Map (RecordFields 'Structure) (NESet Text)) Identity)
      (Struct 'Structure))
-> Struct 'Structure
-> ReaderT
     Text
     (StateT (Map (RecordFields 'Structure) (NESet Text)) Identity)
     (Struct 'Structure)
forall a b. (a -> b) -> a -> b
$ RecordFields 'Structure -> Struct 'Structure
SRecord RecordFields 'Structure
m'
        ArrayF ArrayF
  (ReaderT
     Text
     (StateT (Map (RecordFields 'Structure) (NESet Text)) Identity)
     (Struct 'Structure))
itemsM -> do
            case (ArrayF
  (ReaderT
     Text
     (StateT (Map (RecordFields 'Structure) (NESet Text)) Identity)
     (Struct 'Structure))
itemsM ArrayF
  (ReaderT
     Text
     (StateT (Map (RecordFields 'Structure) (NESet Text)) Identity)
     (Struct 'Structure))
-> Int
-> Maybe
     (ReaderT
        Text
        (StateT (Map (RecordFields 'Structure) (NESet Text)) Identity)
        (Struct 'Structure))
forall a. Vector a -> Int -> Maybe a
V.!? Int
0) of
                Just ReaderT
  Text
  (StateT (Map (RecordFields 'Structure) (NESet Text)) Identity)
  (Struct 'Structure)
s  -> Struct 'Structure -> Struct 'Structure
forall (r :: RecordType). Struct r -> Struct r
SArray (Struct 'Structure -> Struct 'Structure)
-> ReaderT
     Text
     (StateT (Map (RecordFields 'Structure) (NESet Text)) Identity)
     (Struct 'Structure)
-> ReaderT
     Text
     (StateT (Map (RecordFields 'Structure) (NESet Text)) Identity)
     (Struct 'Structure)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT
  Text
  (StateT (Map (RecordFields 'Structure) (NESet Text)) Identity)
  (Struct 'Structure)
s
                Maybe
  (ReaderT
     Text
     (StateT (Map (RecordFields 'Structure) (NESet Text)) Identity)
     (Struct 'Structure))
Nothing -> Struct 'Structure
-> ReaderT
     Text
     (StateT (Map (RecordFields 'Structure) (NESet Text)) Identity)
     (Struct 'Structure)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Struct 'Structure
 -> ReaderT
      Text
      (StateT (Map (RecordFields 'Structure) (NESet Text)) Identity)
      (Struct 'Structure))
-> Struct 'Structure
-> ReaderT
     Text
     (StateT (Map (RecordFields 'Structure) (NESet Text)) Identity)
     (Struct 'Structure)
forall a b. (a -> b) -> a -> b
$ Struct 'Structure -> Struct 'Structure
forall (r :: RecordType). Struct r -> Struct r
SArray Struct 'Structure
forall (r :: RecordType). Struct r
SValue
        StringF Text
_     -> Struct 'Structure
-> ReaderT
     Text
     (StateT (Map (RecordFields 'Structure) (NESet Text)) Identity)
     (Struct 'Structure)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Struct 'Structure
forall (r :: RecordType). Struct r
SString
        NumberF Scientific
n     -> Struct 'Structure
-> ReaderT
     Text
     (StateT (Map (RecordFields 'Structure) (NESet Text)) Identity)
     (Struct 'Structure)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Struct 'Structure
 -> ReaderT
      Text
      (StateT (Map (RecordFields 'Structure) (NESet Text)) Identity)
      (Struct 'Structure))
-> (NumberVariant -> Struct 'Structure)
-> NumberVariant
-> ReaderT
     Text
     (StateT (Map (RecordFields 'Structure) (NESet Text)) Identity)
     (Struct 'Structure)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NumberVariant -> Struct 'Structure
forall (r :: RecordType). NumberVariant -> Struct r
SNumber
            (NumberVariant
 -> ReaderT
      Text
      (StateT (Map (RecordFields 'Structure) (NESet Text)) Identity)
      (Struct 'Structure))
-> NumberVariant
-> ReaderT
     Text
     (StateT (Map (RecordFields 'Structure) (NESet Text)) Identity)
     (Struct 'Structure)
forall a b. (a -> b) -> a -> b
$ if (Scientific -> Int
forall a b. (RealFrac a, Integral b) => a -> b
ceiling Scientific
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== (Scientific -> Int
forall a b. (RealFrac a, Integral b) => a -> b
floor Scientific
n :: Int))
                then NumberVariant
Whole
                else NumberVariant
Fractional
        BoolF Bool
_       -> Struct 'Structure
-> ReaderT
     Text
     (StateT (Map (RecordFields 'Structure) (NESet Text)) Identity)
     (Struct 'Structure)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Struct 'Structure
forall (r :: RecordType). Struct r
SBool
        ValueF
  (ReaderT
     Text
     (StateT (Map (RecordFields 'Structure) (NESet Text)) Identity)
     (Struct 'Structure))
NullF         -> Struct 'Structure
-> ReaderT
     Text
     (StateT (Map (RecordFields 'Structure) (NESet Text)) Identity)
     (Struct 'Structure)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Struct 'Structure
forall (r :: RecordType). Struct r
SNull

    -- Pair the given record with the name in scope
    nameRecord :: RecordFields 'Structure ->  AnalyzeM ()
    nameRecord :: RecordFields 'Structure -> AnalyzeM ()
nameRecord RecordFields 'Structure
record = do
        Text
name <- (Text -> Text)
-> ReaderT
     Text
     (StateT (Map (RecordFields 'Structure) (NESet Text)) Identity)
     Text
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Text -> Text
toRecordName
        (Map (RecordFields 'Structure) (NESet Text)
 -> Map (RecordFields 'Structure) (NESet Text))
-> AnalyzeM ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((Map (RecordFields 'Structure) (NESet Text)
  -> Map (RecordFields 'Structure) (NESet Text))
 -> AnalyzeM ())
-> ((Maybe (NESet Text) -> Maybe (NESet Text))
    -> Map (RecordFields 'Structure) (NESet Text)
    -> Map (RecordFields 'Structure) (NESet Text))
-> (Maybe (NESet Text) -> Maybe (NESet Text))
-> AnalyzeM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Maybe (NESet Text) -> Maybe (NESet Text))
 -> RecordFields 'Structure
 -> Map (RecordFields 'Structure) (NESet Text)
 -> Map (RecordFields 'Structure) (NESet Text))
-> RecordFields 'Structure
-> (Maybe (NESet Text) -> Maybe (NESet Text))
-> Map (RecordFields 'Structure) (NESet Text)
-> Map (RecordFields 'Structure) (NESet Text)
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Maybe (NESet Text) -> Maybe (NESet Text))
-> RecordFields 'Structure
-> Map (RecordFields 'Structure) (NESet Text)
-> Map (RecordFields 'Structure) (NESet Text)
forall k a.
Ord k =>
(Maybe a -> Maybe a) -> k -> Map k a -> Map k a
M.alter RecordFields 'Structure
record ((Maybe (NESet Text) -> Maybe (NESet Text)) -> AnalyzeM ())
-> (Maybe (NESet Text) -> Maybe (NESet Text)) -> AnalyzeM ()
forall a b. (a -> b) -> a -> b
$ \case
          Maybe (NESet Text)
Nothing -> NESet Text -> Maybe (NESet Text)
forall a. a -> Maybe a
Just (NESet Text -> Maybe (NESet Text))
-> NESet Text -> Maybe (NESet Text)
forall a b. (a -> b) -> a -> b
$ Text -> NESet Text
forall a. a -> NESet a
NES.singleton Text
name
          Just NESet Text
s -> NESet Text -> Maybe (NESet Text)
forall a. a -> Maybe a
Just (NESet Text -> Maybe (NESet Text))
-> NESet Text -> Maybe (NESet Text)
forall a b. (a -> b) -> a -> b
$ Text -> NESet Text -> NESet Text
forall a. Ord a => a -> NESet a -> NESet a
NES.insert Text
name NESet Text
s

-- | 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 :: Map (RecordFields 'Structure) (NESet Text)
-> Bimap Text (RecordFields 'Structure)
canonicalizeRecordNames Map (RecordFields 'Structure) (NESet Text)
m =
    (State (Bimap Text (RecordFields 'Structure)) ()
 -> Bimap Text (RecordFields 'Structure)
 -> Bimap Text (RecordFields 'Structure))
-> Bimap Text (RecordFields 'Structure)
-> State (Bimap Text (RecordFields 'Structure)) ()
-> Bimap Text (RecordFields 'Structure)
forall a b c. (a -> b -> c) -> b -> a -> c
flip State (Bimap Text (RecordFields 'Structure)) ()
-> Bimap Text (RecordFields 'Structure)
-> Bimap Text (RecordFields 'Structure)
forall s a. State s a -> s -> s
execState Bimap Text (RecordFields 'Structure)
forall a b. Bimap a b
BM.empty (State (Bimap Text (RecordFields 'Structure)) ()
 -> Bimap Text (RecordFields 'Structure))
-> State (Bimap Text (RecordFields 'Structure)) ()
-> Bimap Text (RecordFields 'Structure)
forall a b. (a -> b) -> a -> b
$ do
        -- Pick names for those with the fewest candidates first
        -- This helps give everything a "good" name
        [(RecordFields 'Structure, NESet Text)]
-> ((RecordFields 'Structure, NESet Text)
    -> State (Bimap Text (RecordFields 'Structure)) ())
-> State (Bimap Text (RecordFields 'Structure)) ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (((RecordFields 'Structure, NESet Text) -> Int)
-> [(RecordFields 'Structure, NESet Text)]
-> [(RecordFields 'Structure, NESet Text)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
L.sortOn (NESet Text -> Int
forall a. NESet a -> Int
NES.size (NESet Text -> Int)
-> ((RecordFields 'Structure, NESet Text) -> NESet Text)
-> (RecordFields 'Structure, NESet Text)
-> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (RecordFields 'Structure, NESet Text) -> NESet Text
forall a b. (a, b) -> b
snd) ([(RecordFields 'Structure, NESet Text)]
 -> [(RecordFields 'Structure, NESet Text)])
-> (Map (RecordFields 'Structure) (NESet Text)
    -> [(RecordFields 'Structure, NESet Text)])
-> Map (RecordFields 'Structure) (NESet Text)
-> [(RecordFields 'Structure, NESet Text)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map (RecordFields 'Structure) (NESet Text)
-> [(RecordFields 'Structure, NESet Text)]
forall k a. Map k a -> [(k, a)]
M.toList (Map (RecordFields 'Structure) (NESet Text)
 -> [(RecordFields 'Structure, NESet Text)])
-> Map (RecordFields 'Structure) (NESet Text)
-> [(RecordFields 'Structure, NESet Text)]
forall a b. (a -> b) -> a -> b
$ Map (RecordFields 'Structure) (NESet Text)
m) (((RecordFields 'Structure, NESet Text)
  -> State (Bimap Text (RecordFields 'Structure)) ())
 -> State (Bimap Text (RecordFields 'Structure)) ())
-> ((RecordFields 'Structure, NESet Text)
    -> State (Bimap Text (RecordFields 'Structure)) ())
-> State (Bimap Text (RecordFields 'Structure)) ()
forall a b. (a -> b) -> a -> b
$ \(RecordFields 'Structure
struct, NESet Text
names) -> do
            Bimap Text (RecordFields 'Structure)
existingNames <- StateT
  (Bimap Text (RecordFields 'Structure))
  Identity
  (Bimap Text (RecordFields 'Structure))
forall s (m :: * -> *). MonadState s m => m s
get
            let bestName :: Text
bestName = NESet Text -> Set Text -> Text
chooseBestName NESet Text
names ([Text] -> Set Text
forall a. Eq a => [a] -> Set a
S.fromAscList ([Text] -> Set Text)
-> (Bimap Text (RecordFields 'Structure) -> [Text])
-> Bimap Text (RecordFields 'Structure)
-> Set Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bimap Text (RecordFields 'Structure) -> [Text]
forall a b. Bimap a b -> [a]
BM.keys (Bimap Text (RecordFields 'Structure) -> Set Text)
-> Bimap Text (RecordFields 'Structure) -> Set Text
forall a b. (a -> b) -> a -> b
$ Bimap Text (RecordFields 'Structure)
existingNames)
            (Bimap Text (RecordFields 'Structure)
 -> Bimap Text (RecordFields 'Structure))
-> State (Bimap Text (RecordFields 'Structure)) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (Text
-> RecordFields 'Structure
-> Bimap Text (RecordFields 'Structure)
-> Bimap Text (RecordFields 'Structure)
forall a b. (Ord a, Ord b) => a -> b -> Bimap a b -> Bimap a b
BM.insert Text
bestName RecordFields 'Structure
struct)

-- | 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 :: NESet Text -> Set Text -> Text
chooseBestName NESet Text
candidates Set Text
takenNames =
    case Set Text -> Maybe Text
forall a. Set a -> Maybe a
S.lookupMin (Set Text -> Maybe Text) -> Set Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ Set Text -> Set Text -> Set Text
forall a. Ord a => Set a -> Set a -> Set a
S.difference (NESet Text -> Set Text
forall a. NESet a -> Set a
NES.toSet NESet Text
candidates) Set Text
takenNames of
        Maybe Text
Nothing -> Text -> Set Text -> Text
makeUnique (NESet Text -> Text
forall a. NESet a -> a
NES.findMin NESet Text
candidates) Set Text
takenNames
        Just Text
name -> Text
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 :: Text -> Set Text -> Text
makeUnique Text
candidate Set Text
takenNames =
    -- construct an infinite candidates list of ["name", "name2", "name3", ...]
    let candidates :: [Text]
candidates = (Text
candidate Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>) (Text -> Text) -> [Text] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Text
"" Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: (Int -> Text) -> [Int] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String -> Text
T.pack (String -> Text) -> (Int -> String) -> Int -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String
forall a. Show a => a -> String
show) [(Int
2 :: Int)..])
    -- Get the first unique name from the list.
    -- The list is infinite, so head is safe here.
     in [Text] -> Text
forall a. [a] -> a
head ([Text] -> Text) -> ([Text] -> [Text]) -> [Text] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Text -> Bool) -> Text -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Set Text -> Bool) -> Set Text -> Text -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip Text -> Set Text -> Bool
forall a. Ord a => a -> Set a -> Bool
S.member Set Text
takenNames) ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ [Text]
candidates

-- | Switch literal struct definitions with their "names"
addReferences :: BM.Bimap T.Text (RecordFields 'Structure) -> Struct 'Structure -> Struct 'Ref
addReferences :: Bimap Text (RecordFields 'Structure)
-> Struct 'Structure -> Struct 'Ref
addReferences Bimap Text (RecordFields 'Structure)
m =
  \case
    Struct 'Structure
SNull -> Struct 'Ref
forall (r :: RecordType). Struct r
SNull
    Struct 'Structure
SString -> Struct 'Ref
forall (r :: RecordType). Struct r
SString
    SNumber NumberVariant
t -> NumberVariant -> Struct 'Ref
forall (r :: RecordType). NumberVariant -> Struct r
SNumber NumberVariant
t
    Struct 'Structure
SBool -> Struct 'Ref
forall (r :: RecordType). Struct r
SBool
    Struct 'Structure
SValue -> Struct 'Ref
forall (r :: RecordType). Struct r
SValue
    SMap Struct 'Structure
s -> Struct 'Ref -> Struct 'Ref
forall (r :: RecordType). Struct r -> Struct r
SMap (Bimap Text (RecordFields 'Structure)
-> Struct 'Structure -> Struct 'Ref
addReferences Bimap Text (RecordFields 'Structure)
m Struct 'Structure
s)
    SArray Struct 'Structure
s -> Struct 'Ref -> Struct 'Ref
forall (r :: RecordType). Struct r -> Struct r
SArray (Bimap Text (RecordFields 'Structure)
-> Struct 'Structure -> Struct 'Ref
addReferences Bimap Text (RecordFields 'Structure)
m Struct 'Structure
s)
    SRecord RecordFields 'Structure
s -> Text -> Struct 'Ref
SRecordRef (Text -> Struct 'Ref)
-> (Either SomeException Text -> Text)
-> Either SomeException Text
-> Struct 'Ref
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either SomeException Text -> Text
forall b a. b -> Either a b -> b
fromRight (String -> Text
forall a. HasCallStack => String -> a
error String
"Expected record name but wasn't found") (Either SomeException Text -> Struct 'Ref)
-> Either SomeException Text -> Struct 'Ref
forall a b. (a -> b) -> a -> b
$ RecordFields 'Structure
-> Bimap Text (RecordFields 'Structure)
-> Either SomeException Text
forall a b (m :: * -> *).
(Ord a, Ord b, MonadThrow m) =>
b -> Bimap a b -> m a
BM.lookupR RecordFields 'Structure
s Bimap Text (RecordFields 'Structure)
m

-- | Clean a name into a valid Haskell record name
toRecordName :: T.Text -> T.Text
toRecordName :: Text -> Text
toRecordName = (Char -> Bool) -> Text -> Text
T.filter (Char -> Bool
isAlphaNum) (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack (String -> Text) -> (Text -> String) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Identifier String -> String
toPascal (Identifier String -> String)
-> (Text -> Identifier String) -> Text -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Identifier String
fromAny (String -> Identifier String)
-> (Text -> String) -> Text -> Identifier String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack (Text -> String) -> (Text -> Text) -> Text -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> Text -> Text
T.dropWhile (Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isAlpha)