{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RankNTypes #-}

module Database.NySQL.TH

  ( mkStmt
  , mkQuery

  , mkStmt'
  , mkQuery'

  , ToRow
  , toRow

  , FromRow
  , fromRow

  , SqlStmt
  , runStmt

  , SqlQuery
  , runQuery

  ) where

import Text.Regex
import Data.Tuple (swap)
import Data.Char (toUpper, toLower)
import Data.List
import Data.Maybe
import Data.Convertible
import Database.HDBC
import Database.NySQL.Options
import System.FilePath
import Control.Lens
import Control.Monad ((>=>), (<=<))
import Control.Monad.Catch (MonadThrow)
import Control.Monad.Trans (MonadIO, liftIO)
import Language.Haskell.TH
import Language.Haskell.TH.Quote
import Language.Haskell.TH.Syntax

class FromRow a where
  fromRow :: MonadThrow m => [(String, SqlValue)] -> m a

class ToRow a where
  toRow :: a -> [(String, SqlValue)]

instance FromRow [(String, SqlValue)] where
  fromRow = pure

instance ToRow [(String, SqlValue)] where
  toRow = id

class SqlStmt a where
  runStmt :: forall c m. (IConnection c, MonadIO m, MonadThrow m)
         => c -> a -> m Integer

class SqlQuery a where
  runQuery :: forall c m r. (IConnection c, MonadIO m, MonadThrow m, FromRow r)
         => c -> a -> m [r]

data SqlType
    = Stmt
    | Query

mkStmt :: Options -> FilePath -> Q [Dec]
mkStmt = mkSql (Nothing :: Maybe (IO ConnWrapper)) Stmt

mkStmt' :: (IConnection c, Monad m) => m c -> Options -> FilePath -> Q [Dec]
mkStmt' gc = mkSql (Just gc) Stmt

mkQuery :: Options -> FilePath -> Q [Dec]
mkQuery = mkSql (Nothing :: Maybe (IO ConnWrapper)) Query

mkQuery' :: (IConnection c, Monad m) => m c -> Options -> FilePath -> Q [Dec]
mkQuery' gc = mkSql (Just gc) Query

mkSql :: (IConnection c, Monad m) => Maybe (m c) -> SqlType -> Options -> FilePath -> Q [Dec]
mkSql maybeGetConnection sqlType opts filepath = do

    query <- runIO $ readFile filepath
    nameDum <- newName "dummy"

    let typeName = parseTypeName filepath
        paramPrefix = parseParamPrefix filepath
        className = parseClassName filepath
        classFnName = parseClassFnName filepath
        fnName = parseFnName filepath
        params = (nameDum, "dummy") : fmap (\p -> (mkName (paramModifier opts $ paramPrefix ++ (p & ix 0 %~ toUpper)), p)) (parseParamStrings query)

    (rs, ns, ss) <- fmap unzip3 $ (`mapM` nub params) $ \(pn, ps) -> do
                      pn' <- newName ps
                      pure (pure (pn, NotStrict, VarT pn'), pn', ps)

    let vs = PlainTV <$> ns
        eqRecords (a,_,_) (b,_,_) = a == b
        con = mkName "con"

    sequence

      [ dataD (cxt []) typeName vs [recC typeName (tail rs)] []

      , let tvb = mkName "a"
        in classD
             (cxt [])
             className
             [PlainTV tvb]
             []
             [ sigD classFnName
                 (forallT
                    vs
                    ((`mapM` ns) (\n ->
                      appT
                        (appT
                          (conT ''Convertible)
                          (varT n))
                        (conT ''SqlValue)))
                    [t| $(varT tvb) -> $(foldl appT (conT typeName) (varT <$> ns))|]) ]

      , instanceD

          ((`mapM` (tail ns)) (\n ->

            appT
             (appT
               (conT ''Convertible)
               (varT n))

             (conT ''SqlValue)))

          (appT
           (conT $ mkName $ case sqlType of
              Stmt -> "SqlStmt"
              Query -> "SqlQuery")
            (foldl appT (conT typeName) (varT <$> ns)))

          [funD

             (mkName (case sqlType of
                Stmt -> "runStmt"
                Query -> "runQuery"))

             [ let cv = mkName "cv"
               in clause []
                   (normalB
                    (lamE
                     [varP con, varP cv]
                     (let fns = tail $ fmap (\s -> (s, appE (varE $ mkName (paramModifier opts $ paramPrefix ++ (s & ix 0 %~ toUpper))))) ss
                          vals = listE (fmap (\(s, f) -> tupE [litE (StringL s), appE (varE 'toSql) (f (varE cv))]) fns)
                      in case sqlType of
                        Stmt ->
                          [| liftIO (withTransaction $(varE con) (\con' -> do
                              stmt <- prepare con' $ replaceQs query
                              i <- execute stmt $ sortVals query $ toRow $vals
                              pure i)) |]
                        Query ->
                          [| liftIO (withTransaction $(varE con) (\con' -> do
                              stmt <- prepare con' $ replaceQs query
                              execute stmt $ sortVals query $ toRow $vals
                              mapM fromRow =<< fetchAllRowsAL stmt)) |]))) [] ]] ]

parseBaseName :: FilePath -> String
parseBaseName = (ix 0 %~ toUpper) . dropExtension . takeFileName

parseTypeName :: FilePath -> Name
parseTypeName = mkName . parseBaseName

parseParamPrefix :: FilePath -> String
parseParamPrefix = (ix 0 %~ toLower) . parseBaseName

parseClassName :: FilePath -> Name
parseClassName = mkName . ("Can"++) . parseBaseName

parseClassFnName :: FilePath -> Name
parseClassFnName = mkName . ("to"++) . parseBaseName

parseFnName :: FilePath -> Name
parseFnName = mkName . (ix 0 %~ toLower) . parseBaseName

parseParamStrings :: String -> [String]
parseParamStrings str =
    concatMap (findMatches $ mkRegex "[^:]+")
              (findMatches paramRegex str)

replaceQs :: String -> String
replaceQs s = subRegex paramRegex s "?"

sortVals :: String -> [(String, SqlValue)] -> [SqlValue]
sortVals str vs = catMaybes $ (`lookup` vs) <$> parseParamStrings str

paramRegex :: Regex
paramRegex = mkRegex "[:][[:alnum:]_-][[:alnum:]_-]*"

findMatches :: Regex -> String -> [String]
findMatches r s = maybe [] (\(_,m,s',_) -> m : findMatches r s')
                           (matchRegexAll r s)
