-- 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 = (Annotated
   (UniqFM RuleName [Rewrite (LocatedAn AnnListItem (HsExpr GhcPs))])
 -> UniqFM RuleName [Rewrite (LHsExpr GhcPs)])
-> IO
     (Annotated
        (UniqFM RuleName [Rewrite (LocatedAn AnnListItem (HsExpr GhcPs))]))
-> IO (UniqFM RuleName [Rewrite (LHsExpr GhcPs)])
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Annotated
  (UniqFM RuleName [Rewrite (LocatedAn AnnListItem (HsExpr GhcPs))])
-> UniqFM RuleName [Rewrite (LHsExpr GhcPs)]
Annotated
  (UniqFM RuleName [Rewrite (LocatedAn AnnListItem (HsExpr GhcPs))])
-> UniqFM RuleName [Rewrite (LocatedAn AnnListItem (HsExpr GhcPs))]
forall ast. Annotated ast -> ast
astA (IO
   (Annotated
      (UniqFM RuleName [Rewrite (LocatedAn AnnListItem (HsExpr GhcPs))]))
 -> IO (UniqFM RuleName [Rewrite (LHsExpr GhcPs)]))
-> IO
     (Annotated
        (UniqFM RuleName [Rewrite (LocatedAn AnnListItem (HsExpr GhcPs))]))
-> IO (UniqFM RuleName [Rewrite (LHsExpr GhcPs)])
forall a b. (a -> b) -> a -> b
$ AnnotatedModule
-> (Located (HsModule GhcPs)
    -> TransformT
         IO
         (UniqFM RuleName [Rewrite (LocatedAn AnnListItem (HsExpr GhcPs))]))
-> IO
     (Annotated
        (UniqFM RuleName [Rewrite (LocatedAn AnnListItem (HsExpr GhcPs))]))
forall (m :: * -> *) ast1 ast2.
Monad m =>
Annotated ast1 -> (ast1 -> TransformT m ast2) -> m (Annotated ast2)
transformA AnnotatedModule
am ((Located (HsModule GhcPs)
  -> TransformT
       IO
       (UniqFM RuleName [Rewrite (LocatedAn AnnListItem (HsExpr GhcPs))]))
 -> IO
      (Annotated
         (UniqFM
            RuleName [Rewrite (LocatedAn AnnListItem (HsExpr GhcPs))])))
-> (Located (HsModule GhcPs)
    -> TransformT
         IO
         (UniqFM RuleName [Rewrite (LocatedAn AnnListItem (HsExpr GhcPs))]))
-> IO
     (Annotated
        (UniqFM RuleName [Rewrite (LocatedAn AnnListItem (HsExpr GhcPs))]))
forall a b. (a -> b) -> a -> b
$ \ Located (HsModule GhcPs)
m -> do
  let
    fsMap :: UniqFM RuleName [Direction]
fsMap = [(RuleName, Direction)] -> UniqFM RuleName [Direction]
forall a b. Uniquable a => [(a, b)] -> UniqFM a [b]
uniqBag [(RuleName, Direction)]
specs

  [(RuleName, Rewrite (LocatedAn AnnListItem (HsExpr GhcPs)))]
-> UniqFM RuleName [Rewrite (LocatedAn AnnListItem (HsExpr GhcPs))]
forall a b. Uniquable a => [(a, b)] -> UniqFM a [b]
uniqBag ([(RuleName, Rewrite (LocatedAn AnnListItem (HsExpr GhcPs)))]
 -> UniqFM
      RuleName [Rewrite (LocatedAn AnnListItem (HsExpr GhcPs))])
-> TransformT
     IO [(RuleName, Rewrite (LocatedAn AnnListItem (HsExpr GhcPs)))]
-> TransformT
     IO
     (UniqFM RuleName [Rewrite (LocatedAn AnnListItem (HsExpr GhcPs))])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TransformT
   IO (RuleName, Rewrite (LocatedAn AnnListItem (HsExpr GhcPs)))]
-> TransformT
     IO [(RuleName, Rewrite (LocatedAn AnnListItem (HsExpr GhcPs)))]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence
    [ Direction
-> RuleInfo -> TransformT IO (RuleName, Rewrite (LHsExpr GhcPs))
mkRuleRewrite Direction
dir RuleInfo
info
    | info :: RuleInfo
info@RuleInfo{[RdrName]
RuleName
LHsExpr GhcPs
riName :: RuleName
riQuantifiers :: [RdrName]
riLHS :: LHsExpr GhcPs
riRHS :: LHsExpr GhcPs
riName :: RuleInfo -> RuleName
riQuantifiers :: RuleInfo -> [RdrName]
riLHS :: RuleInfo -> LHsExpr GhcPs
riRHS :: RuleInfo -> LHsExpr GhcPs
..} <- ([RuleInfo] -> [RuleInfo] -> [RuleInfo])
-> GenericQ [RuleInfo] -> GenericQ [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 GhcPs)
m
    , Direction
dir <- [Direction] -> Maybe [Direction] -> [Direction]
forall a. a -> Maybe a -> a
fromMaybe [] (UniqFM RuleName [Direction] -> RuleName -> Maybe [Direction]
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]
RuleName
LHsExpr GhcPs
riName :: RuleInfo -> RuleName
riQuantifiers :: RuleInfo -> [RdrName]
riLHS :: RuleInfo -> LHsExpr GhcPs
riRHS :: RuleInfo -> LHsExpr GhcPs
riName :: RuleName
riQuantifiers :: [RdrName]
riLHS :: LHsExpr GhcPs
riRHS :: LHsExpr GhcPs
..} = do
  Annotated (LocatedAn AnnListItem (HsExpr GhcPs))
p <- LocatedAn AnnListItem (HsExpr GhcPs)
-> TransformT IO (Annotated (LocatedAn AnnListItem (HsExpr GhcPs)))
forall ast (m :: * -> *).
(Data ast, Monad m) =>
ast -> TransformT m (Annotated ast)
pruneA (LocatedAn AnnListItem (HsExpr GhcPs)
-> DeltaPos -> LocatedAn AnnListItem (HsExpr GhcPs)
forall t a. Default t => LocatedAn t a -> DeltaPos -> LocatedAn t a
setEntryDP LHsExpr GhcPs
LocatedAn AnnListItem (HsExpr GhcPs)
riLHS (Int -> DeltaPos
SameLine Int
1))
  Annotated (LocatedAn AnnListItem (HsExpr GhcPs))
t <- LocatedAn AnnListItem (HsExpr GhcPs)
-> TransformT IO (Annotated (LocatedAn AnnListItem (HsExpr GhcPs)))
forall ast (m :: * -> *).
(Data ast, Monad m) =>
ast -> TransformT m (Annotated ast)
pruneA (LocatedAn AnnListItem (HsExpr GhcPs)
-> DeltaPos -> LocatedAn AnnListItem (HsExpr GhcPs)
forall t a. Default t => LocatedAn t a -> DeltaPos -> LocatedAn t a
setEntryDP LHsExpr GhcPs
LocatedAn AnnListItem (HsExpr GhcPs)
riRHS (Int -> DeltaPos
SameLine Int
1))
  -- lift $ debugPrint Loud "mkRuleRewrite" [showAstA p, showAstA t]
  (RuleName, Rewrite (LocatedAn AnnListItem (HsExpr GhcPs)))
-> TransformT
     IO (RuleName, Rewrite (LocatedAn AnnListItem (HsExpr GhcPs)))
forall a. a -> TransformT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (RuleName
riName, Quantifiers
-> Annotated (LocatedAn AnnListItem (HsExpr GhcPs))
-> Annotated (LocatedAn AnnListItem (HsExpr GhcPs))
-> Rewrite (LocatedAn AnnListItem (HsExpr GhcPs))
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)