mirror of
https://github.com/github/semantic.git
synced 2024-11-28 10:15:55 +03:00
Try to implement alignment over functors. Try, and fail miserably.
This commit is contained in:
parent
15a0022152
commit
6c2948e317
@ -66,6 +66,7 @@ library
|
|||||||
, QuickCheck >= 2.8.1
|
, QuickCheck >= 2.8.1
|
||||||
, quickcheck-text
|
, quickcheck-text
|
||||||
, semigroups
|
, semigroups
|
||||||
|
, syb
|
||||||
, text >= 1.2.1.3
|
, text >= 1.2.1.3
|
||||||
, text-icu
|
, text-icu
|
||||||
, these
|
, these
|
||||||
|
23
src/Term.hs
23
src/Term.hs
@ -1,4 +1,4 @@
|
|||||||
{-# LANGUAGE RankNTypes, TypeFamilies, TypeSynonymInstances #-}
|
{-# LANGUAGE ScopedTypeVariables, RankNTypes, TypeFamilies, TypeSynonymInstances #-}
|
||||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||||
module Term where
|
module Term where
|
||||||
|
|
||||||
@ -9,6 +9,9 @@ import Data.Functor.Both
|
|||||||
import Data.OrderedMap hiding (size)
|
import Data.OrderedMap hiding (size)
|
||||||
import Data.These
|
import Data.These
|
||||||
import Syntax
|
import Syntax
|
||||||
|
import Data.Data
|
||||||
|
import Data.Generics.Twins
|
||||||
|
import Unsafe.Coerce
|
||||||
|
|
||||||
-- | An annotated node (Syntax) in an abstract syntax tree.
|
-- | An annotated node (Syntax) in an abstract syntax tree.
|
||||||
type TermF a annotation = CofreeF (Syntax a) annotation
|
type TermF a annotation = CofreeF (Syntax a) annotation
|
||||||
@ -50,3 +53,21 @@ alignSyntax' a b = case (a, b) of
|
|||||||
(Fixed a, Fixed b) -> Just (Fixed (align a b))
|
(Fixed a, Fixed b) -> Just (Fixed (align a b))
|
||||||
(Keyed a, Keyed b) -> Just (Keyed (align a b))
|
(Keyed a, Keyed b) -> Just (Keyed (align a b))
|
||||||
_ -> Nothing
|
_ -> Nothing
|
||||||
|
|
||||||
|
alignF :: (Data (f a), Data (f b), Data (f (These a b)), Typeable a, Typeable b) => f a -> f b -> Maybe (f b)
|
||||||
|
alignF a b = do
|
||||||
|
guard (toConstr a == toConstr b)
|
||||||
|
alignM a b
|
||||||
|
where alignM :: (Data a, Data b, Alternative m, Monad m) => a -> b -> m b
|
||||||
|
alignM a b = gzipWithM go a b
|
||||||
|
where go :: forall m a b. (Data a, Data b, Alternative m, Monad m) => a -> b -> m b
|
||||||
|
go a b = do
|
||||||
|
guard (toConstr a == toConstr b)
|
||||||
|
fromConstrM (do
|
||||||
|
b' <- guardCast b
|
||||||
|
alignM a b') (toConstr b)
|
||||||
|
|
||||||
|
guardCast :: forall f a b. (Typeable a, Typeable b, Alternative f) => a -> f b
|
||||||
|
guardCast a =
|
||||||
|
guard (typeRep (Proxy :: Proxy a) == typeRep (Proxy :: Proxy b))
|
||||||
|
*> unsafeCoerce a
|
||||||
|
Loading…
Reference in New Issue
Block a user