module Utils.PathPiece
  ( nullaryToPathPiece', nullaryToPathPiece
  , nullaryPathPiece', nullaryPathPiece, finitePathPiece
  , splitCamel
  , camelToPathPiece, camelToPathPiece'
  , nameToPathPiece, nameToPathPiece'
  , tuplePathPiece
  , pathPieceJSON, pathPieceJSONKey
  , pathPieceBinary
  ) 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 qualified Data.HashMap.Strict as HashMap

import Numeric.Natural

import Data.List (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
  

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

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