From f2cd05d5fccca8901c2dc4b7e641a9f0a9b429d7 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 8 Sep 2017 16:45:08 +0100 Subject: [PATCH] Rename Cofree/CofreeF to Term/TermF. --- src/Data/Syntax/Assignment.hs | 6 ++-- src/Language/Markdown.hs | 6 ++-- src/Language/Markdown/Syntax.hs | 6 ++-- src/Parser.hs | 6 ++-- src/Renderer.hs | 2 +- src/Renderer/JSON.hs | 6 ++-- src/Term.hs | 53 +++++++++++++++------------------ 7 files changed, 40 insertions(+), 45 deletions(-) diff --git a/src/Data/Syntax/Assignment.hs b/src/Data/Syntax/Assignment.hs index e5127d4a8..f95484630 100644 --- a/src/Data/Syntax/Assignment.hs +++ b/src/Data/Syntax/Assignment.hs @@ -127,7 +127,7 @@ type Assignment ast grammar = Freer (Tracing (AssignmentF ast grammar)) data AssignmentF ast grammar a where End :: AssignmentF ast grammar () Location :: AssignmentF ast grammar (Record Location) - CurrentNode :: AssignmentF ast grammar (CofreeF ast (Node grammar) ()) + CurrentNode :: AssignmentF ast grammar (TermF ast (Node grammar) ()) Source :: AssignmentF ast grammar ByteString Children :: Assignment ast grammar a -> AssignmentF ast grammar a Advance :: AssignmentF ast grammar () @@ -157,7 +157,7 @@ location :: HasCallStack => Assignment ast grammar (Record Location) location = tracing Location `Then` return -- | Zero-width production of the current node. -currentNode :: HasCallStack => Assignment ast grammar (CofreeF ast (Node grammar) ()) +currentNode :: HasCallStack => Assignment ast grammar (TermF ast (Node grammar) ()) currentNode = tracing CurrentNode `Then` return -- | Zero-width match of a node with the given symbol, producing the current node’s location. @@ -206,7 +206,7 @@ toIndex = index (minBound, maxBound) type Location = '[Info.Range, Info.Span] -- | An AST node labelled with symbols and source location. -type AST f grammar = Cofree f (Node grammar) +type AST f grammar = Term f (Node grammar) data Node grammar = Node { nodeSymbol :: !grammar diff --git a/src/Language/Markdown.hs b/src/Language/Markdown.hs index c0f62b17e..b33727117 100644 --- a/src/Language/Markdown.hs +++ b/src/Language/Markdown.hs @@ -11,7 +11,7 @@ import Data.Source import qualified Data.Syntax.Assignment as A (AST, Node(..)) import Info import TreeSitter.Language (Symbol(..), SymbolType(..)) -import Term as Cofree +import Term data Grammar = Document @@ -48,9 +48,9 @@ exts = [ , extTagfilter ] -cmarkParser :: Source -> A.AST (CofreeF [] NodeType) Grammar +cmarkParser :: Source -> A.AST (TermF [] NodeType) Grammar cmarkParser source = toTerm (totalRange source) (totalSpan source) $ commonmarkToNode [ optSourcePos, optSafe ] exts (toText source) - where toTerm :: Range -> Span -> Node -> A.AST (CofreeF [] NodeType) Grammar + where toTerm :: Range -> Span -> Node -> A.AST (TermF [] NodeType) Grammar toTerm within withinSpan (Node position t children) = let range = maybe within (spanToRangeInLineRanges lineRanges . toSpan) position span = maybe withinSpan toSpan position diff --git a/src/Language/Markdown/Syntax.hs b/src/Language/Markdown/Syntax.hs index b21a63ef1..89899ad98 100644 --- a/src/Language/Markdown/Syntax.hs +++ b/src/Language/Markdown/Syntax.hs @@ -20,7 +20,7 @@ import Data.Text.Encoding (encodeUtf8) import Data.Union import GHC.Stack import Language.Markdown as Grammar (Grammar(..)) -import Term (Cofree(..), CofreeF(..), unwrap, headF, tailF) +import Term (TermF(..), unwrap, headF, tailF) import qualified Term type Syntax = @@ -52,7 +52,7 @@ type Syntax = ] type Term = Term.Term (Union Syntax) (Record Location) -type Assignment = HasCallStack => Assignment.Assignment (CofreeF [] CMarkGFM.NodeType) Grammar Term +type Assignment = HasCallStack => Assignment.Assignment (TermF [] CMarkGFM.NodeType) Grammar Term assignment :: Assignment @@ -68,7 +68,7 @@ paragraph :: Assignment paragraph = makeTerm <$> symbol Paragraph <*> children (Markup.Paragraph <$> many inlineElement) list :: Assignment -list = (:<) <$> symbol List <*> ((\ (CMarkGFM.LIST CMarkGFM.ListAttributes{..}) -> case listType of +list = (Term.:<) <$> symbol List <*> ((\ (CMarkGFM.LIST CMarkGFM.ListAttributes{..}) -> case listType of CMarkGFM.BULLET_LIST -> inj . Markup.UnorderedList CMarkGFM.ORDERED_LIST -> inj . Markup.OrderedList) . headF . tailF <$> currentNode <*> children (many item)) diff --git a/src/Parser.hs b/src/Parser.hs index feeeeecd5..c70c5b3c2 100644 --- a/src/Parser.hs +++ b/src/Parser.hs @@ -39,14 +39,14 @@ data Parser term where -- | A parser producing 'AST' using a 'TS.Language'. ASTParser :: (Bounded grammar, Enum grammar) => Ptr TS.Language -> Parser (AST [] grammar) -- | A parser producing an à la carte term given an 'AST'-producing parser and an 'Assignment' onto 'Term's in some syntax type. - AssignmentParser :: (Bounded grammar, Ix grammar, Show grammar, TS.Symbol grammar, Syntax.Error :< fs, Eq (ast (Cofree ast (Node grammar))), Apply1 Foldable fs, Apply1 Functor fs, Foldable ast, Functor ast) - => Parser (Cofree ast (Node grammar)) -- ^ A parser producing AST. + AssignmentParser :: (Bounded grammar, Ix grammar, Show grammar, TS.Symbol grammar, Syntax.Error :< fs, Eq (ast (Term ast (Node grammar))), Apply1 Foldable fs, Apply1 Functor fs, Foldable ast, Functor ast) + => Parser (Term ast (Node grammar)) -- ^ A parser producing AST. -> Assignment ast grammar (Term (Union fs) (Record Location)) -- ^ An assignment from AST onto 'Term's. -> Parser (Term (Union fs) (Record Location)) -- ^ A parser producing 'Term's. -- | A tree-sitter parser. TreeSitterParser :: Ptr TS.Language -> Parser (SyntaxTerm DefaultFields) -- | A parser for 'Markdown' using cmark. - MarkdownParser :: Parser (Cofree (CofreeF [] CMarkGFM.NodeType) (Node Markdown.Grammar)) + MarkdownParser :: Parser (Term (TermF [] CMarkGFM.NodeType) (Node Markdown.Grammar)) -- | A parser which will parse any input 'Source' into a top-level 'Term' whose children are leaves consisting of the 'Source's lines. LineByLineParser :: Parser (SyntaxTerm DefaultFields) diff --git a/src/Renderer.hs b/src/Renderer.hs index 39a3468f3..28f551ee6 100644 --- a/src/Renderer.hs +++ b/src/Renderer.hs @@ -74,7 +74,7 @@ data SomeRenderer f where deriving instance Show (SomeRenderer f) -identifierAlgebra :: RAlgebra (CofreeF Syntax a) (Cofree Syntax a) (Maybe Identifier) +identifierAlgebra :: RAlgebra (TermF Syntax a) (Term Syntax a) (Maybe Identifier) identifierAlgebra (_ :<< syntax) = case syntax of S.Assignment f _ -> identifier f S.Class f _ _ -> identifier f diff --git a/src/Renderer/JSON.hs b/src/Renderer/JSON.hs index 667943e57..2ca643d28 100644 --- a/src/Renderer/JSON.hs +++ b/src/Renderer/JSON.hs @@ -56,7 +56,7 @@ instance (ToJSONFields a, ToJSONFields (f (Free f a))) => ToJSON (Free f a) wher toJSON = object . toJSONFields toEncoding = pairs . mconcat . toJSONFields -instance (ToJSONFields a, ToJSONFields (f (Cofree f a))) => ToJSON (Cofree f a) where +instance (ToJSONFields a, ToJSONFields (f (Term f a))) => ToJSON (Term f a) where toJSON (a :< f) = object (toJSONFields a <> toJSONFields f) toEncoding (a :< f) = pairs (mconcat (toJSONFields a <> toJSONFields f)) @@ -85,10 +85,10 @@ instance ToJSONFields Span where instance ToJSONFields a => ToJSONFields (Maybe a) where toJSONFields = maybe [] toJSONFields -instance (ToJSONFields a, ToJSONFields (f (Cofree f a))) => ToJSONFields (Cofree f a) where +instance (ToJSONFields a, ToJSONFields (f (Term f a))) => ToJSONFields (Term f a) where toJSONFields (a :< f) = toJSONFields a <> toJSONFields f -instance (ToJSONFields a, ToJSONFields (f b)) => ToJSONFields (CofreeF f a b) where +instance (ToJSONFields a, ToJSONFields (f b)) => ToJSONFields (TermF f a b) where toJSONFields (a :<< f) = toJSONFields a <> toJSONFields f instance (ToJSONFields a, ToJSONFields (f (Free f a))) => ToJSONFields (Free f a) where diff --git a/src/Term.hs b/src/Term.hs index 6392f0b0d..b7b050671 100644 --- a/src/Term.hs +++ b/src/Term.hs @@ -1,19 +1,17 @@ {-# LANGUAGE MultiParamTypeClasses, RankNTypes, TypeFamilies, TypeSynonymInstances, UndecidableInstances #-} module Term -( Term -, TermF +( Term(..) +, TermF(..) , SyntaxTerm , SyntaxTermF , zipTerms , termSize -, alignCofreeWith +, alignTermWith , cofree , runCofree -, Cofree(..) , extract , unwrap , hoistCofree -, CofreeF(..) ) where import Control.Comonad @@ -33,28 +31,25 @@ import Data.Union import Syntax -- | A Term with an abstract syntax tree and an annotation. -type Term = Cofree -type TermF = CofreeF - infixr 5 :< -data Cofree f a = a :< f (Cofree f a) -data CofreeF f a b = (:<<) { headF :: a, tailF :: f b } +data Term f a = a :< f (Term f a) +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 (NFData (f (Cofree f a)), NFData a, Functor f) => NFData (Cofree f a) where +instance (NFData (f (Term f a)), NFData a, Functor f) => NFData (Term f a) where rnf = rnf . runCofree -instance (NFData a, NFData (f b)) => NFData (CofreeF f a b) where +instance (NFData a, NFData (f b)) => NFData (TermF f a b) where rnf (a :<< s) = rnf a `seq` rnf s `seq` () -- | 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 :: (Traversable f, GAlign f) => Term f annotation -> Term f annotation -> Maybe (Term f (Both annotation)) -zipTerms t1 t2 = iter go (alignCofreeWith galign (const Nothing) both (These t1 t2)) +zipTerms t1 t2 = iter go (alignTermWith galign (const Nothing) both (These t1 t2)) where go (a :<< s) = (a :<) <$> sequenceA s -- | Return the node count of a term. @@ -63,58 +58,58 @@ termSize = cata size where size (_ :<< syntax) = 1 + sum syntax -- | Aligns (zips, retaining non-overlapping portions of the structure) a pair of terms. -alignCofreeWith :: Functor f +alignTermWith :: 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. -> (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 +alignTermWith compare contrast combine = go where go terms = fromMaybe (pure (contrast terms)) $ case terms of These (a1 :< f1) (a2 :< f2) -> wrap . (combine a1 a2 :<<) . fmap go <$> compare f1 f2 _ -> Nothing -cofree :: CofreeF f a (Cofree f a) -> Cofree f a +cofree :: TermF f a (Term f a) -> Term f a cofree (a :<< f) = a :< f -runCofree :: Cofree f a -> CofreeF f a (Cofree f a) +runCofree :: Term f a -> TermF f a (Term f a) runCofree (a :< f) = a :<< f -hoistCofree :: Functor f => (forall a. f a -> g a) -> Cofree f a -> Cofree g a +hoistCofree :: Functor f => (forall a. f a -> g a) -> Term f a -> Term g a hoistCofree f = go where go (a :< r) = a :< f (fmap go r) -instance Pretty1 f => Pretty1 (Cofree f) where +instance Pretty1 f => Pretty1 (Term f) where liftPretty p pl = go where go (a :< f) = p a <+> liftPretty go (list . map (liftPretty p pl)) f -instance (Pretty1 f, Pretty a) => Pretty (Cofree f a) where +instance (Pretty1 f, Pretty a) => Pretty (Term f a) where pretty = liftPretty pretty prettyList instance Apply1 Pretty1 fs => Pretty1 (Union fs) where liftPretty p pl = apply1 (Proxy :: Proxy Pretty1) (liftPretty p pl) -type instance Base (Cofree f a) = CofreeF f a +type instance Base (Term f a) = TermF f a -instance Functor f => Recursive (Cofree f a) where project = runCofree -instance Functor f => Corecursive (Cofree f a) where embed = cofree +instance Functor f => Recursive (Term f a) where project = runCofree +instance Functor f => Corecursive (Term f a) where embed = cofree -instance Functor f => Comonad (Cofree f) where +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 (Cofree f) where +instance Functor f => Functor (Term f) where fmap f = go where go (a :< r) = f a :< fmap go r -instance Functor f => ComonadCofree f (Cofree f) where +instance Functor f => ComonadCofree f (Term f) where unwrap (_ :< as) = as {-# INLINE unwrap #-} -instance (Eq (f (Cofree f a)), Eq a) => Eq (Cofree f a) where +instance (Eq (f (Term f a)), Eq a) => Eq (Term f a) where a1 :< f1 == a2 :< f2 = a1 == a2 && f1 == f2 -instance (Show (f (Cofree f a)), Show a) => Show (Cofree f a) where +instance (Show (f (Term f a)), Show a) => Show (Term f a) where showsPrec d (a :< f) = showParen (d > 5) $ showsPrec 6 a . showString " :< " . showsPrec 5 f -instance Functor f => Bifunctor (CofreeF f) where +instance Functor f => Bifunctor (TermF f) where bimap f g (a :<< r) = f a :<< fmap g r