A function for constructing a value of any record type (that has the required instances) by asking the user interactively for the value of each field. Depends on http://hackage.haskell.org/package/red-black-record

BuildRecordInteractively.hs

{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE ViewPatterns #-}

-- In an empty folder, invoke (assuming cabal-install >= 3.0) this command
--      cabal install --lib --package-env . red-black-record
-- then you can load this program from GHCi

module Main where

import Control.Applicative.Lift
  ( Errors, -- a Validation-like Applicative that accumulates errors
    failure,
    runErrors,
  )
import Data.List (intercalate)
import qualified Data.Map.Strict as Map
import Data.Maybe (fromJust)
import Data.Monoid (Endo (..))
import Data.Proxy
import Data.RBR
  ( (:.:) (Comp), -- Functor composition as a fancy type operator
    And, -- combine constraints
    -- contravariant, the last type parameter is actually the input
    Case (..),
    FromRecord (fromRecord), -- convert extensible record to nominal record
    I (..), -- identity functor
    IsRecordType, -- can be converted to and from extensible record form
    K (..), -- constant functor
    -- a constraint for an entry in a type-level map
    KeyValueConstraints,
    -- require constraint of all key-value entries in type-level map
    KeysValuesAll,
    Maplike, -- enables Applicative-like operations over Records
    Record, -- extensible Record
    ToRecord (toRecord),
    collapse'_Record, -- smash togeter the fields of a Record with uniform type
    cpure'_Record, -- create a Record knowing that all fields satisfy a constraint
    injections_Record, -- create a Record where each field is a setter
    liftA2_Record,
    liftA_Record,
    sequence_Record, -- pull outside an applicative that wraps each field
    unI,
  )
import qualified Data.Set as Set
import Data.Typeable
import GHC.Generics (Generic)
import GHC.TypeLits

type FieldName = String

type TextInput = String

-- Given any nominal record with the suitable instances,
-- construct the record by asking the user interactively for
-- the value of each field.
readRecordInteractively ::
  forall r c.
  ( IsRecordType r c,
    Maplike c,
    KeysValuesAll (KeyValueConstraints KnownSymbol (Read `And` Typeable)) c
  ) =>
  IO r
readRecordInteractively =
  let -- returns a parse function inside a tuple inside another tuple
      parserForField ::
        forall v.
        (Read `And` Typeable) v =>
        FieldName ->
        ((,) FieldName :.: (,) TypeRep :.: (->) TextInput) v
      parserForField fieldName = Comp (fieldName, Comp (typeRep (Proxy @v), read))
      parserRecord = cpure'_Record (Proxy @(Read `And` Typeable)) $ parserForField
      -- The first parameter is a function that takes a field value
      -- and returns a record updater.
      -- The second parameter is a parsing function for the field value,
      -- with extra info attached like the field name and its type rep.
      makeFieldHandler ::
        forall f c a.
        Applicative f =>
        Case f (Endo (Record f c)) a ->
        ((,) FieldName :.: (,) TypeRep :.: (->) TextInput) a ->
        (FieldName, (TypeRep, Case I (Endo (Record f c)) TextInput))
      makeFieldHandler (Case makeUpdater) (Comp (fieldName, Comp (rep, readFunc))) =
        ( fieldName,
          ( rep,
            Case $ \textInput ->
              let !parsedFieldValue = readFunc . unI $ textInput
               in makeUpdater . pure $ parsedFieldValue
          )
        )
      -- We combine the functions that create record udpaters with the parsing
      -- functions for each field.  We put the result inside the constant
      -- functor K as a prelude to collapsing the record.
      fieldHandlerRecord ::
        forall f.
        Applicative f =>
        Record (K [(FieldName, (TypeRep, Case I (Endo (Record f c)) TextInput))]) c
      fieldHandlerRecord = liftA2_Record (\u p -> K [makeFieldHandler u p]) injections_Record parserRecord
      -- A field handler knows the type of the field, how to read it,
      -- and how to update a Record with the value
      fieldHandlers :: Map.Map FieldName (TypeRep, Case I (Endo (Record (Errors [FieldName]) c)) TextInput)
      fieldHandlers = Map.fromList $ collapse'_Record fieldHandlerRecord
      -- Initially all fields are in a "missing" state, filled with the field name as the "error" value.
      initialRecordState :: Record (Errors [FieldName]) c
      initialRecordState = liftA_Record (\(Comp (fieldName, _)) -> failure [fieldName]) parserRecord
      go recordState = do
        case runErrors $ sequence_Record recordState of
          Right (fromRecord -> r) -> return $ r
          Left (Set.fromList -> missing) -> do
            let asteriskOnMissing k = ['*' | Set.member k missing] ++ k
            putStrLn $ "Record has fields: " ++ intercalate "," (asteriskOnMissing <$> Map.keys fieldHandlers)
            putStrLn $ "Enter the name of the next field to process:"
            fieldName <- getLine
            let (rep, Case makeUpdater) = fromJust $ Map.lookup fieldName fieldHandlers
            putStrLn $ "That field has type " ++ show rep
            putStrLn $ "Enter its value:"
            textInput <- getLine
            let Endo update = makeUpdater (I textInput)
            go (update recordState)
   in go initialRecordState

--
-- EXAMPLE
--
data Person = Person {name :: String, age :: Int} deriving (Generic, Show)

instance ToRecord Person

instance FromRecord Person

main :: IO ()
main = do
  r <- readRecordInteractively @Person
  putStrLn $ "Finished! The constructed record is " ++ show r

-- * Main> :main
-- Record has fields: *age,*name
-- Enter the name of the next field to process:
-- age
-- That field has type Int
-- Enter its value:
-- 62
-- Record has fields: age,*name
-- Enter the name of the next field to process:
-- name
-- That field has type [Char]
-- Enter its value:
-- "John"
-- Finished! The constructed record is Person {name = "John", age = 62}