module Sqel.Class.MatchView where
import Type.Errors (ErrorMessage, IfStuck, Pure)
import Sqel.Data.Dd (DdK)
import Sqel.Data.FieldPath (FieldPath (FieldPath), FieldPaths, PathEq, ShowFields)
import Sqel.SOP.Error (JoinSym, QuotedError, QuotedType, Unlines)
type family CheckAvail (fields :: [FieldPath]) :: Type where
CheckAvail ('FieldPath _ t : _) = t
type family AvailableColumns (fields :: [FieldPath]) :: ErrorMessage where
AvailableColumns fields =
"The specified table contains these fields:" %
Unlines (ShowFields fields)
type NoViewMatch :: Symbol -> [FieldPath] -> FieldPath -> ErrorMessage
type family NoViewMatch viewType avail path where
NoViewMatch viewType avail ('FieldPath path tpe) =
"The " <> viewType <> " column " <> QuotedError (JoinSym "." path) <> " with type " <> QuotedType tpe <>
" does not correspond to a table column." %
AvailableColumns avail
type family UnknownMsg (viewType :: Symbol) (field :: FieldPath) :: ErrorMessage where
UnknownMsg viewType ('FieldPath path tpe) =
"This " <> viewType <> " cannot determine whether the column " <> QuotedError (JoinSym "." path) <> " with type " <>
QuotedType tpe %
"corresponds to a table column."
type family PathConstraint (path :: [Symbol]) :: ErrorMessage where
PathConstraint '[field] = "HasField " <> 'ShowType field
PathConstraint path = "HasPath " <> path
type family AvailStuckMsg (viewType :: Symbol) (table :: DdK) (field :: FieldPath) :: ErrorMessage where
AvailStuckMsg viewType table ('FieldPath path tpe) =
UnknownMsg viewType ('FieldPath path tpe) %
"This is likely due to the structure type " <> QuotedType table <> " being polymorphic." %
"Try adding the constraint:" %
" " <> QuotedError (PathConstraint path <> " " <> tpe <> " " <> table)
type MatchStuckMsg :: Symbol -> [FieldPath] -> FieldPath -> ErrorMessage
type family MatchStuckMsg viewType avail path where
MatchStuckMsg viewType avail field =
UnknownMsg viewType field %
AvailableColumns avail
type family MatchStuck (viewType :: Symbol) (field :: FieldPath) (avail :: [FieldPath]) :: k where
MatchStuck viewType field avail =
TypeError (MatchStuckMsg viewType avail field)
type family AvailStuck (viewType :: Symbol) (table :: DdK) (field :: FieldPath) :: k where
AvailStuck viewType table field =
TypeError (AvailStuckMsg viewType table field)
type CheckMatch :: Symbol -> DdK -> FieldPath -> [FieldPath] -> Bool -> Bool
type family CheckMatch viewType table vfield avail match where
CheckMatch viewType table vfield avail match =
IfStuck match (IfStuck (CheckAvail avail) (AvailStuck viewType table vfield) (Pure (MatchStuck viewType vfield avail))) (Pure match)
type MatchPath :: FieldPath -> FieldPath -> Bool -> Constraint
class MatchPath view avail match | view avail -> match where
instance (
match ~ PathEq view avail
) => MatchPath view avail match where
type CheckPathMatch :: FieldPath -> [FieldPath] -> Bool -> Bool -> Constraint
class CheckPathMatch view avail match finalMatch | view avail match -> finalMatch where
instance (
MatchViewPath view avail match
) => CheckPathMatch view avail 'False match where
instance CheckPathMatch view avail 'True 'True where
type MatchViewPath :: FieldPath -> [FieldPath] -> Bool -> Constraint
class MatchViewPath view avail match | view avail -> match where
instance (
MatchPath view tfield match,
CheckPathMatch view tfields match finalMatch
) => MatchViewPath view (tfield : tfields) finalMatch where
instance MatchViewPath view '[] 'False where
type CheckViewPathError :: Symbol -> DdK -> FieldPath -> [FieldPath] -> [FieldPath] -> Bool -> Maybe ErrorMessage -> Constraint
class CheckViewPathError viewType table vfield vfields avail match error | viewType table vfield vfields avail match -> error where
instance (
MatchViewPaths viewType table vfields avail error
) => CheckViewPathError viewType table vfield vfields avail 'True error where
instance (
err ~ NoViewMatch viewType avail vfield
) => CheckViewPathError viewType table vfield vfields avail 'False ('Just err) where
type MatchViewPaths :: Symbol -> DdK -> [FieldPath] -> [FieldPath] -> Maybe ErrorMessage -> Constraint
class MatchViewPaths viewType table view avail error | viewType table view avail -> error where
instance MatchViewPaths viewType table '[] avail 'Nothing where
instance (
MatchViewPath vfield avail match,
CheckViewPathError viewType table vfield vfields avail (CheckMatch viewType table vfield avail match) finalError
) => MatchViewPaths viewType table (vfield : vfields) avail finalError where
type family MaybeError (msg :: Maybe ErrorMessage) :: Maybe k where
MaybeError 'Nothing = 'Nothing
MaybeError ('Just msg) = 'Just (TypeError msg)
type MatchView :: Symbol -> DdK -> DdK -> Maybe Void -> Constraint
class MatchView viewType view avail error | viewType view avail -> error where
instance (
MatchViewPaths viewType table (FieldPaths view) (FieldPaths table) msg,
error ~ MaybeError msg
) => MatchView viewType view table error where
type MatchQuery view table error =
MatchView "query" view table error
type MatchProjection view table error =
MatchView "projection" view table error
class (
MatchViewPath ('FieldPath path t) (FieldPaths table) 'True
) => HasPath path t table where
instance (
MatchViewPath ('FieldPath path t) (FieldPaths table) 'True
) => HasPath path t table where
class (
MatchViewPath ('FieldPath '[path] t) (FieldPaths table) 'True
) => HasField path t table where
instance (
MatchViewPath ('FieldPath '[path] t) (FieldPaths table) 'True
) => HasField path t table where