2015-11-18 22:27:09 +03:00
|
|
|
module Term where
|
2015-11-18 22:28:16 +03:00
|
|
|
|
2015-11-19 04:33:09 +03:00
|
|
|
import Data.Map
|
2015-11-19 04:11:13 +03:00
|
|
|
import Data.Maybe
|
2015-11-18 22:28:16 +03:00
|
|
|
import Control.Comonad.Cofree
|
|
|
|
import Syntax
|
|
|
|
|
|
|
|
type Term a annotation = Cofree (Syntax a) annotation
|
2015-11-18 22:39:08 +03:00
|
|
|
|
2015-11-27 17:31:56 +03:00
|
|
|
zipTerms :: Term a annotation -> Term a annotation -> Maybe (Term a (annotation, annotation))
|
2015-11-19 04:33:09 +03:00
|
|
|
zipTerms (annotation1 :< a) (annotation2 :< b) = annotate $ zipUnwrap a b
|
2015-11-19 03:58:37 +03:00
|
|
|
where
|
2015-11-19 04:33:09 +03:00
|
|
|
annotate = fmap ((annotation1, annotation2) :<)
|
2015-11-27 19:58:20 +03:00
|
|
|
zipUnwrap (Leaf _) (Leaf b) = Just $ Leaf b
|
2015-11-19 04:38:48 +03:00
|
|
|
zipUnwrap (Indexed a) (Indexed b) = Just . Indexed . catMaybes $ zipWith zipTerms a b
|
|
|
|
zipUnwrap (Fixed a) (Fixed b) = Just . Fixed . catMaybes $ zipWith zipTerms a b
|
2015-11-19 05:00:10 +03:00
|
|
|
zipUnwrap (Keyed a) (Keyed b) | keys a == keys b = Just . Keyed . fromList . catMaybes $ zipUnwrapMaps a b <$> keys a
|
2015-11-19 03:58:37 +03:00
|
|
|
zipUnwrap a b = Nothing
|
2015-11-19 05:00:10 +03:00
|
|
|
zipUnwrapMaps a b key = (,) key <$> zipTerms (a ! key) (b ! key)
|
2015-11-20 04:17:17 +03:00
|
|
|
|
|
|
|
cata :: (annotation -> Syntax a b -> b) -> Term a annotation -> b
|
|
|
|
cata f (annotation :< syntax) = f annotation $ cata f <$> syntax
|