-- Copyright (c) Facebook, Inc. and its affiliates.
--
-- This source code is licensed under the MIT license found in the
-- LICENSE file in the root directory of this source tree.
--
{-# LANGUAGE CPP #-}
{-# LANGUAGE RecordWildCards #-}
module Retrie.Rewrites.Rules (rulesToRewrites) where

import Data.Generics
import Data.Maybe

import Retrie.ExactPrint
import Retrie.GHC
import Retrie.Quantifiers
import Retrie.Types

rulesToRewrites
  :: [(FastString, Direction)]
  -> AnnotatedModule
#if __GLASGOW_HASKELL__ < 900
  -> IO (UniqFM [Rewrite (LHsExpr GhcPs)])
#else
  -> IO (UniqFM RuleName [Rewrite (LHsExpr GhcPs)])
#endif
rulesToRewrites :: [(FastString, Direction)]
-> AnnotatedModule -> IO (UniqFM [Rewrite (LHsExpr GhcPs)])
rulesToRewrites [(FastString, Direction)]
specs AnnotatedModule
am = (Annotated (UniqFM [Rewrite (LHsExpr GhcPs)])
 -> UniqFM [Rewrite (LHsExpr GhcPs)])
-> IO (Annotated (UniqFM [Rewrite (LHsExpr GhcPs)]))
-> IO (UniqFM [Rewrite (LHsExpr GhcPs)])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Annotated (UniqFM [Rewrite (LHsExpr GhcPs)])
-> UniqFM [Rewrite (LHsExpr GhcPs)]
forall ast. Annotated ast -> ast
astA (IO (Annotated (UniqFM [Rewrite (LHsExpr GhcPs)]))
 -> IO (UniqFM [Rewrite (LHsExpr GhcPs)]))
-> IO (Annotated (UniqFM [Rewrite (LHsExpr GhcPs)]))
-> IO (UniqFM [Rewrite (LHsExpr GhcPs)])
forall a b. (a -> b) -> a -> b
$ AnnotatedModule
-> (Located HsModule
    -> TransformT IO (UniqFM [Rewrite (LHsExpr GhcPs)]))
-> IO (Annotated (UniqFM [Rewrite (LHsExpr GhcPs)]))
forall (m :: * -> *) ast1 ast2.
Monad m =>
Annotated ast1 -> (ast1 -> TransformT m ast2) -> m (Annotated ast2)
transformA AnnotatedModule
am ((Located HsModule
  -> TransformT IO (UniqFM [Rewrite (LHsExpr GhcPs)]))
 -> IO (Annotated (UniqFM [Rewrite (LHsExpr GhcPs)])))
-> (Located HsModule
    -> TransformT IO (UniqFM [Rewrite (LHsExpr GhcPs)]))
-> IO (Annotated (UniqFM [Rewrite (LHsExpr GhcPs)]))
forall a b. (a -> b) -> a -> b
$ \ Located HsModule
m -> do
  let
    fsMap :: UniqFM [Direction]
fsMap = [(FastString, Direction)] -> UniqFM [Direction]
forall a b. Uniquable a => [(a, b)] -> UniqFM [b]
uniqBag [(FastString, Direction)]
specs

  [(FastString, Rewrite (LHsExpr GhcPs))]
-> UniqFM [Rewrite (LHsExpr GhcPs)]
forall a b. Uniquable a => [(a, b)] -> UniqFM [b]
uniqBag ([(FastString, Rewrite (LHsExpr GhcPs))]
 -> UniqFM [Rewrite (LHsExpr GhcPs)])
-> TransformT IO [(FastString, Rewrite (LHsExpr GhcPs))]
-> TransformT IO (UniqFM [Rewrite (LHsExpr GhcPs)])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TransformT IO (FastString, Rewrite (LHsExpr GhcPs))]
-> TransformT IO [(FastString, Rewrite (LHsExpr GhcPs))]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence
    [ Direction
-> RuleInfo -> TransformT IO (FastString, Rewrite (LHsExpr GhcPs))
mkRuleRewrite Direction
dir RuleInfo
info
    | info :: RuleInfo
info@RuleInfo{[RdrName]
LHsExpr GhcPs
FastString
riRHS :: RuleInfo -> LHsExpr GhcPs
riLHS :: RuleInfo -> LHsExpr GhcPs
riQuantifiers :: RuleInfo -> [RdrName]
riName :: RuleInfo -> FastString
riRHS :: LHsExpr GhcPs
riLHS :: LHsExpr GhcPs
riQuantifiers :: [RdrName]
riName :: FastString
..} <- ([RuleInfo] -> [RuleInfo] -> [RuleInfo])
-> GenericQ [RuleInfo] -> Located HsModule -> [RuleInfo]
forall r. (r -> r -> r) -> GenericQ r -> GenericQ r
everything [RuleInfo] -> [RuleInfo] -> [RuleInfo]
forall a. [a] -> [a] -> [a]
(++) ([RuleInfo] -> (RuleDecl GhcPs -> [RuleInfo]) -> a -> [RuleInfo]
forall a b r. (Typeable a, Typeable b) => r -> (b -> r) -> a -> r
mkQ [] RuleDecl GhcPs -> [RuleInfo]
ruleInfo) Located HsModule
m
    , Direction
dir <- [Direction] -> Maybe [Direction] -> [Direction]
forall a. a -> Maybe a -> a
fromMaybe [] (UniqFM [Direction] -> FastString -> Maybe [Direction]
forall key elt. Uniquable key => UniqFM elt -> key -> Maybe elt
lookupUFM UniqFM [Direction]
fsMap FastString
riName)
    ]

------------------------------------------------------------------------

mkRuleRewrite
  :: Direction
  -> RuleInfo
  -> TransformT IO (RuleName, Rewrite (LHsExpr GhcPs))
mkRuleRewrite :: Direction
-> RuleInfo -> TransformT IO (FastString, Rewrite (LHsExpr GhcPs))
mkRuleRewrite Direction
RightToLeft (RuleInfo FastString
name [RdrName]
qs LHsExpr GhcPs
lhs LHsExpr GhcPs
rhs) =
  Direction
-> RuleInfo -> TransformT IO (FastString, Rewrite (LHsExpr GhcPs))
mkRuleRewrite Direction
LeftToRight (FastString
-> [RdrName] -> LHsExpr GhcPs -> LHsExpr GhcPs -> RuleInfo
RuleInfo FastString
name [RdrName]
qs LHsExpr GhcPs
rhs LHsExpr GhcPs
lhs)
mkRuleRewrite Direction
_ RuleInfo{[RdrName]
LHsExpr GhcPs
FastString
riRHS :: LHsExpr GhcPs
riLHS :: LHsExpr GhcPs
riQuantifiers :: [RdrName]
riName :: FastString
riRHS :: RuleInfo -> LHsExpr GhcPs
riLHS :: RuleInfo -> LHsExpr GhcPs
riQuantifiers :: RuleInfo -> [RdrName]
riName :: RuleInfo -> FastString
..} = do
  Annotated (LHsExpr GhcPs)
p <- LHsExpr GhcPs -> TransformT IO (Annotated (LHsExpr GhcPs))
forall ast (m :: * -> *).
(Data ast, Monad m) =>
ast -> TransformT m (Annotated ast)
pruneA LHsExpr GhcPs
riLHS
  Annotated (LHsExpr GhcPs)
t <- LHsExpr GhcPs -> TransformT IO (Annotated (LHsExpr GhcPs))
forall ast (m :: * -> *).
(Data ast, Monad m) =>
ast -> TransformT m (Annotated ast)
pruneA LHsExpr GhcPs
riRHS
  (FastString, Rewrite (LHsExpr GhcPs))
-> TransformT IO (FastString, Rewrite (LHsExpr GhcPs))
forall (m :: * -> *) a. Monad m => a -> m a
return (FastString
riName, Quantifiers
-> Annotated (LHsExpr GhcPs)
-> Annotated (LHsExpr GhcPs)
-> Rewrite (LHsExpr GhcPs)
forall ast.
Quantifiers -> Annotated ast -> Annotated ast -> Rewrite ast
mkRewrite ([RdrName] -> Quantifiers
mkQs [RdrName]
riQuantifiers) Annotated (LHsExpr GhcPs)
p Annotated (LHsExpr GhcPs)
t)