{-# LANGUAGE RecordWildCards #-}
-- 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 OverloadedStrings #-}
module Retrie.Rewrites
  ( RewriteSpec(..)
  , QualifiedName
  , parseRewriteSpecs
  , parseQualified
  , parseAdhocs
  ) where

import Control.Exception
import qualified Data.Map as Map
import Data.Maybe
import Data.Data hiding (Fixity)
import qualified Data.Text as Text
import Data.Traversable
import System.FilePath

import Retrie.CPP
import Retrie.ExactPrint
import Retrie.Fixity
#if __GLASGOW_HASKELL__ < 904
import Retrie.GHC
#else
import Retrie.GHC hiding (Pattern)
#endif
import Retrie.Rewrites.Function
import Retrie.Rewrites.Patterns
import Retrie.Rewrites.Rules
import Retrie.Rewrites.Types
import Retrie.Types
import Retrie.Universe
import Retrie.Util

-- | A qualified name. (e.g. @"Module.Name.functionName"@)
type QualifiedName = String

-- | Possible ways to specify rewrites to 'parseRewrites'.
data RewriteSpec
  = Adhoc String
    -- ^ Equation in RULES-format. (e.g. @"forall x. succ (pred x) = x"@)
    -- Will be applied left-to-right.
  | AdhocPattern String
    -- ^ Equation in pattern-synonym format, _without_ the keyword 'pattern'.
  | AdhocType String
    -- ^ Equation in type-synonym format, _without_ the keyword 'type'.
  | Fold QualifiedName
    -- ^ Fold a function definition. The inverse of unfolding/inlining.
    -- Replaces instances of the function body with calls to the function.
  | RuleBackward QualifiedName
    -- ^ Apply a GHC RULE right-to-left.
  | RuleForward QualifiedName
    -- ^ Apply a GHC RULE left-to-right.
  | TypeBackward QualifiedName
    -- ^ Apply a type synonym right-to-left.
  | TypeForward QualifiedName
    -- ^ Apply a type synonym left-to-right.
  | Unfold QualifiedName
    -- ^ Unfold, or inline, a function definition.
  | PatternForward QualifiedName
    -- ^ Unfold a pattern synonym
  | PatternBackward QualifiedName
    -- ^ Fold a pattern synonym, replacing instances of the rhs with the synonym


data ClassifiedRewrites = ClassifiedRewrites
  { ClassifiedRewrites -> [String]
adhocRules :: [String]
  , ClassifiedRewrites -> [String]
adhocPatterns :: [String]
  , ClassifiedRewrites -> [String]
adhocTypes :: [String]
  , ClassifiedRewrites
-> [(String, [(FileBasedTy, [(FastString, Direction)])])]
fileBased :: [(FilePath, [(FileBasedTy,[(FastString, Direction)])])]
  }

instance Monoid ClassifiedRewrites where
  mempty :: ClassifiedRewrites
mempty = [String]
-> [String]
-> [String]
-> [(String, [(FileBasedTy, [(FastString, Direction)])])]
-> ClassifiedRewrites
ClassifiedRewrites [] [] [] []

instance Semigroup ClassifiedRewrites where
  ClassifiedRewrites [String]
a [String]
b [String]
c [(String, [(FileBasedTy, [(FastString, Direction)])])]
d <> :: ClassifiedRewrites -> ClassifiedRewrites -> ClassifiedRewrites
<> ClassifiedRewrites [String]
a' [String]
b' [String]
c' [(String, [(FileBasedTy, [(FastString, Direction)])])]
d' =
    [String]
-> [String]
-> [String]
-> [(String, [(FileBasedTy, [(FastString, Direction)])])]
-> ClassifiedRewrites
ClassifiedRewrites ([String]
a forall a. Semigroup a => a -> a -> a
<> [String]
a') ([String]
b forall a. Semigroup a => a -> a -> a
<> [String]
b') ([String]
c forall a. Semigroup a => a -> a -> a
<> [String]
c') ([(String, [(FileBasedTy, [(FastString, Direction)])])]
d forall a. Semigroup a => a -> a -> a
<> [(String, [(FileBasedTy, [(FastString, Direction)])])]
d')

parseRewriteSpecs
  :: LibDir
  -> (FilePath -> IO (CPP AnnotatedModule))
  -> FixityEnv
  -> [RewriteSpec]
  -> IO [Rewrite Universe]
parseRewriteSpecs :: String
-> (String -> IO (CPP AnnotatedModule))
-> FixityEnv
-> [RewriteSpec]
-> IO [Rewrite Universe]
parseRewriteSpecs String
libdir String -> IO (CPP AnnotatedModule)
parser FixityEnv
fixityEnv [RewriteSpec]
specs = do
  ClassifiedRewrites{[String]
[(String, [(FileBasedTy, [(FastString, Direction)])])]
fileBased :: [(String, [(FileBasedTy, [(FastString, Direction)])])]
adhocTypes :: [String]
adhocPatterns :: [String]
adhocRules :: [String]
fileBased :: ClassifiedRewrites
-> [(String, [(FileBasedTy, [(FastString, Direction)])])]
adhocTypes :: ClassifiedRewrites -> [String]
adhocPatterns :: ClassifiedRewrites -> [String]
adhocRules :: ClassifiedRewrites -> [String]
..} <- forall a. Monoid a => [a] -> a
mconcat 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
    [ case RewriteSpec
spec of
        Adhoc String
rule -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Monoid a => a
mempty{adhocRules :: [String]
adhocRules = [String
rule]}
        AdhocPattern String
pSyn -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Monoid a => a
mempty{adhocPatterns :: [String]
adhocPatterns = [String
pSyn]}
        AdhocType String
tySyn -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Monoid a => a
mempty{adhocTypes :: [String]
adhocTypes = [String
tySyn]}
        Fold String
name -> FileBasedTy -> Direction -> String -> IO ClassifiedRewrites
mkFileBased FileBasedTy
FoldUnfold Direction
RightToLeft String
name
        RuleBackward String
name -> FileBasedTy -> Direction -> String -> IO ClassifiedRewrites
mkFileBased FileBasedTy
Rule Direction
RightToLeft String
name
        RuleForward String
name -> FileBasedTy -> Direction -> String -> IO ClassifiedRewrites
mkFileBased FileBasedTy
Rule Direction
LeftToRight String
name
        TypeBackward String
name -> FileBasedTy -> Direction -> String -> IO ClassifiedRewrites
mkFileBased FileBasedTy
Type Direction
RightToLeft String
name
        TypeForward String
name -> FileBasedTy -> Direction -> String -> IO ClassifiedRewrites
mkFileBased FileBasedTy
Type Direction
LeftToRight String
name
        PatternBackward String
name -> FileBasedTy -> Direction -> String -> IO ClassifiedRewrites
mkFileBased FileBasedTy
Pattern Direction
RightToLeft String
name
        PatternForward String
name -> FileBasedTy -> Direction -> String -> IO ClassifiedRewrites
mkFileBased FileBasedTy
Pattern Direction
LeftToRight String
name
        Unfold String
name -> FileBasedTy -> Direction -> String -> IO ClassifiedRewrites
mkFileBased FileBasedTy
FoldUnfold Direction
LeftToRight String
name
    | RewriteSpec
spec <- [RewriteSpec]
specs
    ]
  [Rewrite Universe]
fbRewrites <- String
-> (String -> IO (CPP AnnotatedModule))
-> [(String, [(FileBasedTy, [(FastString, Direction)])])]
-> IO [Rewrite Universe]
parseFileBased String
libdir String -> IO (CPP AnnotatedModule)
parser [(String, [(FileBasedTy, [(FastString, Direction)])])]
fileBased
  [Rewrite Universe]
adhocExpressionRewrites <- String -> FixityEnv -> [String] -> IO [Rewrite Universe]
parseAdhocs String
libdir FixityEnv
fixityEnv [String]
adhocRules
  -- debugPrint Loud "parseRewriteSpecs" (["adhocExpressionRewrites:" ++ show adhocRules]  ++ map (\r -> showAst ((astA . qPattern) r)) adhocExpressionRewrites)
  [Rewrite Universe]
adhocTypeRewrites <- String -> FixityEnv -> [String] -> IO [Rewrite Universe]
parseAdhocTypes String
libdir FixityEnv
fixityEnv [String]
adhocTypes
  -- debugPrint Loud "parseRewriteSpecs" (["adhocTypeRewrites:"] ++ map (\r -> showAst ((astA . qPattern) r)) adhocTypeRewrites)
  [Rewrite Universe]
adhocPatternRewrites <- String -> FixityEnv -> [String] -> IO [Rewrite Universe]
parseAdhocPatterns String
libdir FixityEnv
fixityEnv [String]
adhocPatterns
  -- debugPrint Loud "parseRewriteSpecs" (["adhocPatternRewrites:"] ++ map (\r -> showAst ((astA . qPattern) r)) adhocPatternRewrites)
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
    [Rewrite Universe]
fbRewrites forall a. [a] -> [a] -> [a]
++
    [Rewrite Universe]
adhocExpressionRewrites forall a. [a] -> [a] -> [a]
++
    [Rewrite Universe]
adhocTypeRewrites forall a. [a] -> [a] -> [a]
++
    [Rewrite Universe]
adhocPatternRewrites
  where
    mkFileBased :: FileBasedTy -> Direction -> String -> IO ClassifiedRewrites
mkFileBased FileBasedTy
ty Direction
dir String
name =
      case String -> Either String (String, FastString)
parseQualified String
name of
        Left String
err -> forall e a. Exception e => e -> IO a
throwIO forall a b. (a -> b) -> a -> b
$ String -> ErrorCall
ErrorCall forall a b. (a -> b) -> a -> b
$ String
"parseRewriteSpecs: " forall a. [a] -> [a] -> [a]
++ String
err
        Right (String
fp, FastString
fs) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Monoid a => a
mempty{fileBased :: [(String, [(FileBasedTy, [(FastString, Direction)])])]
fileBased = [(String
fp, [(FileBasedTy
ty, [(FastString
fs, Direction
dir)])])]}

data FileBasedTy = FoldUnfold | Rule | Type | Pattern
  deriving (FileBasedTy -> FileBasedTy -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: FileBasedTy -> FileBasedTy -> Bool
$c/= :: FileBasedTy -> FileBasedTy -> Bool
== :: FileBasedTy -> FileBasedTy -> Bool
$c== :: FileBasedTy -> FileBasedTy -> Bool
Eq, Eq FileBasedTy
FileBasedTy -> FileBasedTy -> Bool
FileBasedTy -> FileBasedTy -> Ordering
FileBasedTy -> FileBasedTy -> FileBasedTy
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: FileBasedTy -> FileBasedTy -> FileBasedTy
$cmin :: FileBasedTy -> FileBasedTy -> FileBasedTy
max :: FileBasedTy -> FileBasedTy -> FileBasedTy
$cmax :: FileBasedTy -> FileBasedTy -> FileBasedTy
>= :: FileBasedTy -> FileBasedTy -> Bool
$c>= :: FileBasedTy -> FileBasedTy -> Bool
> :: FileBasedTy -> FileBasedTy -> Bool
$c> :: FileBasedTy -> FileBasedTy -> Bool
<= :: FileBasedTy -> FileBasedTy -> Bool
$c<= :: FileBasedTy -> FileBasedTy -> Bool
< :: FileBasedTy -> FileBasedTy -> Bool
$c< :: FileBasedTy -> FileBasedTy -> Bool
compare :: FileBasedTy -> FileBasedTy -> Ordering
$ccompare :: FileBasedTy -> FileBasedTy -> Ordering
Ord)

parseFileBased
  :: LibDir
  -> (FilePath -> IO (CPP AnnotatedModule))
  -> [(FilePath, [(FileBasedTy, [(FastString, Direction)])])]
  -> IO [Rewrite Universe]
parseFileBased :: String
-> (String -> IO (CPP AnnotatedModule))
-> [(String, [(FileBasedTy, [(FastString, Direction)])])]
-> IO [Rewrite Universe]
parseFileBased String
_ String -> IO (CPP AnnotatedModule)
_ [] = forall (m :: * -> *) a. Monad m => a -> m a
return []
parseFileBased String
libdir String -> IO (CPP AnnotatedModule)
parser [(String, [(FileBasedTy, [(FastString, Direction)])])]
specs = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry String
-> [(FileBasedTy, [(FastString, Direction)])]
-> IO [Rewrite Universe]
goFile) (forall a b. Ord a => [(a, [b])] -> [(a, [b])]
gather [(String, [(FileBasedTy, [(FastString, Direction)])])]
specs)
  where
    gather :: Ord a => [(a,[b])] -> [(a,[b])]
    gather :: forall a b. Ord a => [(a, [b])] -> [(a, [b])]
gather = forall k a. Map k a -> [(k, a)]
Map.toList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith forall a. [a] -> [a] -> [a]
(++)

    goFile
      :: FilePath
      -> [(FileBasedTy, [(FastString, Direction)])]
      -> IO [Rewrite Universe]
    goFile :: String
-> [(FileBasedTy, [(FastString, Direction)])]
-> IO [Rewrite Universe]
goFile String
fp [(FileBasedTy, [(FastString, Direction)])]
rules = do
      CPP AnnotatedModule
cpp <- String -> IO (CPP AnnotatedModule)
parser String
fp
      forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall a b. (a -> b) -> a -> b
$ String
-> CPP AnnotatedModule
-> FileBasedTy
-> [(FastString, Direction)]
-> IO [Rewrite Universe]
constructRewrites String
libdir CPP AnnotatedModule
cpp) (forall a b. Ord a => [(a, [b])] -> [(a, [b])]
gather [(FileBasedTy, [(FastString, Direction)])]
rules)

parseAdhocs :: LibDir -> FixityEnv -> [String] -> IO [Rewrite Universe]
parseAdhocs :: String -> FixityEnv -> [String] -> IO [Rewrite Universe]
parseAdhocs String
_ FixityEnv
_ [] = forall (m :: * -> *) a. Monad m => a -> m a
return []
parseAdhocs String
libdir FixityEnv
fixities [String]
adhocs = do
  -- debugPrint Loud "parseAdhocs:adhocs" adhocs
  -- debugPrint Loud "parseAdhocs:adhocRules" (map show adhocRules)
  CPP AnnotatedModule
cpp <-
    forall (m :: * -> *).
Monad m =>
(String -> m AnnotatedModule) -> Text -> m (CPP AnnotatedModule)
parseCPP (String -> FixityEnv -> String -> String -> IO AnnotatedModule
parseContent String
libdir FixityEnv
fixities String
"parseAdhocs") ([Text] -> Text
Text.unlines [Text]
adhocRules)
  -- debugPrint Loud "parseAdhocs:cpp" [showCpp cpp]
  String
-> CPP AnnotatedModule
-> FileBasedTy
-> [(FastString, Direction)]
-> IO [Rewrite Universe]
constructRewrites String
libdir CPP AnnotatedModule
cpp FileBasedTy
Rule [(FastString, Direction)]
adhocSpecs
  where
    -- In search mode, there is no need to specify a right-hand side, but we
    -- need one to parse as a RULE, so add it if necessary.
    addRHS :: String -> String
addRHS String
s
      | Char
'=' forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
s = String
s
      | Bool
otherwise = String
s forall a. [a] -> [a] -> [a]
++ String
" = undefined"
    ([(FastString, Direction)]
adhocSpecs, [Text]
adhocRules) = forall a b. [(a, b)] -> ([a], [b])
unzip
      [ ( (String -> FastString
mkFastString String
nm, Direction
LeftToRight)
        , Text
"{-# RULES \"" forall a. Semigroup a => a -> a -> a
<> String -> Text
Text.pack String
nm forall a. Semigroup a => a -> a -> a
<> Text
"\" " forall a. Semigroup a => a -> a -> a
<> String -> Text
Text.pack String
s forall a. Semigroup a => a -> a -> a
<> Text
" #-}"
        )
      | (Int
i,String
s) <- forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1..] forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map String -> String
addRHS [String]
adhocs
      , let nm :: String
nm = String
"adhoc" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (Int
i::Int)
      ]


showCpp :: (Data ast, ExactPrint ast) => CPP (Annotated ast) -> String
showCpp :: forall ast.
(Data ast, ExactPrint ast) =>
CPP (Annotated ast) -> String
showCpp (NoCPP Annotated ast
c) = forall ast. (Data ast, ExactPrint ast) => Annotated ast -> String
showAstA Annotated ast
c
showCpp (CPP{}) = String
"CPP{}"

parseAdhocTypes :: LibDir -> FixityEnv -> [String] -> IO [Rewrite Universe]
parseAdhocTypes :: String -> FixityEnv -> [String] -> IO [Rewrite Universe]
parseAdhocTypes String
_ FixityEnv
_ [] = forall (m :: * -> *) a. Monad m => a -> m a
return []
parseAdhocTypes String
libdir FixityEnv
fixities [String]
tySyns = do
  forall a. Show a => a -> IO ()
print [Text]
adhocTySyns
  CPP AnnotatedModule
cpp <-
    forall (m :: * -> *).
Monad m =>
(String -> m AnnotatedModule) -> Text -> m (CPP AnnotatedModule)
parseCPP (String -> FixityEnv -> String -> String -> IO AnnotatedModule
parseContent String
libdir FixityEnv
fixities String
"parseAdhocTypes") ([Text] -> Text
Text.unlines [Text]
adhocTySyns)
  String
-> CPP AnnotatedModule
-> FileBasedTy
-> [(FastString, Direction)]
-> IO [Rewrite Universe]
constructRewrites String
libdir CPP AnnotatedModule
cpp FileBasedTy
Type [(FastString, Direction)]
adhocSpecs
  where
    ([(FastString, Direction)]
adhocSpecs, [Text]
adhocTySyns) = forall a b. [(a, b)] -> ([a], [b])
unzip
      [ ( (String -> FastString
mkFastString String
nm, Direction
LeftToRight), Text
"type " forall a. Semigroup a => a -> a -> a
<> String -> Text
Text.pack String
s)
      | String
s <- [String]
tySyns
      , Just String
nm <- [forall a. [a] -> Maybe a
listToMaybe forall a b. (a -> b) -> a -> b
$ String -> [String]
words String
s]
      ]

parseAdhocPatterns :: LibDir -> FixityEnv -> [String] -> IO [Rewrite Universe]
parseAdhocPatterns :: String -> FixityEnv -> [String] -> IO [Rewrite Universe]
parseAdhocPatterns String
_ FixityEnv
_ [] = forall (m :: * -> *) a. Monad m => a -> m a
return []
parseAdhocPatterns String
libdir FixityEnv
fixities [String]
patSyns = do
  CPP AnnotatedModule
cpp <-
    forall (m :: * -> *).
Monad m =>
(String -> m AnnotatedModule) -> Text -> m (CPP AnnotatedModule)
parseCPP (String -> FixityEnv -> String -> String -> IO AnnotatedModule
parseContent String
libdir FixityEnv
fixities String
"parseAdhocPatterns")
             ([Text] -> Text
Text.unlines forall a b. (a -> b) -> a -> b
$ Text
pragma forall a. a -> [a] -> [a]
: [Text]
adhocPatSyns)
  String
-> CPP AnnotatedModule
-> FileBasedTy
-> [(FastString, Direction)]
-> IO [Rewrite Universe]
constructRewrites String
libdir CPP AnnotatedModule
cpp FileBasedTy
Pattern [(FastString, Direction)]
adhocSpecs
  where
    pragma :: Text
pragma = Text
"{-# LANGUAGE PatternSynonyms #-}"
    ([(FastString, Direction)]
adhocSpecs, [Text]
adhocPatSyns) = forall a b. [(a, b)] -> ([a], [b])
unzip
      [ ( (String -> FastString
mkFastString String
nm, Direction
LeftToRight), Text
"pattern " forall a. Semigroup a => a -> a -> a
<> String -> Text
Text.pack String
s)
      | String
s <- [String]
patSyns
      , Just String
nm <- [forall a. [a] -> Maybe a
listToMaybe forall a b. (a -> b) -> a -> b
$ String -> [String]
words String
s]
      ]

constructRewrites
  :: LibDir
  -> CPP AnnotatedModule
  -> FileBasedTy
  -> [(FastString, Direction)]
  -> IO [Rewrite Universe]
constructRewrites :: String
-> CPP AnnotatedModule
-> FileBasedTy
-> [(FastString, Direction)]
-> IO [Rewrite Universe]
constructRewrites String
libdir CPP AnnotatedModule
cpp FileBasedTy
ty [(FastString, Direction)]
specs = do
  CPP (UniqFM FastString [Rewrite Universe])
cppM <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (String
-> FileBasedTy
-> [(FastString, Direction)]
-> AnnotatedModule
-> IO (UniqFM FastString [Rewrite Universe])
tyBuilder String
libdir FileBasedTy
ty [(FastString, Direction)]
specs) CPP AnnotatedModule
cpp
  let
    names :: [FastString]
names = forall elt. UniqSet elt -> [elt]
nonDetEltsUniqSet forall a b. (a -> b) -> a -> b
$ forall a. Uniquable a => [a] -> UniqSet a
mkUniqSet forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(FastString, Direction)]
specs

    nameOf :: FileBasedTy -> a
nameOf FileBasedTy
FoldUnfold = a
"definition"
    nameOf FileBasedTy
Rule = a
"rule"
    nameOf FileBasedTy
Type = a
"type synonym"
    nameOf FileBasedTy
Pattern = a
"pattern synonym"

    m :: UniqFM FastString [Rewrite Universe]
m = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (forall elt key.
(elt -> elt -> elt)
-> UniqFM key elt -> UniqFM key elt -> UniqFM key elt
plusUFM_C forall a. [a] -> [a] -> [a]
(++)) forall key elt. UniqFM key elt
emptyUFM CPP (UniqFM FastString [Rewrite Universe])
cppM

  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat 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]
names forall a b. (a -> b) -> a -> b
$ \FastString
fs ->
    case forall key elt. Uniquable key => UniqFM key elt -> key -> Maybe elt
lookupUFM UniqFM FastString [Rewrite Universe]
m FastString
fs of
      Maybe [Rewrite Universe]
Nothing ->
        forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"could not find " forall a. [a] -> [a] -> [a]
++ forall {a}. IsString a => FileBasedTy -> a
nameOf FileBasedTy
ty forall a. [a] -> [a] -> [a]
++ String
" named " forall a. [a] -> [a] -> [a]
++ FastString -> String
unpackFS FastString
fs
      Just [Rewrite Universe]
rrs -> do
        -- debugPrint Loud "constructRewrites:cppM" ["enter"]
        forall (m :: * -> *) a. Monad m => a -> m a
return [Rewrite Universe]
rrs

tyBuilder
  :: LibDir
  -> FileBasedTy
  -> [(FastString, Direction)]
  -> AnnotatedModule
#if __GLASGOW_HASKELL__ < 900
  -> IO (UniqFM [Rewrite Universe])
#else
  -> IO (UniqFM FastString [Rewrite Universe])
#endif
tyBuilder :: String
-> FileBasedTy
-> [(FastString, Direction)]
-> AnnotatedModule
-> IO (UniqFM FastString [Rewrite Universe])
tyBuilder String
libdir FileBasedTy
FoldUnfold [(FastString, Direction)]
specs AnnotatedModule
am = forall a k.
Matchable a =>
UniqFM k [Rewrite a] -> UniqFM k [Rewrite Universe]
promote forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String
-> [(FastString, Direction)]
-> AnnotatedModule
-> IO (UniqFM FastString [Rewrite (LHsExpr GhcPs)])
dfnsToRewrites String
libdir [(FastString, Direction)]
specs AnnotatedModule
am
tyBuilder String
_libdir FileBasedTy
Rule [(FastString, Direction)]
specs AnnotatedModule
am = forall a k.
Matchable a =>
UniqFM k [Rewrite a] -> UniqFM k [Rewrite Universe]
promote forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(FastString, Direction)]
-> AnnotatedModule
-> IO (UniqFM FastString [Rewrite (LHsExpr GhcPs)])
rulesToRewrites [(FastString, Direction)]
specs AnnotatedModule
am
tyBuilder String
_libdir FileBasedTy
Type [(FastString, Direction)]
specs AnnotatedModule
am = forall a k.
Matchable a =>
UniqFM k [Rewrite a] -> UniqFM k [Rewrite Universe]
promote forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(FastString, Direction)]
-> AnnotatedModule
-> IO (UniqFM FastString [Rewrite (LHsType GhcPs)])
typeSynonymsToRewrites [(FastString, Direction)]
specs AnnotatedModule
am
tyBuilder String
libdir FileBasedTy
Pattern [(FastString, Direction)]
specs AnnotatedModule
am = String
-> [(FastString, Direction)]
-> AnnotatedModule
-> IO (UniqFM FastString [Rewrite Universe])
patternSynonymsToRewrites String
libdir [(FastString, Direction)]
specs AnnotatedModule
am

#if __GLASGOW_HASKELL__ < 900
promote :: Matchable a => UniqFM [Rewrite a] -> UniqFM [Rewrite Universe]
#else
promote :: Matchable a => UniqFM k [Rewrite a] -> UniqFM k [Rewrite Universe]
#endif
promote :: forall a k.
Matchable a =>
UniqFM k [Rewrite a] -> UniqFM k [Rewrite Universe]
promote = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. (a -> b) -> [a] -> [b]
map forall ast. Matchable ast => Rewrite ast -> Rewrite Universe
toURewrite)

parseQualified :: String -> Either String (FilePath, FastString)
parseQualified :: String -> Either String (String, FastString)
parseQualified [] = forall a b. a -> Either a b
Left String
"qualified name is empty"
parseQualified String
fqName =
  case forall a. (a -> Bool) -> [a] -> ([a], [a])
span Char -> Bool
isHsSymbol String
reversed of
    (String
_,[]) -> forall {b}. String -> Either String b
mkError String
"unqualified operator name"
    ([],String
_) ->
      case forall a. (a -> Bool) -> [a] -> ([a], [a])
span (forall a. Eq a => a -> a -> Bool
/=Char
'.') String
reversed of
        (String
_,[]) -> forall {b}. String -> Either String b
mkError String
"unqualified function name"
        (String
rname,Char
_:String
rmod) -> forall {a}. String -> String -> Either a (String, FastString)
mkResult (forall a. [a] -> [a]
reverse String
rmod) (forall a. [a] -> [a]
reverse String
rname)
    (String
rop,String
rmod) ->
      case forall a. [a] -> [a]
reverse String
rop of
        Char
'.':String
op -> forall {a}. String -> String -> Either a (String, FastString)
mkResult (forall a. [a] -> [a]
reverse String
rmod) String
op
        String
_ -> forall {b}. String -> Either String b
mkError String
"malformed qualified operator"
  where
    reversed :: String
reversed = forall a. [a] -> [a]
reverse String
fqName
    mkError :: String -> Either String b
mkError String
str = forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ String
str forall a. [a] -> [a] -> [a]
++ String
": " forall a. [a] -> [a] -> [a]
++ String
fqName
    mkResult :: String -> String -> Either a (String, FastString)
mkResult String
moduleNameStr String
occNameStr = forall a b. b -> Either a b
Right
      -- 'moduleNameSlashes' gives us system-dependent path separator
      ( ModuleName -> String
moduleNameSlashes (String -> ModuleName
mkModuleName String
moduleNameStr) String -> String -> String
<.> String
"hs"
      , String -> FastString
mkFastString String
occNameStr
      )

isHsSymbol :: Char -> Bool
isHsSymbol :: Char -> Bool
isHsSymbol = (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
symbols)
  -- see https://www.haskell.org/onlinereport/lexemes.html
  where
    symbols :: String
    symbols :: String
symbols = String
"!#$%&*+./<=>?@\\^|-~"