module Model.Types.TH.PathPiece
  ( derivePersistFieldPathPiece
  , derivePersistFieldPathPiece'
  ) where

import ClassyPrelude.Yesod
import Data.List (foldl)
import Database.Persist.Sql

import qualified Data.Text.Encoding as Text

import Language.Haskell.TH
import Language.Haskell.TH.Datatype


derivePersistFieldPathPiece :: Name -> DecsQ
derivePersistFieldPathPiece = derivePersistFieldPathPiece' SqlString

derivePersistFieldPathPiece' :: SqlType -> Name -> DecsQ
derivePersistFieldPathPiece' sType tName = do
  DatatypeInfo{..} <- reifyDatatype tName
  vars <- forM datatypeVars (const $ newName "a")
  let t = foldl (\t' n' -> t' `appT` varT n') (conT tName) vars
      iCxt
        | null vars = cxt []
        | otherwise = cxt [[t|PathPiece|] `appT` t]
      sqlCxt
        | null vars = cxt []
        | otherwise = cxt [[t|PersistField|] `appT` t]
  sequence
    [ instanceD iCxt ([t|PersistField|] `appT` t)
      [ funD 'toPersistValue
        [ clause [] (normalB [e|PersistText . toPathPiece|]) []
        ]
      , funD 'fromPersistValue
        [ do
            bs <- newName "bs"
            clause [[p|PersistByteString $(varP bs)|]] (normalB [e|maybe (Left "Could not decode PathPiece from PersistByteString") Right $ fromPathPiece =<< either (const Nothing) Just (Text.decodeUtf8' $(varE bs))|]) []
        , do
            bs <- newName "bs"
            clause [[p|PersistLiteralEscaped $(varP bs)|]] (normalB [e|maybe (Left "Could not decode PathPiece from PersistLiteralEscaped") Right $ fromPathPiece =<< either (const Nothing) Just (Text.decodeUtf8' $(varE bs))|]) []
        , do
            text <- newName "text"
            clause [[p|PersistText $(varP text)|]] (normalB [e|maybe (Left "Could not decode PathPiece from PersistText") Right $ fromPathPiece $(varE text)|]) []
        , clause [wildP] (normalB [e|Left "PathPiece values must be converted from PersistText, PersistByteString, or PersistLiteralEscaped"|]) []
        ]
      ]
    , instanceD sqlCxt ([t|PersistFieldSql|] `appT` t)
      [ funD 'sqlType
        [ clause [wildP] (normalB [e|sType|]) []
        ]
      ]
    ]

