Sunday, June 2, 2019

Have GHC parsing respect dynamic pragmas

Have GHC parsing respect dynamic pragmas

This post about Handling GHC parse errors shows that using qualified in postpostive position is a syntax error unless the ImportQualifiedPost language extension is enabled. In that post, it is explained that the program

module M where
import Data.List qualified
is invalid whereas,
{#- LANGUAGE ImportQualifiedPost -#}
module M where
import Data.List qualified
which enables the extension via a "dynamic pragma", is legit.

Perhaps surprisingly, running the second of these programs through the parsing code presented in that post continues to generate the error

     Found `qualified' in postpositive position.
     To allow this, enable language extension 'ImportQualifiedPost'
Evidently, our parse-fu needs an upgrade to respect dynamic pragmas and that's what this post provides.

This code exercises the GHC API to parse a module.

parse :: String -> DynFlags -> String -> ParseResult (Located (HsModule GhcPs))
parse filename flags str =
  unP Parser.parseModule parseState
    location = mkRealSrcLoc (mkFastString filename) 1 1
    buffer = stringToStringBuffer str
    parseState = mkPState flags buffer location

Note in the above, the second argument flags :: DynFlags. In order for parse to take into account extensions enabled by pragmas in the source argument str, then flags must be set up to do so a priori. That is, before jumping into parse, a "first pass" must be made to sniff out flags. There is a GHC API for that. It's called parseDynamicFilePragma.

Here's a function to harvest flags from pragmas that makes that call to parseDynamicFlags.

parsePragmasIntoDynFlags :: DynFlags -> FilePath -> String -> IO (Maybe DynFlags)
parsePragmasIntoDynFlags flags filepath str =
  catchErrors $ do
    let opts = getOptions flags (stringToStringBuffer str) filepath
    (flags, _, _) <- parseDynamicFilePragma flags opts
    return $ Just flags
    catchErrors :: IO (Maybe DynFlags) -> IO (Maybe DynFlags)
    catchErrors act = handleGhcException reportErr
                        (handleSourceError reportErr act)
    reportErr e = do putStrLn $ "error : " ++ show e; return Nothing
The main contribution of this function is to account for the complication that parseDynamicFilePragma can throw two kinds of exceptions : GhcException and SourceError. The GHC API functions handleGhcException and handleSourceError are the means to achieve that.

Putting it all together then, here's an outline of how to parse in the presence of dynamic pragmas.

      s <- readFile' file
      flags <-
          (defaultDynFlags fakeSettings fakeLlvmConfig) file s
      whenJust flags $ \flags ->
         case parse file flags s of
            PFailed s ->
              report flags $ snd (getMessages s flags)
            POk s m -> do
              let (wrns, errs) = getMessages s flags
              report flags wrns
              report flags errs
              when (null errs) $ analyzeModule flags m
For a complete working program that utilizes this function, see this example in the ghc-lib repo.

Friday, May 10, 2019

Handling GHC parser errors right

Handling GHC parser errors right

Did you know, a POk parse result from the GHC parser doesn't necessarily mean the parse was OK? This blog explains what's up with that. The source code below is from this example in the ghc-lib repo.

Here is code that tries to make a parse tree of a Haskell module.

parse :: String -> DynFlags -> String -> ParseResult (Located (HsModule GhcPs))
parse filename flags str =
  unP Parser.parseModule parseState
    location = mkRealSrcLoc (mkFastString filename) 1 1
    buffer = stringToStringBuffer str
    parseState = mkPState flags buffer location

The way to call the above code is like this.

case parse file flags s of
  PFailed s ->
    report flags $ snd (getMessages s flags)
  POk s m -> do
    report flags $ fst (getMessages s flags)
    analyzeModule flags m
In the PFailed s case (where s is the parse state), the expression snd (getMessages s flags) retrieves the errors and we report them. In the POk case, we report warnings and do whatever it is we wanted to do with the parse tree m right?

Not quite. The problem is that the parser produces two sorts of errors : "fatal" and "non-fatal". Thus far, we have only considered the "fatal" ones.

Fatal errors are such that production of a parse tree is impossible. Non-fatal parse errors are those that don't prevent construction of a parse tree. A parse that generates non-fatal errors is going to associate with a parse tree in some way non-conforming to the Haskell language specification.

The right way to write the POk case is like this.

POk s m -> do
  let (warns, errs) = getMessages s flags
  report flags warns
  report flags errs
  when (null errs) $ analyzeModule flags m
The key point is analyzeModule is called only if there are absolutely no parse errors at all.

A non-fatal error example is provided by the ImportQualifiedPost language extension (see this post for how to add a GHC language extension). Specifically, it is only legal to write import M qualified if the extension is in effect via pragma or the option -XImportQualifiedPost. In the event this syntax is used when the extension is not in effect, the user should see an error like

 test/MiniHlintTest_non_fatal_error.hs:6:18: error:
     Found `qualified' in postpositive position.
     To allow this, enable language extension 'ImportQualifiedPost'
and further analysis of the parse abandoned.

Sunday, April 7, 2019

Announcing ghc-lib 0.20190404

Announcing ghc-lib 0.20190404

On behalf of Digital Asset I am excited to share with you the latest release of ghc-lib.

As described in detail in the ghc-lib README, the ghc-lib project lets you use the GHC API for parsing and analyzing Haskell code without tying you to a specific GHC version.

What's new

The GHC source code in this release is updated to GHC HEAD as of April the 4th, 2019. Accordingly, the mini-hlint example in the ghc-lib repo was adjusted to accomodate GHC API changes to the ParseResult datatype and parser error handling.

By far the biggest change though is this : the ghc-lib project now provides two packages, ghc-lib-parser and ghc-lib. The packages are released on Hackage, and can be installed as usual e.g. cabal install ghc-lib.

Some projects don't require the ability to compile Haskell to GHC's Core language. If lexical analysis alone is sufficient for your project's needs, then the ghc-lib-parser package alone will do for that. The build time for ghc-lib-parser is roughly half of the combined build times of ghc-lib-parser and ghc-lib. That is, in this case, switching to the new release will decrease the build time for your project. Note that if your project does require compiling Haskell to Core, then your project will now depend on both the ghc-lib-parser and ghc-lib packages.

The ghc-lib package "re-exports" the modules of the ghc-lib-parser package. So, if you depend upon the ghc-lib package, you'll get the ghc-lib-parser modules "for free". Sadly though, at this time, package import syntax (and we do recommend using package import syntax for these packages) doesn't quite work like you'd expect so that if you, import "ghc-lib" DynFlags for example, this will fail because DynFlags is in fact in the ghc-lib-parser package. In this case, you'd write, import "ghc-lib-parser" DynFlags and all would be well. The mini-compile example in the ghc-lib repo demonstrates mixing modules from both packages.

Digital Asset make extensive use of the ghc-lib packages in the DAML smart contract language compiler and hope you continue to benefit from this project too!

Wednesday, March 20, 2019

Bush fixing Travis and GitLab

Bush fixing Travis and CI

Ever had one of those days?

You are not alone!

This Saturday 9th March 2019, the GHC devs are going to announce that git:// has been decommissioned. The new official upstream GHC will be

Sadly (for us) this broke ghc-lib CI's Travis linux configuration.

What does our CI do? The ghc-lib CI script pulls down the latest GHC sources and builds and tests them as a ghc-lib. The details of the problem are that Travis gives you a broken Ubuntu where cloning the official URL fails with a TLS “handshake error”. More generally, any Travis job that tries to git clone over the https protocol from a GitLab remote will fail the same way.

This .travis.yml shows a workaround. The idea is to spin up a container before install that doesn’t have this problem and clone from there. The essential bits are:

- docker

# [Why we git clone on linux here]
# At this time, `git clone`
# from within `CI.hs` does not work on on linux. This appears to be a
# known Travis/ubuntu SSL verification issue. We've tried many less
# drastic workarounds. This grand hack is the only way we've found so
# far that can be made to work.
- |
    if [[ "$TRAVIS_OS_NAME" == "linux" ]]; then
      docker pull alpine/git
      docker run -ti --rm -v ${HOME}:/root -v $(pwd):/git \
        alpine/git clone /git/ghc --recursive

Note, MacOS docker services aren’t supported but that’s OK! The TLS handshake problem doesn’t exhibit in that configuration.

Update : It turns out that while this issue exists in Ubuntu 14.04 which Travis uses by default, it is “fixed” in Ubuntu 16.04. So by writing dist: xenial in your .travis.yml file, the above workaround can be avoided.

Saturday, February 23, 2019

Adding a GHC Language Extension

Adding a GHC Language Extension

This note summarizes the essential mechanics of adding a new language extension to GHC. The example code will illustrate adding a Foo extension.

Implementing the extension

The first step is to add a Foo constructor to the Extension type in libraries/ghc-boot-th/GHC/LanguageExtensions/Type.hs.

data Extension
    = Cpp
    | OverlappingInstances
    | Foo

The next job is to extend xFlagsDeps in compiler/main/DynFlags.hs.

xFlagsDeps = [
  flagSpec "AllowAmbiguousTypes" LangExt.AllowAmbiguousTypes,
  flagSpec "Foo"                 LangExt.Foo

That's all it takes. With these two changes, it is now possible to enable Foo in Haskell source files by writing {-# LANGUAGE Foo #-} or from a compile command by passing the argument -XFoo.

Testing for the extension


In compiler/parser/Lexer.x, locate data ExtBits and add a constructor for Foo.

data ExtBits
  = FfiBit
  | ...
  | FooBit
Next, extend the where clause of function mkParserFlags' with a case for Foo.
langExtBits =
        FfiBit `xoptBit` LangExt.ForeignFunctionInterface
    .|. InterruptibleFfiBit `xoptBit` LangExt.InterruptibleFFI


    .|. FooBit `xoptBit` LangExt.FooBit
The function xtest is then the basic building block for testing if Foo is enabled. For example, this specific function tests a bitmap for the on/off status of the Foo bit.
fooEnabled :: ExtsBitMap -> Bool
fooEnabled = xtest FooBit
In practice, testing for a language extension in the lexer is called from a function computing a lexer action. Suppose foo to be such a function and the action it computes depends somehow on whether the Foo language extension is in effect. Putting it all together, schematically it will have the following form.
foo :: (FastString -> Token) -> Action
foo con span buf len = do
    exts <- getExts
    if FooBit `xtest` exts then


This utility computes a monadic expression testing for the on/off state of a bit in a parser state monad.

extension :: (ExtsBitmap -> Bool) -> P Bool
extension p = P $ \s -> POk s (p $! (pExtsBitmap . options) s)
An expression of this kind can be evaluated in the semantic action of a parse rule in compiler/parser/Parser.y. Here's an example of how one might be used.
foo :: { () }
  : 'foo'  {}
  | {- empty -}    {% do
                         foo_required <- extension fooEnabled
                         when foo_required $ do
                           loc <- fileSrcSpan
                           parseErrorSDoc loc $ text "Missing foo"

Renaming, type-checking and de-sugaring

All of renaming, typechecking and desurgaring occur in the contexts of TcRnIf _ _ monads. Function xoptM :: Extension -> TcRnIf gbl lcl Bool is provided for extension testing in such contexts. Here's a schematic of how such a test might be used in a renaming function.

import GHC.LanguageExtensions

updateFoos :: [AvailInfo] -> RnM (TcGlbEnv, TcLclEnv)
updateFoos info = do
  (globals, locals) <- getEnvs
  opt_Foo <- xoptM Foo
  if not opt_Foo then
    return (globals, locals)
    let globals' = ...
        locals' = ...
    return (globals', locals')

Sunday, June 10, 2018

Bucket Sort

Bucket Sort

Bucket sort assumes input generated by a random process that distributes elements uniformly over the interval [0, 1).

The idea of bucket sort is to divide [0, 1) into n equal-sized subintervals or buckets, and then distribute the n input numbers into the buckets. To produce the output, sort the numbers in each bucket and then go through the buckets in order. Sorting a bucket can be done with insertion sort.

let rec insert x = function
  | [] -> [x]
  | h :: tl as ls ->
    if x < h then x :: ls else h :: insert x tl

let rec insertion_sort = function
  | [] | [_] as ls -> ls
  | h :: tl -> insert h (insertion_sort tl)

This code for bucket sort assumes the input is an n-element array a and that each element 0 ≤ a.(i) < 1. The code requires an auxillary array b.(0 .. n - 1) of lists (buckets).

let bucket_sort a =
  let n = Array.length a in
  let b = Array.make n [] in
    (fun x ->
       let i =
         int_of_float (
           floor (float_of_int n *. x)
         ) in
        Array.set b i (x :: Array.get b i)
      ) a;
    (fun i l ->
       Array.set b i (insertion_sort l)
    ) b;
  Array.fold_left (fun acc bucket -> acc @ bucket) [] b
bucket_sort [| 0.78; 0.17; 0.39; 0.26; 0.72; 0.94
             ; 0.21; 0.12; 0.23; 0.68|]
Bucket sort runs in linear time on the average.

[1] "Introduction to Algorithms" Section 9.4:Bucket Sort -- Cormen et. al. (Second ed.) 2001.

Sunday, May 20, 2018

Dijkstra's algorithm

Shortest Path

This article assumes familiarity with Dijkstra's shortest path algorithm. For a refresher, see [1]. The code assumes open Core is in effect and is online here.

The first part of the program organizes our thoughts about what we are setting out to compute. The signature summarizes the notion (for our purposes) of a graph definition in modular form. A module implementing this signature defines a type vertex_t for vertices, a type t for graphs and type extern_t : a representation of a t for interaction between an implemening module and its "outside world".

module type Graph_sig = sig
  type vertex_t [@@deriving sexp]
  type t [@@deriving sexp]
  type extern_t

  type load_error = [ `Duplicate_vertex of vertex_t ] [@@deriving sexp]
  exception Load_error of load_error [@@deriving sexp]

  val of_adjacency : extern_t -> [ `Ok of t | `Load_error of load_error ]
  val to_adjacency : t -> extern_t

  module Dijkstra : sig
    type state

    type error = [
      | `Relax of vertex_t
    ] [@@deriving sexp]
    exception Error of error [@@deriving sexp]

    val dijkstra : vertex_t -> t -> [ `Ok of state | `Error of error ]
    val d : state -> (vertex_t * float) list
    val shortest_paths : state -> (vertex_t * vertex_t list) list

A realization of Graph_sig provides "conversion" functions of_adjacency/to_adjacency between the types extern_t and t and nests a module Dijkstra. The signature of the sub-module Dijkstra requires concrete modules provide a type state and an implementation of Dijkstra's algorithm in terms of the function signature val dijkstra : vertex_t -> t -> [ `Ok of state | `Error of error ].

For reusability, the strategy for implementing graphs will be generic programming via functors over modules implementing s vertex type.

An implementation of the module type GRAPH defines a module type VERT which is required to provide a comparable type t. It further defines a module type S that is exactly module type Graph_sig above. Lastly, modules of type GRAPH provide a functor Make that maps any module of type VERT to new module of type S fixing extern_t to an adjacency list representation in terms of the native OCaml type 'a list and float to represent weights on edges.

module type GRAPH = sig
  module type VERT = sig
    type t[@@deriving sexp]
    include Comparable.S with type t := t

  module type S = sig
    include Graph_sig

  module Make : functor (V : VERT) ->
    S with type vertex_t = V.t
       and type extern_t = (V.t * (V.t * float) list) list
The two module types Graph_sig and GRAPH together provide the specification for the program. module Graph in the next section implements this specification.

Implementation of module Graph is in outline this.

module Graph : GRAPH = struct
  module type VERT = sig
    type t[@@deriving sexp]
    include Comparable.S with type t := t

  module type S = sig
    include Graph_sig

  module Make : functor (V : VERT) ->
    S with type vertex_t = V.t
       and type extern_t = (V.t * (V.t * float) list) list

    functor (V : VERT) -> struct
As per the requirements of GRAPH the module types VERT and S are provided as is the functor Make. It is the code that is ellided by the ... above in the definition of Make that is now the focus.

Modules produced by applications of Make satisfy S. This requires suitable definitions of types vertext_t, t and extern_t. The modules Map and Set are available due to modules of type VERT being comparable in their type t.

      module Map = V.Map
      module Set = V.Set

      type vertex_t = V.t [@@deriving sexp]
      type t = (vertex_t * float) list Map.t [@@deriving sexp]
      type extern_t = (vertex_t * (vertex_t * float) list) list
      type load_error = [ `Duplicate_vertex of vertex_t ] [@@deriving sexp]
      exception Load_error of load_error [@@deriving sexp]

While the external representation extern_t of graphs is chosen to be an adjacency list representation in terms of association lists, the internal representation t is a vertex map of adjacency lists providing logarithmic loookup complexity. The conversion functions between the two representations "come for free" via module Map.

      let to_adjacency g = Map.to_alist g

      let of_adjacency_exn l =  match Map.of_alist l with
        | `Ok t -> t
        | `Duplicate_key c -> raise (Load_error (`Duplicate_vertex c))

      let of_adjacency l =
          `Ok (of_adjacency_exn l)
        | Load_error err -> `Load_error err

At this point the "scaffolding" for Dijkstra's algorithm, that part of GRAPH dealing with the representation of graphs is implemented.

The interpretation of Dijkstra's algorithm we adopt is functional : the idea is we loop over vertices relaxing their edges until all shortest paths are known. What we know on any recursive iteration of the loop is a current "state" (of the computation) and each iteration produces a new state. This next definition is the formal definition of type state.

      module Dijkstra = struct

        type state = {
          src    :                  vertex_t
        ; g      :                         t
        ; d      :               float Map.t
        ; pred   :            vertex_t Map.t
        ; s      :                     Set.t
        ; v_s    : (vertex_t * float) Heap.t
The fields of this record are:
  • src : vertex_t, the source vertex;
  • g : t, G the graph;
  • d : float Map.t, d the shortest path weight estimates;
  • pre : vertex_t Map.t, π the predecessor relation;
  • s : Set.t, the set S of nodes for which the lower bound shortest path weight is known;
  • v_s : (vertex_t * float) Heap.t, V - {S}, , the set of nodes of g for which the lower bound of the shortest path weight is not yet known ordered on their estimates.

Function invocation init src g compuates an initial state for the graph g containing the source node src. In the initial state, d is everywhere except for src which is 0. Set S (i.e. s) and the predecessor relation π (i.e. pred) are empty and the set V - {S} (i.e. v_s) contains all nodes.

        let init src g =
          let init x = match V.equal src x with
            | true -> 0.0 | false -> Float.infinity in
          let d = List.fold (Map.keys g) ~init:Map.empty
              ~f:(fun acc x -> Map.set acc ~key:x ~data:(init x)) in
          ; g
          ; s = Set.empty
          ; d
          ; pred = Map.empty
          ; v_s = Heap.of_list (Map.to_alist d)
                ~cmp:(fun (_, e1) (_, e2) -> e1 e2)

Relaxing an edge (u, v) with weight w (u, v) tests whether the shortest path to v so far can be improved by going through u and if so, updating d (v) and π (v) accordingly.

        type error = [
          | `Relax of vertex_t
        ] [@@deriving sexp]
        exception Error of error [@@deriving sexp]

        let relax state (u, v, w) =
          let {d; pred; v_s; _} = state in
          let dv = match Map.find d v with
            | Some dv -> dv
            | None -> raise (Error (`Relax v)) in
          let du = match Map.find d u with
            | Some du -> du
            | None -> raise (Error (`Relax u)) in
          if dv > du +. w then
            let dv = du +. w in
            (match Heap.find_elt v_s ~f:(fun (n, _) -> V.equal n v) with
            | Some tok -> ignore (Heap.update v_s tok (v, dv))
            | None -> raise (Error (`Relax v))
            { state with
              d = Map.change d v
                      | Some _ -> Some dv
                      | None -> raise (Error (`Relax v))
            ; pred = Map.set (Map.remove pred v) ~key:v ~data:u
          else state
Here, relaxation can result in a linear heap update operation. A better implementation might seek to avoid that.

One iteration of the body of the loop of Dijkstra's algorithm consists of the node in V - {S} with the least shortest path weight estimate being moved to S and its edges relaxed.

        let dijkstra_exn src g =
          let rec loop ({s; v_s; _} as state) =
            match Heap.is_empty v_s with
            | true -> state
            | false ->
              let u = fst (Heap.pop_exn v_s) in
              loop (
                List.fold (Map.find_exn g u)
                  ~init:{ state with s = Set.add s u }
                  ~f:(fun state (v, w) -> relax state (u, v, w))
          in loop (init src g)

        let dijkstra src g =
            `Ok (dijkstra_exn src g)
          | Error err -> `Error err

The shortest path estimates contained by a value of state is given by the projection d.

        let d state = Map.to_alist (state.d)

The shortest paths themselves are easily computed as,

   let path state n =
          let rec loop acc x =
            (match V.equal x state.src with
            | true -> x :: acc
            | false -> loop (x :: acc) (Map.find_exn state.pred x)
            ) in
          loop [] n

        let shortest_paths state =
 (Map.keys state.g) ~f:(fun n -> (n, path state n))
which completes the implementation of Make.

The following program produces a concrete instance of the shortest path problem (with some evaluation output from the top-level).

module G : Graph.S with
  type vertex_t = char and type extern_t = (char * (char * float) list) list
  Graph.Make (Char)

let g : G.t =
  match G.of_adjacency
          [ 's', ['u',  3.0; 'x', 5.0]
          ; 'u', ['x',  2.0; 'v', 6.0]
          ; 'x', ['v',  4.0; 'y', 6.0; 'u', 1.0]
          ; 'v', ['y',  2.0]
          ; 'y', ['v',  7.0]
  | `Ok g -> g
  | `Load_error e -> failwiths "Graph load error : %s" e G.sexp_of_load_error
let s = match (G.Dijkstra.dijkstra 's' g) with
  | `Ok s -> s
  | `Error e -> failwiths "Error : %s" e G.Dijkstra.sexp_of_error

;; G.Dijkstra.d s
- : (char * float) list =
[('s', 0.); ('u', 3.); ('v', 9.); ('x', 5.); ('y', 11.)]

;; G.Dijkstra.shortest_paths s
- : (char * char list) list =
[('s', ['s']); ('u', ['s'; 'u']); ('v', ['s'; 'u'; 'v']); ('x', ['s'; 'x']);
 ('y', ['s'; 'x'; 'y'])]

[1] "Introduction to Algorithms" Section 24.3:Dijkstra's algorithm -- Cormen et. al. (Second ed.) 2001.