{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DeriveLift #-}

-- Turn off partial field warnings for Datatype.
{-# OPTIONS_GHC -Wno-partial-fields #-}
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 Language.Haskell.TH.Syntax (Lift)
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   :: NonEmpty 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, Lift)

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