hasql-check-ghc 0.5.0.0 → 0.5.1.0
raw patch · 4 files changed
+145/−117 lines, 4 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
Files
- ChangeLog.md +9/−0
- hasql-check-ghc.cabal +1/−1
- src/Hasql/Check/Ghc/Source.hs +94/−68
- src/Hasql/Check/Plugin.hs +41/−48
ChangeLog.md view
@@ -1,5 +1,14 @@ # Changelog +## 0.5.1.0++`hasql-check-hie` identified an inferred quote by its `Params` dictionary,+which the quoters that build their own encoder and decoder do not carry, so+it emitted nothing for them; the plugin matched only `statement` and+`resultless` and skipped them too. Both now read the Haskell types from+`HaskellParams` and `HaskellColumns`, and evaluate the `Append` that GHC+records unreduced.+ ## 0.5.0.0 Initial release, alongside `hasql-check` 0.5.0.0: `Hasql.Check.Plugin`, a GHC
hasql-check-ghc.cabal view
@@ -1,6 +1,6 @@ cabal-version: 3.0 name: hasql-check-ghc-version: 0.5.0.0+version: 0.5.1.0 synopsis: Check inferred hasql statements with what GHC knows of their types
src/Hasql/Check/Ghc/Source.hs view
@@ -1,19 +1,20 @@--- |--- 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+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 (..),@@ -39,7 +40,6 @@ import Data.Char (isAlphaNum, isDigit) import Data.List (intercalate) - data Quote = Quote { column :: Int -- ^ GHC's column of the quote's opening bracket.@@ -48,10 +48,10 @@ } 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.+{- | 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@@ -89,21 +89,21 @@ [] -> -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.+ | {- | 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.+{- | 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@@ -111,7 +111,6 @@ (_, []) | 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@@ -121,25 +120,22 @@ | 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.+{- | 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@@ -148,9 +144,9 @@ 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.+{- | 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@@ -158,27 +154,28 @@ 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)+ column = columnOf +-- | A column's type and whether it is a 'Maybe', so may be NULL.+columnOf :: Ty -> (Ty, Bool)+columnOf = \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.+{- | 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@@ -188,7 +185,6 @@ -- ^ Nothing for a statement that returns no rows. } - -- | A parameter or result column. data Column = Column { haskellType :: String@@ -198,37 +194,54 @@ , 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.+{- | 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.+{- | 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+statementOf line' q here = case first paramHs of+ -- The quoters build the encoder and the decoder themselves, so the types+ -- come one per placeholder and per column rather than as a tuple to+ -- split: a record target and a param field are neither.+ Just hs+ | Just names <- first paramNames+ , Just labels' <- first paramLabels ->+ Just (Right (Statement line' q (columnsOf (map columnOf hs) names labels') resultRow))+ | otherwise -> Just (Left unresolved)+ Nothing -> 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"- )+ _ -> Just (Left unresolved) where+ unresolved =+ "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"+ -- A statement that returns rows carries either the column types the+ -- quoter collected, or, where it could not count them, the Haskell row+ -- type's. One that returns none carries neither.+ resultRow = case (first columnNames, first columnLabels) of+ (Just names, Just labels') -> case (first columnHs, filter ground rows) of+ (Just hs, _) -> Just (columnsOf (map columnOf hs) names labels')+ (Nothing, r : _) -> Just (columnsOf (columnTypes False r) names labels')+ _ -> Nothing+ _ -> Nothing params' = [p | Con "Hasql.Check.Inferred" "Params" [p] <- here] rows = [r | Con "Hasql.Check.Inferred" "Row" [r] <- here]+ paramHs = [hs | Con "Hasql.Check.Inferred" "HaskellParams" [l] <- here, Just hs <- [types l], all ground hs]+ columnHs = [hs | Con "Hasql.Check.Inferred" "HaskellColumns" [l] <- here, Just hs <- [types l], all ground hs] 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]]@@ -236,9 +249,9 @@ 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'-+ columns isParams (t, names, labels') = columnsOf (columnTypes isParams t) names labels'+ columnsOf cs names labels' =+ zipWith3 (\(c, nullable') postgres' ls -> Column (typeName c) postgres' ls nullable') cs names labels' -- | A type as Haskell would write it, qualified. typeName :: Ty -> String@@ -250,18 +263,31 @@ where parenthesised name = if ' ' `elem` name then concat ["(", name, ")"] else name ---- | A type-level list of strings.+{- | A type-level list of strings. The quoters build theirs by appending,+and GHC records the Append unreduced, so it is evaluated here.+-} symbols :: Ty -> Maybe [String] symbols = \case Con _ ":" [Lit s, rest] -> (s :) <$> symbols rest Con _ "[]" [] -> Just []+ Con _ "Append" [a, b] -> (<>) <$> symbols a <*> symbols b _ -> Nothing +{- | A type-level list of types, as 'Slots' and 'Target' carry: one per+placeholder or result column, which a record target or a param field makes+something other than a tuple's elements.+-}+types :: Ty -> Maybe [Ty]+types = \case+ Con _ ":" [t, rest] -> (t :) <$> types rest+ Con _ "[]" [] -> Just []+ Con _ "Append" [a, b] -> (<>) <$> types a <*> types b+ _ -> Nothing -- | A type-level list of lists of strings. labelLists :: Ty -> Maybe [[String]] labelLists = \case Con _ ":" [l, rest] -> (:) <$> symbols l <*> labelLists rest Con _ "[]" [] -> Just []+ Con _ "Append" [a, b] -> (<>) <$> labelLists a <*> labelLists b _ -> Nothing
src/Hasql/Check/Plugin.hs view
@@ -1,25 +1,26 @@--- |--- 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+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)@@ -51,7 +52,6 @@ import Hasql.Check.Inferred.Quote (Inferred (Inferred), checkInferred) import Hasql.Check.Inferred.Quote qualified as Quote - plugin :: Plugin plugin = defaultPlugin@@ -61,15 +61,14 @@ , 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.+{- | 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@@ -87,7 +86,6 @@ 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)@@ -102,7 +100,6 @@ 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 =@@ -117,7 +114,6 @@ 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)))@@ -127,13 +123,12 @@ 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)]+{- | 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@@ -142,9 +137,9 @@ [(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.+{- | 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@@ -153,30 +148,28 @@ 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])]+{- | 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"]+ | getOccString v `elem` ["statement", "statementWith", "statementRow", "resultless", "resultlessWith", "rowsAffected", "rowsAffectedWith"] , 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