ocamlcoq

Is there a function that returns a list of values with specific type in OCaml?


In Haskell, using listify with Data can extract values of a specific type from a deeply nested structure without lots of getters. For example, with the following code:

{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE OverloadedStrings  #-}

module Lib
  ( john
  , listStrings
  ) where

import           Data.Data
import           Data.Generics.Schemes
import           Data.Text

data Person = Person
  { name    :: Name
  , address :: Address
  } deriving (Data, Show)

data Name = Name
  { firstName :: Text
  , lastName  :: Text
  } deriving (Data, Show)

data Address = Address
  { addressLine :: Text
  , city        :: Text
  , province    :: Text
  , country     :: Text
  } deriving (Data, Show)

john :: Person
john =
  Person
    { name = Name {firstName = "John", lastName = "Smith"}
    , address =
        Address
          { addressLine = "1-2-3 Nantoka-kantoka-machi"
          , city = "Nishinomiya"
          , province = "Hyogo"
          , country = "Japan"
          }
    }

listStrings :: Person -> [Text]
listStrings = listify (const True)

listStrings john returns a list of Texts in john.

ghci> listStrings john
["John","Smith","1-2-3 Nantoka-kantoka-machi","Nishinomiya","Hyogo","Japan"]

Is there something like this in OCaml?

Context

I'm writing a Coq code formatter, and having difficulty pretty-printing notations (e.g., _ = _.) The node constructor for notations is CNotation in constr_expr_r.

Coq's OCaml API provides find_notation_printing_rule which takes a value in CNotation and returns the printing rule for the notation, but I also don't understand what the returned rule means. This led me to write a printing rule dumper; a program that takes a Coq code as an input, extracts notations from the code, and dumps the notations with printing rules and other useful information. For the extraction phase, I need a function like listify to get CNotations from the code.


Solution

  • After all, I converted an AST into an S-expression using functions in coq-serapi, filtered it, and converted them back to the concrete types

    let extract_cnotations (ast : Vernacexpr.vernac_control) :
        Constrexpr.constr_expr_r list =
      let open Sexplib.Sexp in
      (* Traverse the given S-expression and return a list of S-expressions
         satisfying the given condition. *)
      let rec find_sexp_recursively cond = function
        | Atom x -> if cond (Atom x) then [ Atom x ] else []
        | List xs ->
            let tail = List.concat_map (find_sexp_recursively cond) xs in
            if cond (List xs) then List xs :: tail else tail
      in
    
      let cond = function
        | List
            [
              List [ Atom "v"; List (Atom "CNotation" :: _) ]; List (Atom "loc" :: _);
            ] ->
            true
        | _ -> false
      in
    
      Serlib.Ser_vernacexpr.sexp_of_vernac_control ast
      |> find_sexp_recursively cond
      |> List.map Serlib.Ser_constrexpr.constr_expr_of_sexp
      |> List.map (fun x -> x.CAst.v)
    

    It turned out that sertop could dump printing rules for some notations with the Unparsing query.

    $ rlwrap sertop --printer=human
    
    ...
    
    (Query () (Unparsing "_ = _"))
    (Answer 0 Ack)
    (Answer 0
     (ObjList
      ((CoqUnparsing
        ((notation_printing_unparsing
          ((UnpBox (PpHOVB 0)
            ((()
              (UnpMetaVar
               ((notation_subentry InConstrEntry)
                (notation_relative_level (LevelLt 70))
                (notation_position (Left)))))
             (() (UnpTerminal " =")) (() (UnpCut (PpBrk 1 0)))
             (()
              (UnpMetaVar
               ((notation_subentry InConstrEntry)
                (notation_relative_level (LevelLt 70))
                (notation_position (Right)))))))))
         (notation_printing_level 70))
        (((notgram_level
           (((notation_entry InConstrEntry) (notation_level 70))
            ((LevelLt 70) (LevelLt 70))))
          (notgram_assoc ()) (notgram_notation (InConstrEntry "_ = _"))
          (notgram_prods
           (((GramConstrNonTerminal
              (ETProdConstr InConstrEntry
               ((NumLevel 70) (BorderProd Left (NonA))))
              ((Id x)))
             (GramConstrTerminal true =)
             (GramConstrNonTerminal
              (ETProdConstr InConstrEntry
               ((NumLevel 70) (BorderProd Right (NonA))))
              ((Id y))))))
          (notgram_typs
           ((ETConstr InConstrEntry () ((NumLevel 70) (BorderProd Left (NonA))))
            (ETConstr InConstrEntry () ((NumLevel 70) (BorderProd Right (NonA))))))))))))
    (Answer 0 Completed)