packages feed

Annotations (empty) → 0.1

raw patch · 21 files changed

+1293/−0 lines, 21 filesdep +basedep +mtldep +multirecsetup-changed

Dependencies added: base, mtl, multirec, parsec

Files

+ Annotations.cabal view
@@ -0,0 +1,42 @@+Name:           Annotations+Version:        0.1+Synopsis:       Constructing, analyzing and destructing annotated trees+Description:+  @Annotations@ provides utility functions to make working with annotated trees easier. There are two implementations: one for working with open datatypes that explicitly make their child positions accessible through a type argument, and one for working with MultiRec datatypes.+  .+  Parser combinators make it easy to construct trees annotated with position information. For the MultiRec implementation, there is the @Yield@ monad that allows construction of trees in postorder.+  .+  Error algebras allow destruction of trees using catamorphisms. The algebra is allowed to indicate failure in which case the error is automatically coupled with the annotation at the position at which the error occurred.++Author:         Martijn van Steenbergen+Maintainer:     martijn@van.steenbergen.nl+Copyright:      Copyright (c) 2008-2009 Martijn van Steenbergen++Cabal-Version:  >= 1.2+License:        BSD3+License-file:   LICENSE+Category:       Generics+Build-type:     Simple++Library+  Build-Depends:    base >= 4.1 && < 4.2, mtl >= 1.1 && < 1.2,+                    parsec >= 3.0 && < 3.1, multirec >= 0.4 && < 0.5+  Exposed-Modules:  Annotations.Bounds,+                    Annotations.BoundsParser,+                    Annotations.Except,+                    Annotations.ExploreHints,+                    Annotations.F.Fixpoints,+                    Annotations.F.Annotated,+                    Annotations.F.Zipper,+                    Annotations.F.Positional,+                    Annotations.F.ParserCombinators,+                    Annotations.MultiRec.Annotated,+                    Annotations.MultiRec.Any,+                    Annotations.MultiRec.ErrorAlg,+                    Annotations.MultiRec.ParserCombinators,+                    Annotations.MultiRec.ShowFam,+                    Annotations.MultiRec.Yield,+                    Annotations.MultiRec.Zipper,+                    Annotations.MultiRec.ZipperFix,+                    Annotations.MultiRec.Positional+
+ Annotations/Bounds.hs view
@@ -0,0 +1,53 @@+-- | Types and utility functions for expression text selections.+module Annotations.Bounds+  ( -- * Types+    Range+  , Bounds(..), innerRange, outerRange+    -- * Membership predicates+  , posInRange, rangeInRange, rangeInBounds, rangesInBounds, distRange+  ) where+++-- | A simple textual selection: starting offset and ending offset,+-- respectively. Offsets are 0-based.+type  Range         = (Int, Int)  -- left, right++-- | A structural selection expressed as a textual selection. The margins+-- indicate the whitespace directly around the selected structure.+data  Bounds        = Bounds { leftMargin :: Range, rightMargin :: Range }+  deriving (Eq, Show)++-- | A @Bounds@' inner range does not include the whitespace around the selected structure.+innerRange :: Bounds -> Range+innerRange (Bounds (_, left) (right, _)) = (left, right)++-- | A @Bounds@' outer range includes the whitespace around the selected structure.+outerRange :: Bounds -> Range+outerRange (Bounds (left, _) (_, right)) = (left, right)+++-- | Tells whether the offset falls within the given range.+posInRange :: Int -> Range -> Bool+posInRange pos (left, right) = left <= pos && pos <= right++-- | Tells whether the first range is enclosed by the second range.+rangeInRange :: Range -> Range -> Bool+rangeInRange (left, right) range = left `posInRange` range && right `posInRange` range++-- | A range is within certain bounds if its left offset is within the bounds' +-- left margin and its right offset is within the bounds' right margin.+rangeInBounds :: Range -> Bounds -> Bool+rangeInBounds (l, r) b =+  l `posInRange` leftMargin  b &&+  r `posInRange` rightMargin b++-- | @rangesInBounds b@ yields all those ranges @r@ for which+-- @rangeInBounds r b@.+rangesInBounds :: Bounds -> [Range]+rangesInBounds (Bounds (ol, il) (ir, or)) = [ (l, r) | l <- [ol..il], r <- [ir..or] ]++-- | A measure for the dissimilarity between two ranges.+-- +--   @distRange (l1, r1) (l2, r2) = |l1 - l2| + |r1 - r2|@+distRange :: Range -> Range -> Int+distRange (l1, r1) (l2, r2) = abs (l1 - l2) + abs (r1 - r2)
+ Annotations/BoundsParser.hs view
@@ -0,0 +1,72 @@+-- | A Parsec parser type that parses 'Symbol's and keeps track of the +-- position within the input stream. Unlike Parsec's default position +-- tracking, this parser keeps track of the range of whitespace between two +-- tokens.+module Annotations.BoundsParser+  ( -- * Symbols+    Symbol(..), collapse,+    +    -- * Parsing+    P, satisfy, pToken, getPos+  ) where++import Annotations.Bounds++import qualified Text.Parsec as P+import qualified Text.Parsec.Pos as P+++-- | Symbols form input for parsers. Minimal complete definition: 'unparse'.+class Symbol s where+  -- | Unparses a symbol, converting it back to text.+  unparse :: s -> String++  -- | Yields the size of a symbol. Default implementation is @length . unparse@.+  symbolSize :: s -> Int+  symbolSize = length . unparse++instance Symbol s => Symbol [s] where+  unparse = concatMap unparse+  symbolSize = sum . fmap symbolSize++-- | Given a predicate that tells what tokens to discard, keeps only the meaningful tokens and couples them with position information.+collapse :: Symbol s => (s -> Bool) -> [s] -> [(s, Bounds)]+collapse space ts = collapse' (0, symbolSize lefts) space rest+  where+    (lefts, rest) = span space ts++collapse' :: Symbol s => Range -> (s -> Bool) -> [s] -> [(s, Bounds)]+collapse' _ _ [] = []+collapse' left space (t:ts) = new : collapse' right space rest+  where+    (_, leftInner)  = left+    rightInner      = leftInner   + symbolSize t+    rightOuter      = rightInner  + symbolSize rights+    right           = (rightInner, rightOuter)+    (rights, rest)  = span space ts+    new             = (t, Bounds left right)++++-- | A parser that works on symbols coupled with token information. The state maintains the current position in the stream. This position is the range of whitespace between two tokens.+type P s = P.ParsecT [(s, Bounds)] Range++-- | Yield the current position in the input.+getPos :: Monad m => P s m Range+getPos = P.getState++-- | Recognise a symbol matching a predicate.+satisfy :: (Monad m, Symbol s) => (s -> Bool) -> P s m s+satisfy ok = do+  let pos _ (_, bounds) _ = P.newPos "" 0 (fst (rightMargin bounds) + 1)+  let match x@(tok, _)+        | ok tok    = Just x+        | otherwise = Nothing+  (tok, bounds) <- P.tokenPrim (unparse . fst) pos match+  P.setState (rightMargin bounds)+  return tok++-- | Recognise a specific symbol.+pToken :: (Monad m, Symbol s, Eq s) => s -> P s m s+pToken = satisfy . (==)+
+ Annotations/Except.hs view
@@ -0,0 +1,23 @@+-- | The 'Except' datatype captures monoidal exceptions in applicative +-- computations.+module Annotations.Except where++import Data.Monoid+import Control.Applicative++-- | @Except@ is like @Either@ but is meant to be used only in applicative +-- computations. When two exceptions are sequenced, their sum (using +-- 'mappend') is computed.+data Except e a = Failed e | OK a+  deriving (Eq, Show)++instance Functor (Except e) where+  fmap f  (OK x) = OK (f x)+  fmap _  (Failed e) = Failed e++instance Monoid e => Applicative (Except e) where+  pure = OK+  OK f <*> OK x = OK (f x)+  OK _ <*> Failed e = Failed e+  Failed e <*> OK _ = Failed e+  Failed e1 <*> Failed e2 = Failed (e1 `mappend` e2)
+ Annotations/ExploreHints.hs view
@@ -0,0 +1,8 @@+module Annotations.ExploreHints (ExploreHints(..)) where++-- | Captures hints for the exploration of annotated trees.+data ExploreHints = ExploreHints+  { matchHere     :: Bool  -- ^ Whether the current focus matches.+  , exploreDown   :: Bool  -- ^ Whether to explore the children.+  , exploreRight  :: Bool  -- ^ Whether to explore further to the right.+  }
+ Annotations/F/Annotated.hs view
@@ -0,0 +1,93 @@+module Annotations.F.Annotated (+    -- * Annotations+    Ann(..), AnnFix, rootAnn, AnnFix1, mkAnnFix, unannotate, errorCata,+    -- * Exploring annotated trees using zippers+    explore, findLeftmostDeepest,+  ) where+++import Annotations.Except+import Annotations.ExploreHints+import Annotations.F.Fixpoints+import Annotations.F.Zipper++import Data.Foldable (Foldable, foldMap)+import Data.Traversable+import Data.Maybe+import Control.Applicative+import Control.Monad+++-- | Lifted annotation of functors.+data Ann x f a = Ann x (f a)+  deriving (Eq, Show)++instance Functor f => Functor (Ann x f) where+  fmap f (Ann x t) = Ann x (fmap f t)++instance Foldable f => Foldable (Ann x f) where+  foldMap f (Ann _ t) = foldMap f t++instance Traversable f => Traversable (Ann x f) where+  traverse f (Ann x t) = Ann x <$> traverse f t++-- | A fully annotated tree.+type AnnFix   xT fT  = Fix (Ann xT fT)++-- | A functor with fully annotated children.+type AnnFix1  xT fT  = fT (AnnFix xT fT)++-- | Supply a tree with an annotation at the top level.+mkAnnFix :: x -> AnnFix1 x f -> AnnFix x f+mkAnnFix x = In . Ann x++-- | Yields the annotation at the root of the tree.+rootAnn :: AnnFix x f -> x+rootAnn (In (Ann x _)) = x++-- | Recursively discard annotations.+unannotate :: Functor f => AnnFix x f -> Fix f+unannotate (In (Ann _ tree)) = In (fmap unannotate tree)++-- | Reduces a tree to a value according to the algebra, collecting potential+--   errors. The errors are combined with the annotations in the tree at the+--   positions at which the errors occurred.+errorCata :: Traversable fT => ErrorAlgebra fT eT aT -> AnnFix xT fT -> Except [(eT, xT)] aT+errorCata alg (In (Ann x expr)) =+  case traverse (errorCata alg) expr of+    Failed xs  -> Failed xs+    OK expr'   -> case alg expr' of+      Left x'   -> Failed [(x', x)]+      Right v   -> OK v++-- | Explore an annotated tree. Starting with the root of the tree, at each +-- position the annotation at that position is matched against the +-- 'ExploreHints' predicates and all the selections where 'matchHere' was +-- positive are collected. The 'exploreRight' and 'exploreDown' allow pruning +-- of the tree, preventing entire parts from being visited.+explore :: Foldable f => (x -> ExploreHints) -> AnnFix x f -> [Zipper (AnnFix x f)]+explore hints = explore' hints . enter++explore' :: Foldable f => (x -> ExploreHints) -> Zipper (AnnFix x f) -> [Zipper (AnnFix x f)]+explore' hints root = [ z | (dirOk, zs) <- dirs, dirOk (hints x), z <- zs ]+  where+    In (Ann x _) = zFocus root+    dirs =+      [  (matchHere,     [root])+      ,  (exploreDown,   exploreMore (zDown   root))+      ,  (exploreRight,  exploreMore (zRight  root))+      ]+    exploreMore = maybe [] (explore' hints)++-- | Find the deepest node in an annotated tree that matches the predicate.+-- Starting with the root, the predicate tells whether a node's annotation+-- matches. If so, the search continues at the node's children and the node's+-- siblings to the right are excluded from further exploration. If no child+-- matches, the node itself is returned.+findLeftmostDeepest :: Foldable f =>+  (x -> Bool) -> AnnFix x f -> Maybe (Zipper (AnnFix x f))+findLeftmostDeepest down = listToMaybe . reverse . explore hints+  where+    hints x+      | down x     = ExploreHints  True   True   False+      | otherwise  = ExploreHints  False  False  True
+ Annotations/F/Fixpoints.hs view
@@ -0,0 +1,58 @@+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE RankNTypes #-}++module Annotations.F.Fixpoints (+    -- * Fixed points of functors+    Fix(..), compos,+    Algebra, cata,+    Coalgebra, ana,+    ErrorAlgebra, cascade,+  ) where++import Annotations.Except++import Data.Monoid+import Data.Traversable+import Control.Monad+++-- | Fixpoint of functors.+newtype Fix fT  = In    { out      :: fT (Fix fT)  }++deriving instance Show (f (Fix f)) => Show (Fix f)+deriving instance Eq (f (Fix f)) => Eq (Fix f)++mapFix :: (f (Fix f) -> g (Fix g)) -> Fix f -> Fix g+mapFix f = In . f . out++-- | Algebras for catamorphisms.+type Algebra fT aT = fT aT -> aT++-- | Reduces a tree to a value according to the algebra.+cata :: Functor fT => Algebra fT aT -> Fix fT -> aT+cata f = f . fmap (cata f) . out++-- | Coalgebras for anamorphisms.+type Coalgebra fT aT = aT -> fT aT++-- | Constructs a tree from a value according to the coalgebra.+ana :: Functor fT => Coalgebra fT aT -> aT -> Fix fT+ana f = In . fmap (ana f) . f++-- | Apply a transformation to a tree's direct children.+compos :: Functor f => (Fix f -> Fix f) -> Fix f -> Fix f+compos = mapFix . fmap++-- | Algebras for error catamorphisms.+type ErrorAlgebra fT eT aT = fT aT -> Either eT aT++-- | Reduces a tree to a value according to the algebra, propagating potential errors.+cascade :: (Traversable fT, Monoid eT) =>+  ErrorAlgebra fT eT aT -> Algebra fT (Except eT aT)+cascade alg expr = case sequenceA expr of+  Failed xs  -> Failed xs+  OK tree'   -> case alg tree' of+    Left xs    -> Failed xs+    Right res  -> OK res
+ Annotations/F/ParserCombinators.hs view
@@ -0,0 +1,50 @@+module Annotations.F.ParserCombinators (+    -- * Parser combinators for bounds parsers+    mkBounded, unit, chainr, chainl+  ) where++import Annotations.Bounds+import Annotations.BoundsParser+import Annotations.F.Annotated++import qualified Text.Parsec as P++import Data.Function+++-- | Given the left margin of a structure, asks the parser for the right+--   margin and wraps the position information around the root of the tree.+mkBounded :: Monad m => Range -> AnnFix1 Bounds f -> P s m (AnnFix Bounds f)+mkBounded left x = do -- (\right -> mkAnnFix (Bounds left right) x) <$> getPos+  right <- getPos+  return (mkAnnFix (Bounds left right) x)++-- | Wrap an unnotated tree with position information from the parse state.+unit :: Monad m => P s m (AnnFix1 Bounds f) -> P s m (AnnFix Bounds f)+unit p = do+  left <- getPos+  x <- p+  mkBounded left x++-- | Parse right-recursive structures.+chainr :: Monad m => P s m (AnnFix Bounds f) ->+  P s m (AnnFix Bounds f -> AnnFix Bounds f -> AnnFix1 Bounds f) -> P s m (AnnFix Bounds f)+chainr px pf = fix $ \loop -> do+  left <- getPos+  x <- px+  P.option x $ do+    f <- pf+    y <- loop+    mkBounded left (f x y)++-- | Parse left-recursive structures.+chainl :: Monad m => P s m (AnnFix Bounds f) ->+  P s m (AnnFix Bounds f -> AnnFix Bounds f -> AnnFix1 Bounds f) -> P s m (AnnFix Bounds f)+chainl px pf = do+    left <- getPos+    px >>= rest left+  where+    rest left = fix $ \loop x -> P.option x $ do+      f <- pf+      y <- px+      mkBounded left (f x y) >>= loop
+ Annotations/F/Positional.hs view
@@ -0,0 +1,51 @@+-- | Queries on trees annotated with position information.+module Annotations.F.Positional+  ( selectByRange, selectByPos, validBounds, repairBy, repair, moveSelection+  ) where++import Annotations.Bounds+import Annotations.ExploreHints+import Annotations.F.Fixpoints+import Annotations.F.Zipper+import Annotations.F.Annotated++import Data.Foldable (Foldable, toList)+import Data.Ord+import Data.List+import Data.Maybe+import Control.Applicative++-- | Find the deepest node whose bounds match the given range. See 'rangeInBounds'.+selectByRange :: Foldable f => Range -> AnnFix Bounds f -> Maybe (Zipper (AnnFix Bounds f))+selectByRange range@(left, _) = listToMaybe . reverse . explore hints where+  hints bounds@(Bounds _ (ir, _)) = +      ExploreHints+        {  matchHere     = range `rangeInBounds` bounds+        ,  exploreDown   = range `rangeInRange` outerRange bounds+        ,  exploreRight  = left >= ir+        }++-- | Find the deepest node whose bounds contain the given position.+selectByPos :: Foldable f => Int -> AnnFix Bounds f -> Maybe (Zipper (AnnFix Bounds f))+selectByPos pos = findLeftmostDeepest (posInRange pos . innerRange)++-- | Find all selections in the tree and return their bounds. The tree is traversed in preorder. Consequently, the bounds are returned in lexicographical order.+validBounds :: Foldable f => AnnFix Bounds f -> [Bounds]+validBounds (In (Ann b f)) = b : concatMap validBounds (toList f)++-- | @repairBy cost tree range@ finds the the closest valid text selection to @range@, where ''closest'' is determined by the specified cost function.+repairBy :: (Foldable f, Ord dist) =>+  (Range -> Range -> dist) -> AnnFix Bounds f -> Range -> Bounds+repairBy cost tree range =+  head (sortOn (cost range . innerRange) (validBounds tree))++-- | Defined as @'repairBy' 'distRange'@.+repair :: Foldable f => AnnFix Bounds f -> Range -> Bounds+repair = repairBy distRange++sortOn :: Ord b => (a -> b) -> [a] -> [a]+sortOn = sortBy . comparing++-- | Move around in a tree according to the 'Nav', expressed in tree selections. Although a 'Range' is required as input, a 'Bounds' is returned, providing information about all the valid text selections that would select the particular tree node.+moveSelection :: Foldable f => AnnFix Bounds f -> Nav -> Range -> Maybe Bounds+moveSelection tree (Nav nav) range = (rootAnn . zFocus) <$> (selectByRange range tree >>= nav)
+ Annotations/F/Zipper.hs view
@@ -0,0 +1,59 @@+{-# LANGUAGE RankNTypes #-}++module Annotations.F.Zipper+  ( Zipper(..), enter, leave, child, allFoci, Nav(..),+  ) where++import Annotations.F.Fixpoints+import Data.Foldable+import Data.Maybe+import Control.Monad+import Data.Monoid++-- | A quasi-zipper, meant for O(1), fixed-memory stepping through a tree structure, but not meant for updates.+data Zipper a = Zipper+  { zFocus :: a                 -- ^ The current focus of this zipper.+  , zUp    :: Maybe (Zipper a)  -- ^ Move up to the parent.+  , zLeft  :: Maybe (Zipper a)  -- ^ Move to the left sibling.+  , zRight :: Maybe (Zipper a)  -- ^ Move to the right sibling.+  , zDown  :: Maybe (Zipper a)  -- ^ Move down into the leftmost child.+  }++-- | Captures navigation steps in a 'Zipper'. Its 'Monoid' instance specifies the identity step ('mempty') and step composition ('mappend').+newtype Nav = Nav { nav :: forall a. Zipper a -> Maybe (Zipper a) }++instance Monoid Nav where+  mempty = Nav return+  mappend (Nav n1) (Nav n2) = Nav (n1 >=> n2)++-- | Move into the root of the fixed point. The returned zipper builds a data structure with optimal sharing and fixed memory usage. For example, @zLeft >=> zRight@ (if successful) returns to the same node in memory.+enter :: Foldable f => Fix f -> Zipper (Fix f)+enter f = fromJust (enter' Nothing Nothing [f])++enter' :: Foldable f =>+  Maybe (Zipper (Fix f)) ->+  Maybe (Zipper (Fix f)) ->+  [Fix f] ->+  Maybe (Zipper (Fix f))+enter' _  _    [] = Nothing+enter' up left (focus@(In f) : fs) = here+  where+    here   = Just (Zipper focus up left right down)+    right  = enter' up here fs+    down   = enter' here Nothing (toList f)++-- | Walk back up to the root of the fixed point and leave the zipper structure.+leave :: Zipper a -> a+leave z = maybe (zFocus z) leave (zUp z)++-- | Move down into a specific child.+child :: Int -> Zipper a -> Maybe (Zipper a)+child 0 = zDown+child n = child (n - 1) >=> zRight++-- | Traverses the tree in preorder, yielding all possible tree selections.+allFoci :: Foldable f => Fix f -> [Zipper (Fix f)]+allFoci = allFoci' . enter++allFoci' :: Foldable f => Zipper (Fix f) -> [Zipper (Fix f)]+allFoci' z = z : [ z'' | Just z' <- [zDown z, zRight z], z'' <- allFoci' z' ]
+ Annotations/MultiRec/Annotated.hs view
@@ -0,0 +1,120 @@+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Annotations.MultiRec.Annotated (+    AnnFix, AnnFix1, mkAnnFix, AnyAnnFix,+    unannotate, children, flatten, filterAnnFix, debugFlatten, allAnnotations, +    AnnZipper, focusAnn,+    explore, findLeftmostDeepest+  ) where++import Annotations.ExploreHints+import Annotations.MultiRec.ShowFam+import Annotations.MultiRec.Any++import Control.Monad.Writer (Writer, execWriter, tell)++import Generics.MultiRec hiding (show)+import Generics.MultiRec.HFix+import Annotations.MultiRec.Zipper+import Annotations.MultiRec.ZipperFix++import Data.Maybe+++-- | A fully annotated tree.+type AnnFix x s = HFix (K x :*: PF s)++-- | A functor with fully annotated children.+type AnnFix1 x s = (PF s) (AnnFix x s)++-- | Supply a tree with an annotation at the top level.+mkAnnFix :: x -> AnnFix1 x s ix -> AnnFix x s ix+mkAnnFix x = HIn . (K x :*:)++-- | A fixpoint of a data family @s@ annotated with an @x@ at every recursive position, with existentially quantified top-level index.+type AnyAnnFix x s = AnyF s (AnnFix x s)++-- | Removes all annotations from a recursively annotated fixpoint.+unannotate :: HFunctor s (PF s) => s ix -> AnnFix x s ix -> HFix (PF s) ix+unannotate p = HIn . hmap unannotate p . snd' . hout++-- fst' :: (f :*: g) r ix -> f r ix+-- fst' (x :*: _) = x++snd' :: (f :*: g) r ix -> g r ix+snd' (_ :*: y) = y++-- | Collects the direct children of a functor in a list.+children :: HFunctor s f => s ix -> f r ix -> [AnyF s r]+children p x = execWriter (hmapM collect p x) where+  collect :: s ix -> r ix -> Writer [AnyF s r] (r ix)+  collect w x = tell [AnyF w x] >> return x++-- | Flatten an annotated tree to a list of subtrees coupled with their annotations.+flatten :: forall s x ix. (HFunctor s (PF s), Fam s) => s ix -> AnnFix x s ix -> [(x, Any s)]+flatten p tree@(HIn (K x :*: y)) = (x, Any p (hto p (unannotate p tree :: HFix (PF s) ix))) :+    concatMap (flatten $?) (children p y)++-- | Yield all subtrees whose annotation matches the predicate.+filterAnnFix :: (Fam s, HFunctor s (PF s)) => s ix -> (x -> Bool) -> AnnFix x s ix -> [(x, Any s)]+filterAnnFix p f = filter (f . fst) . flatten p++-- | Flatten an annotated tree and print all subtrees to stdout.+debugFlatten :: (HFunctor s (PF s), ShowFam s, Show x, Fam s) => s ix -> AnnFix x s ix -> IO ()+debugFlatten p = putStr . unlines . map show . flatten p++-- | Recursively yield all annotations in the tree in preorder.+allAnnotations :: HFunctor phi (PF phi) => phi ix -> AnnFix x phi ix -> [x]+allAnnotations p y = f (AnyF p y)+  where+    f (AnyF p' (HIn (K x :*: y))) = x : concatMap f (children p' y)+++-- | Extract the annotation of the current focus.+focusAnn :: Loc phi f (HFix (K x :*: g)) ix -> x+focusAnn = on (\_ (HIn (K x :*: _)) -> x)++type AnnZipper phi x = FixZipper phi (K x :*: PF phi)++-- | Explore an annotated tree. Starting with the root of the tree, at each +-- position the annotation at that position is matched against the +-- 'ExploreHints' predicates and all the selections where 'matchHere' was +-- positive are collected. The 'exploreRight' and 'exploreDown' allow pruning +-- of the tree, preventing entire parts from being visited.+explore :: Zipper phi (PF phi) =>+  phi ix -> (x -> ExploreHints) -> (AnnFix x phi) ix -> [AnnZipper phi x ix]+explore p hints = explore' hints . enter p++explore' :: Zipper phi (PF phi) =>+  (x -> ExploreHints) -> AnnZipper phi x ix -> [AnnZipper phi x ix]+explore' hints root = [ z | (dirOk, zs) <- dirs, dirOk (hints x), z <- zs ]+  where+    x = focusAnn root+    dirs =+      [  (matchHere,     [root])+      ,  (exploreDown,   exploreMore (down   root))+      ,  (exploreRight,  exploreMore (right  root))+      ]+    exploreMore = maybe [] (explore' hints)++-- | Find the deepest node in an annotated tree that matches the predicate.+-- Starting with the root, the predicate tells whether a node's annotation+-- matches. If so, the search continues at the node's children and the node's+-- siblings to the right are excluded from further exploration. If no child+-- matches, the node itself is returned.+findLeftmostDeepest+  :: (Zipper phi (PF phi))+  => phi ix+  -> (x -> Bool)+  -> AnnFix x phi ix+  -> Maybe (AnnZipper phi x ix)+findLeftmostDeepest p down = listToMaybe . reverse . explore p hints+  where+    hints x+      | down x     = ExploreHints  True   True   False+      | otherwise  = ExploreHints  False  False  True
+ Annotations/MultiRec/Any.hs view
@@ -0,0 +1,58 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | Pattern functors existentially quantified in their top-level index type @ix@.+module Annotations.MultiRec.Any+  ( Any(..), mkAny, matchAny+  , AnyF(..), mkAnyF, matchAnyF, unwrapAnyF, ($?)+  ) where++import Annotations.MultiRec.ShowFam+import Generics.MultiRec++-- | A value of some type in data family @s@, together with its witness.+data Any s where+  Any :: s ix -> ix -> Any s++instance ShowFam s => Show (Any s) where+  show = showAny++showAny :: ShowFam s => Any s -> String+showAny (Any w x) = showFam w x++-- | Helper constructor.+mkAny :: El s ix => ix -> Any s+mkAny = Any proof++-- | Unify an 'Any' with an @a@.+matchAny :: forall s a. EqS s => s a -> Any s -> Maybe a+matchAny p (Any w x) = match' w x p where+  match' :: forall b. s b -> b -> s a -> Maybe a+  match' w x w' = case eqS w w' of+    Nothing -> Nothing+    Just Refl -> Just x++-- | A value of some type in data family @s@ wrapped in an @f@, together with its witness.+data AnyF s f where+  AnyF :: s ix -> f ix -> AnyF s f++-- | Helper constructor.+mkAnyF :: El s ix => r ix -> AnyF s r+mkAnyF = AnyF proof++-- | Unify an 'AnyF' with an @f a@.+matchAnyF :: forall s f a. EqS s => s a -> AnyF s f -> Maybe (f a)+matchAnyF p (AnyF w x) = match' w x p where+  match' :: forall b. s b -> f b -> s a -> Maybe (f a)+  match' w x w' = case eqS w w' of+    Nothing -> Nothing+    Just Refl -> Just x++-- | Unwrap an 'AnyF' and pass it to a function.+($?) :: (forall b. s b -> f b -> a) -> AnyF s f -> a+f $? (AnyF p x) = f p x++-- | Removes the value from its functor @f@.+unwrapAnyF :: (forall ix. f ix -> ix) -> AnyF s f -> Any s+unwrapAnyF g (AnyF ix rix) = Any ix (g rix)
+ Annotations/MultiRec/ErrorAlg.hs view
@@ -0,0 +1,66 @@+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE TypeOperators         #-}+{-# LANGUAGE Rank2Types            #-}+{-# LANGUAGE FlexibleInstances     #-}++module Annotations.MultiRec.ErrorAlg (ErrorAlg, ErrorAlg_PF, MkErrorAlg(..), errorCata, (&)) where++import Annotations.Except++import Generics.MultiRec.Base+import Generics.MultiRec.HFunctor+import Generics.MultiRec.HFix++import Control.Applicative++-- | An error algebra over pattern functors.+type ErrorAlg_PF f e a = forall ix. f (K0 a) ix -> Either e a++-- | Type family that converts pattern functors to convenient algebra types.+type family ErrorAlg (f :: (* -> *) -> * -> *) e a :: *++type instance ErrorAlg U              e a = Either e a+type instance ErrorAlg (K b   :*: f)  e a = b  -> ErrorAlg f e a+type instance ErrorAlg (I xi  :*: f)  e a = a  -> ErrorAlg f e a+type instance ErrorAlg (f :+: g)      e a = (ErrorAlg f e a, ErrorAlg g e a)+type instance ErrorAlg (f :>: xi)     e a = ErrorAlg f e a++-- | Converts convenient algebras to algebras that are able to work with+-- pattern functors.+class MkErrorAlg f where+  mkErrorAlg :: ErrorAlg f e a -> ErrorAlg_PF f e a++instance MkErrorAlg U where+  mkErrorAlg x U = x++instance MkErrorAlg f => MkErrorAlg (K a :*: f) where+  mkErrorAlg alg (K x :*: f) = mkErrorAlg (alg x) f++instance MkErrorAlg f => MkErrorAlg (I xi :*: f) where+  mkErrorAlg alg (I (K0 x) :*: f) = mkErrorAlg (alg x) f++instance MkErrorAlg f => MkErrorAlg (f :>: xi) where+  mkErrorAlg alg (Tag f) = mkErrorAlg alg f++instance (MkErrorAlg f, MkErrorAlg g) => MkErrorAlg (f :+: g) where+  mkErrorAlg (alg, _) (L x) = mkErrorAlg alg x+  mkErrorAlg (_, alg) (R y) = mkErrorAlg alg y++-- | Reduces a tree to a value according to the algebra, collecting potential+--   errors. The errors are combined with the annotations in the tree at the+--   positions at which the errors occurred.+errorCata :: HFunctor phi f => ErrorAlg_PF f e r ->+  phi ix -> HFix (K x :*: f) ix -> Except [(e, x)] r+errorCata alg p_f (HIn (K k :*: f)) =+    case hmapA (\p_g g -> K0 <$> errorCata alg p_g g) p_f f of+      Failed xs -> Failed xs+      OK expr' -> case alg expr' of+        Left x'  -> Failed [(x', k)]+        Right v  -> OK v++-- | For constructing algebras that are made of nested pairs rather+--   than n-ary tuples, it is helpful to use this pairing combinator.+(&) :: a -> b -> (a, b)+(&) = (,)++infixr 5 &
+ Annotations/MultiRec/ParserCombinators.hs view
@@ -0,0 +1,56 @@+{-# LANGUAGE FlexibleContexts #-}++module Annotations.MultiRec.ParserCombinators (YP, mkBounded, unit, chainr, chainl) where++import Annotations.Bounds+import Annotations.BoundsParser+import Annotations.MultiRec.Yield+import Control.Monad.Trans++import qualified Text.Parsec as P+import Generics.MultiRec hiding (show)++import Data.Function++-- | A parser that yields its components, annotated with 'Bounds'.+type YP s fam m = P s (YieldT Bounds fam m)++-- | Wrap an unnotated tree with position information from the parse state.+unit :: (Fam fam, EqS fam, HFunctor fam (PF fam), Monad m) =>+  fam a ->+  YP s fam m a ->+  YP s fam m a+unit w p = do+  left <- getPos+  x <- p+  mkBounded w left x++-- | Given the left margin of a structure, asks the parser for the right+--   margin and wraps the position information around the root of the tree.+mkBounded :: (Fam fam, EqS fam, HFunctor fam (PF fam), Monad m) => fam a -> Range -> a -> YP s fam m a+mkBounded w left x = do+  right <- getPos+  lift $ yield w (Bounds left right) x++-- | Parse right-recursive structures.+chainr :: (Fam fam, EqS fam, HFunctor fam (PF fam), Monad m, Show a) =>+  fam a -> YP s fam m a -> YP s fam m (a -> a -> a) -> YP s fam m a+chainr w px pf = fix $ \loop -> do+  left <- getPos+  x <- px+  P.option x $ do+    f <- pf+    y <- loop+    mkBounded w left (f x y)++-- | Parse left-recursive structures.+chainl :: (Fam fam, EqS fam, HFunctor fam (PF fam), Monad m, Show a) =>+  fam a -> YP s fam m a -> YP s fam m (a -> a -> a) -> YP s fam m a+chainl w px pf = do+    left <- getPos+    px >>= rest left+  where+    rest left = fix $ \loop x -> P.option x $ do+      f <- pf+      y <- px+      mkBounded w left (f x y) >>= loop
+ Annotations/MultiRec/Positional.hs view
@@ -0,0 +1,53 @@+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes            #-}++module Annotations.MultiRec.Positional where++import Annotations.Bounds+import Annotations.ExploreHints+import Annotations.MultiRec.Annotated+import Annotations.MultiRec.Zipper+import Annotations.MultiRec.ZipperFix+import Generics.MultiRec.Base+import Generics.MultiRec.HFunctor++import Data.Maybe+import Data.List+import Data.Ord+import Control.Applicative+++-- | Find the deepest node whose bounds match the given range. See 'rangeInBounds'.+selectByRange :: Zipper phi (PF phi) =>+   phi ix -> Range -> AnnFix Bounds phi ix ->+   Maybe (AnnZipper phi Bounds ix)+selectByRange p range@(left, _) = listToMaybe . reverse . explore p hints where+  hints bounds@(Bounds _ (ir, _)) = +      ExploreHints+        {  matchHere     = range `rangeInBounds` bounds+        ,  exploreDown   = range `rangeInRange` outerRange bounds+        ,  exploreRight  = left >= ir+        }++selectByPos :: (Zipper phi (PF phi)) =>+  phi ix -> Int -> AnnFix Bounds phi ix ->+  Maybe (AnnZipper phi Bounds ix)+selectByPos p pos = findLeftmostDeepest p (posInRange pos . innerRange)++repairBy :: (Ord dist, HFunctor phi (PF phi)) =>+  phi ix -> (Range -> Range -> dist) -> AnnFix Bounds phi ix -> Range -> Bounds+repairBy p cost tree range =+  head (sortOn (cost range . innerRange) (allAnnotations p tree))++-- | Defined as @'repairBy' 'distRange'@.+repair :: HFunctor phi (PF phi) =>+  phi ix -> AnnFix Bounds phi ix -> Range -> Bounds+repair p = repairBy p distRange++sortOn :: Ord b => (a -> b) -> [a] -> [a]+sortOn = sortBy . comparing++-- | Move around in a tree according to the 'Nav', expressed in tree selections. Although a 'Range' is required as input, a 'Bounds' is returned, providing information about all the valid text selections that would select the particular tree node.+moveSelection :: Zipper phi (PF phi) => phi ix -> AnnFix Bounds phi ix -> Nav -> Range -> Maybe Bounds+moveSelection p tree nav range = focusAnn <$> (selectByRange p range tree >>= nav)
+ Annotations/MultiRec/ShowFam.hs view
@@ -0,0 +1,6 @@+-- | A Show-like type class for families of data types.+module Annotations.MultiRec.ShowFam where++class ShowFam fam where+  -- | Given a witness, convert the value of that type to String.+  showFam :: fam a -> a -> String
+ Annotations/MultiRec/Yield.hs view
@@ -0,0 +1,93 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module Annotations.MultiRec.Yield+  ( MonadYield(..)+  , YieldT, Yield+  , runYield, runYieldG, runYieldT, runYieldTG+  ) where++import Control.Monad.State.Strict+import Control.Monad.Identity++import Generics.MultiRec hiding (show)+import Generics.MultiRec.HFix++import Annotations.MultiRec.Annotated+import Annotations.MultiRec.Any++-- | Monads that allow yielding recursively annotated values.+class Monad m => MonadYield m where+  -- | Yielded values have types in this datatype family.+  type YieldFam m :: * -> *+  +  -- | The type of the annotation.+  type AnnType  m :: *+  +  -- | Yields a value with its annotation.+  yield :: (YieldFam m) ix -> AnnType m -> ix -> m ix+++-- | The Yield transformer. Allows yielding generic values in family @fam@ with annotations of type @x@.+newtype YieldT x fam m a = YieldT (StateT [AnyAnnFix x fam] m a)+  deriving (Functor, Monad)++runYieldTG :: Monad m => YieldT x fam m a -> m (a, Maybe (AnyAnnFix x fam))+runYieldTG (YieldT y) = do+  (x, zs) <- runStateT y []+  return $ (,) x $ case zs of+    [z] -> Just z+    _   -> Nothing++runYieldT :: (Monad m, EqS fam) => fam a -> YieldT x fam m a -> m (Maybe (AnnFix x fam a))+runYieldT p y = do+  (_, x) <- runYieldTG y+  return (x >>= matchAnyF p)++runYieldG :: Yield x fam a -> (a, Maybe (AnyAnnFix x fam))+runYieldG = runIdentity . runYieldTG++runYield :: EqS fam => fam a -> Yield x fam a -> Maybe (AnnFix x fam a)+runYield p = runIdentity . runYieldT p++-- | Yield over the identity monad.+type Yield x fam = YieldT x fam Identity++instance MonadTrans (YieldT x fam) where+  lift = YieldT . lift+++instance (Monad m, HFunctor fam (PF fam), EqS fam, Fam fam) => MonadYield (YieldT x fam m) where+  type YieldFam (YieldT x fam m) = fam+  type AnnType (YieldT x fam m) = x+  yield = doYield++doYield :: (Monad m, HFunctor fam (PF fam), EqS fam, Fam fam) =>+  fam ix -> x -> ix -> YieldT x fam m ix+doYield p bounds x = YieldT $ do+  let pfx = from p x+  let n = length (children p pfx)+  stack <- get+  if length stack < n+    then+      fail ("structure mismatch: required " ++ show n +++            " accumulated children but found only " +++            show (length stack))+    else do+      let (cs, cs') = splitAt n stack+      let newChild = evalState (hmapM distribute p pfx) (reverse cs)+      put (AnyF p (HIn (K bounds :*: newChild)) : cs')+      return x++distribute :: EqS phi => phi ix -> I0 ix -> State [AnyAnnFix x phi] (AnnFix x phi ix)+distribute w _ = do+  xs <- get+  case xs of+    [] -> error "structure mismatch: too few children"+    AnyF w' x : xs' ->+      case eqS w w' of+        Nothing   -> error "structure mismatch: incompatible child type"+        Just Refl -> do put xs'; return x
+ Annotations/MultiRec/Zipper.hs view
@@ -0,0 +1,226 @@+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE GADTs                 #-}+{-# LANGUAGE KindSignatures        #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes            #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE TypeOperators         #-}+{-# LANGUAGE ScopedTypeVariables   #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Generics.MultiRec.Zipper+-- Copyright   :  (c) 2008--2009 Universiteit Utrecht+-- License     :  BSD3+--+-- Maintainer  :  generics@haskell.org+-- Stability   :  experimental+-- Portability :  non-portable+--+--+-- The generic zipper.+--+-----------------------------------------------------------------------------++module Annotations.MultiRec.Zipper+  (-- * Locations+   Loc(..),+   -- * Context frames+   Ctx(..),+   Ctxs(..),+   -- * Generic zipper class+   Zipper(..),+   -- * Interface+   enter,+   on, +   update, +   -- foldZipper+  )+  where++import Prelude hiding (last)++import Control.Monad+import Control.Applicative+import Data.Maybe++import Generics.MultiRec.Base+import Generics.MultiRec.HFunctor++-- * Locations and context stacks++-- | Abstract type of locations. A location contains the current focus+-- and its context. A location is parameterized over the family of+-- datatypes and over the type of the complete value.++data Loc :: (* -> *) -> ((* -> *) -> * -> *) -> (* -> *) -> * -> * where+  Loc :: phi ix -> r ix -> Ctxs phi f ix r a -> Loc phi f r a++data Ctxs :: (* -> *) -> ((* -> *) -> * -> *) -> * -> (* -> *) -> * -> * where+  Empty :: Ctxs phi f a r a+  Push  :: phi ix -> Ctx f b r ix -> Ctxs phi f ix r a -> Ctxs phi f b r a++-- * Context frames++-- | Abstract type of context frames. Not required for the high-level+-- navigation functions.++data family Ctx f :: * -> (* -> *) -> * -> *++data instance Ctx (K a) b r ix+data instance Ctx U b r ix+data instance Ctx (f :+: g) b r ix  = CL (Ctx f b r ix)+                                    | CR (Ctx g b r ix)+data instance Ctx (f :*: g) b r ix  = C1 (Ctx f b r ix) (g r ix)+                                    | C2 (f r ix) (Ctx g b r ix)++-- The equality constraints simulate GADTs. GHC currently+-- does not allow us to use GADTs as data family instances.++data instance Ctx (I xi) b r ix     = CId (b :=: xi)+data instance Ctx (f :>: xi) b r ix = CTag (ix :=: xi) (Ctx f b r ix)+data instance Ctx (C c f) b r ix    = CC (Ctx f b r ix)++-- * Contexts and locations are functors++instance Zipper phi f => HFunctor phi (Ctx f b) where+  hmapA = cmapA++instance Zipper phi f => HFunctor phi (Ctxs phi f b) where+  hmapA f p' Empty        = pure Empty+  hmapA f p' (Push p c s) = liftA2 (Push p) (hmapA f p c) (hmapA f p' s)++instance Zipper phi f => HFunctor phi (Loc phi f) where+  hmapA f p' (Loc p x s)  = liftA2 (Loc p) (f p x) (hmapA f p' s)++-- * Generic navigation functions++-- | It is in general not necessary to use the generic navigation+-- functions directly. The functions listed in the ``Interface'' section+-- below are more user-friendly.+++class HFunctor phi f => Zipper phi f where+  cmapA       :: Applicative a => (forall ix. phi ix -> r ix -> a (r' ix)) ->+                 phi ix -> Ctx f b r ix -> a (Ctx f b r' ix)+  fill        :: phi b -> Ctx f b r ix -> r b -> f r ix+  first, last :: (forall b. phi b -> r b -> Ctx f b r ix -> a)+              -> f r ix -> Maybe a+  next, prev  :: (forall b. phi b -> r b -> Ctx f b r ix -> a)+              -> phi b -> Ctx f b r ix -> r b -> Maybe a++instance El phi xi => Zipper phi (I xi) where+  cmapA f p (CId prf)   = pure (CId prf)+  fill    p (CId prf) x = castId prf I x+  first f (I x)  = return (f proof x (CId Refl))+  last  f (I x)  = return (f proof x (CId Refl))+  next  f p (CId prf) x = Nothing+  prev  f p (CId prf) x = Nothing++instance Zipper phi (K a) where+  cmapA f p void   = impossible void+  fill    p void x = impossible void+  first f (K a)    = Nothing+  last  f (K a)    = Nothing+  next  f p void x = impossible void+  prev  f p void x = impossible void++instance Zipper phi U where+  cmapA f p void   = impossible void+  fill    p void x = impossible void+  first f U        = Nothing+  last  f U        = Nothing+  next  f p void x = impossible void+  prev  f p void x = impossible void++instance (Zipper phi f, Zipper phi g) => Zipper phi (f :+: g) where+  cmapA f p (CL c)   = liftA CL (cmapA f p c)+  cmapA f p (CR c)   = liftA CR (cmapA f p c)+  fill    p (CL c) x = L (fill p c x)+  fill    p (CR c) y = R (fill p c y)+  first f (L x)      = first (\p z -> f p z . CL) x+  first f (R y)      = first (\p z -> f p z . CR) y+  last  f (L x)      = last  (\p z -> f p z . CL) x+  last  f (R y)      = last  (\p z -> f p z . CR) y+  next  f p (CL c) x = next  (\p z -> f p z . CL) p c x+  next  f p (CR c) y = next  (\p z -> f p z . CR) p c y+  prev  f p (CL c) x = prev  (\p z -> f p z . CL) p c x+  prev  f p (CR c) y = prev  (\p z -> f p z . CR) p c y++instance (Zipper phi f, Zipper phi g) => Zipper phi (f :*: g) where+  cmapA f p (C1 c y)   = liftA2 C1 (cmapA f p c) (hmapA f p y)+  cmapA f p (C2 x c)   = liftA2 C2 (hmapA f p x) (cmapA f p c)+  fill    p (C1 c y) x = fill p c x :*: y+  fill    p (C2 x c) y = x :*: fill p c y+  first f (x :*: y)                =+                first (\p z c  -> f p z (C1 c          y ))   x `mplus`+                first (\p z c  -> f p z (C2 x          c ))   y+  last  f (x :*: y)                 =+                last  (\p z c  -> f p z (C2 x          c ))   y `mplus`+                last  (\p z c  -> f p z (C1 c          y ))   x+  next  f p (C1 c y) x =+                next  (\p' z c' -> f p' z (C1 c'           y )) p c x `mplus`+                first (\p' z c' -> f p' z (C2 (fill p c x) c'))     y+  next  f p (C2 x c) y =+                next  (\p' z c' -> f p' z (C2 x            c')) p c y+  prev  f p (C1 c y) x =+                prev  (\p' z c' -> f p' z (C1 c'           y )) p c x+  prev  f p (C2 x c) y =+                prev  (\p' z c' -> f p' z (C2 x            c')) p c y `mplus`+                last  (\p' z c' -> f p' z (C1 c' (fill p c y)))     x++instance Zipper phi f => Zipper phi (f :>: xi) where+  cmapA f p (CTag prf c)   = liftA (CTag prf) (cmapA f p c)+  fill    p (CTag prf c) x = castTag prf Tag (fill p c x)+  first f (Tag x)          = first (\p z -> f p z . CTag Refl)     x+  last  f (Tag x)          = last  (\p z -> f p z . CTag Refl)     x+  next  f p (CTag prf c) x = next  (\p z -> f p z . CTag prf)  p c x+  prev  f p (CTag prf c) x = prev  (\p z -> f p z . CTag prf)  p c x++instance (Constructor c, Zipper phi f) => Zipper phi (C c f) where+  cmapA f p (CC c)   = liftA CC (cmapA f p c)+  fill    p (CC c) x = C (fill p c x)+  first f (C x)      = first (\p z -> f p z . CC)     x+  last  f (C x)      = last  (\p z -> f p z . CC)     x+  next  f p (CC c) x = next  (\p z -> f p z . CC) p c x+  prev  f p (CC c) x = prev  (\p z -> f p z . CC) p c x++-- * Interface++-- ** Introduction++-- | Start navigating a datastructure. Returns a location that+-- focuses the entire value and has an empty context.+enter :: Zipper phi f => phi ix -> r ix -> Loc phi f r ix+enter p x = Loc p x Empty++-- ** Navigation+++-- | Operate on the current focus. This function can be used to+-- extract the current point of focus.+on :: (forall xi. phi xi -> r xi -> a) -> Loc phi f r ix -> a+on f (Loc p x _) = f p x++-- | Update the current focus without changing its type.+update :: (forall xi. phi xi -> r xi -> r xi) -> Loc phi f r ix -> Loc phi f r ix+update f (Loc p x s) = Loc p (f p x) s++-- * Internal functions++impossible :: a -> b+impossible x = error "impossible"++-- Helping the typechecker to apply equality proofs correctly ...++castId  :: (b :=: xi)+        -> (r xi -> I xi r ix)+        -> (r b  -> I xi r ix)++castTag :: (ix :=: xi)+        -> (f r ix -> (f :>: ix) r ix)+        -> (f r ix -> (f :>: xi) r ix)++castId  Refl = id+castTag Refl = id
+ Annotations/MultiRec/ZipperFix.hs view
@@ -0,0 +1,80 @@+{-# LANGUAGE RankNTypes #-}++-- | Zipper functions specialised to work on fixpoints of pattern functors.+module Annotations.MultiRec.ZipperFix (+    Nav, FixZipper,+    down, down', up, right, left,+    dfnext, dfprev,+    leave, +  ) where++import Annotations.MultiRec.Zipper+import Generics.MultiRec.HFix++import Prelude hiding (last)+import Data.Maybe++-- | A location within a fixpoint.+type FixZipper phi f = Loc phi f (HFix f)++-- | A navigation step in a fixpoint.+type Nav = forall phi f ix. Zipper phi f =>+  FixZipper phi f ix -> Maybe (FixZipper phi f ix)++-- | Move down to the leftmost child. Returns 'Nothing' if the+-- current focus is a leaf.+down            :: Nav++-- | Move down to the rightmost child. Returns 'Nothing' if the+-- current focus is a leaf.+down'           :: Nav++-- | Move up to the parent. Returns 'Nothing' if the current+-- focus is the root.+up              :: Nav++-- | Move to the right sibling. Returns 'Nothing' if the current+-- focus is the rightmost sibling.+right           :: Nav++-- | Move to the left sibling. Returns 'Nothing' if the current+-- focus is the leftmost sibling.+left            :: Nav++down  (Loc p (HIn x) s      ) = first (\p' z c  -> Loc p' z (Push p c  s)) x+down' (Loc p (HIn x) s      ) = last  (\p' z c  -> Loc p' z (Push p c  s)) x+up    (Loc p x Empty        ) = Nothing+up    (Loc p x (Push p' c s)) = return (Loc p' (HIn $ fill p c x) s)+right (Loc p x Empty        ) = Nothing+right (Loc p x (Push p' c s)) = next (\p z c' -> Loc p z (Push p' c' s)) p c x+left  (Loc p x Empty        ) = Nothing+left  (Loc p x (Push p' c s)) = prev (\p z c' -> Loc p z (Push p' c' s)) p c x++-- ** Derived navigation.++df :: (a -> Maybe a) -> (a -> Maybe a) -> (a -> Maybe a) -> a -> Maybe a+df d u lr l =+    case d l of+      Nothing -> df' l+      r       -> r+  where+    df' l =+      case lr l of+        Nothing ->+          case u l of+            Nothing -> Nothing+            Just l' -> df' l'+        r       -> r++-- | Move through all positions in depth-first left-to-right order.+dfnext :: Nav+dfnext = df down up right++-- | Move through all positions in depth-first right-to-left order.+dfprev :: Nav+dfprev = df down' up left++-- | Return the entire value, independent of the current focus.+leave :: Zipper phi f => Loc phi f (HFix f) ix -> HFix f ix+leave (Loc p x Empty) = x+leave loc             = leave (fromJust (up loc))
+ LICENSE view
@@ -0,0 +1,24 @@+Copyright (c) 2008-2009, Martijn van Steenbergen+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:+    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.+    * Redistributions in binary form must reproduce the above copyright+      notice, this list of conditions and the following disclaimer in the+      documentation and/or other materials provided with the distribution.+    * Neither the name of the author nor the+      names of his contributors may be used to endorse or promote products+      derived from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY+EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL <copyright holder> BE LIABLE FOR ANY+DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES+(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;+LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND+ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS+SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain