module Utils.PathPiece
  ( finiteFromPathPiece
  , nullaryToPathPiece
  , nullaryPathPiece, finitePathPiece
  , splitCamel
  , camelToPathPiece, camelToPathPiece'
  , tuplePathPiece
  , pathPieceJSONKey
  ) where

import ClassyPrelude.Yesod

import Language.Haskell.TH
import qualified Language.Haskell.TH.Syntax as TH (Lift(..))
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 Numeric.Natural

import Data.List (foldl)

import Data.Aeson.Types
  

finiteFromPathPiece :: (PathPiece a, Finite a) => Text -> Maybe a
finiteFromPathPiece text = case filter (\c -> toPathPiece c == text) universeF of
  [x] -> Just x
  _xs -> Nothing

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

nullaryPathPiece :: Name -> (Text -> Text) -> DecsQ
nullaryPathPiece nullaryType mangle =
  pure <$> instanceD (cxt []) [t|PathPiece $(conT nullaryType)|]
    [ funD 'toPathPiece
      [ clause [] (normalB $ nullaryToPathPiece nullaryType mangle) [] ]
    , funD 'fromPathPiece
      [ clause [] (normalB [e|finiteFromPathPiece|]) [] ]
    ]

finitePathPiece :: Name -> [Text] -> DecsQ
finitePathPiece finiteType verbs =
  pure <$> instanceD (cxt []) [t|PathPiece $(conT finiteType)|]
    [ funD 'toPathPiece
      [ clause [] (normalB [|(Map.fromList (zip universeF verbs) !)|]) [] ]
    , funD 'fromPathPiece
      [ clause [] (normalB [e|(Map.fromList (zip verbs universeF) !?)|]) [] ]
    ]
  
  
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) 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


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