module Utils.PathPiece
  ( nullaryToPathPiece', nullaryToPathPiece
  , nullaryPathPiece', nullaryPathPiece, finitePathPiece
  , derivePathPiece
  , splitCamel
  , camelToPathPiece, camelToPathPiece'
  , nameToPathPiece, nameToPathPiece'
  , tuplePathPiece
  , pathPieceJSON, pathPieceJSONKey
  , pathPieceBinary
  , pathPieceHttpApiData
  ) where

import ClassyPrelude.Yesod

import Language.Haskell.TH
import qualified Language.Haskell.TH.Syntax as TH (Lift(..))
import Language.Haskell.TH.Datatype
import Data.Universe

import qualified Data.Text as Text
import qualified Data.Char as Char

import Data.Map ((!))
import qualified Data.Map as Map

import qualified Data.HashMap.Strict as HashMap

import Numeric.Natural

import Data.List (nub, foldl)

import Data.Aeson.Types
import qualified Data.Aeson.Types as Aeson

import Control.Monad.Fail

import Data.Binary (Binary)
import qualified Data.Binary as Binary

import Control.Lens
import Data.Generics.Product.Types

import Web.HttpApiData


mkFiniteFromPathPiece :: Name -> Q ([Dec], Exp)
mkFiniteFromPathPiece finiteType = do
  mapName <- newName $ "pathPieceMap" <> nameBase finiteType
  let
    decs = sequence
      [ pragInlD mapName NoInline FunLike AllPhases
      , sigD mapName [t|HashMap Text $(conT finiteType)|]
      , funD mapName
        [ clause [] (normalB [e|HashMap.fromList $ map (toPathPiece &&& id) universeF|]) [] ]
      ]
  (,) <$> decs <*> [e|flip HashMap.lookup $(varE mapName)|]

nullaryToPathPiece' :: Name -> (Name -> Text) -> ExpQ
nullaryToPathPiece' nullaryType mangle = do
  TyConI (DataD _ _ _ _ constructors _) <- reify nullaryType
  helperName <- newName "helper"
  let
    toClause (NormalC cName []) = clause [conP cName []] (normalB . TH.lift $ mangle cName) []
    toClause con = fail $ "Unsupported constructor: " ++ show con
    helperDec = funD helperName $ map toClause constructors
  letE [helperDec] $ varE helperName

nullaryToPathPiece :: Name -> (Text -> Text) -> ExpQ
nullaryToPathPiece nullaryType = nullaryToPathPiece' nullaryType . flip (.) (Text.pack . nameBase)

nullaryPathPiece' :: Name -> (Name -> Text) -> DecsQ
nullaryPathPiece' nullaryType mangle = do
  (finDecs, finExp) <- mkFiniteFromPathPiece nullaryType
  sequence . (map return finDecs ++) . pure $
    instanceD (cxt []) [t|PathPiece $(conT nullaryType)|]
      [ funD 'toPathPiece
        [ clause [] (normalB $ nullaryToPathPiece' nullaryType mangle) [] ]
      , funD 'fromPathPiece
        [ clause [] (normalB $ return finExp) [] ]
      ]

nullaryPathPiece :: Name -> (Text -> Text) -> DecsQ
nullaryPathPiece nullaryType = nullaryPathPiece' nullaryType . flip (.) (Text.pack . nameBase)

finitePathPiece :: Name -> [Text] -> DecsQ
finitePathPiece finiteType verbs = do
  (finDecs, finExp) <- mkFiniteFromPathPiece finiteType
  sequence . (map return finDecs ++) . pure $
    instanceD (cxt []) [t|PathPiece $(conT finiteType)|]
      [ funD 'toPathPiece
        [ clause [] (normalB [|(Map.fromList (zip universeF verbs) !)|]) [] ]
      , funD 'fromPathPiece
        [ clause [] (normalB $ return finExp) [] ]
      ]

derivePathPiece :: Name -> (Text -> Text) -> Text -> DecsQ
derivePathPiece adt mangle joinPP = do
  let mangle' = TH.lift . mangle . pack . nameBase
  DatatypeInfo{..} <- reifyDatatype adt
  mapName <- newName $ "pathPieceConstructorMap" <> nameBase adt
  let
    toClause ConstructorInfo{..} = do
      vars <- mapM (const $ newName "x") constructorFields
      clause [conP constructorName $ map varP vars] (normalB [e|Text.intercalate joinPP $ $(mangle' constructorName) : $(listE $ map (\v -> [e|toPathPiece $(varE v)|]) vars)|]) []
    fromClause = do
      constrName <- newName "c"
      argsName <- newName "args"
      clause [viewP [e|Text.splitOn joinPP|] $ infixP (varP constrName) '(:) (varP argsName)]
             (normalB [e|HashMap.lookup $(varE constrName) $(varE mapName) >>= ($ $(varE argsName))|])
             []
    finDecs =
      [ pragInlD mapName NoInline FunLike AllPhases
      , sigD mapName $ forallT [] (cxt iCxt) [t|HashMap Text ([Text] -> Maybe $(typ))|]
      , funD mapName
        [ clause [] (normalB finClause) [] ]
      ]
      where finClause = ([e|HashMap.fromList|] `appE`) . listE $ map listItem datatypeCons
            listItem ConstructorInfo{..} = do
              vars <- mapM (const $ newName "x") constructorFields
              tupE [ mangle' constructorName
                   , lamCaseE
                     [ match (listP $ map varP vars)
                             (normalB $ case vars of
                                          []     -> [e|Just $(conE constructorName)|]
                                          v : vs -> foldl' (\acc v' -> [e|$(acc) <*> fromPathPiece $(varE v')|]) [e|$(conE constructorName) <$> fromPathPiece $(varE v)|] vs
                             )
                             []
                     , match wildP (normalB [e|Nothing|]) []
                     ]
                   ]
    typ = foldl (\t bndr -> t `appT` varT (tvarName bndr)) (conT adt) datatypeVars
    iCxt = map (appT [t|PathPiece|] . pure) $ filter (\t -> any (flip (elemOf types) t) usedTVars) fieldTypes
      where usedTVars = filter (\n -> any (`usesVar` n) datatypeCons) $ map tvarName datatypeVars
            usesVar ConstructorInfo{..} n
              | n `elem` map tvarName constructorVars = False
              | otherwise = any (elemOf types n) constructorFields
            fieldTypes = nub $ concatMap constructorFields datatypeCons
    tvarName (PlainTV n) = n
    tvarName (KindedTV n _) = n
  sequence . (finDecs ++ ) . pure $
    instanceD (cxt iCxt) [t|PathPiece $(typ)|]
      [ funD 'toPathPiece
          (map toClause datatypeCons)
      , funD 'fromPathPiece
          [ fromClause
          , clause [wildP] (normalB [e|Nothing|]) []
          ]
      ]


splitCamel :: Textual t => t -> [t]
splitCamel = map fromList . reverse . helper (error "hasChange undefined at start of string") [] "" . otoList
  where
    helper _hadChange items thisWord [] = reverse thisWord : items
    helper _hadChange items [] (c:cs) = helper True items [c] cs
    helper  hadChange items ws@(w:ws') (c:cs)
      | sameCategory w c
      , null ws'         = helper (Char.isLower w || Char.isDigit w) items (c:ws) cs
      | sameCategory w c = helper hadChange items (c:ws) cs
      | Char.isLower w
      , Char.isUpper c   = helper True (reverse ws :items) [c] cs
      | null ws'         = helper True items (c:ws) cs
      | not hadChange    = helper True (reverse ws':items) [c,w] cs
      | otherwise        = helper True (reverse ws :items) [c] cs

    sameCategory = (==) `on` Char.generalCategory

camelToPathPiece' :: Textual t => Natural -> t -> t
camelToPathPiece' dropN = intercalate "-" . map toLower . drop (fromIntegral dropN) . splitCamel

camelToPathPiece :: Textual t => t -> t
camelToPathPiece = camelToPathPiece' 0

nameToPathPiece' :: Textual t => Natural -> Name -> t
nameToPathPiece' dropN = camelToPathPiece' dropN . repack . nameBase

nameToPathPiece :: Textual t => Name -> t
nameToPathPiece = nameToPathPiece' 0


tuplePathPiece :: Int -> DecQ
tuplePathPiece tupleDim = do
  let
    tupleSeparator :: Text
    tupleSeparator = ","

  xs <- replicateM tupleDim $ newName "x" :: Q [Name]
  xs' <- replicateM tupleDim $ newName "x'" :: Q [Name]

  let tupleType = foldl appT (tupleT tupleDim) $ map varT xs
      tCxt = cxt
        [ [t|PathPiece $(varT x)|] | x <- xs ]

  t <- newName "t"

  instanceD tCxt [t|PathPiece $(tupleType)|]
    [ funD 'toPathPiece
      [ clause [tupP $ map varP xs] (normalB [e|Text.intercalate tupleSeparator $(listE $ map (appE [e|toPathPiece|] . varE) xs)|]) []
      ]
    , funD 'fromPathPiece
      [ clause [varP t] (normalB . doE $ concat
                         [ pure $ bindS (listP $ map varP xs) [e|return $ Text.splitOn tupleSeparator $(varE t)|]
                         , [ bindS (varP x') [e|fromPathPiece $(varE x)|] | (x, x') <- zip xs xs' ]
                         , pure $ noBindS [e|return $(tupE $ map varE xs')|]
                         ]) []
      ]
    ]


pathPieceJSONKey :: Name -> DecsQ
-- ^ Derive `ToJSONKey`- and `FromJSONKey`-Instances from a `PathPiece`-Instance
pathPieceJSONKey tName
  = [d| instance ToJSONKey $(conT tName) where
          toJSONKey = toJSONKeyText toPathPiece
        instance FromJSONKey $(conT tName) where
          fromJSONKey = FromJSONKeyTextParser $ \t -> maybe (fail $ "Could not parse ‘" <> unpack t <> "’ as value for " <> $(TH.lift $ nameBase tName) <> " via PathPiece") return $ fromPathPiece t
      |]

pathPieceJSON :: Name -> DecsQ
-- ^ Derive `ToJSON`- and `FromJSON`-Instances from a `PathPiece`-Instance
pathPieceJSON tName
  = [d| instance ToJSON $(conT tName) where
          toJSON = Aeson.String . toPathPiece
        instance FromJSON $(conT tName) where
          parseJSON = Aeson.withText $(TH.lift $ nameBase tName) $ \t -> maybe (fail $ "Could not parse ‘" <> unpack t <> "’ as value for " <> $(TH.lift $ nameBase tName) <> " via PathPiece") return $ fromPathPiece t
      |]

pathPieceBinary :: Name -> DecsQ
pathPieceBinary tName
  = [d| instance Binary $(conT tName) where
          get = Binary.get >>= maybe (fail $ "Could not parse value of " <> $(TH.lift $ nameBase tName) <> " via PathPiece") return . fromPathPiece
          put = Binary.put . toPathPiece
      |]

pathPieceHttpApiData :: Name -> DecsQ
pathPieceHttpApiData tName
  = [d| instance ToHttpApiData $(conT tName) where
          toUrlPiece = toPathPiece
        instance FromHttpApiData $(conT tName) where
          parseUrlPiece = maybe (Left $ "Could not parse value of " <> $(TH.lift $ nameBase tName) <> " via PathPiece") Right . fromPathPiece
      |]
