-- 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
import Retrie.Util
import Retrie.Monad
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Trans.Class

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

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

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

mkRuleRewrite
  :: Direction
  -> RuleInfo
  -> TransformT IO (RuleName, Rewrite (LHsExpr GhcPs))
mkRuleRewrite :: Direction
-> RuleInfo -> TransformT IO (RuleName, Rewrite (LHsExpr GhcPs))
mkRuleRewrite Direction
RightToLeft (RuleInfo RuleName
name [RdrName]
qs LHsExpr GhcPs
lhs LHsExpr GhcPs
rhs) =
  Direction
-> RuleInfo -> TransformT IO (RuleName, Rewrite (LHsExpr GhcPs))
mkRuleRewrite Direction
LeftToRight (RuleName -> [RdrName] -> LHsExpr GhcPs -> LHsExpr GhcPs -> RuleInfo
RuleInfo RuleName
name [RdrName]
qs LHsExpr GhcPs
rhs LHsExpr GhcPs
lhs)
mkRuleRewrite Direction
_ RuleInfo{[RdrName]
LHsExpr GhcPs
RuleName
riRHS :: LHsExpr GhcPs
riLHS :: LHsExpr GhcPs
riQuantifiers :: [RdrName]
riName :: RuleName
riRHS :: RuleInfo -> LHsExpr GhcPs
riLHS :: RuleInfo -> LHsExpr GhcPs
riQuantifiers :: RuleInfo -> [RdrName]
riName :: RuleInfo -> RuleName
..} = do
  Annotated (LocatedAn AnnListItem (HsExpr GhcPs))
p <- forall ast (m :: * -> *).
(Data ast, Monad m) =>
ast -> TransformT m (Annotated ast)
pruneA (forall t a. Default t => LocatedAn t a -> DeltaPos -> LocatedAn t a
setEntryDP LHsExpr GhcPs
riLHS (Int -> DeltaPos
SameLine Int
1))
  Annotated (LocatedAn AnnListItem (HsExpr GhcPs))
t <- forall ast (m :: * -> *).
(Data ast, Monad m) =>
ast -> TransformT m (Annotated ast)
pruneA (forall t a. Default t => LocatedAn t a -> DeltaPos -> LocatedAn t a
setEntryDP LHsExpr GhcPs
riRHS (Int -> DeltaPos
SameLine Int
1))
  -- lift $ debugPrint Loud "mkRuleRewrite" [showAstA p, showAstA t]
  forall (m :: * -> *) a. Monad m => a -> m a
return (RuleName
riName, forall ast.
Quantifiers -> Annotated ast -> Annotated ast -> Rewrite ast
mkRewrite ([RdrName] -> Quantifiers
mkQs [RdrName]
riQuantifiers) Annotated (LocatedAn AnnListItem (HsExpr GhcPs))
p Annotated (LocatedAn AnnListItem (HsExpr GhcPs))
t)