{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeSynonymInstances #-}
module Retrie.Universe
( Universe
, printU
, Matchable(..)
, UMap(..)
) where
import Control.Monad
import Data.Data
import Retrie.AlphaEnv
import Retrie.ExactPrint
import Retrie.GHC
import Retrie.PatternMap.Class
import Retrie.PatternMap.Instances
import Retrie.Quantifiers
import Retrie.Substitution
data Universe
= ULHsExpr (LHsExpr GhcPs)
| ULStmt (LStmt GhcPs (LHsExpr GhcPs))
| ULType (LHsType GhcPs)
| ULPat (Located (Pat GhcPs))
deriving (Typeable Universe
DataType
Constr
Typeable Universe
-> (forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Universe -> c Universe)
-> (forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c Universe)
-> (Universe -> Constr)
-> (Universe -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c Universe))
-> (forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c Universe))
-> ((forall b. Data b => b -> b) -> Universe -> Universe)
-> (forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> Universe -> r)
-> (forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> Universe -> r)
-> (forall u. (forall d. Data d => d -> u) -> Universe -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> Universe -> u)
-> (forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> Universe -> m Universe)
-> (forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> Universe -> m Universe)
-> (forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> Universe -> m Universe)
-> Data Universe
Universe -> DataType
Universe -> Constr
(forall b. Data b => b -> b) -> Universe -> Universe
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Universe -> c Universe
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c Universe
forall a.
Typeable a
-> (forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> a -> c a)
-> (forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c a)
-> (a -> Constr)
-> (a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c a))
-> (forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
-> ((forall b. Data b => b -> b) -> a -> a)
-> (forall r r'.
(r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall r r'.
(r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall u. (forall d. Data d => d -> u) -> a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> a -> u)
-> (forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> a -> m a)
-> Data a
forall u. Int -> (forall d. Data d => d -> u) -> Universe -> u
forall u. (forall d. Data d => d -> u) -> Universe -> [u]
forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> Universe -> r
forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> Universe -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> Universe -> m Universe
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> Universe -> m Universe
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c Universe
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Universe -> c Universe
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c Universe)
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c Universe)
$cULPat :: Constr
$cULType :: Constr
$cULStmt :: Constr
$cULHsExpr :: Constr
$tUniverse :: DataType
gmapMo :: (forall d. Data d => d -> m d) -> Universe -> m Universe
$cgmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> Universe -> m Universe
gmapMp :: (forall d. Data d => d -> m d) -> Universe -> m Universe
$cgmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> Universe -> m Universe
gmapM :: (forall d. Data d => d -> m d) -> Universe -> m Universe
$cgmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> Universe -> m Universe
gmapQi :: Int -> (forall d. Data d => d -> u) -> Universe -> u
$cgmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> Universe -> u
gmapQ :: (forall d. Data d => d -> u) -> Universe -> [u]
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> Universe -> [u]
gmapQr :: (r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> Universe -> r
$cgmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> Universe -> r
gmapQl :: (r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> Universe -> r
$cgmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> Universe -> r
gmapT :: (forall b. Data b => b -> b) -> Universe -> Universe
$cgmapT :: (forall b. Data b => b -> b) -> Universe -> Universe
dataCast2 :: (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c Universe)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c Universe)
dataCast1 :: (forall d. Data d => c (t d)) -> Maybe (c Universe)
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c Universe)
dataTypeOf :: Universe -> DataType
$cdataTypeOf :: Universe -> DataType
toConstr :: Universe -> Constr
$ctoConstr :: Universe -> Constr
gunfold :: (forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c Universe
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c Universe
gfoldl :: (forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Universe -> c Universe
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Universe -> c Universe
$cp1Data :: Typeable Universe
Data)
printU :: Annotated Universe -> String
printU :: Annotated Universe -> String
printU Annotated Universe
u = Universe -> Anns -> String
exactPrintU (Annotated Universe -> Universe
forall ast. Annotated ast -> ast
astA Annotated Universe
u) (Annotated Universe -> Anns
forall ast. Annotated ast -> Anns
annsA Annotated Universe
u)
exactPrintU :: Universe -> Anns -> String
exactPrintU :: Universe -> Anns -> String
exactPrintU (ULHsExpr LHsExpr GhcPs
e) Anns
anns = LHsExpr GhcPs -> Anns -> String
forall ast. Annotate ast => Located ast -> Anns -> String
exactPrint LHsExpr GhcPs
e Anns
anns
exactPrintU (ULStmt LStmt GhcPs (LHsExpr GhcPs)
s) Anns
anns = LStmt GhcPs (LHsExpr GhcPs) -> Anns -> String
forall ast. Annotate ast => Located ast -> Anns -> String
exactPrint LStmt GhcPs (LHsExpr GhcPs)
s Anns
anns
exactPrintU (ULType LHsType GhcPs
t) Anns
anns = LHsType GhcPs -> Anns -> String
forall ast. Annotate ast => Located ast -> Anns -> String
exactPrint LHsType GhcPs
t Anns
anns
exactPrintU (ULPat Located (Pat GhcPs)
p) Anns
anns = Located (Pat GhcPs) -> Anns -> String
forall ast. Annotate ast => Located ast -> Anns -> String
exactPrint Located (Pat GhcPs)
p Anns
anns
class Matchable ast where
inject :: ast -> Universe
project :: Universe -> ast
getOrigin :: ast -> SrcSpan
instance Matchable Universe where
inject :: Universe -> Universe
inject = Universe -> Universe
forall a. a -> a
id
project :: Universe -> Universe
project = Universe -> Universe
forall a. a -> a
id
getOrigin :: Universe -> SrcSpan
getOrigin (ULHsExpr LHsExpr GhcPs
e) = LHsExpr GhcPs -> SrcSpan
forall ast. Matchable ast => ast -> SrcSpan
getOrigin LHsExpr GhcPs
e
getOrigin (ULStmt LStmt GhcPs (LHsExpr GhcPs)
s) = LStmt GhcPs (LHsExpr GhcPs) -> SrcSpan
forall ast. Matchable ast => ast -> SrcSpan
getOrigin LStmt GhcPs (LHsExpr GhcPs)
s
getOrigin (ULType LHsType GhcPs
t) = LHsType GhcPs -> SrcSpan
forall ast. Matchable ast => ast -> SrcSpan
getOrigin LHsType GhcPs
t
getOrigin (ULPat Located (Pat GhcPs)
p) = Located (Pat GhcPs) -> SrcSpan
forall ast. Matchable ast => ast -> SrcSpan
getOrigin Located (Pat GhcPs)
p
instance Matchable (LHsExpr GhcPs) where
inject :: LHsExpr GhcPs -> Universe
inject = LHsExpr GhcPs -> Universe
ULHsExpr
project :: Universe -> LHsExpr GhcPs
project (ULHsExpr LHsExpr GhcPs
x) = LHsExpr GhcPs
x
project Universe
_ = String -> LHsExpr GhcPs
forall a. HasCallStack => String -> a
error String
"project LHsExpr"
getOrigin :: LHsExpr GhcPs -> SrcSpan
getOrigin LHsExpr GhcPs
e = LHsExpr GhcPs -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
getLoc LHsExpr GhcPs
e
instance Matchable (LStmt GhcPs (LHsExpr GhcPs)) where
inject :: LStmt GhcPs (LHsExpr GhcPs) -> Universe
inject = LStmt GhcPs (LHsExpr GhcPs) -> Universe
ULStmt
project :: Universe -> LStmt GhcPs (LHsExpr GhcPs)
project (ULStmt LStmt GhcPs (LHsExpr GhcPs)
x) = LStmt GhcPs (LHsExpr GhcPs)
x
project Universe
_ = String -> LStmt GhcPs (LHsExpr GhcPs)
forall a. HasCallStack => String -> a
error String
"project LStmt"
getOrigin :: LStmt GhcPs (LHsExpr GhcPs) -> SrcSpan
getOrigin LStmt GhcPs (LHsExpr GhcPs)
e = LStmt GhcPs (LHsExpr GhcPs) -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
getLoc LStmt GhcPs (LHsExpr GhcPs)
e
instance Matchable (LHsType GhcPs) where
inject :: LHsType GhcPs -> Universe
inject = LHsType GhcPs -> Universe
ULType
project :: Universe -> LHsType GhcPs
project (ULType LHsType GhcPs
t) = LHsType GhcPs
t
project Universe
_ = String -> LHsType GhcPs
forall a. HasCallStack => String -> a
error String
"project ULType"
getOrigin :: LHsType GhcPs -> SrcSpan
getOrigin LHsType GhcPs
e = LHsType GhcPs -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
getLoc LHsType GhcPs
e
instance Matchable (Located (Pat GhcPs)) where
inject :: Located (Pat GhcPs) -> Universe
inject = Located (Pat GhcPs) -> Universe
ULPat
project :: Universe -> Located (Pat GhcPs)
project (ULPat Located (Pat GhcPs)
p) = Located (Pat GhcPs)
p
project Universe
_ = String -> Located (Pat GhcPs)
forall a. HasCallStack => String -> a
error String
"project ULPat"
getOrigin :: Located (Pat GhcPs) -> SrcSpan
getOrigin = Located (Pat GhcPs) -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
getLoc
data UMap a = UMap
{ UMap a -> EMap a
umExpr :: EMap a
, UMap a -> SMap a
umStmt :: SMap a
, UMap a -> TyMap a
umType :: TyMap a
, UMap a -> PatMap a
umPat :: PatMap a
}
deriving (a -> UMap b -> UMap a
(a -> b) -> UMap a -> UMap b
(forall a b. (a -> b) -> UMap a -> UMap b)
-> (forall a b. a -> UMap b -> UMap a) -> Functor UMap
forall a b. a -> UMap b -> UMap a
forall a b. (a -> b) -> UMap a -> UMap b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> UMap b -> UMap a
$c<$ :: forall a b. a -> UMap b -> UMap a
fmap :: (a -> b) -> UMap a -> UMap b
$cfmap :: forall a b. (a -> b) -> UMap a -> UMap b
Functor)
instance PatternMap UMap where
type Key UMap = Universe
mEmpty :: UMap a
mEmpty :: UMap a
mEmpty = EMap a -> SMap a -> TyMap a -> PatMap a -> UMap a
forall a. EMap a -> SMap a -> TyMap a -> PatMap a -> UMap a
UMap EMap a
forall (m :: * -> *) a. PatternMap m => m a
mEmpty SMap a
forall (m :: * -> *) a. PatternMap m => m a
mEmpty TyMap a
forall (m :: * -> *) a. PatternMap m => m a
mEmpty PatMap a
forall (m :: * -> *) a. PatternMap m => m a
mEmpty
mUnion :: UMap a -> UMap a -> UMap a
mUnion :: UMap a -> UMap a -> UMap a
mUnion UMap a
m1 UMap a
m2 = EMap a -> SMap a -> TyMap a -> PatMap a -> UMap a
forall a. EMap a -> SMap a -> TyMap a -> PatMap a -> UMap a
UMap
((UMap a -> EMap a) -> UMap a -> UMap a -> EMap a
forall (m :: * -> *) a b.
PatternMap m =>
(a -> m b) -> a -> a -> m b
unionOn UMap a -> EMap a
forall a. UMap a -> EMap a
umExpr UMap a
m1 UMap a
m2)
((UMap a -> SMap a) -> UMap a -> UMap a -> SMap a
forall (m :: * -> *) a b.
PatternMap m =>
(a -> m b) -> a -> a -> m b
unionOn UMap a -> SMap a
forall a. UMap a -> SMap a
umStmt UMap a
m1 UMap a
m2)
((UMap a -> TyMap a) -> UMap a -> UMap a -> TyMap a
forall (m :: * -> *) a b.
PatternMap m =>
(a -> m b) -> a -> a -> m b
unionOn UMap a -> TyMap a
forall a. UMap a -> TyMap a
umType UMap a
m1 UMap a
m2)
((UMap a -> PatMap a) -> UMap a -> UMap a -> PatMap a
forall (m :: * -> *) a b.
PatternMap m =>
(a -> m b) -> a -> a -> m b
unionOn UMap a -> PatMap a
forall a. UMap a -> PatMap a
umPat UMap a
m1 UMap a
m2)
mAlter :: AlphaEnv -> Quantifiers -> Universe -> A a -> UMap a -> UMap a
mAlter :: AlphaEnv -> Quantifiers -> Universe -> A a -> UMap a -> UMap a
mAlter AlphaEnv
env Quantifiers
vs Universe
u A a
f UMap a
m = Universe -> UMap a
go Universe
u
where
go :: Universe -> UMap a
go (ULHsExpr LHsExpr GhcPs
e) = UMap a
m { umExpr :: EMap a
umExpr = AlphaEnv -> Quantifiers -> Key EMap -> A a -> EMap a -> EMap a
forall (m :: * -> *) a.
PatternMap m =>
AlphaEnv -> Quantifiers -> Key m -> A a -> m a -> m a
mAlter AlphaEnv
env Quantifiers
vs LHsExpr GhcPs
Key EMap
e A a
f (UMap a -> EMap a
forall a. UMap a -> EMap a
umExpr UMap a
m) }
go (ULStmt LStmt GhcPs (LHsExpr GhcPs)
s) = UMap a
m { umStmt :: SMap a
umStmt = AlphaEnv -> Quantifiers -> Key SMap -> A a -> SMap a -> SMap a
forall (m :: * -> *) a.
PatternMap m =>
AlphaEnv -> Quantifiers -> Key m -> A a -> m a -> m a
mAlter AlphaEnv
env Quantifiers
vs LStmt GhcPs (LHsExpr GhcPs)
Key SMap
s A a
f (UMap a -> SMap a
forall a. UMap a -> SMap a
umStmt UMap a
m) }
go (ULType LHsType GhcPs
t) = UMap a
m { umType :: TyMap a
umType = AlphaEnv -> Quantifiers -> Key TyMap -> A a -> TyMap a -> TyMap a
forall (m :: * -> *) a.
PatternMap m =>
AlphaEnv -> Quantifiers -> Key m -> A a -> m a -> m a
mAlter AlphaEnv
env Quantifiers
vs LHsType GhcPs
Key TyMap
t A a
f (UMap a -> TyMap a
forall a. UMap a -> TyMap a
umType UMap a
m) }
go (ULPat Located (Pat GhcPs)
p) = UMap a
m { umPat :: PatMap a
umPat = AlphaEnv
-> Quantifiers -> Key PatMap -> A a -> PatMap a -> PatMap a
forall (m :: * -> *) a.
PatternMap m =>
AlphaEnv -> Quantifiers -> Key m -> A a -> m a -> m a
mAlter AlphaEnv
env Quantifiers
vs (Located (Pat GhcPs) -> LPat GhcPs
forall (p :: Pass). Located (Pat (GhcPass p)) -> LPat (GhcPass p)
cLPat Located (Pat GhcPs)
p) A a
f (UMap a -> PatMap a
forall a. UMap a -> PatMap a
umPat UMap a
m) }
mMatch :: MatchEnv -> Universe -> (Substitution, UMap a) -> [(Substitution, a)]
mMatch :: MatchEnv
-> Universe -> (Substitution, UMap a) -> [(Substitution, a)]
mMatch MatchEnv
env = Universe -> (Substitution, UMap a) -> [(Substitution, a)]
go
where
go :: Universe -> (Substitution, UMap a) -> [(Substitution, a)]
go (ULHsExpr LHsExpr GhcPs
e) = (UMap a -> EMap a)
-> (Substitution, UMap a) -> [(Substitution, EMap a)]
forall b c a. (b -> c) -> (a, b) -> [(a, c)]
mapFor UMap a -> EMap a
forall a. UMap a -> EMap a
umExpr ((Substitution, UMap a) -> [(Substitution, EMap a)])
-> ((Substitution, EMap a) -> [(Substitution, a)])
-> (Substitution, UMap a)
-> [(Substitution, a)]
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> MatchEnv
-> Key EMap -> (Substitution, EMap a) -> [(Substitution, a)]
forall (m :: * -> *) a.
PatternMap m =>
MatchEnv -> Key m -> (Substitution, m a) -> [(Substitution, a)]
mMatch MatchEnv
env LHsExpr GhcPs
Key EMap
e
go (ULStmt LStmt GhcPs (LHsExpr GhcPs)
s) = (UMap a -> SMap a)
-> (Substitution, UMap a) -> [(Substitution, SMap a)]
forall b c a. (b -> c) -> (a, b) -> [(a, c)]
mapFor UMap a -> SMap a
forall a. UMap a -> SMap a
umStmt ((Substitution, UMap a) -> [(Substitution, SMap a)])
-> ((Substitution, SMap a) -> [(Substitution, a)])
-> (Substitution, UMap a)
-> [(Substitution, a)]
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> MatchEnv
-> Key SMap -> (Substitution, SMap a) -> [(Substitution, a)]
forall (m :: * -> *) a.
PatternMap m =>
MatchEnv -> Key m -> (Substitution, m a) -> [(Substitution, a)]
mMatch MatchEnv
env LStmt GhcPs (LHsExpr GhcPs)
Key SMap
s
go (ULType LHsType GhcPs
t) = (UMap a -> TyMap a)
-> (Substitution, UMap a) -> [(Substitution, TyMap a)]
forall b c a. (b -> c) -> (a, b) -> [(a, c)]
mapFor UMap a -> TyMap a
forall a. UMap a -> TyMap a
umType ((Substitution, UMap a) -> [(Substitution, TyMap a)])
-> ((Substitution, TyMap a) -> [(Substitution, a)])
-> (Substitution, UMap a)
-> [(Substitution, a)]
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> MatchEnv
-> Key TyMap -> (Substitution, TyMap a) -> [(Substitution, a)]
forall (m :: * -> *) a.
PatternMap m =>
MatchEnv -> Key m -> (Substitution, m a) -> [(Substitution, a)]
mMatch MatchEnv
env LHsType GhcPs
Key TyMap
t
go (ULPat Located (Pat GhcPs)
p) = (UMap a -> PatMap a)
-> (Substitution, UMap a) -> [(Substitution, PatMap a)]
forall b c a. (b -> c) -> (a, b) -> [(a, c)]
mapFor UMap a -> PatMap a
forall a. UMap a -> PatMap a
umPat ((Substitution, UMap a) -> [(Substitution, PatMap a)])
-> ((Substitution, PatMap a) -> [(Substitution, a)])
-> (Substitution, UMap a)
-> [(Substitution, a)]
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> MatchEnv
-> Key PatMap -> (Substitution, PatMap a) -> [(Substitution, a)]
forall (m :: * -> *) a.
PatternMap m =>
MatchEnv -> Key m -> (Substitution, m a) -> [(Substitution, a)]
mMatch MatchEnv
env (Located (Pat GhcPs) -> LPat GhcPs
forall (p :: Pass). Located (Pat (GhcPass p)) -> LPat (GhcPass p)
cLPat Located (Pat GhcPs)
p)