{-# 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 Control.Effects.Signal
import Internal.Data.Basic.TH.Types
import Internal.Data.Basic.TH.Compiler
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
Right context -> runQ $ compileContext context
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
Right context -> runQ $ compileContext context
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
Right context -> runQ $ do
r <- compileContext context
let out = concatMap (<> "\n\n") $ pprint <$> r
runIO $ writeFile filenameOut $ toS out
return []