Ann.hs

-- | Annotations - allow custom, extra data in AST nodes.
module Descript.Misc.Ann
  ( Ann (..)
  , SAnn (..)
  , EAnn (..)
  , AnnSummary (..)
  , SummaryWithAnn (..)
  , remAnns
  , (=@=)
  , (/@=)
  , (<$@>)
  , (<*@>)
  , summaryWithAnn
  ) where

import Data.Semigroup

-- | An AST node which can be annotated.
class (Functor a, Foldable a, Traversable a) => Ann a where
  -- | Gets the annotation.
  getAnn :: a an -> an

-- | An AST node whose surface annotation can be transformed.
-- Technically every 'Ann' is an 'SAnn', but this functionality rarely
-- seems necessary so for most values it isn't implemented.
class (Ann a) => SAnn a where
  -- | Transforms the surface annotation. Different than 'fmap', which
  -- also transforms child nodes' annotations.
  mapSAnn :: (an -> an) -> a an -> a an

-- | An AST node which can be combined with a semantically equivalent
-- node (equal via '=@='), combining annotations. Technically every
-- 'Ann' is an 'EAnn', but not all have implementations.
class (Ann a) => EAnn a where
  -- | Combine 2 nodes with equivalent semantic content, but different
  -- annotations. Assumes the nodes are semantically equal (via '=@=').
  eappend :: (Semigroup an) => a an -> a an -> a an

-- | An annotation which affects a summary.
class (Show a) => AnnSummary a where
  -- | A prefix added to a summary by the annotation
  annSummaryPre :: a -> String

-- | Gets its summary by adding its annotation to a base summary.
--
-- > instance (SummaryWithAnn a) => Summary a where
-- >   summary = summaryWithAnn
class (Ann a) => SummaryWithAnn a where
  -- | The part of the summary without the annotation.
  baseSummary :: a an -> String

instance AnnSummary () where
  annSummaryPre () = ""

-- | Removes the annotations from the value and sub-values.
remAnns :: (Functor w) => w a -> w ()
remAnns x = () <$ x

-- | Whether the expressions are equal without annotations.
(=@=) :: (Functor w, Eq (w ())) => w a1 -> w a2 -> Bool
x =@= y = remAnns x == remAnns y

-- | Whether the expressions aren't equal without annotations.
(/@=) :: (Functor w, Eq (w ())) => w a1 -> w a2 -> Bool
x /@= y = remAnns x /= remAnns y

-- | Like '<$>', but delays applying an initial argument (the annotation).
--
-- Useful for creating parsers or other functors on annotated values,
-- which get ranges later. For example:
--
-- > ranged $ Add <$@> numParser <*@> numParser
--
-- is equivalent to
--
-- > ranged $ \range -> Add range <$> numParser <*> numParser
infixl 4 <$@>
(<$@>) :: (Functor w) => (ann -> a -> b) -> w a -> w (ann -> b)
f <$@> x = flip f <$> x

-- | Like '<*>', but delays applying an initial argument (the annotation).
--
-- Useful for creating parsers or other functors on annotated values,
-- which get ranges later. For example:
--
-- > ranged $ Add <$@> numParser <*@> numParser
--
-- is equivalent to
--
-- > ranged $ \range -> Add range <$> numParser <*> numParser
infixl 4 <*@>
(<*@>) :: (Applicative w) => w (ann -> a -> b) -> w a -> w (ann -> b)
f <*@> x = fmap flip f <*> x

-- | Gets the summary of a value, including its annotation.
summaryWithAnn :: (SummaryWithAnn a, AnnSummary an) => a an -> String
summaryWithAnn x = annSummaryPre (getAnn x) ++ baseSummary x