module Annotations.F.Annotated (
Ann(..), AnnFix, rootAnn, AnnFix1, mkAnnFix, unannotate, errorCata,
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
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
type AnnFix xT fT = Fix (Ann xT fT)
type AnnFix1 xT fT = fT (AnnFix xT fT)
mkAnnFix :: x -> AnnFix1 x f -> AnnFix x f
mkAnnFix x = In . Ann x
rootAnn :: AnnFix x f -> x
rootAnn (In (Ann x _)) = x
unannotate :: Functor f => AnnFix x f -> Fix f
unannotate (In (Ann _ tree)) = In (fmap unannotate tree)
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 :: 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)
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