-- | Functions that help generate Beam schema at compile time.
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell   #-}
module Frames.SQL.Beam.Postgres.BeamSchemaGen (
  genBeamSchema,
  genBeamSchemaForTests,
  getCode
) where

import qualified Data.ByteString                as B
import qualified Data.Text                      as T
import           Database.Beam.Migrate.Simple   (haskellSchema)
import           Database.Beam.Postgres         (runBeamPostgres)
import           Database.Beam.Postgres.Migrate (migrationBackend)
import qualified Database.PostgreSQL.Simple     as Pg
import           Language.Haskell.TH
import           System.Process

data FolderName = Src | Test

instance Show FolderName where
  show Src  = "src"
  show Test = "test"

go :: B.ByteString -> FolderName -> Q String
go connString folder = do
  _ <- runIO $ readCreateProcess (shell ("touch " ++ (show folder) ++ "/NewBeamSchema.hs")) ""
  code <- runIO $ getCode connString
  return code

genBeamSchemaHelper :: B.ByteString -> FolderName -> Q [Dec]
genBeamSchemaHelper str folder = do
  code <-  go str folder
  _ <- runIO $ readCreateProcess (shell ("echo " ++ (show code) ++ " > " ++ (show folder) ++ "/NewBeamSchema.hs")) ""
  [d| id x = x |]

-- | Takes code generated by @getCode@ and puts it in a file named
-- "NewBeamSchema.hs" in the 'src' directory (relative to your project's root)
--  at compile time.
genBeamSchema :: B.ByteString -> Q [Dec]
genBeamSchema str = genBeamSchemaHelper str Src

-- | Takes code generated by @getCode@ and puts it in a file named
-- "NewBeamSchema.hs" in the 'test' directory (relative to your project's root)
--  at compile time. Used internally in the test suite.
genBeamSchemaForTests :: B.ByteString -> Q [Dec]
genBeamSchemaForTests str = genBeamSchemaHelper str Test

-- | Generates Beam code for a schema corresponding to the postgres
--  database referred to in the connection string.
getCode :: B.ByteString -> IO String
getCode connString = do
  conn <- Pg.connectPostgreSQL connString
  codeString <- runBeamPostgres conn (haskellSchema migrationBackend)
  return $ sanitizeCode codeString

-- | Edits code at the Text level to bring it into a form that compiles.
sanitizeCode :: String -> String
sanitizeCode str =
  addExts ++ (T.unpack moduleNameAndImports) ++ addImports ++ (T.unpack beforeMigrationTySig) ++
    "\nmigration :: Migration PgCommandSyntax (CheckedDatabaseSettings Postgres Db)\n" ++
    (T.unpack includeThisChunk) ++
    "\ndb :: DatabaseSettings Postgres Db\ndb = unCheckDatabase (runMigrationSilenced (migration))\n"
  where
    txt = T.pack str
    (_exts, remainingCode) = T.breakOn "module" txt
    (moduleNameAndImports, rest) = T.breakOn "data" remainingCode
    (beforeMigrationTySig, afterIncludingMigrationTySig) = T.breakOn "migration ::" rest
    (_migrationTySig, afterIncludingMigrationDecl) = T.breakOn "migration\n  =" afterIncludingMigrationTySig
    (includeThisChunk, _discardThisChunk) = T.breakOn "db ::" afterIncludingMigrationDecl

addExts :: String
addExts =
  "{-# LANGUAGE StandaloneDeriving    #-}\n" ++
    "{-# LANGUAGE DeriveGeneric         #-}\n" ++
    "{-# LANGUAGE ExplicitNamespaces    #-}\n" ++
    "{-# LANGUAGE FlexibleContexts      #-}\n" ++
    "{-# LANGUAGE FlexibleInstances     #-}\n" ++
    "{-# LANGUAGE GADTs                 #-}\n" ++
    "{-# LANGUAGE MultiParamTypeClasses #-}\n" ++
    "{-# LANGUAGE OverloadedStrings     #-}\n" ++
    "{-# LANGUAGE ScopedTypeVariables   #-}\n" ++
    "{-# LANGUAGE StandaloneDeriving    #-}\n" ++
    "{-# LANGUAGE TypeFamilies          #-}\n" ++
    "{-# LANGUAGE TypeSynonymInstances  #-}\n"


addImports :: String
addImports =
  "import           Database.Beam.Postgres\n\n\n"