module Utils.PathPiece
  ( finiteFromPathPiece
  , nullaryToPathPiece
  , nullaryPathPiece
  , splitCamel
  , camelToPathPiece, camelToPathPiece'
  ) 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 Numeric.Natural

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