mirror of
https://github.com/github/semantic.git
synced 2024-12-24 07:25:44 +03:00
143 lines
4.5 KiB
Haskell
143 lines
4.5 KiB
Haskell
{-# LANGUAGE MultiParamTypeClasses, RankNTypes, TypeFamilies, TypeSynonymInstances, UndecidableInstances #-}
|
|
module Term
|
|
( Term(..)
|
|
, TermF(..)
|
|
, SyntaxTerm
|
|
, SyntaxTermF
|
|
, termSize
|
|
, term
|
|
, unTerm
|
|
, extract
|
|
, unwrap
|
|
, hoistTerm
|
|
) where
|
|
|
|
import Control.Comonad
|
|
import Control.Comonad.Cofree.Class
|
|
import Control.DeepSeq
|
|
import Data.Bifunctor
|
|
import Data.Functor.Classes
|
|
import Data.Functor.Classes.Pretty.Generic as Pretty
|
|
import Data.Functor.Foldable
|
|
import Data.Functor.Listable
|
|
import Data.Proxy
|
|
import Data.Record
|
|
import Data.Union
|
|
import Syntax
|
|
|
|
-- | A Term with an abstract syntax tree and an annotation.
|
|
infixr 5 :<
|
|
data Term f a = a :< f (Term f a)
|
|
infixr 5 :<<
|
|
data TermF f a b = (:<<) { headF :: a, tailF :: f b }
|
|
deriving (Eq, Foldable, Functor, Show, Traversable)
|
|
|
|
-- | A Term with a Syntax leaf and a record of fields.
|
|
type SyntaxTerm fields = Term Syntax (Record fields)
|
|
type SyntaxTermF fields = TermF Syntax (Record fields)
|
|
|
|
instance NFData1 f => NFData1 (Term f) where
|
|
liftRnf rnfA = go where go (a :< f) = rnfA a `seq` liftRnf go f
|
|
|
|
instance (NFData1 f, NFData a) => NFData (Term f a) where
|
|
rnf = rnf1
|
|
|
|
instance NFData1 f => NFData2 (TermF f) where
|
|
liftRnf2 rnfA rnfB (a :<< f) = rnfA a `seq` liftRnf rnfB f `seq` ()
|
|
|
|
instance (NFData1 f, NFData a) => NFData1 (TermF f a) where
|
|
liftRnf = liftRnf2 rnf
|
|
|
|
instance (NFData1 f, NFData a, NFData b) => NFData (TermF f a b) where
|
|
rnf = rnf1
|
|
|
|
-- | Return the node count of a term.
|
|
termSize :: (Foldable f, Functor f) => Term f annotation -> Int
|
|
termSize = cata size where
|
|
size (_ :<< syntax) = 1 + sum syntax
|
|
|
|
|
|
term :: TermF f a (Term f a) -> Term f a
|
|
term (a :<< f) = a :< f
|
|
|
|
unTerm :: Term f a -> TermF f a (Term f a)
|
|
unTerm (a :< f) = a :<< f
|
|
|
|
hoistTerm :: Functor f => (forall a. f a -> g a) -> Term f a -> Term g a
|
|
hoistTerm f = go where go (a :< r) = a :< f (fmap go r)
|
|
|
|
liftPrettyUnion :: Apply1 Pretty1 fs => (a -> Doc ann) -> ([a] -> Doc ann) -> Union fs a -> Doc ann
|
|
liftPrettyUnion p pl = apply1 (Proxy :: Proxy Pretty1) (liftPretty p pl)
|
|
|
|
instance Pretty1 f => Pretty1 (Term f) where
|
|
liftPretty p pl = go where go (a :< f) = p a <+> liftPretty go (Pretty.list . map (liftPretty p pl)) f
|
|
|
|
instance (Pretty1 f, Pretty a) => Pretty (Term f a) where
|
|
pretty = liftPretty pretty prettyList
|
|
|
|
instance Apply1 Pretty1 fs => Pretty1 (Union fs) where
|
|
liftPretty = liftPrettyUnion
|
|
|
|
type instance Base (Term f a) = TermF f a
|
|
|
|
instance Functor f => Recursive (Term f a) where project = unTerm
|
|
instance Functor f => Corecursive (Term f a) where embed = term
|
|
|
|
instance Functor f => Comonad (Term f) where
|
|
extract (a :< _) = a
|
|
duplicate w = w :< fmap duplicate (unwrap w)
|
|
extend f = go where go w = f w :< fmap go (unwrap w)
|
|
|
|
instance Functor f => Functor (Term f) where
|
|
fmap f = go where go (a :< r) = f a :< fmap go r
|
|
|
|
instance Functor f => ComonadCofree f (Term f) where
|
|
unwrap (_ :< as) = as
|
|
{-# INLINE unwrap #-}
|
|
|
|
instance Eq1 f => Eq1 (Term f) where
|
|
liftEq eqA = go where go (a1 :< f1) (a2 :< f2) = eqA a1 a2 && liftEq go f1 f2
|
|
|
|
instance (Eq1 f, Eq a) => Eq (Term f a) where
|
|
(==) = eq1
|
|
|
|
instance Show1 f => Show1 (Term f) where
|
|
liftShowsPrec spA slA = go where go d (a :< f) = showParen (d > 5) $ spA 6 a . showString " :< " . liftShowsPrec go (liftShowList spA slA) 5 f
|
|
|
|
instance (Show1 f, Show a) => Show (Term f a) where
|
|
showsPrec = showsPrec1
|
|
|
|
instance Functor f => Bifunctor (TermF f) where
|
|
bimap f g (a :<< r) = f a :<< fmap g r
|
|
|
|
instance Listable1 f => Listable2 (TermF f) where
|
|
liftTiers2 annotationTiers recurTiers = liftCons2 annotationTiers (liftTiers recurTiers) (:<<)
|
|
|
|
instance (Listable1 f, Listable a) => Listable1 (TermF f a) where
|
|
liftTiers = liftTiers2 tiers
|
|
|
|
instance (Functor f, Listable1 f) => Listable1 (Term f) where
|
|
liftTiers annotationTiers = go
|
|
where go = liftCons1 (liftTiers2 annotationTiers go) term
|
|
|
|
instance Eq1 f => Eq2 (TermF f) where
|
|
liftEq2 eqA eqB (a1 :<< f1) (a2 :<< f2) = eqA a1 a2 && liftEq eqB f1 f2
|
|
|
|
instance (Eq1 f, Eq a) => Eq1 (TermF f a) where
|
|
liftEq = liftEq2 (==)
|
|
|
|
instance Show1 f => Show2 (TermF f) where
|
|
liftShowsPrec2 spA _ spB slB d (a :<< f) = showParen (d > 5) $ spA 6 a . showString " :<< " . liftShowsPrec spB slB 5 f
|
|
|
|
instance (Show1 f, Show a) => Show1 (TermF f a) where
|
|
liftShowsPrec = liftShowsPrec2 showsPrec showList
|
|
|
|
instance Pretty1 f => Pretty2 (TermF f) where
|
|
liftPretty2 pA _ pB plB (a :<< f) = pA a <+> liftPretty pB plB f
|
|
|
|
instance (Pretty1 f, Pretty a) => Pretty1 (TermF f a) where
|
|
liftPretty = liftPretty2 pretty prettyList
|
|
|
|
instance (Pretty1 f, Pretty a, Pretty b) => Pretty (TermF f a b) where
|
|
pretty = liftPretty pretty prettyList
|