diff options
Diffstat (limited to 'src/Language/Fiddle/GenericTree.hs')
| -rw-r--r-- | src/Language/Fiddle/GenericTree.hs | 39 |
1 files changed, 32 insertions, 7 deletions
diff --git a/src/Language/Fiddle/GenericTree.hs b/src/Language/Fiddle/GenericTree.hs index 59db6aa..031f6ab 100644 --- a/src/Language/Fiddle/GenericTree.hs +++ b/src/Language/Fiddle/GenericTree.hs @@ -40,17 +40,38 @@ type Context stage = data GenericSyntaxTree f a where {- GenericSyntaxtTree with a name and children. -} SyntaxTreeObject :: - forall a f tree. - (Typeable tree) => + forall t f a. + (Typeable t, Typeable f, Typeable a) => String -> [GenericSyntaxTree f a] -> a -> - tree -> + t f a -> GenericSyntaxTree f a SyntaxTreeList :: [GenericSyntaxTree f a] -> GenericSyntaxTree f a SyntaxTreeDeferred :: f (GenericSyntaxTree f a) -> GenericSyntaxTree f a SyntaxTreeValue :: String -> GenericSyntaxTree f a +alterGenericSyntaxTree :: + (Functor f) => + (GenericSyntaxTree f a -> Maybe (GenericSyntaxTree f a)) -> + GenericSyntaxTree f a -> + GenericSyntaxTree f a +alterGenericSyntaxTree fn genericTree + | (Just newGenericTree) <- fn genericTree = newGenericTree + | otherwise = + case genericTree of + SyntaxTreeObject str members annot tree -> + SyntaxTreeObject + str + (map (alterGenericSyntaxTree fn) members) + annot + tree + SyntaxTreeList members -> + SyntaxTreeList $ map (alterGenericSyntaxTree fn) members + SyntaxTreeDeferred sub -> + SyntaxTreeDeferred $ fmap (alterGenericSyntaxTree fn) sub + v -> v + instance ToJSON Comment where toJSON (NormalComment str) = object ["normal" .= str] toJSON (DocComment str) = object ["doc" .= str] @@ -71,9 +92,11 @@ instance ToJSON SourcePos where "col" .= sourceColumn sourcePos ] -instance (Foldable f, ToJSON a) => ToJSON (GenericSyntaxTree f a) where +instance (Foldable f) => ToJSON (GenericSyntaxTree f (Maybe Value)) where toJSON = \case - (SyntaxTreeObject typ membs a _) -> + (SyntaxTreeObject typ membs Nothing _) -> + object ["_con" .= typ, "_members" .= membs] + (SyntaxTreeObject typ membs (Just a) _) -> object ["_con" .= typ, "_members" .= membs, "_annot" .= a] (SyntaxTreeList l) -> Array $ Data.Vector.fromList $ map toJSON l @@ -82,8 +105,10 @@ instance (Foldable f, ToJSON a) => ToJSON (GenericSyntaxTree f a) where (SyntaxTreeValue s) -> String (Data.Text.pack s) toEncoding = \case - (SyntaxTreeObject typ membs a t) -> + (SyntaxTreeObject typ membs (Just a) t) -> pairs $ "_type" .= show (typeOf t) <> "_con" .= typ <> "_members" .= membs <> "_annot" .= a + (SyntaxTreeObject typ membs Nothing t) -> + pairs $ "_type" .= show (typeOf t) <> "_con" .= typ <> "_members" .= membs (SyntaxTreeList l) -> foldable $ map toJSON l (SyntaxTreeDeferred fdef) -> @@ -118,7 +143,7 @@ class ToGenericSyntaxTree (t :: SynTree) where toGenericSyntaxTree t = gToGenericSyntaxTree t (from t) class GToGenericSyntaxTree r f a where - gToGenericSyntaxTree :: (Typeable t) => t -> r x -> GenericSyntaxTree f a + gToGenericSyntaxTree :: (Typeable t, Typeable f, Typeable a) => t f a -> r x -> GenericSyntaxTree f a class GToMemberList r f a where gToMemberList :: Int -> r x -> [GenericSyntaxTree f a] |