Parse error on `(:++:)`

[fredericcogny]

I've got a hlint parse error on a file (below). All previous parse error issues seem to be closed so I doubt this is a duplicate but apologies of it is.

hlint --version                                        fcogny@fcogny-home23:39:16
HLint v2.0.11, (C) Neil Mitchell 2006-2017

error message is

hlint . --report                                       fcogny@fcogny-home23:37:13
./src/Data/HTree.hs:28:34: Error: Parse error
Found:
    module Data.HTree
  >   ( HTree(..), HShape, HL, type (:++:)
      , (*++*), pattern (:++:)
      , hnodes, hleaves, hroot, hleaf

Writing report to report.html ...

the file is

{-# LANGUAGE AllowAmbiguousTypes       #-}
{-# LANGUAGE ConstraintKinds           #-}
{-# LANGUAGE DataKinds                 #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE ExplicitNamespaces        #-}
{-# LANGUAGE FlexibleInstances         #-}
{-# LANGUAGE FunctionalDependencies    #-}
{-# LANGUAGE GADTs                     #-}
{-# LANGUAGE KindSignatures            #-}
{-# LANGUAGE MultiParamTypeClasses     #-}
{-# LANGUAGE PatternSynonyms           #-}
{-# LANGUAGE RankNTypes                #-}
{-# LANGUAGE ScopedTypeVariables       #-}
{-# LANGUAGE TupleSections             #-}
{-# LANGUAGE TypeApplications          #-}
{-# LANGUAGE TypeFamilies              #-}
{-# LANGUAGE TypeOperators             #-}
{-# LANGUAGE ViewPatterns              #-}
-----------------------------------------------------------------------------
-- |
-- Module :  "Data.HTree"
--
-- The goal of this module is to provide an abstraction called 'HTree' (for
-- _heterogeneous tree_) that will be used notably to compose models.
-----------------------------------------------------------------------------

module Data.HTree
  ( HTree(..), HShape, HL, type (:++:)
  , (*++*), pattern (:++:)
  , hnodes, hleaves, hroot, hleaf
  , ToTaglessHTree(..), FromTaglessHTree(..)
  , ForAllLeavesOf
  , mapMAccumHTree, mapMHTree, mapMAccumHTreeBottomUp
  , Flip(..), L.Const(..)
  ) where

import           Control.Lens as L
import           GHC.Exts     (Constraint)

-- | @HShape is to be used as a kind
data HShape = HBranch HShape HShape | forall t. HLeaf t

-- | The constructor of a branching in an 'HTree' shape
type (:++:) = 'HBranch

-- | The constructor of a leave in an 'HTree' shape
type HL = 'HLeaf

-- | A heterogeneous tree where each node contains some type @node@ and each
-- leaf is typed as @leaf t@, where @leaf@ is the same type constructor for
-- every leaf and @t@ can vary. This way leaf information is separated between
-- common (@leaf@) and local (@t@) information. This is the base type for a tree
-- of 'Models', if @node@=@BioReacMatchup v p@, @leaf@=@Flip Model Double@ and
-- @t@'s are instances of 'ModelCore'
--
-- Example of a concrete model tree type:
-- `:: HTree (VPMatchup a) (Flip Model a) (HB (HL [BioReaction]) (HB (HL [BioReaction]) (HL [ODE]) ))`
--
-- To avoid type @n@ not being fixable when creating a node, you shouldn't
-- directly use HLeaf_ and HBranch_. Instead instanciate 'ToTaglessHTree' and use
-- '(*++*)' to construct nodes and '(:++:)' to pattern-match on nodes. Node
-- labels (@n@) can be edited via `over hnodes` for instance.
--
-- Example of usage:
--
-- ```
-- newtype X a = X a
-- instance ToTaglessHTree (X a) X (HL a)
--   where toHTreeNode = HLeaf_
-- instance FromTaglessHTree (X a) n X (HL a)
--   where fromHTreeNode (HLeaf_ x) = x
--
-- -- t :: HTree () X (HL Int :++: HL Int :++: HL Double)
-- t = X 3 *++* X 90 *++* X 56.23
-- functionOnTree (X a :++: X b :++: X c) = fromIntegral a + fromIntegral b + c
-- a = functionOnTree t
-- ```
data HTree node leaf (shape :: HShape) where
  HBranch_ :: HTree n l s -> n -> HTree n l s' -> HTree n l (s :++: s')
  HLeaf_ :: l t -> HTree n l (HL t)

-- | Class of things that can directly be turned into a tagless tree node
class ToTaglessHTree a l s | a -> l s where
  toHTreeNode :: a -> HTree () l s

class FromTaglessHTree a n l s | n l s -> a  where
  fromHTreeNode :: HTree n l s -> a

instance ToTaglessHTree (HTree () l s) l s where
  toHTreeNode = id
instance FromTaglessHTree (HTree n l (s :++: s')) n l (s :++: s') where
  fromHTreeNode = id

instance FromTaglessHTree a n (Const a) (HL t) where
  fromHTreeNode (HLeaf_ (L.Const x)) = x

-- | Construct an HTree from basic elements (such as Models)
(*++*)
  :: (ToTaglessHTree a l s, ToTaglessHTree b l s')
  => a -> b -> HTree () l (s :++: s')
a *++* b = HBranch_ (toHTreeNode a) () (toHTreeNode b)

-- | Deconstruct an HTree ignoring its nodes (for instance to retrieve ModelResults)
pattern (:++:)
  :: (FromTaglessHTree a n l s, FromTaglessHTree b n l s')
  => a -> b -> HTree n l (s :++: s')
pattern a :++: b <- HBranch_ (fromHTreeNode -> a) _ (fromHTreeNode -> b)

hroot :: Lens' (HTree n l (s :++: s')) n
hroot f (HBranch_ s n s') = rebuild <$> f n
  where rebuild n' = HBranch_ s n' s'

hleaf :: Lens (HTree n l (HL t)) (HTree n' l' (HL t')) (l t) (l' t')
hleaf f (HLeaf_ l) = HLeaf_ <$> f l

-- | A traversal to each node of the tree
--
-- Example of use:
-- ```
-- t' = over hnodes (const 18) t
-- ```
hnodes :: Traversal (HTree n l s) (HTree n' l s) n n'
hnodes _ (HLeaf_ l) = pure $ HLeaf_ l
hnodes f (HBranch_ s n s') =
  HBranch_ <$> hnodes f s <*> f n <*> hnodes f s'

-- | A pseudo-traversal to each leaf of the tree. It is not usable with classic
-- `over`, `mapMOf` etc. lens functions and it is difficult to compose it with
-- other lenses/traversals. But it's possible to use it direcly as a function.
--
-- Example of use:
-- ```
-- t'' = runIdentity $ hleaves @Num (\(X x) -> Identity $ X $ x+1) t
-- ```
--
-- Modulo the t, the type of @hleaves@ is equivalent to:
--    `(c `ForAllLeavesOf` s) => Traversal (HTree n l s) (HTree n l' s) (l t) (l' t)`
hleaves
  :: forall c s f l l' n. (c `ForAllLeavesOf` s, Applicative f)
  => (forall t. (c t) => l t -> f (l' t)) -> HTree n l s -> f (HTree n l' s)
hleaves f (HLeaf_ l) = HLeaf_ <$> f l
hleaves f (HBranch_ s n s') =
  HBranch_ <$> hleaves @c f s <*> pure n <*> hleaves @c f s'

-- | Finds whether each leaf type in the tree satisfies a Constraint. We cannot
-- express it as a typeclass.
type family constraint `ForAllLeavesOf` (shape :: HShape) :: Constraint where
  c `ForAllLeavesOf` (s :++: s') = (c `ForAllLeavesOf` s, c `ForAllLeavesOf` s')
  c `ForAllLeavesOf` HL t        = c t

-- | Permits to traverse *from top to bottom* a tree-like structure whose leaves
-- aren't of the same type, but all satisfy some Constraint @c@. @acc@ is
-- propagated _down_ the tree only (hence it couldn't be encompassed in the
-- monad @m@, because it's not a state global to the whole traversal). The
-- structure is preserved, this is statically guaranteed by the fact the shape
-- type @s@ isn't changed.
--
-- Obeys the following law:
-- - `mapMAccumHTree (curry return) (const return) undefined t == return t`
mapMAccumHTree
  :: forall c m n n' l l' s acc. (Monad m, c `ForAllLeavesOf` s)
  => (acc -> n -> m (acc, n'))
     -- ^ Applied on each node of the @HTree@. MAYBE it should split @acc@ into
     -- two versions, one for each son?
  -> (forall t. (c t) => acc -> l t -> m (l' t))
     -- ^ Applied on each leaf of the @HTree@. It doesn't return a new @acc@
     -- because @acc@ is only passed *down* the tree
  -> acc
     -- ^ The initial value of the accumulator (for the root)
  -> HTree n l s
     -- ^ The tree to map over
  -> m (HTree n' l' s)
mapMAccumHTree _ onLeaf z (HLeaf_ l) = HLeaf_ <$> onLeaf z l
mapMAccumHTree onBranch onLeaf z (HBranch_ a n b) = do
  (z', n') <- onBranch z n
  HBranch_ <$> mapMAccumHTree @c onBranch onLeaf z' a
          <*> pure n'
          <*> mapMAccumHTree @c onBranch onLeaf z' b

-- | Does the same type of traversal than 'mapMAccumHTree' but *from bottom to
-- top*, and returns the final value of the accumulator. The accumulator should
-- be akin to a Monoid.
--
-- Obeys the following law:
-- - `mapMAccumHTreeBottomUp (curry return) (\_ n _ -> return ((), n)) () t == return ((), t)`
mapMAccumHTreeBottomUp
  :: forall c m n n' l l' s acc. (Monad m, c `ForAllLeavesOf` s)
  => (forall t. (c t) => l t -> m (acc, l' t))
     -- ^ Applied on each leaf of the @HTree@
  -> (acc -> n -> acc -> m (acc, n'))
     -- ^ Applied on each node of the @HTree@. It should combine the two states
     -- of the accumulator it receives from its sons to propagate it further up
     -- the tree
  -> HTree n l s
     -- ^ The tree to map over
  -> m (acc, HTree n' l' s)
mapMAccumHTreeBottomUp onLeaf _ (HLeaf_ l) = do
  (z, newL) <- onLeaf l
  return (z, HLeaf_ newL)
mapMAccumHTreeBottomUp onLeaf onBranch (HBranch_ a n b) = do
  (za, a') <- mapMAccumHTreeBottomUp @c @_ @_ @_ @_ @l' onLeaf onBranch a
  (zb, b') <- mapMAccumHTreeBottomUp @c @_ @_ @_ @_ @l' onLeaf onBranch b
  (z', n') <- onBranch za n zb
  return (z', HBranch_ a' n' b')

mapMHTree
  :: forall c m n n' l l' s. (Monad m, c `ForAllLeavesOf` s)
  => (n -> m n')
  -> (forall t. (c t) => l t -> m (l' t))
  -> HTree n l s
  -> m (HTree n' l' s)
mapMHTree onBranch onLeaf =
  mapMAccumHTree @c (\a -> fmap (a,) . onBranch) (const onLeaf) ()

-- | A type with its type parameters swapped
newtype Flip f a b = Flip { unFlip :: f b a }

[ndmitchell]

Thanks Fred, always good to get such reports, although unfortunately the Haskell parser I depend on isn't that faithful to real GHC anymore - it's diverged and having a hard time keeping up. The plan is to switch HLint to ghc-lib which will let me use the real GHC parser, and should fix all these things and keep up with the latest GHC going forward.

[fredericcogny]

Cool. Yes I saw your blog-post on this. This is neat. Good luck for the switch. No hurry at all on my end, just thought it might be useful to report

[ndmitchell]

Confirmed works with HEAD that doesn't use HSE for parsing, so fixed in the next release.