hasql-check-ghc (empty) → 0.5.0.0
raw patch · 9 files changed
+1128/−0 lines, 9 filesdep +basedep +bytestringdep +containers
Dependencies added: base, bytestring, containers, directory, filepath, ghc, hasql-check, hasql-check-ghc, process, temporary, text
Files
- ChangeLog.md +8/−0
- LICENSE +28/−0
- README.md +50/−0
- app/Main.hs +136/−0
- hasql-check-ghc.cabal +113/−0
- src/Hasql/Check/Ghc/Source.hs +267/−0
- src/Hasql/Check/Plugin.hs +193/−0
- test/Main.hs +85/−0
- test/Plugin.hs +248/−0
+ ChangeLog.md view
@@ -0,0 +1,8 @@+# Changelog++## 0.5.0.0++Initial release, alongside `hasql-check` 0.5.0.0: `Hasql.Check.Plugin`, a GHC+plugin that checks the statements of `Hasql.Check.Inferred.TH` against a+database while their module compiles, and `hasql-check-hie`, which reads their+types from GHC's `.hie` files for `hasql-check --inferred`.
+ LICENSE view
@@ -0,0 +1,28 @@+BSD 3-Clause License++Copyright (c) 2021-2026, Kronor++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++1. Redistributions of source code must retain the above copyright notice, this+ list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright notice,+ this list of conditions and the following disclaimer in the documentation+ and/or other materials provided with the distribution.++3. Neither the name of the copyright holder nor the names of its+ contributors may be used to endorse or promote products derived from+ this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"+AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,+OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,50 @@+# hasql-check-ghc++The GHC half of [hasql-check](https://hackage.haskell.org/package/hasql-check).++`Hasql.Check.Inferred.TH`'s quoters take no annotations: a statement's+parameter and result types come from the Haskell type it is used at. GHC only+knows those types once it has type-checked the module, which is after the+quoter ran, so this package gets them from GHC itself:++- **`Hasql.Check.Plugin`**, a GHC plugin that checks each statement against a+ database while its module compiles. Add it to the package that holds the+ statements:++ ```+ build-depends: hasql-check-ghc+ ghc-options: -fplugin=Hasql.Check.Plugin+ ```++ and set `HASQL_CHECK_DATABASE_URL`. A statement that does not fit the schema+ is then a compile error at its quote. Without the variable nothing is+ checked; if the database cannot be reached the plugin says so once and the+ build carries on.++- **`hasql-check-hie`**, which reads the same types out of the `.hie` files GHC+ writes with `-fwrite-ide-info`, for `hasql-check --inferred`:++ ```+ $ cabal build --ghc-options='-fwrite-ide-info -hiedir=.hie'+ $ hasql-check-hie $(find .hie -name '*.hie') > statements.jsonl+ $ hasql-check --inferred statements.jsonl --nullability --types+ ```++ It needs no database, so it can run inside a sandboxed build, such as a Nix+ derivation, with only the checking step outside it.++Both use GHC's own library, whose internals change with each release, so this+package supports the series it has been built against — currently **GHC 9.12+and 9.14**. Build it with the GHC the checked project is built with.++The full documentation, including everything the checks report, is in the+[main README](https://github.com/kronor-io/hasql-check#readme).++## Development++`cabal test` compiles fixture modules with GHC itself, against a throwaway+PostgreSQL server, so `initdb`, `pg_ctl` and `psql` must be on `PATH`. The+compiler finds the plugin through the package environment cabal writes+(`write-ghc-environment-files: always`, in the project's `cabal.project`), so+run the tests from a checkout of the whole repository rather than from this+directory's sdist.
+ app/Main.hs view
@@ -0,0 +1,136 @@+-- |+-- Module : Main+-- Copyright : (c) 2026 Kronor.io+--+-- License : BSD-3-Clause+-- Maintainer : lorenzo@kronor.io+-- Stability : experimental+-- Portability : GHC+--+-- Print, for every quote of "Hasql.Check.Inferred.TH" in the given .hie+-- files, the types GHC instantiated its statement at, one JSON object a line:+--+-- > {"file":"src/Shop.hs","line":14,"column":11,"quoter":"maybeStatement",+-- > "sql":"...","params":[{"type":"GHC.Internal.Int.Int64","nullable":false}],+-- > "row":[...]}+--+-- for @hasql-check --inferred@. The quote's own span holds the nodes of the+-- code it generated, typed where it is used, even when the statement is an+-- argument with no signature of its own. @row@ is null for a statement+-- returning no rows.+--+-- The .hie format changes with each GHC release: build this with the GHC the+-- project is built with.+module Main where++import Control.Monad (unless)+import Data.Char (ord)+import Data.List (intercalate)+import Data.Map qualified as Map+import Data.Text qualified as Text+import Data.Text.Encoding qualified as Text+import GHC.Data.FastString (getLexicalFastString, unpackFS)+import GHC.Iface.Ext.Binary (HieFileResult (..), readHieFile)+import GHC.Iface.Ext.Types+import GHC.Iface.Ext.Utils (recoverFullType)+import GHC.Iface.Type (IfaceTyCon (..), IfaceTyLit (..))+import GHC.Types.Name (Name, nameModule_maybe, nameOccName)+import GHC.Types.Name.Cache (initNameCache)+import GHC.Types.Name.Occurrence (occNameString)+import GHC.Types.SrcLoc (srcSpanEndCol, srcSpanEndLine, srcSpanStartCol, srcSpanStartLine)+import GHC.Unit.Module (moduleName, moduleNameString)+import Hasql.Check.Ghc.Source (Column (..), Quote (..), Statement (..), Ty (..), statementAt)+import System.Environment (getArgs)+import System.Exit (exitFailure)+import System.IO (hPutStrLn, stderr)+import Text.Printf (printf)+++main :: IO ()+main = do+ files <- getArgs+ nc <- initNameCache 'z' []+ errors <- concat <$> mapM (dump nc) files+ mapM_ (hPutStrLn stderr) errors+ unless (null errors) exitFailure+ where+ dump nc path = do+ result <- readHieFile nc path+ let hf = hie_file_result result+ toTy = convert . flip recoverFullType (hie_types hf)+ found = Map.fromListWith (flip (<>)) [(s, [t]) | (s, t) <- concatMap (collect toTy) (Map.elems (getAsts (hie_asts hf)))]+ source = lines (Text.unpack (Text.decodeUtf8Lenient (hie_hs_src hf)))+ concat+ <$> mapM+ ( \(s, here) ->+ -- The enclosing declarations hold the same dictionaries,+ -- but only the quote's own span starts after "[quoter|".+ case statementAt source (srcSpanStartLine s, srcSpanStartCol s) (srcSpanEndLine s, srcSpanEndCol s) here of+ Nothing -> pure []+ Just (Right statement) -> [] <$ putStrLn (output (hie_hs_file hf) statement)+ Just (Left err) -> pure [hie_hs_file hf <> ":" <> show (srcSpanStartLine s) <> ":" <> show (srcSpanStartCol s) <> ": " <> err]+ )+ (Map.toList found)++ collect toTy node =+ -- The dictionaries the generated code passes are identifiers of the+ -- quote's node, typed by the instance GHC chose.+ let infos = Map.elems (getSourcedNodeInfo (sourcedNodeInfo node))+ here =+ [(nodeSpan node, toTy t) | info <- infos, t <- nodeType info]+ <> [(nodeSpan node, toTy t) | info <- infos, (Right _, details) <- Map.toList (nodeIdentifiers info), Just t <- [identType details]]+ in here <> concatMap (collect toTy) (nodeChildren node)+++-- | One statement's line of output.+output :: FilePath -> Statement -> String+output file statement =+ object+ [ ("file", string file)+ , ("line", show statement.line)+ , ("column", show statement.quote.column)+ , ("quoter", string statement.quote.quoter)+ , ("sql", string statement.quote.body)+ , ("params", columns statement.params)+ , ("row", maybe "null" columns statement.row)+ ]+ where+ columns cs = "[" <> intercalate "," (map column cs) <> "]"+ column c =+ object+ [ ("type", string c.haskellType)+ , ("postgres", string c.postgres)+ , ("labels", "[" <> intercalate "," (map string c.labels) <> "]")+ , ("nullable", if c.nullable then "true" else "false")+ ]+++convert :: HieTypeFix -> Ty+convert (Roll t) = case t of+ HTyConApp tc (HieArgs args) -> uncurry Con (names (ifaceTyConName tc)) [convert a | (True, a) <- args]+ HQualTy _ b -> convert b+ HForAllTy _ b -> convert b+ HCastTy a -> convert a+ HLitTy (IfaceStrTyLit s) -> Lit (unpackFS (getLexicalFastString s))+ HLitTy (IfaceNumTyLit n) -> OtherLit (show n)+ HLitTy (IfaceCharTyLit c) -> OtherLit (show c)+ _ -> Var+ where+ names :: Name -> (String, String)+ names n = (maybe "" (moduleNameString . moduleName) (nameModule_maybe n), occNameString (nameOccName n))+++object :: [(String, String)] -> String+object fields = "{" <> intercalate "," [string k <> ":" <> v | (k, v) <- fields] <> "}"+++string :: String -> String+string s = "\"" <> concatMap escape s <> "\""+ where+ escape = \case+ '"' -> "\\\""+ '\\' -> "\\\\"+ '\n' -> "\\n"+ '\t' -> "\\t"+ c | ord c < 0x20 -> printf "\\u%04x" (ord c)+ c -> [c]
+ hasql-check-ghc.cabal view
@@ -0,0 +1,113 @@+cabal-version: 3.0+name: hasql-check-ghc+version: 0.5.0.0+synopsis:+ Check inferred hasql statements with what GHC knows of their types++description:+ The types of a statement of Hasql.Check.Inferred.TH are only known once GHC+ has type-checked its module. This package gets them from GHC in two ways:+ .+ * Hasql.Check.Plugin, a GHC plugin that checks the statements against a+ database while their module compiles, making a statement that does not+ fit the schema a compile error at its quote.+ .+ * hasql-check-hie, which reads them from the .hie files GHC writes with+ -fwrite-ide-info, for hasql-check --inferred. It needs no database, so it+ can run inside a sandboxed build.+ .+ Both depend on GHC's own library: build them with the GHC the checked+ project is built with.++category: Database, Development+homepage: https://github.com/kronor-io/hasql-check+bug-reports: https://github.com/kronor-io/hasql-check/issues+license: BSD-3-Clause+license-file: LICENSE+author: Pranay Sashank, Jose Lorenzo Rodriguez+maintainer: lorenzo@kronor.io, pranay.sashank@kronor.io+copyright: 2026 Kronor+build-type: Simple+tested-with: GHC ==9.12.4 || ==9.14.1+extra-doc-files:+ ChangeLog.md+ README.md++source-repository head+ type: git+ location: https://github.com/kronor-io/hasql-check+ subdir: ghc++flag lint+ description: lint+ manual: True+ default: False++common warnings+ default-language: GHC2021+ default-extensions:+ BlockArguments+ DerivingStrategies+ LambdaCase+ OverloadedRecordDot++ ghc-options:+ -Wall -Wcompat -Widentities -Wincomplete-record-updates+ -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints++ if flag(lint)+ ghc-options: -Werror++library+ import: warnings+ exposed-modules:+ Hasql.Check.Ghc.Source+ Hasql.Check.Plugin++ hs-source-dirs: src+ build-depends:+ , base >=4.21 && <4.23+ , bytestring >=0.11 && <0.13+ , ghc >=9.12 && <9.15+ , hasql-check >=0.5 && <0.6+ , text >=2.0 && <2.2++executable hasql-check-hie+ import: warnings+ main-is: Main.hs+ hs-source-dirs: app++ -- 9.14 deprecates initNameCache in favour of a newNameCache that takes no+ -- arguments and does not exist in 9.12. Drop this with 9.12.+ ghc-options: -Wno-deprecations+ build-depends:+ , base >=4.21 && <4.23+ , containers >=0.6 && <0.9+ , ghc >=9.12 && <9.15+ , hasql-check-ghc+ , text >=2.0 && <2.2++test-suite hasql-check-ghc-test+ import: warnings+ type: exitcode-stdio-1.0+ main-is: Main.hs+ hs-source-dirs: test+ build-depends:+ , base >=4.21 && <4.23+ , hasql-check-ghc++-- Compiles fixture modules with the plugin, against a throwaway PostgreSQL+-- server: initdb, pg_ctl and psql must be on PATH, and cabal must write the+-- package environment the compiler finds the plugin through.+test-suite hasql-check-plugin-test+ import: warnings+ type: exitcode-stdio-1.0+ main-is: Plugin.hs+ hs-source-dirs: test+ build-depends:+ , base >=4.21 && <4.23+ , directory >=1.3 && <1.4+ , filepath >=1.4 && <1.6+ , hasql-check-ghc+ , process >=1.6 && <1.7+ , temporary >=1.3 && <1.4
+ src/Hasql/Check/Ghc/Source.hs view
@@ -0,0 +1,267 @@+-- |+-- Module : Hasql.Check.Ghc.Source+-- Copyright : (c) 2026 Kronor.io+--+-- License : BSD-3-Clause+-- Maintainer : lorenzo@kronor.io+-- Stability : experimental+-- Portability : GHC+--+-- A statement of "Hasql.Check.Inferred.TH", from what GHC knows of it: its+-- quote, found in its source from the span GHC gives the code it generated,+-- and its types, from the dictionaries that code is passed. Whether GHC's+-- types come from a @.hie@ file or a compiler plugin, they are read here.+--+-- GHC counts columns from 1, and a tab as reaching the next tab stop, every 8+-- columns; the source text counts characters.+module Hasql.Check.Ghc.Source (+ -- * Statements+ Statement (..),+ Column (..),+ statementAt,+ statementOf,+ typeName,++ -- * Quotes+ Quote (..),+ quoteAt,+ Types (..),+ typesOf,+ Ty (..),+ ground,+ columnTypes,+ symbols,+ labelLists,+ charIndex,+ ghcColumn,+) where++import Data.Char (isAlphaNum, isDigit)+import Data.List (intercalate)+++data Quote = Quote+ { column :: Int+ -- ^ GHC's column of the quote's opening bracket.+ , quoter :: String+ , body :: String+ }+ deriving stock (Eq, Show)+++-- | The quote a span covers, given the source's lines and the span's start+-- and end, as GHC's line and column. The span starts right after+-- @[quoter|@ and ends right after @|]@; any other span is not a quote's.+quoteAt :: [String] -> (Int, Int) -> (Int, Int) -> Maybe Quote+quoteAt source (startLine, startColumn) (endLine, endColumn) = do+ first <- line startLine+ final <- line endLine+ let start = charIndex first startColumn+ end = charIndex final endColumn - 2+ opening = take (start - 1) first+ bracket = lastIndex '[' opening+ name = drop (bracket + 1) opening+ if start >= 1+ && take 1 (drop (start - 1) first) == "|"+ && bracket >= 0+ && not (null name)+ && all (\c -> isAlphaNum c || c `elem` ("._'" :: String)) name+ then+ Just+ Quote+ { column = ghcColumn first bracket+ , quoter = name+ , body =+ if startLine == endLine+ then take (end - start) (drop start first)+ else+ intercalate "\n" $+ [drop start first]+ <> [l | n <- [startLine + 1 .. endLine - 1], Just l <- [line n]]+ <> [take end final]+ }+ else Nothing+ where+ line n+ | n >= 1, l : _ <- drop (n - 1) source = Just l+ | otherwise = Nothing+ lastIndex c s = case [i | (i, x) <- zip [0 ..] s, x == c] of+ [] -> -1+ is -> last is+++-- | What the dictionaries in a quote's span say about its statement's types.+data Types t+ = -- | Not a statement of Hasql.Check.Inferred.TH.+ NotInferred+ | -- | Its types are only known where it is used, and may differ from one+ -- use to the next.+ Unresolved+ | -- | Its parameter type, and its row type unless it returns no rows.+ Resolved t (Maybe t)+ deriving stock (Eq, Show)+++-- | The statement's types, given which types are concrete, and the types of+-- the quote's Params and Row dictionaries.+typesOf :: (t -> Bool) -> [t] -> [t] -> Types t+typesOf concrete params rows = case (filter concrete params, filter concrete rows) of+ _ | null params -> NotInferred+ ([], _) -> Unresolved+ (_, []) | not (null rows) -> Unresolved+ (p : _, r) -> Resolved p (case r of x : _ -> Just x; [] -> Nothing)+++-- | The index in a line of the character at a GHC column.+charIndex :: String -> Int -> Int+charIndex = go 0 1+ where+ go i c rest target+ | c >= target = i+ | x : xs <- rest = go (i + 1) (advance c x) xs target+ | otherwise = i+++-- | GHC's column of the character at an index in a line.+ghcColumn :: String -> Int -> Int+ghcColumn s i = foldl advance 1 (take i s)+++advance :: Int -> Char -> Int+advance c = \case+ '\t' -> ((c - 1) `div` 8 + 1) * 8 + 1+ _ -> c + 1+++-- | A type: a constructor applied to its visible arguments, by module and+-- name; a string literal, which names a Postgres type or label; another+-- literal; or something not concrete.+data Ty = Con String String [Ty] | Lit String | OtherLit String | Var+ deriving stock (Eq, Show)+++-- | Whether a type is concrete.+ground :: Ty -> Bool+ground = \case+ Var -> False+ Lit _ -> True+ OtherLit _ -> True+ Con _ _ args -> all ground args+++-- | A parameter or row type's columns, each with whether it is a 'Maybe':+-- a tuple's elements, none for unit as parameters, or the type itself.+columnTypes :: Bool -> Ty -> [(Ty, Bool)]+columnTypes isParams t = map column (split t)+ where+ split = \case+ Con m "Unit" [] | isParams, m `elem` tupleModules -> []+ Con m name args | m `elem` tupleModules, isTuple name -> args+ other -> [other]+ column = \case+ Con m "Maybe" [inner] | m `elem` maybeModules -> (inner, True)+ other -> (other, False)+++-- | Where GHC defines tuples and unit, and Maybe: a type of the same name+-- elsewhere, a newtype TupleId say, is a type of its own.+tupleModules, maybeModules :: [String]+tupleModules = ["GHC.Tuple", "GHC.Tuple.Prim"]+maybeModules = ["GHC.Internal.Maybe", "GHC.Maybe"]+++isTuple :: String -> Bool+isTuple name = case splitAt 5 name of+ ("Tuple", n) -> not (null n) && all isDigit n+ _ -> False+++-- * Statements+++-- | A statement, with what the checker needs of it.+data Statement = Statement+ { line :: Int+ , quote :: Quote+ , params :: [Column]+ , row :: Maybe [Column]+ -- ^ Nothing for a statement that returns no rows.+ }+++-- | A parameter or result column.+data Column = Column+ { haskellType :: String+ , postgres :: String+ , labels :: [String]+ -- ^ The enum's labels, if it is one.+ , nullable :: Bool+ }+++-- | The statement whose generated code has the given span, given the source+-- lines and the types of the dictionaries the code is passed there: nothing+-- if the span is not a quote of these quoters, an error if its types are not+-- concrete there.+statementAt :: [String] -> (Int, Int) -> (Int, Int) -> [Ty] -> Maybe (Either String Statement)+statementAt source start@(line', _) end here = do+ q <- quoteAt source start end+ statementOf line' q here+++-- | The statement of a quote on a line, given the types of the dictionaries+-- its generated code is passed: nothing if it is not a quote of these+-- quoters, an error if its types are not concrete there.+statementOf :: Int -> Quote -> [Ty] -> Maybe (Either String Statement)+statementOf line' q here =+ case typesOf ground params' rows of+ NotInferred -> Nothing+ Resolved p r+ | Just names <- first paramNames+ , Just labels' <- first paramLabels+ , Just row' <- traverse (\r' -> (r',,) <$> first columnNames <*> first columnLabels) r ->+ Just (Right (Statement line' q (columns True (p, names, labels')) (columns False <$> row')))+ _ ->+ Just+ ( Left+ "the statement's types are not known where it is written, so it cannot be checked; give its binding a concrete type, such as Statement Int64 Text"+ )+ where+ params' = [p | Con "Hasql.Check.Inferred" "Params" [p] <- here]+ rows = [r | Con "Hasql.Check.Inferred" "Row" [r] <- here]+ paramNames = [ns | Con "Hasql.Check.Inferred" "PostgresParams" [l] <- here, Just ns <- [symbols l]]+ columnNames = [ns | Con "Hasql.Check.Inferred" "PostgresColumns" [l] <- here, Just ns <- [symbols l]]+ paramLabels = [ls | Con "Hasql.Check.Inferred" "PostgresParamLabels" [l] <- here, Just ls <- [labelLists l]]+ columnLabels = [ls | Con "Hasql.Check.Inferred" "PostgresColumnLabels" [l] <- here, Just ls <- [labelLists l]]+ first = \case+ x : _ -> Just x+ [] -> Nothing+ columns isParams (t, names, labels') =+ zipWith3 (\(c, nullable') postgres' ls -> Column (typeName c) postgres' ls nullable') (columnTypes isParams t) names labels'+++-- | A type as Haskell would write it, qualified.+typeName :: Ty -> String+typeName = \case+ Con m n args -> unwords ((if null m then n else m <> "." <> n) : map (parenthesised . typeName) args)+ Lit s -> show s+ OtherLit s -> s+ Var -> "?"+ where+ parenthesised name = if ' ' `elem` name then concat ["(", name, ")"] else name+++-- | A type-level list of strings.+symbols :: Ty -> Maybe [String]+symbols = \case+ Con _ ":" [Lit s, rest] -> (s :) <$> symbols rest+ Con _ "[]" [] -> Just []+ _ -> Nothing+++-- | A type-level list of lists of strings.+labelLists :: Ty -> Maybe [[String]]+labelLists = \case+ Con _ ":" [l, rest] -> (:) <$> symbols l <*> labelLists rest+ Con _ "[]" [] -> Just []+ _ -> Nothing
+ src/Hasql/Check/Plugin.hs view
@@ -0,0 +1,193 @@+-- |+-- Module : Hasql.Check.Plugin+-- Copyright : (c) 2026 Kronor.io+--+-- License : BSD-3-Clause+-- Maintainer : lorenzo@kronor.io+-- Stability : experimental+-- Portability : GHC+--+-- A GHC plugin that checks the statements of "Hasql.Check.Inferred.TH"+-- against a database while their module compiles, as "Hasql.Check.TH" does+-- for hasql-th's: once GHC has type-checked the module, the types each+-- statement is used at are known, and the plugin checks it as+-- @hasql-check --inferred@ would. A statement that does not fit the schema+-- is a compile error at its quote.+--+-- > {-# OPTIONS_GHC -fplugin=Hasql.Check.Plugin #-}+--+-- or @ghc-options: -fplugin=Hasql.Check.Plugin@ for a whole package, which+-- depends on @hasql-check-ghc@. It is configured as "Hasql.Check.TH" is, by+-- @HASQL_CHECK_DATABASE_URL@ and the rest (see "Hasql.Check.Compile"); with+-- no database set, it checks nothing.+module Hasql.Check.Plugin (plugin) where++import Control.Monad (forM_, unless)+import Control.Monad.IO.Class (liftIO)+import Data.Data (Data, cast, gmapQ)+import Data.Maybe (catMaybes)+import Data.Text qualified as Text+import GHC.Core.TyCo.Rep (Type)+import GHC.Core.TyCon (tyConName)+import GHC.Core.Type (filterOutInvisibleTypes, isCharLitTy, isNumLitTy, isStrLitTy, splitTyConApp_maybe)+import GHC.Core.Utils (exprType)+import GHC.Data.FastString (unpackFS)+import GHC.Driver.Plugins (Plugin (..), PluginRecompile (..), defaultPlugin, keepRenamedSource)+import GHC.Hs+import GHC.Tc.Errors.Types (TcRnMessage (..))+import GHC.Tc.Types (TcGblEnv (..), TcM)+import GHC.Tc.Types.Evidence (EvTerm (..), HsWrapper (..))+import GHC.Tc.Utils.Monad (addErrAt, updTcRef)+import GHC.Types.Error (mkPlainError, mkSimpleUnknownDiagnostic, noHints)+import GHC.Types.Name (getOccString, nameModule_maybe)+import GHC.Types.SrcLoc+import GHC.Types.Var (varName)+import GHC.Unit.Module (moduleName)+import GHC.Utils.Fingerprint (fingerprintString)+import GHC.Utils.Outputable (empty, nest, text, vcat)+import Hasql.Check.Compile (Config (..), Session (..), readConfig, reportUnavailable, warning, warnings, withSession)+import Hasql.Check.Finding (Rule (..))+import Hasql.Check.Ghc.Source (Column (..), Quote (..), Statement (..), Ty (..), statementOf)+import Hasql.Check.Inferred.Quote (Inferred (Inferred), checkInferred)+import Hasql.Check.Inferred.Quote qualified as Quote+++plugin :: Plugin+plugin =+ defaultPlugin+ { -- The quotes as GHC read them, after CPP and from an editor's buffer.+ renamedResultAction = keepRenamedSource+ , typeCheckResultAction = \_ _ env -> env <$ check env+ , pluginRecompile = \_ -> recompile <$> readConfig+ }+++-- | A module is checked again when what it was checked with changes, as a+-- different database; a change of schema rechecks only the modules with+-- statements, which depend on the schema file.+recompile :: Config -> PluginRecompile+recompile config =+ MaybeRecompile (fingerprintString (show (config.databaseUrl, config.schemaFile, config.nullability, config.types, config.baseline)))+++check :: TcGblEnv -> TcM ()+check env = do+ config <- liftIO readConfig+ forM_ config.databaseUrl \url -> do+ -- A module with a statement depends on the schema, so that a change+ -- of schema rechecks it, as for "Hasql.Check.TH"'s quoters, and on+ -- the baseline its warnings are settled against.+ let found = statements (tcg_binds env)+ quotes = quasiQuotes (tcg_rn_decls env)+ unless (null found) (forM_ (catMaybes [config.schemaFile, config.baseline]) \file -> updTcRef (tcg_dependent_files env) (file :))+ forM_ found \(s, passed) ->+ forM_ (quoteAround quotes s) \(line, q) ->+ case statementOf line q (map fromType passed) of+ Nothing -> pure ()+ Just (Left err) -> failAt s err+ Just (Right statement) -> checkStatement config url s statement+++checkStatement :: Config -> String -> RealSrcSpan -> Statement -> TcM ()+checkStatement config url s statement = do+ let file = unpackFS (srcSpanFile s)+ inferred = toInferred file statement+ rules = [Nullable | config.nullability, Just _ <- [statement.row]] <> [Narrowing | config.types]+ outcome <- liftIO $ withSession config url (not (null rules)) \session ->+ checkInferred session.connection (snd <$> session.catalogue) (Nullable `elem` rules) (Narrowing `elem` rules) inferred+ case outcome of+ Left why -> liftIO (reportUnavailable why)+ Right (Left err) -> failAt s ("hasql-check: the statement does not fit HASQL_CHECK_DATABASE_URL's schema:\n" <> err)+ Right (Right (found, fingerprint)) -> liftIO do+ messages <- warnings config rules file statement.line fingerprint found+ forM_ messages (warning file (statement.line, statement.quote.column))+++-- | The statement as @hasql-check --inferred@ reads it.+toInferred :: FilePath -> Statement -> Inferred+toInferred file statement =+ Inferred+ file+ statement.line+ statement.quote.column+ (Text.pack statement.quote.quoter)+ (Text.pack statement.quote.body)+ (map column statement.params)+ (map column <$> statement.row)+ where+ column c = Quote.Column (Text.pack c.haskellType) (Text.pack c.postgres) (map Text.pack c.labels) c.nullable+++failAt :: RealSrcSpan -> String -> TcM ()+failAt s message =+ addErrAt (RealSrcSpan s mempty) (TcRnUnknownMessage (mkSimpleUnknownDiagnostic (mkPlainError noHints layout)))+ where+ -- GHC's layout: the first line, and the rest under it.+ layout = case filter (not . null) (lines message) of+ first : rest -> vcat [text first, nest 2 (vcat (map text rest))]+ [] -> empty+++-- * The statements in a type-checked module+++-- | The quasi-quotes of a renamed module, with their spans and the line each+-- starts on.+quasiQuotes :: Data a => a -> [(RealSrcSpan, Quote)]+quasiQuotes x = here <> concat (gmapQ quasiQuotes x)+ where+ here = case cast x of+ Just (L l (HsUntypedSplice _ (HsQuasiQuote _ quoter (L _ body))) :: LHsExpr GhcRn)+ | RealSrcSpan s _ <- locA l ->+ [(s, Quote (srcSpanStartCol s) (getOccString quoter) (unpackFS body))]+ _ -> []+++-- | The innermost quote whose span holds the given span - that of the code it+-- was spliced into - with the line it starts on.+quoteAround :: [(RealSrcSpan, Quote)] -> RealSrcSpan -> Maybe (Int, Quote)+quoteAround quotes s =+ case [(srcSpanStartLine o, q) | (o, q) <- around, all (\(o', _) -> o' `containsSpan` o) around] of+ found : _ -> Just found+ [] -> Nothing+ where+ around = filter (\(o, _) -> o `containsSpan` s) quotes+++-- | Each use of 'Hasql.Check.Inferred.statement' or+-- 'Hasql.Check.Inferred.resultless' - each quote - with its span and the+-- types of the dictionaries it is passed: GHC has worked out the types it is+-- used at.+statements :: Data a => a -> [(RealSrcSpan, [Type])]+statements x = here <> concat (gmapQ statements x)+ where+ here = case cast x of+ Just (L l (XExpr (WrapExpr w (HsVar _ (L _ v)))) :: LHsExpr GhcTc)+ | getOccString v `elem` ["statement", "resultless"]+ , Just m <- nameModule_maybe (varName v)+ , moduleNameString (moduleName m) == "Hasql.Check.Inferred"+ , RealSrcSpan s _ <- locA l ->+ [(s, dictionaries w)]+ _ -> []+++dictionaries :: HsWrapper -> [Type]+dictionaries = \case+ WpCompose a b -> dictionaries a <> dictionaries b+ WpEvApp (EvExpr e) -> [exprType e]+ _ -> []+++-- | A type, as "Hasql.Check.Ghc.Source" reads it.+fromType :: Type -> Ty+fromType t+ | Just s <- isStrLitTy t = Lit (unpackFS s)+ | Just n <- isNumLitTy t = OtherLit (show n)+ | Just c <- isCharLitTy t = OtherLit (show c)+ | Just (tc, args) <- splitTyConApp_maybe t =+ let name = tyConName tc+ in Con+ (maybe "" (moduleNameString . moduleName) (nameModule_maybe name))+ (getOccString name)+ (map fromType (filterOutInvisibleTypes tc args))+ | otherwise = Var
+ test/Main.hs view
@@ -0,0 +1,85 @@+module Main where++import Control.Monad (unless)+import Hasql.Check.Ghc.Source+import System.Exit (exitFailure)+++-- | Each case: the source, the span GHC gives the quote's generated code, and+-- the quote. The columns are worked out by hand from GHC's rule that a tab+-- reaches the next of columns 9, 17, 25, ...+--+-- In "t =\t[singletonStatement| select 1 |]" the tab reaches column 9: '['+-- is at 9, the quoter at 10-27, '|' at 28, the body at 29-38, "|]" at 39-40.+-- In "\tb|]", 'b' is at 9 and "|]" at 10-11.+cases :: [(String, [String], (Int, Int), (Int, Int), Maybe Quote)]+cases =+ [ ("no tabs", ["f = [q|x|]"], (1, 8), (1, 11), Just (Quote 5 "q" "x"))+ , ("a tab before the quote", ["t =\t[singletonStatement| select 1 |]"], (1, 29), (1, 41), Just (Quote 9 "singletonStatement" " select 1 "))+ , ("a tab inside a multiline quote", ["f = [q|a", "\tb|]"], (1, 8), (2, 12), Just (Quote 5 "q" "a\n\tb"))+ , ("a span that is not a quote's", ["f = g x"], (1, 5), (1, 8), Nothing)+ ]+++-- | The types of a quote, from its dictionaries' types; here a type is+-- concrete unless it is "?".+typeCases :: [(String, [String], [String], Types String)]+typeCases =+ [ ("concrete", ["Int64"], ["Text"], Resolved "Int64" (Just "Text"))+ , ("no rows", ["Int64"], [], Resolved "Int64" Nothing)+ , ("a polymorphic statement", ["?"], ["?"], Unresolved)+ , ("a polymorphic row", ["Int64"], ["?"], Unresolved)+ , ("not a statement of these quoters", [], [], NotInferred)+ ]+++-- | A row type's columns: the oracle is the type itself.+columnCases :: [(String, Ty, [(Ty, Bool)])]+columnCases =+ [ ("a tuple", Con "GHC.Tuple" "Tuple2" [int64, maybe' text], [(int64, False), (text, True)])+ , ("a newtype named like a tuple", tupleId, [(tupleId, False)])+ , ("a type with a number in it", amount, [(amount, False)])+ , ("a Maybe of another module", otherMaybe, [(otherMaybe, False)])+ ]+ where+ int64 = Con "GHC.Internal.Int" "Int64" []+ text = Con "Data.Text.Internal" "Text" []+ maybe' a = Con "GHC.Internal.Maybe" "Maybe" [a]+ tupleId = Con "Shop" "TupleId" []+ amount = Con "Shop" "Amount" [OtherLit "2"]+ otherMaybe = Con "Shop" "Maybe" [int64]+++main :: IO ()+main = do+ columnFailures <-+ traverse+ ( \(name, t, expected) -> do+ let found = columnTypes False t+ unless (found == expected) $+ putStrLn (name <> ": expected " <> show expected <> ", found " <> show found)+ pure (found /= expected)+ )+ columnCases+ unless (ground (Con "Shop" "Amount" [OtherLit "2"])) $ putStrLn "a type with a number in it is not concrete"+ typeFailures <-+ traverse+ ( \(name, params, rows, expected) -> do+ let found = typesOf (/= "?") params rows+ unless (found == expected) $+ putStrLn (name <> ": expected " <> show expected <> ", found " <> show found)+ pure (found /= expected)+ )+ typeCases+ failures <-+ traverse+ ( \(name, source, start, end, expected) -> do+ let found = quoteAt source start end+ unless (found == expected) $+ putStrLn (name <> ": expected " <> show expected <> ", found " <> show found)+ pure (found /= expected)+ )+ cases+ if or (failures <> typeFailures <> columnFailures) || not (ground (Con "Shop" "Amount" [OtherLit "2"]))+ then exitFailure+ else putStrLn (show (length cases + length typeCases + length columnCases + 1) <> " passed")
+ test/Plugin.hs view
@@ -0,0 +1,248 @@+-- | The plugin, as GHC runs it: each case compiles a fixture module with+-- @-fplugin=Hasql.Check.Plugin@, against a throwaway PostgreSQL server.+--+-- GHC finds the plugin and its dependencies through the package environment+-- cabal writes (@write-ghc-environment-files: always@ in cabal.project), and+-- must be the GHC that built them: @ghc-<version>@, or @$GHC@.+module Main where++import Control.Exception (bracket_)+import Control.Monad (unless, when)+import Data.List (isInfixOf, isPrefixOf)+import Data.Maybe (isNothing)+import Data.Version (showVersion)+import System.Directory (findExecutable, getCurrentDirectory, listDirectory)+import System.Environment (getEnvironment, lookupEnv)+import System.Exit (ExitCode (..), exitFailure)+import System.FilePath (takeDirectory, (</>))+import System.IO.Temp (withSystemTempDirectory)+import System.Info (fullCompilerVersion)+import System.Process (callProcess, proc, readCreateProcessWithExitCode, readProcess)+import System.Process qualified as Process+++main :: IO ()+main = do+ env <- environmentFile+ compiler <- ghc+ withPostgres \conn -> do+ failures <- traverse (run compiler env conn) cases+ let failed = [name | (name, False) <- zip (map caseName cases) failures]+ mapM_ (putStrLn . ("failed: " <>)) failed+ if null failed then putStrLn (show (length cases) <> " passed") else exitFailure+++data Case = Case+ { caseName :: String+ , before :: [Database]+ -- ^ Compilations of the same module, in the same directory, first.+ , database :: Database+ , extraEnv :: [(String, String)]+ , source :: String+ , expect :: (ExitCode, String) -> Bool+ }+++data Database = TestDatabase | NoDatabase | Unreachable+++cases :: [Case]+cases =+ [ Case+ "checks nothing when no database is set"+ []+ NoDatabase+ []+ (fixture "Statement Int64 Text" "select nope from customer where id = $1")+ \(code, out) -> code == ExitSuccess && not ("hasql-check:" `isInfixOf` out)+ , Case+ "accepts a statement that fits the schema"+ []+ TestDatabase+ []+ (fixture "Statement Int64 (Maybe Text)" "select nickname from customer where id = $1")+ \(code, _) -> code == ExitSuccess+ , Case+ "fails at the quote on a statement that does not prepare"+ []+ TestDatabase+ []+ (fixture "Statement Int64 Text" "select nope from customer where id = $1")+ \(code, out) ->+ code /= ExitSuccess+ && "Fixture.hs:11:" `isInfixOf` out+ && "column \"nope\" does not exist" `isInfixOf` out+ , Case+ "fails on a column read through a conversion that can fail"+ []+ TestDatabase+ []+ (fixture "Statement Int64 Int64" "select email from customer where id = $1")+ \(code, out) -> code /= ExitSuccess && "column 1 (email) is text, but is read as" `isInfixOf` out+ , Case+ "fails on an enum read without a label the database has"+ []+ TestDatabase+ []+ ( unlines+ [ "{-# LANGUAGE DataKinds, DerivingVia, QuasiQuotes, UndecidableInstances #-}"+ , "module Fixture where"+ , "import Data.Int (Int64)"+ , "import GHC.Generics (Generic)"+ , "import Hasql.Check.Inferred (PgEnum (..), Value)"+ , "import Hasql.Check.Inferred.TH"+ , "import Hasql.Statement (Statement)"+ , "data State = PENDING | PAID"+ , " deriving stock (Generic)"+ , " deriving (Value) via PgEnum \"payment_state\" State"+ , "s :: Statement Int64 State"+ , "s = [singletonStatement| select state from payment where id = $1 |]"+ ]+ )+ \(code, out) -> code /= ExitSuccess && "which cannot read labels payment_state has: REFUNDED" `isInfixOf` out+ , Case+ "warns about a nullable column read without a Maybe, without failing"+ []+ TestDatabase+ [("HASQL_CHECK_NULLABILITY", "1")]+ (fixture "Statement Int64 Text" "select nickname from customer where id = $1")+ \(code, out) ->+ code == ExitSuccess+ && "Fixture.hs:11:" `isInfixOf` out+ && "warning: hasql-check: column 1 (nickname) is not a Maybe in Haskell" `isInfixOf` out+ , Case+ "checks the statement GHC compiled, after CPP, not the file"+ []+ TestDatabase+ []+ ( unlines+ [ "{-# LANGUAGE CPP, QuasiQuotes #-}"+ , "module Fixture where"+ , "import Data.Int (Int64)"+ , "import Data.Text (Text)"+ , "import Hasql.Check.Inferred.TH"+ , "import Hasql.Statement (Statement)"+ , "#define FIELD nope"+ , "s :: Statement Int64 Text"+ , "s = [singletonStatement| select FIELD from customer where id = $1 |]"+ ]+ )+ \(code, out) -> code /= ExitSuccess && "column \"nope\" does not exist" `isInfixOf` out+ , Case+ "checks a module compiled before without a database once one is set"+ [NoDatabase]+ TestDatabase+ []+ (fixture "Statement Int64 Text" "select nope from customer where id = $1")+ \(code, out) -> code /= ExitSuccess && "column \"nope\" does not exist" `isInfixOf` out+ , Case+ "does not fail the build when the database cannot be reached"+ []+ Unreachable+ []+ (fixture "Statement Int64 Text" "select nope from customer where id = $1")+ \(code, out) -> code == ExitSuccess && "hasql-check: not checking statements" `isInfixOf` out+ ]+++-- | A module with one statement, of the given type, on line 11.+fixture :: String -> String -> String+fixture type' sql =+ unlines+ [ "{-# LANGUAGE QuasiQuotes #-}"+ , "module Fixture where"+ , ""+ , "import Data.Int (Int64)"+ , "import Data.Text (Text)"+ , "import Hasql.Check.Inferred.TH"+ , "import Hasql.Statement (Statement)"+ , ""+ , ""+ , "s :: " <> type'+ , "s = [singletonStatement| " <> sql <> " |]"+ ]+++run :: FilePath -> FilePath -> String -> Case -> IO Bool+run compiler env conn c =+ withSystemTempDirectory "hasql-check-plugin" \dir -> do+ writeFile (dir </> "Fixture.hs") c.source+ inherited <- getEnvironment+ let compile db = do+ let database = case db of+ TestDatabase -> [("HASQL_CHECK_DATABASE_URL", conn)]+ NoDatabase -> []+ Unreachable -> [("HASQL_CHECK_DATABASE_URL", "host=/nonexistent")]+ ours = database <> c.extraEnv+ procEnv = ours <> filter (not . ("HASQL_CHECK_" `isPrefixOf`) . fst) inherited+ -- Interfaces written, so that a later compilation can reuse them.+ readCreateProcessWithExitCode+ (proc compiler ["-package-env", env, "-fno-code", "-fwrite-interface", "-fplugin=Hasql.Check.Plugin", "Fixture.hs"]){Process.cwd = Just dir, Process.env = Just procEnv}+ ""+ mapM_ compile c.before+ (code, out, err) <- compile c.database+ let ok = c.expect (code, out <> err)+ unless ok (putStrLn (c.caseName <> ":\n" <> show code <> "\n" <> out <> err))+ pure ok+++-- | The package environment cabal wrote, in this directory or one above.+-- Cabal writes it once a command has run, after the tests of a first+-- @cabal test@: then it is written here, by building the plugin.+environmentFile :: IO FilePath+environmentFile =+ find >>= \case+ Just file -> pure file+ Nothing -> do+ callProcess "cabal" ["build", "-v0", "--write-ghc-environment-files=always", "hasql-check-ghc:lib:hasql-check-ghc"]+ find >>= \case+ Just file -> pure file+ Nothing -> do+ putStrLn "no .ghc.environment file: set write-ghc-environment-files: always in cabal.project"+ exitFailure+ where+ find = getCurrentDirectory >>= go+ go dir = do+ found <- filter (".ghc.environment." `isPrefixOf`) <$> listDirectory dir+ case found of+ file : _ -> pure (Just (dir </> file))+ []+ | takeDirectory dir == dir -> pure Nothing+ | otherwise -> go (takeDirectory dir)+++-- | The GHC that built the plugin.+ghc :: IO FilePath+ghc =+ lookupEnv "GHC" >>= \case+ Just path -> pure path+ Nothing -> do+ let versioned = "ghc-" <> showVersion fullCompilerVersion+ found <- findExecutable versioned+ pure (maybe "ghc" (const versioned) found)+++-- | A connection string for a throwaway server, reachable only over a socket+-- in a temporary directory.+withPostgres :: (String -> IO ()) -> IO ()+withPostgres action =+ withSystemTempDirectory "hasql-check-plugin-db" \dir -> do+ initdb <- findExecutable "initdb"+ when (isNothing initdb) do+ putStrLn "initdb is not on PATH; the plugin tests need a PostgreSQL installation"+ exitFailure+ let dataDir = dir </> "data"+ conn = "host=" <> dir <> " port=5432 user=postgres dbname=postgres"+ _ <- readProcess "initdb" ["--pgdata", dataDir, "--username", "postgres", "--auth", "trust", "--no-sync"] ""+ bracket_+ (callProcess "pg_ctl" ["--pgdata", dataDir, "--log", dir </> "postgres.log", "--options", "-k " <> dir <> " -c listen_addresses=''", "--wait", "--silent", "start"])+ (callProcess "pg_ctl" ["--pgdata", dataDir, "--mode", "immediate", "--silent", "stop"])+ do+ callProcess+ "psql"+ [ conn+ , "--quiet"+ , "--command"+ , "create table customer (id int8 primary key, email text not null, nickname text); create type payment_state as enum ('PENDING', 'PAID', 'REFUNDED'); create table payment (id int8 primary key, state payment_state not null)"+ ]+ action conn