-- 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 RankNTypes #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
module Retrie.Rewrites.Types where

import Control.Monad
import Data.Maybe

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

typeSynonymsToRewrites
  :: [(FastString, Direction)]
  -> AnnotatedModule
#if __GLASGOW_HASKELL__ < 900
  -> IO (UniqFM [Rewrite (LHsType GhcPs)])
#else
  -> IO (UniqFM FastString [Rewrite (LHsType GhcPs)])
#endif
typeSynonymsToRewrites :: [(FastString, Direction)]
-> AnnotatedModule
-> IO (UniqFM FastString [Rewrite (LHsType GhcPs)])
typeSynonymsToRewrites [(FastString, 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 FastString [Direction]
fsMap = forall a b. Uniquable a => [(a, b)] -> UniqFM a [b]
uniqBag [(FastString, Direction)]
specs
    tySyns :: [(FastString,
  (Direction,
   (GenLocated SrcSpanAnnN RdrName,
    [GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs)],
    GenLocated SrcSpanAnnA (HsType GhcPs))))]
tySyns =
      [ (FastString
rdr, (Direction
dir, (LIdP GhcPs
nm, forall pass. LHsQTyVars pass -> [LHsTyVarBndr () pass]
hsq_explicit LHsQTyVars GhcPs
vars, LHsType GhcPs
rhs)))
        -- only hsq_explicit is available pre-renaming
      | L SrcSpanAnnA
_ (TyClD XTyClD GhcPs
_ (SynDecl XSynDecl GhcPs
_ LIdP GhcPs
nm LHsQTyVars GhcPs
vars LexicalFixity
_ LHsType GhcPs
rhs)) <- HsModule -> [LHsDecl GhcPs]
hsmodDecls forall a b. (a -> b) -> a -> b
$ forall l e. GenLocated l e -> e
unLoc Located HsModule
m
      , let rdr :: FastString
rdr = RdrName -> FastString
rdrFS (forall l e. GenLocated l e -> e
unLoc LIdP GhcPs
nm)
      , Direction
dir <- forall a. a -> Maybe a -> a
fromMaybe [] (forall key elt. Uniquable key => UniqFM key elt -> key -> Maybe elt
lookupUFM UniqFM FastString [Direction]
fsMap FastString
rdr)
      ]
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. Uniquable a => [(a, b)] -> UniqFM a [b]
uniqBag forall a b. (a -> b) -> a -> b
$
    forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(FastString,
  (Direction,
   (GenLocated SrcSpanAnnN RdrName,
    [GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs)],
    GenLocated SrcSpanAnnA (HsType GhcPs))))]
tySyns forall a b. (a -> b) -> a -> b
$ \(FastString
rdr, (Direction,
 (GenLocated SrcSpanAnnN RdrName,
  [GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs)],
  GenLocated SrcSpanAnnA (HsType GhcPs)))
args) -> (FastString
rdr,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Direction
-> (GenLocated SrcSpanAnnN RdrName, [LHsTyVarBndr () GhcPs],
    LHsType GhcPs)
-> TransformT IO (Rewrite (LHsType GhcPs))
mkTypeRewrite (Direction,
 (GenLocated SrcSpanAnnN RdrName,
  [GenLocated SrcSpanAnnA (HsTyVarBndr () GhcPs)],
  GenLocated SrcSpanAnnA (HsType GhcPs)))
args

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

-- | Compile a list of RULES into a list of rewrites.
mkTypeRewrite
  :: Direction
  -> (LocatedN RdrName, [LHsTyVarBndr () GhcPs], LHsType GhcPs)
  -> TransformT IO (Rewrite (LHsType GhcPs))
mkTypeRewrite :: Direction
-> (GenLocated SrcSpanAnnN RdrName, [LHsTyVarBndr () GhcPs],
    LHsType GhcPs)
-> TransformT IO (Rewrite (LHsType GhcPs))
mkTypeRewrite Direction
d (GenLocated SrcSpanAnnN RdrName
lhsName, [LHsTyVarBndr () GhcPs]
vars, LHsType GhcPs
rhs) = do
  let lhsName' :: GenLocated SrcSpanAnnN RdrName
lhsName' = forall t a. Default t => LocatedAn t a -> DeltaPos -> LocatedAn t a
setEntryDP GenLocated SrcSpanAnnN RdrName
lhsName (Int -> DeltaPos
SameLine Int
0)
  GenLocated SrcSpanAnnA (HsType GhcPs)
tc <- forall (m :: * -> *).
Monad m =>
GenLocated SrcSpanAnnN RdrName -> TransformT m (LHsType GhcPs)
mkTyVar GenLocated SrcSpanAnnN RdrName
lhsName'
  let
    lvs :: [GenLocated SrcSpanAnnN RdrName]
lvs = forall s.
[LHsTyVarBndr s GhcPs] -> [GenLocated SrcSpanAnnN RdrName]
tyBindersToLocatedRdrNames [LHsTyVarBndr () GhcPs]
vars
  [GenLocated SrcSpanAnnA (HsType GhcPs)]
args <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [GenLocated SrcSpanAnnN RdrName]
lvs forall a b. (a -> b) -> a -> b
$ \ GenLocated SrcSpanAnnN RdrName
lv -> do
    GenLocated SrcSpanAnnA (HsType GhcPs)
tv <- forall (m :: * -> *).
Monad m =>
GenLocated SrcSpanAnnN RdrName -> TransformT m (LHsType GhcPs)
mkTyVar GenLocated SrcSpanAnnN RdrName
lv
    let tv' :: GenLocated SrcSpanAnnA (HsType GhcPs)
tv' = forall t a. Default t => LocatedAn t a -> DeltaPos -> LocatedAn t a
setEntryDP GenLocated SrcSpanAnnA (HsType GhcPs)
tv (Int -> DeltaPos
SameLine Int
1)
    forall (m :: * -> *) a. Monad m => a -> m a
return GenLocated SrcSpanAnnA (HsType GhcPs)
tv'
  GenLocated SrcSpanAnnA (HsType GhcPs)
lhsApps <- forall (m :: * -> *).
Monad m =>
[LHsType GhcPs] -> TransformT m (LHsType GhcPs)
mkHsAppsTy (GenLocated SrcSpanAnnA (HsType GhcPs)
tcforall a. a -> [a] -> [a]
:[GenLocated SrcSpanAnnA (HsType GhcPs)]
args)
  let
    (GenLocated SrcSpanAnnA (HsType GhcPs)
pat, GenLocated SrcSpanAnnA (HsType GhcPs)
tmp) = case Direction
d of
      Direction
LeftToRight -> (GenLocated SrcSpanAnnA (HsType GhcPs)
lhsApps, LHsType GhcPs
rhs)
      Direction
RightToLeft -> (LHsType GhcPs
rhs, GenLocated SrcSpanAnnA (HsType GhcPs)
lhsApps)
  Annotated (GenLocated SrcSpanAnnA (HsType GhcPs))
p <- forall ast (m :: * -> *).
(Data ast, Monad m) =>
ast -> TransformT m (Annotated ast)
pruneA GenLocated SrcSpanAnnA (HsType GhcPs)
pat
  Annotated (GenLocated SrcSpanAnnA (HsType GhcPs))
t <- forall ast (m :: * -> *).
(Data ast, Monad m) =>
ast -> TransformT m (Annotated ast)
pruneA GenLocated SrcSpanAnnA (HsType GhcPs)
tmp
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall ast.
Quantifiers -> Annotated ast -> Annotated ast -> Rewrite ast
mkRewrite ([RdrName] -> Quantifiers
mkQs forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall l e. GenLocated l e -> e
unLoc [GenLocated SrcSpanAnnN RdrName]
lvs) Annotated (GenLocated SrcSpanAnnA (HsType GhcPs))
p Annotated (GenLocated SrcSpanAnnA (HsType GhcPs))
t