TH.hs

{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
{-# LANGUAGE AllowAmbiguousTypes        #-}
{-# LANGUAGE DataKinds                  #-}
{-# LANGUAGE DuplicateRecordFields      #-}
{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE GADTs                      #-}
{-# LANGUAGE InstanceSigs               #-}
{-# LANGUAGE MultiParamTypeClasses      #-}
{-# LANGUAGE PolyKinds                  #-}
{-# LANGUAGE Rank2Types                 #-}
{-# LANGUAGE TypeFamilies               #-}
{-# LANGUAGE TypeOperators              #-}
{-# LANGUAGE TypeApplications           #-}
{-# LANGUAGE UndecidableInstances       #-}
{-# LANGUAGE UndecidableSuperClasses    #-}
module Internal.Data.Basic.TH (mkFromFile, mkFromFiles, printToFile) where

import           Control.Monad                 (fail)
import           Internal.Interlude            hiding (Type)
import           Language.Haskell.TH           hiding (Name)
import qualified Language.Haskell.TH.Syntax    as TH
import           System.FilePath.Lens

import           Control.Effects.Signal
import           Internal.Data.Basic.TH.Types
import           Internal.Data.Basic.TH.Compiler
import           Internal.Data.Basic.TH.Generator (schemaValue)

-- | Generates haskell code from an SQL file.
mkFromFile :: FilePath -> Q [Dec]
mkFromFile filename = do
  TH.addDependentFile filename
  eStatements <- compileSQL $ toS filename
  case eStatements of
    Left (ParseError e) -> runIO.fail $ toS e
    Right statements -> do
      r <- runIO $ handleToEither @ParseError $ compileSQLStatements mempty statements
      case r of
        Left (ParseError e) -> runIO.fail $ toS e -- actually a compile error
        Right context -> do
          ctx <- compileContext context
          schemaTxt <- runIO $ readFile filename
          return (ctx <> schemaValue (toS $ filename ^. basename) schemaTxt)


-- MonadIO Identity
-- | Generates haskell code from multiple SQL files.
mkFromFiles :: [FilePath] -> Q [Dec]
mkFromFiles filenames = do
  _ <- sequence $ TH.addDependentFile <$> filenames
  res <- sequence $ compileSQL.toS <$> filenames
  let eStatements = concat <$> sequence res
  case eStatements of
    Left (ParseError e) -> runIO.fail $ toS e
    Right statements -> do
      r <- (runIO $ handleToEither @ParseError $ compileSQLStatements mempty statements)
      case r of
        Left (ParseError e) -> runIO.fail $ toS e -- actually a compile error
        Right context -> runQ $ compileContext context

-- | Allows you to print generated template haskell code to a file
printToFile :: [FilePath] -> FilePath -> Q [Dec]
printToFile filenames filenameOut = do
  res <- sequence $ compileSQL.toS <$> filenames
  let eStatements = concat <$> sequence res
  case eStatements of
    Left (ParseError e) -> runIO.fail $ toS e
    Right statements -> do
      r <- (runIO $ handleToEither @ParseError $ compileSQLStatements mempty statements)
      case r of
        Left (ParseError e) -> runIO.fail $ toS e -- actually a compile error
        Right context -> runQ $ do
          r <- compileContext context
          let out = concatMap (<> "\n\n") $ pprint <$> r
          runIO $ writeFile filenameOut $ toS out
          return []