Add VarName as parameter to Constrained typ constructor

lib/fine-types/src/Language/FineTypes/Export/Haskell/Typ.hs

@@ -201,7 +201,7 @@ typeFromTyp = go
         error "Nested Product is not supported by Haskell"
     go (SumN _) =
         error "Nested Sum is not supported by Haskell"
-    go (Constrained typ _) =
+    go (Constrained _ typ _) =
         -- FIXME: Emit a warning.
         -- TODO: Add Liquid Haskell support for top-level definitions? 😲
         -- Currently no good representation for comments / Liquid Haskell

lib/fine-types/src/Language/FineTypes/Export/OpenAPI/Schema.hs

@@ -104,7 +104,7 @@ supportsJSON =
     isSupportedTyp = everything (&&) isSupported
     isSupported (Two fun _ _) =
         fun `notElem` [PartialFunction, FiniteSupport]
-    isSupported (Constrained _ _) =
+    isSupported Constrained{} =
         False
     isSupported _ = True
 
@@ -203,7 +203,7 @@ schemaFromTyp = go
         schemaFromProductN fields
     go (SumN constructors) =
         schemaFromSumN constructors
-    go (Constrained _ _) =
+    go Constrained{} =
         error "ConstrainedTyp is not supported by JSON schema"
 
 -- | Map a record type to a JSON schema.

lib/fine-types/src/Language/FineTypes/Parser.hs

@@ -40,6 +40,7 @@ import Language.FineTypes.Typ
     , Typ (..)
     , TypConst (..)
     , TypName
+    , VarName
     )
 import Text.Megaparsec
     ( ParseErrorBundle
@@ -169,11 +170,11 @@ mkDocumentedDeclaration doc1 name (DocumentedTyp typ fs cs) doc2 =
 
 constrained :: Parser Typ
 constrained = braces $ do
-    _ <- varName
+    v <- varName
     _ <- symbol ":"
     typ <- zeroVar
     _ <- symbol "|"
-    Constrained typ <$> constraint
+    Constrained v typ <$> constraint
 
 abstract :: Parser Typ
 abstract = Abstract <$ symbol "_"
@@ -379,8 +380,6 @@ fieldName =
     L.lexeme space
         $ many (C.alphaNumChar <|> satisfy (`elem` "_^-"))
 
-type VarName = String
-
 varName :: Parser VarName
 varName =
     L.lexeme space

lib/fine-types/src/Language/FineTypes/Typ.hs

@@ -7,6 +7,7 @@ module Language.FineTypes.Typ
       TypName
     , ConstructorName
     , FieldName
+    , VarName
     , Typ (..)
     , TypConst (..)
     , OpOne (..)
@@ -33,6 +34,7 @@ import qualified Data.List as L
 type TypName = String
 type ConstructorName = String
 type FieldName = String
+type VarName = String
 
 -- | A 'Typ' describes a set of values.
 --
@@ -56,7 +58,7 @@ data Typ
     | -- | Disjoint union with constructor names.
       SumN [(ConstructorName, Typ)]
     | -- | A type with a value constraint
-      Constrained Typ Constraint
+      Constrained VarName Typ Constraint
     deriving (Eq, Ord, Show, Generic)
 
 instance ToExpr Typ
@@ -138,8 +140,8 @@ everywhere f = every
         ProductN [(n, every a) | (n, a) <- nas]
     recurse (SumN nas) =
         SumN [(n, every a) | (n, a) <- nas]
-    recurse (Constrained typ c) =
-        Constrained (every typ) c
+    recurse (Constrained v typ c) =
+        Constrained v (every typ) c
 
 -- | Summarise all nodes; top-down, left-to-right.
 everything :: (r -> r -> r) -> (Typ -> r) -> (Typ -> r)
@@ -159,7 +161,7 @@ everything combine f = recurse
         L.foldl' combine (f x) [recurse a | (_, a) <- nas]
     recurse x@(SumN nas) =
         L.foldl' combine (f x) [recurse a | (_, a) <- nas]
-    recurse x@(Constrained typ _) =
+    recurse x@(Constrained _ typ _) =
         f x `combine` recurse typ
 
 depth :: Typ -> Int
@@ -169,7 +171,7 @@ depth = \case
     Two _ a b -> 1 + max (depth a) (depth b)
     ProductN fields -> 1 + maximum (fmap (depth . snd) fields)
     SumN constructors -> 1 + maximum (fmap (depth . snd) constructors)
-    Constrained a _ -> depth a
+    Constrained _ a _ -> depth a
     Abstract -> 0
     Var _ -> 0
 

lib/fine-types/src/Language/FineTypes/Typ/Gen.hs

@@ -143,7 +143,8 @@ genConstrainedTyp mode = do
     constraintDepth <- choose (1, 2)
     c <- genConstraint constraintDepth
     typ <- genTyp'
-    pure $ Constrained typ c
+    v <- genName
+    pure $ Constrained v typ c
   where
     complete = onComplete mode
     always = id
@@ -225,10 +226,10 @@ shrinkTyp = \case
             <> (SumN <$> shrinkList shrinkNamed constructors)
     Var _ -> []
     Abstract -> []
-    Constrained typ c ->
+    Constrained v typ c ->
         [typ]
-            <> [Constrained typ' c | typ' <- shrinkTyp typ]
-            <> [Constrained typ c' | c' <- shrinkConstraint c]
+            <> [Constrained v typ' c | typ' <- shrinkTyp typ]
+            <> [Constrained v typ c' | c' <- shrinkConstraint c]
 
 shrinkNamed :: (t, Typ) -> [(t, Typ)]
 shrinkNamed (f, t) = (f,) <$> shrinkTyp t

lib/fine-types/src/Language/FineTypes/Typ/PrettyPrinter.hs

@@ -29,6 +29,7 @@ import Language.FineTypes.Typ
     , Typ (..)
     , TypConst (..)
     , TypName
+    , VarName
     )
 import Prettyprinter
     ( Doc
@@ -58,7 +59,7 @@ requireParens = \case
     SumN _ -> False
     Var _ -> False
     Abstract -> False
-    Constrained _ _ -> False
+    Constrained{} -> False
 
 parens :: Doc ann -> Doc ann
 parens doc = encloseSep "(" ")" " " [doc]
@@ -69,12 +70,15 @@ withParens f x = if requireParens x then parens (f x) else f x
 prettyConstrainedTyp
     :: QueryDocumentation
     -> TypName
+    -> VarName
     -> Typ
     -> Constraint
     -> Doc ann
-prettyConstrainedTyp docs typname typ [] = prettyTyp docs typname typ
-prettyConstrainedTyp docs typname typ constraint =
-    "{ x :"
+prettyConstrainedTyp docs typname _v typ [] = prettyTyp docs typname typ
+prettyConstrainedTyp docs typname v typ constraint =
+    "{"
+        <+> pretty v
+        <+> ":"
         <+> prettyTyp docs typname typ
         <+> prettyText "|"
         <+> prettyConstraint constraint
@@ -154,7 +158,7 @@ prettyTyp docs typname = \case
     SumN constructors -> prettySumN docs typname constructors
     Var name -> pretty name
     Abstract -> prettyText "_"
-    Constrained typ c -> prettyConstrainedTyp docs typname typ c
+    Constrained v typ c -> prettyConstrainedTyp docs typname v typ c
   where
     prettyTyp' = prettyTyp docs typname