-- This file is part of HamSql
--
-- Copyright 2014 by it's authors.
-- Some rights reserved. See COPYING, AUTHORS.
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}

module Database.HamSql.Setup where

import Data.Typeable
import Data.Yaml

import Database.HamSql.Internal.Utils
import Database.YamSql
import Database.YamSql.Parser
import Database.HamSql.Internal.Stmt

data SetupContext = SetupContext
  { setupContextSetup :: Setup
  }

data SetupElement where SetupElement :: (ToSqlStmts a, Show b) => { setupElement :: a
    , setupElementSource :: Maybe b
    } -> SetupElement

instance ToSqlStmts SetupElement where
    toSqlStmts x SetupElement{setupElement=y} = toSqlStmts x y

class (Typeable a) => ToSqlStmts a where
    toSqlStmts :: SetupContext -> a -> [Maybe SqlStmt]

-- | Setup
data Setup = Setup
  { setupSchemas :: [SqlName]
  , setupSchemaDirs :: Maybe [FilePath]
  , setupRolePrefix :: Maybe Text
  , setupPreCode :: Maybe Text
  , setupPostCode :: Maybe Text
  , setupSchemaData :: Maybe [Schema]
  } deriving (Generic, Show, Data)

instance FromJSON Setup where
  parseJSON = parseYamSql

instance ToJSON Setup where
  toJSON = toYamSqlJson

setupRolePrefix' :: Setup -> Text
setupRolePrefix' setup = fromMaybe "yamsql_" (setupRolePrefix setup)

-- | Template handling and applyTemplate
data WithSchema a =
  WithSchema Schema
             a
  deriving (Show)

class WithName a  where
  name :: a -> Text

instance WithName (WithSchema TableTpl) where
  name (WithSchema m t) = toSqlCode $ schemaName m <.> tabletplTemplate t

instance WithName (WithSchema FunctionTpl) where
  name (WithSchema m f) = toSqlCode $ schemaName m <.> functiontplTemplate f

withoutSchema :: WithSchema a -> a
withoutSchema (WithSchema _ t) = t

selectTemplates :: (ToSqlCode a, WithName (WithSchema t)) =>
                         Maybe [a] -> [WithSchema t] -> [t]
selectTemplates ns ts
                   -- TODO: error handling here should be done using exceptions
 =
  [ withoutSchema $
   selectUniqueReason ("table or function tpl " <> n) $
   filter (\t -> n == name t) ts
  | n <- maybeMap toSqlCode ns ]

selectTemplate :: (ToSqlCode a1, WithName (WithSchema a)) =>
                        a1 -> [WithSchema a] -> a
selectTemplate x ts =
  head' $ map withoutSchema $ filter (\y -> name y == toSqlCode x) ts
  where
    head' = selectUniqueReason ("Column template " <> toSqlCode x)

-- get things from Setup
setupAllSchemas :: Setup -> [Schema]
setupAllSchemas = fromMaybe [] . setupSchemaData

setupAllFunctionTemplates :: Setup -> [WithSchema FunctionTpl]
setupAllFunctionTemplates s =
  concat
    [ maybeMap (WithSchema m) (schemaFunctionTemplates m)
    | m <- setupAllSchemas s ]

setupAllTableTemplates :: Setup -> [WithSchema TableTpl]
setupAllTableTemplates s =
  concat
    [ maybeMap (WithSchema m) (schemaTableTemplates m)
    | m <- setupAllSchemas s ]



applyTpl :: Setup -> Setup
applyTpl s =
  s
  -- TODO: possible overwrite here!
  { setupSchemaData = Just $ maybeMap applySchema (setupSchemaData s)
  }
  where
    applySchema m =
      m
      { schemaTables =
        Just $
        maybeMap applyTableTemplates (schemaTables m)
      , schemaFunctions =
        Just $ maybeMap applyFunctionTemplates (schemaFunctions m)
      }
    applyTableTemplates :: Table -> Table
    applyTableTemplates t = foldr applyTableTpl t (tableTpls t)
    tableTpls :: Table -> [TableTpl]
    tableTpls t = selectTemplates (tableTemplates t) (setupAllTableTemplates s)
    applyFunctionTemplates :: Function -> Function
    applyFunctionTemplates f = foldr applyFunctionTpl f (functionTpls f)
    functionTpls :: Function -> [FunctionTpl]
    functionTpls f =
      selectTemplates (functionTemplates f) (setupAllFunctionTemplates s)