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

48 lines
2.4 KiB
Haskell
Raw Normal View History

2016-09-24 10:46:50 +03:00
{-# LANGUAGE RankNTypes, TypeFamilies, TypeSynonymInstances #-}
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-07-11 22:13:16 +03:00
import Data.Align.Generic
2016-05-03 19:17:38 +03:00
import Data.Functor.Foldable as Foldable
import Data.Functor.Both
import Data.Record
import Data.These
import Syntax
2016-10-22 01:06:31 +03:00
-- | A Term with an abstract syntax tree and an annotation.
type Term f annotation = Cofree f annotation
type TermF = CofreeF
2016-05-04 21:37:24 +03:00
2016-10-22 00:39:13 +03:00
-- | A Term with a Syntax leaf and a record of fields.
type SyntaxTerm leaf fields = Term (Syntax leaf) (Record fields)
2016-10-22 01:06:31 +03:00
type SyntaxTermF leaf fields = TermF (Syntax leaf) (Record fields)
2016-10-22 00:39:13 +03:00
-- Term has a Base functor TermF which gives it Recursive and Corecursive instances.
type instance Base (Term f a) = TermF f a
instance Functor f => Recursive (Term f a) where project = runCofree
instance Functor f => Corecursive (Term 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.
2016-09-15 00:09:50 +03:00
zipTerms :: (Traversable f, GAlign f) => Term f annotation -> Term f annotation -> Maybe (Term f (Both annotation))
2016-07-11 22:13:16 +03:00
zipTerms t1 t2 = iter go (alignCofreeWith galign (const Nothing) both (These t1 t2))
where go (a :< s) = cofree . (a :<) <$> sequenceA s
2015-11-20 04:17:17 +03:00
2016-04-11 22:06:53 +03:00
-- | Return the node count of a term.
termSize :: (Foldable f, Functor f) => Term f annotation -> Int
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
2016-07-11 21:33:51 +03:00
-- | Aligns (zips, retaining non-overlapping portions of the structure) a pair of terms.
2016-07-11 21:41:59 +03:00
alignCofreeWith :: Functor f
=> (forall a b. f a -> f b -> Maybe (f (These a b))) -- ^ A function comparing a pair of structures, returning `Just` the combined structure if they are comparable (e.g. if they have the same constructor), and `Nothing` otherwise. The 'Data.Align.Generic.galign' function is usually what you want here.
-> (These (Term f a) (Term f b) -> contrasted) -- ^ A function mapping a 'These' of incomparable terms into 'Pure' values in the resulting tree.
2016-07-11 21:41:59 +03:00
-> (a -> b -> combined) -- ^ A function mapping the input terms annotations into annotations in the 'Free' values in the resulting tree.
-> These (Term f a) (Term f b) -- ^ The input terms.
-> Free (TermF 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