{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE OverloadedStrings #-}
module TreeSitter.Deserialize
( Datatype (..)
, Field (..)
, Children(..)
, Required (..)
, Type (..)
, DatatypeName (..)
, Named (..)
, Multiple (..)
) where

import Data.Aeson as Aeson
import Data.Aeson.Types
import Data.Char
import GHC.Generics hiding (Constructor, Datatype)
import Data.Text (Text, unpack)
import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.HashMap.Strict as HM
import Data.Maybe (fromMaybe)

-- Types to deserialize into:
data Datatype
  = SumType
  { datatypeName       :: DatatypeName
  , datatypeNameStatus :: Named
  , datatypeSubtypes   :: [Type]
  }
  | ProductType
  { datatypeName       :: DatatypeName
  , datatypeNameStatus :: Named
  , datatypeChildren   :: Maybe Children
  , datatypeFields     :: [(String, Field)]
  }
  | LeafType
  { datatypeName       :: DatatypeName
  , datatypeNameStatus :: Named
  }
  deriving (Eq, Ord, Show, Generic, ToJSON)

instance FromJSON Datatype where
  parseJSON = withObject "Datatype" $ \v -> do
    type' <- v .: "type"
    named <- v .: "named"
    subtypes <- v .:? "subtypes"
    case subtypes of
      Nothing -> do
        fields <- fmap (fromMaybe HM.empty) (v .:? "fields")
        children <- v .:? "children"
        if null fields && null children then
          pure (LeafType type' named)
        else
          ProductType type' named children <$> parseKVPairs (HM.toList fields)
      Just subtypes   -> pure (SumType type' named subtypes)


-- | Transforms list of key-value pairs to a Parser
parseKVPairs :: [(Text, Value)] -> Parser [(String, Field)]
parseKVPairs = traverse go
  where go :: (Text, Value) -> Parser (String, Field)
        go (t,v) = do
          v' <- parseJSON v
          pure (unpack t, v')

data Field = MkField
  { fieldRequired :: Required
  , fieldTypes    :: NonEmpty Type
  , fieldMultiple :: Multiple
  }
  deriving (Eq, Ord, Show, Generic, ToJSON)

instance FromJSON Field where
  parseJSON = genericParseJSON customOptions


newtype Children = MkChildren Field
  deriving (Eq, Ord, Show, Generic)
  deriving newtype (ToJSON, FromJSON)


data Required = Optional | Required
  deriving (Eq, Ord, Show, Generic, ToJSON)

instance FromJSON Required where
  parseJSON = withBool "Required" (\p -> pure (if p then Required else Optional))

data Type = MkType
  { fieldType :: DatatypeName
  , isNamed :: Named
  }
  deriving (Eq, Ord, Show, Generic, ToJSON)

instance FromJSON Type where
  parseJSON = genericParseJSON customOptions

newtype DatatypeName = DatatypeName { getDatatypeName :: String }
  deriving (Eq, Ord, Show, Generic)
  deriving newtype (FromJSON, ToJSON)

data Named = Anonymous | Named
  deriving (Eq, Ord, Show, Generic, ToJSON)

instance FromJSON Named where
  parseJSON = withBool "Named" (\p -> pure (if p then Named else Anonymous))

data Multiple = Single | Multiple
  deriving (Eq, Ord, Show, Generic, ToJSON)

instance FromJSON Multiple where
  parseJSON = withBool "Multiple" (\p -> pure (if p then Multiple else Single))

customOptions :: Aeson.Options
customOptions = Aeson.defaultOptions
  {
    fieldLabelModifier = initLower . dropPrefix
  , constructorTagModifier = initLower
  }

dropPrefix :: String -> String
dropPrefix = Prelude.dropWhile isLower

initLower :: String -> String
initLower (c:cs) = toLower c : cs
initLower "" = ""