Parser.hs

{-# 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 (Show, Eq, 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 =
    flip execState mempty . flip runReaderT "Model" $ cataA alg value
  where
    -- Algebra for reducing a JSON ValueF from the bottom up.
    alg :: ValueF (AnalyzeM (Struct 'Structure))
        -> AnalyzeM (Struct 'Structure)
    alg = \case
        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
            case (itemsM V.!? 0) of
                Just s  -> SArray <$> s
                Nothing -> pure $ 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

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

-- | 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 names (S.fromAscList . BM.keys $ existingNames)
            modify (BM.insert bestName 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 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 (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

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