module SAI.Data.Generics.Shape.SYB.GHC (
#if 0
Stage(..) ,
#endif
ghom_Staged ,
ghomK_Staged ,
ghomP_Staged ,
ghomE_Staged ,
ghomDyn_Staged ,
ghomBi_Staged ,
shapeOf_Staged ,
shapeOf_Staged_ ,
sizeOf_Staged ,
symmorphic_Staged ,
weightedShapeOf_Staged ,
weightedShapeOf_Staged_ ,
) where
import Data.Data ( gfoldl )
import Data.Data ( gmapQ )
import Data.Data ( Data )
import Data.Data ( Typeable )
import Data.Generics.Aliases ( GenericQ )
#if USE_DATA_TREE
import SAI.Data.Generics.Shape.SYB ( Rose, Tree(Node) )
#else
import SAI.Data.Generics.Shape.SYB ( Rose(..) )
#endif
import SAI.Data.Generics.Shape.SYB ( Homo, Shape, Hetero, Bi )
import SAI.Data.Generics.Shape.SYB ( zipRose )
import SAI.Data.Generics.Shape.SYB ( HomoM )
import SAI.Data.Generics.Shape.SYB.Filter ( filterHomoMM )
import SAI.Data.Generics.Shape.SYB ( shapeOf )
import SAI.Data.Generics.Shape.SYB ( unliftHomoM )
import SAI.Data.Generics.Shape.SYB ( sizeOfRose )
import Data.Generics.Aliases ( mkQ )
import Data.Generics.Aliases ( extQ )
import qualified GHC as GHC
import qualified NameSet as GHC
import qualified FastString as GHC
import qualified Data.Generics as SYB
import Data.Dynamic
import qualified GHC.SYB.Utils as SYB
#if 0
data Stage = Parser | Renamer | TypeChecker deriving (Eq,Ord,Show)
newtype GHC_AST_HOLE = GHC_AST_HOLE Stage deriving ( Typeable )
#else
newtype GHC_AST_HOLE = GHC_AST_HOLE SYB.Stage deriving ( Typeable )
#endif
ghom_Staged :: forall r d. Data d =>
SYB.Stage
-> r
-> GenericQ r
-> d
-> Homo r
ghom_Staged stage z f x
| checkItemStage stage x = z'
| otherwise = foldl k b (gmapQ (ghom_Staged stage z f) x)
where
b = Node (f x) []
z' = Node z []
k (Node r chs) nod@(Node r' _) = Node r (chs++[nod])
ghomK_Staged :: forall r d. Data d =>
SYB.Stage
-> r
-> (r -> r -> r)
-> GenericQ r
-> d
-> Homo r
ghomK_Staged stage z k f x
| checkItemStage stage x = z'
| otherwise = foldl k' b (gmapQ (ghomK_Staged stage z k f) x)
where
b = Node (f x) []
z' = Node z []
k' (Node r chs) nod@(Node r' _) = Node (r `k` r') (chs++[nod])
ghomP_Staged :: forall r s d. Data d =>
SYB.Stage
-> r
-> GenericQ Bool
-> GenericQ r
-> d
-> Homo r
ghomP_Staged stage z p f x
| checkItemStage stage x = z'
| p x = Node (f x) []
| otherwise = foldl k b (gmapQ (ghomP_Staged stage z p f) x)
where
b = Node (f x) []
z' = Node z []
k (Node r chs) nod = Node r (chs++[nod])
ghomE_Staged :: forall r s d. Data d =>
SYB.Stage
-> r
-> GenericQ Bool
-> GenericQ r
-> GenericQ s
-> d
-> Homo (Either r s)
ghomE_Staged stage z p f f_stop x
| checkItemStage stage x = z'
| p x = Node (Right (f_stop x)) []
| otherwise = foldl k b (gmapQ (ghomE_Staged stage z p f f_stop) x)
where
b = Node (Left (f x)) []
z' = Node (Left z) []
k (Node r chs) nod = Node r (chs++[nod])
ghomDyn_Staged :: forall d. Data d => SYB.Stage -> d -> Hetero
ghomDyn_Staged stage x
| checkItemStage stage x = Node (toDyn $ GHC_AST_HOLE stage) []
| otherwise = foldl k b (gmapQ (ghomDyn_Staged stage) x)
where
b = Node (toDyn x) []
k (Node r chs) nod = Node r (chs++[nod])
ghomBi_Staged :: forall r d. Data d => SYB.Stage -> r -> GenericQ r -> d -> Bi r
ghomBi_Staged stage z f x = zipRose (ghomDyn_Staged stage x) $ ghom_Staged stage z f x
shapeOf_Staged :: forall d. Data d => SYB.Stage -> d -> Shape
shapeOf_Staged stage = ghom_Staged stage () (const ())
shapeOf_Staged_ :: forall d. Data d => SYB.Stage -> d -> Shape
shapeOf_Staged_ stage x = ghomP_Staged stage () pg fg x
where
pg :: forall d'. Data d' => d' -> Bool
pg = mkQ False p_String `extQ` p_FastString
p_String :: String -> Bool
p_String _ = True
p_FastString :: GHC.FastString -> Bool
p_FastString _ = True
fg :: forall d''. Data d'' => d'' -> ()
fg = const ()
sizeOf_Staged :: forall d. Data d => SYB.Stage -> d -> Int
sizeOf_Staged stage = sizeOfRose . (shapeOf_Staged stage)
weightedShapeOf_Staged :: forall d. Data d => SYB.Stage -> d -> Homo Int
weightedShapeOf_Staged stage = ghomK_Staged stage 1 (+) (const 1)
weightedShapeOf_Staged_ :: forall d. Data d => SYB.Stage -> d -> Homo Int
weightedShapeOf_Staged_ stage x = weightedRoseSpecial $ ghomP_Staged stage 1 pg fg x
where
pg :: forall d'. Data d' => d' -> Bool
pg = mkQ False p_String `extQ` p_FastString
p_String :: String -> Bool
p_String _ = True
p_FastString :: GHC.FastString -> Bool
p_FastString _ = True
fg :: forall d''. Data d'' => d'' -> Int
fg = mkQ 1 f_String `extQ` f_FastString
f_String :: String -> Int
f_String x = length x
f_FastString :: GHC.FastString -> Int
f_FastString x = GHC.lengthFS x
weightedRoseSpecial :: Rose Int -> Rose Int
weightedRoseSpecial (Node r chs) = foldl k' b (map weightedRoseSpecial chs)
where
b = Node r []
k' (Node rw chs) nod@(Node rw' _) = Node (rw + rw') (chs++[nod])
checkItemStage :: (Typeable a, Data a) => SYB.Stage -> a -> Bool
checkItemStage stage x = (checkItemStage1 stage x)
#if __GLASGOW_HASKELL__ > 704
|| (checkItemStage2 stage x)
#endif
checkItemStage1 :: (Typeable a) => SYB.Stage -> a -> Bool
checkItemStage1 stage x = (const False `SYB.extQ` postTcType `SYB.extQ` fixity `SYB.extQ` nameSet) x
where nameSet = const (stage `elem` [SYB.Parser,SYB.TypeChecker]) :: GHC.NameSet -> Bool
postTcType = const (stage < SYB.TypeChecker ) :: GHC.PostTcType -> Bool
fixity = const (stage < SYB.Renamer ) :: GHC.Fixity -> Bool
#if __GLASGOW_HASKELL__ > 704
checkItemStage2 :: Data a => SYB.Stage -> a -> Bool
checkItemStage2 stage x = (const False `SYB.ext1Q` hsWithBndrs) x
where
hsWithBndrs = const (stage < SYB.Renamer) :: GHC.HsWithBndrs a -> Bool
#endif
#if 0
checkItemRenamer :: (Data a, Typeable a) => a -> Bool
checkItemRenamer x = checkItemStage Renamer x
#endif
symmorphic_Staged :: forall d1 d2. (Data d1,Data d2) =>
SYB.Stage -> d1 -> d2 -> Bool
symmorphic_Staged stage x y = shapeOf_Staged stage x == shapeOf_Staged stage y