1
1
mirror of https://github.com/github/semantic.git synced 2024-12-26 00:12:29 +03:00
semantic/src/Term.hs

44 lines
2.1 KiB
Haskell
Raw Normal View History

{-# LANGUAGE RankNTypes, TypeFamilies #-}
2016-06-30 19:59:26 +03:00
{-# OPTIONS_GHC -fno-warn-orphans #-}
2015-11-18 22:27:09 +03:00
module Term where
import Prologue
2016-05-03 19:17:38 +03:00
import Data.Functor.Foldable as Foldable
import Data.Functor.Both
2016-02-29 18:07:44 +03:00
import Data.OrderedMap hiding (size)
import Data.These
import Syntax
2016-01-13 23:35:40 +03:00
-- | An annotated node (Syntax) in an abstract syntax tree.
2016-05-03 19:17:38 +03:00
type TermF a annotation = CofreeF (Syntax a) annotation
type Term a annotation = Cofree (Syntax a) annotation
2016-05-04 21:37:24 +03:00
type instance Base (Cofree f a) = CofreeF f a
instance Functor f => Foldable.Foldable (Cofree f a) where project = runCofree
2016-05-04 22:15:25 +03:00
instance Functor f => Foldable.Unfoldable (Cofree f a) where embed = cofree
2016-01-13 23:35:40 +03:00
-- | Zip two terms by combining their annotations into a pair of annotations.
-- | If the structure of the two terms don't match, then Nothing will be returned.
zipTerms :: Term a annotation -> Term a annotation -> Maybe (Term a (Both annotation))
2016-05-04 21:37:24 +03:00
zipTerms t1 t2 = annotate (zipUnwrap a b)
2015-11-19 03:58:37 +03:00
where
2016-05-04 21:37:24 +03:00
(annotation1 :< a, annotation2 :< b) = (runCofree t1, runCofree t2)
annotate = fmap (cofree . (both annotation1 annotation2 :<))
2015-11-27 20:02:28 +03:00
zipUnwrap (Leaf _) (Leaf b') = Just $ Leaf b'
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-27 20:02:28 +03:00
zipUnwrap (Keyed a') (Keyed b') | keys a' == keys b' = Just . Keyed . fromList . catMaybes $ zipUnwrapMaps a' b' <$> keys a'
zipUnwrap _ _ = Nothing
zipUnwrapMaps a' b' key = (,) key <$> zipTerms (a' ! key) (b' ! key)
2015-11-20 04:17:17 +03:00
2016-04-11 22:06:53 +03:00
-- | Return the node count of a term.
2015-12-01 03:13:20 +03:00
termSize :: Term a annotation -> Integer
2016-01-13 23:32:03 +03:00
termSize = cata size where
2016-05-03 19:17:38 +03:00
size (_ :< syntax) = 1 + sum syntax
alignCofreeWith :: Functor f => (forall a b. f a -> f b -> Maybe (f (These a b))) -> (These (Cofree f a) (Cofree f b) -> contrasted) -> (a -> b -> combined) -> These (Cofree f a) (Cofree f b) -> Free (CofreeF f combined) contrasted
alignCofreeWith compare contrast combine = go
where go terms = fromMaybe (pure (contrast terms)) $ case terms of
2016-07-11 21:27:38 +03:00
These t1 t2 -> wrap . (combine (extract t1) (extract t2) :<) . fmap go <$> compare (unwrap t1) (unwrap t2)
_ -> Nothing