{-# 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 qualified Data.Text as Text
import Data.Traversable
import System.FilePath

import Retrie.CPP
import Retrie.ExactPrint
import Retrie.Fixity
import Retrie.GHC
import Retrie.Rewrites.Function
import Retrie.Rewrites.Patterns
import Retrie.Rewrites.Rules
import Retrie.Rewrites.Types
import Retrie.Types
import Retrie.Universe

-- | 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 [String] -> [String] -> [String]
forall a. Semigroup a => a -> a -> a
<> [String]
a') ([String]
b [String] -> [String] -> [String]
forall a. Semigroup a => a -> a -> a
<> [String]
b') ([String]
c [String] -> [String] -> [String]
forall a. Semigroup a => a -> a -> a
<> [String]
c') ([(String, [(FileBasedTy, [(FastString, Direction)])])]
d [(String, [(FileBasedTy, [(FastString, Direction)])])]
-> [(String, [(FileBasedTy, [(FastString, Direction)])])]
-> [(String, [(FileBasedTy, [(FastString, Direction)])])]
forall a. Semigroup a => a -> a -> a
<> [(String, [(FileBasedTy, [(FastString, Direction)])])]
d')

parseRewriteSpecs
  :: (FilePath -> IO (CPP AnnotatedModule))
  -> FixityEnv
  -> [RewriteSpec]
  -> IO [Rewrite Universe]
parseRewriteSpecs :: (String -> IO (CPP AnnotatedModule))
-> FixityEnv -> [RewriteSpec] -> IO [Rewrite Universe]
parseRewriteSpecs 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]
..} <- [ClassifiedRewrites] -> ClassifiedRewrites
forall a. Monoid a => [a] -> a
mconcat ([ClassifiedRewrites] -> ClassifiedRewrites)
-> IO [ClassifiedRewrites] -> IO ClassifiedRewrites
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [IO ClassifiedRewrites] -> IO [ClassifiedRewrites]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence
    [ case RewriteSpec
spec of
        Adhoc String
rule -> ClassifiedRewrites -> IO ClassifiedRewrites
forall (m :: * -> *) a. Monad m => a -> m a
return ClassifiedRewrites
forall a. Monoid a => a
mempty{adhocRules :: [String]
adhocRules = [String
rule]}
        AdhocPattern String
pSyn -> ClassifiedRewrites -> IO ClassifiedRewrites
forall (m :: * -> *) a. Monad m => a -> m a
return ClassifiedRewrites
forall a. Monoid a => a
mempty{adhocPatterns :: [String]
adhocPatterns = [String
pSyn]}
        AdhocType String
tySyn -> ClassifiedRewrites -> IO ClassifiedRewrites
forall (m :: * -> *) a. Monad m => a -> m a
return ClassifiedRewrites
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 -> IO (CPP AnnotatedModule))
-> [(String, [(FileBasedTy, [(FastString, Direction)])])]
-> IO [Rewrite Universe]
parseFileBased String -> IO (CPP AnnotatedModule)
parser [(String, [(FileBasedTy, [(FastString, Direction)])])]
fileBased
  [Rewrite Universe]
adhocExpressionRewrites <- FixityEnv -> [String] -> IO [Rewrite Universe]
parseAdhocs FixityEnv
fixityEnv [String]
adhocRules
  [Rewrite Universe]
adhocTypeRewrites <- FixityEnv -> [String] -> IO [Rewrite Universe]
parseAdhocTypes FixityEnv
fixityEnv [String]
adhocTypes
  [Rewrite Universe]
adhocPatternRewrites <- FixityEnv -> [String] -> IO [Rewrite Universe]
parseAdhocPatterns FixityEnv
fixityEnv [String]
adhocPatterns
  [Rewrite Universe] -> IO [Rewrite Universe]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Rewrite Universe] -> IO [Rewrite Universe])
-> [Rewrite Universe] -> IO [Rewrite Universe]
forall a b. (a -> b) -> a -> b
$
    [Rewrite Universe]
fbRewrites [Rewrite Universe] -> [Rewrite Universe] -> [Rewrite Universe]
forall a. [a] -> [a] -> [a]
++
    [Rewrite Universe]
adhocExpressionRewrites [Rewrite Universe] -> [Rewrite Universe] -> [Rewrite Universe]
forall a. [a] -> [a] -> [a]
++
    [Rewrite Universe]
adhocTypeRewrites [Rewrite Universe] -> [Rewrite Universe] -> [Rewrite Universe]
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 -> ErrorCall -> IO ClassifiedRewrites
forall e a. Exception e => e -> IO a
throwIO (ErrorCall -> IO ClassifiedRewrites)
-> ErrorCall -> IO ClassifiedRewrites
forall a b. (a -> b) -> a -> b
$ String -> ErrorCall
ErrorCall (String -> ErrorCall) -> String -> ErrorCall
forall a b. (a -> b) -> a -> b
$ String
"parseRewriteSpecs: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
err
        Right (String
fp, FastString
fs) -> ClassifiedRewrites -> IO ClassifiedRewrites
forall (m :: * -> *) a. Monad m => a -> m a
return ClassifiedRewrites
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
(FileBasedTy -> FileBasedTy -> Bool)
-> (FileBasedTy -> FileBasedTy -> Bool) -> Eq FileBasedTy
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
Eq FileBasedTy
-> (FileBasedTy -> FileBasedTy -> Ordering)
-> (FileBasedTy -> FileBasedTy -> Bool)
-> (FileBasedTy -> FileBasedTy -> Bool)
-> (FileBasedTy -> FileBasedTy -> Bool)
-> (FileBasedTy -> FileBasedTy -> Bool)
-> (FileBasedTy -> FileBasedTy -> FileBasedTy)
-> (FileBasedTy -> FileBasedTy -> FileBasedTy)
-> Ord 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
$cp1Ord :: Eq FileBasedTy
Ord)

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

parseAdhocs :: FixityEnv -> [String] -> IO [Rewrite Universe]
parseAdhocs :: FixityEnv -> [String] -> IO [Rewrite Universe]
parseAdhocs FixityEnv
_ [] = [Rewrite Universe] -> IO [Rewrite Universe]
forall (m :: * -> *) a. Monad m => a -> m a
return []
parseAdhocs FixityEnv
fixities [String]
adhocs = do
  CPP AnnotatedModule
cpp <-
    (String -> IO AnnotatedModule) -> Text -> IO (CPP AnnotatedModule)
forall (m :: * -> *).
Monad m =>
(String -> m AnnotatedModule) -> Text -> m (CPP AnnotatedModule)
parseCPP (FixityEnv -> String -> String -> IO AnnotatedModule
parseContent FixityEnv
fixities String
"parseAdhocs") ([Text] -> Text
Text.unlines [Text]
adhocRules)
  CPP AnnotatedModule
-> FileBasedTy
-> [(FastString, Direction)]
-> IO [Rewrite Universe]
constructRewrites 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
'=' Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
s = String
s
      | Bool
otherwise = String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" = undefined"
    ([(FastString, Direction)]
adhocSpecs, [Text]
adhocRules) = [((FastString, Direction), Text)]
-> ([(FastString, Direction)], [Text])
forall a b. [(a, b)] -> ([a], [b])
unzip
      [ ( (String -> FastString
mkFastString String
nm, Direction
LeftToRight)
        , Text
"{-# RULES \"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
Text.pack String
nm Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
Text.pack String
s Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" #-}"
        )
      | (Int
i,String
s) <- [Int] -> [String] -> [(Int, String)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1..] ([String] -> [(Int, String)]) -> [String] -> [(Int, String)]
forall a b. (a -> b) -> a -> b
$ (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map String -> String
addRHS [String]
adhocs
      , let nm :: String
nm = String
"adhoc" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (Int
i::Int)
      ]

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

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

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

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

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

  ([[Rewrite Universe]] -> [Rewrite Universe])
-> IO [[Rewrite Universe]] -> IO [Rewrite Universe]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[Rewrite Universe]] -> [Rewrite Universe]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (IO [[Rewrite Universe]] -> IO [Rewrite Universe])
-> IO [[Rewrite Universe]] -> IO [Rewrite Universe]
forall a b. (a -> b) -> a -> b
$ [FastString]
-> (FastString -> IO [Rewrite Universe]) -> IO [[Rewrite Universe]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [FastString]
names ((FastString -> IO [Rewrite Universe]) -> IO [[Rewrite Universe]])
-> (FastString -> IO [Rewrite Universe]) -> IO [[Rewrite Universe]]
forall a b. (a -> b) -> a -> b
$ \FastString
fs ->
    case UniqFM [Rewrite Universe] -> FastString -> Maybe [Rewrite Universe]
forall key elt. Uniquable key => UniqFM elt -> key -> Maybe elt
lookupUFM UniqFM [Rewrite Universe]
m FastString
fs of
      Maybe [Rewrite Universe]
Nothing ->
        String -> IO [Rewrite Universe]
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO [Rewrite Universe])
-> String -> IO [Rewrite Universe]
forall a b. (a -> b) -> a -> b
$ String
"could not find " String -> String -> String
forall a. [a] -> [a] -> [a]
++ FileBasedTy -> String
forall p. IsString p => FileBasedTy -> p
nameOf FileBasedTy
ty String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" named " String -> String -> String
forall a. [a] -> [a] -> [a]
++ FastString -> String
unpackFS FastString
fs
      Just [Rewrite Universe]
rrs -> [Rewrite Universe] -> IO [Rewrite Universe]
forall (m :: * -> *) a. Monad m => a -> m a
return [Rewrite Universe]
rrs

tyBuilder
  :: FileBasedTy
  -> [(FastString, Direction)]
  -> AnnotatedModule
#if __GLASGOW_HASKELL__ < 900
  -> IO (UniqFM [Rewrite Universe])
#else
  -> IO (UniqFM FastString [Rewrite Universe])
#endif
tyBuilder :: FileBasedTy
-> [(FastString, Direction)]
-> AnnotatedModule
-> IO (UniqFM [Rewrite Universe])
tyBuilder FileBasedTy
FoldUnfold [(FastString, Direction)]
specs AnnotatedModule
am = UniqFM [Rewrite (LHsExpr GhcPs)] -> UniqFM [Rewrite Universe]
forall a.
Matchable a =>
UniqFM [Rewrite a] -> UniqFM [Rewrite Universe]
promote (UniqFM [Rewrite (LHsExpr GhcPs)] -> UniqFM [Rewrite Universe])
-> IO (UniqFM [Rewrite (LHsExpr GhcPs)])
-> IO (UniqFM [Rewrite Universe])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(FastString, Direction)]
-> AnnotatedModule -> IO (UniqFM [Rewrite (LHsExpr GhcPs)])
dfnsToRewrites [(FastString, Direction)]
specs AnnotatedModule
am
tyBuilder FileBasedTy
Rule [(FastString, Direction)]
specs AnnotatedModule
am = UniqFM [Rewrite (LHsExpr GhcPs)] -> UniqFM [Rewrite Universe]
forall a.
Matchable a =>
UniqFM [Rewrite a] -> UniqFM [Rewrite Universe]
promote (UniqFM [Rewrite (LHsExpr GhcPs)] -> UniqFM [Rewrite Universe])
-> IO (UniqFM [Rewrite (LHsExpr GhcPs)])
-> IO (UniqFM [Rewrite Universe])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(FastString, Direction)]
-> AnnotatedModule -> IO (UniqFM [Rewrite (LHsExpr GhcPs)])
rulesToRewrites [(FastString, Direction)]
specs AnnotatedModule
am
tyBuilder FileBasedTy
Type [(FastString, Direction)]
specs AnnotatedModule
am = UniqFM [Rewrite (LHsType GhcPs)] -> UniqFM [Rewrite Universe]
forall a.
Matchable a =>
UniqFM [Rewrite a] -> UniqFM [Rewrite Universe]
promote (UniqFM [Rewrite (LHsType GhcPs)] -> UniqFM [Rewrite Universe])
-> IO (UniqFM [Rewrite (LHsType GhcPs)])
-> IO (UniqFM [Rewrite Universe])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(FastString, Direction)]
-> AnnotatedModule -> IO (UniqFM [Rewrite (LHsType GhcPs)])
typeSynonymsToRewrites [(FastString, Direction)]
specs AnnotatedModule
am
tyBuilder FileBasedTy
Pattern [(FastString, Direction)]
specs AnnotatedModule
am = [(FastString, Direction)]
-> AnnotatedModule -> IO (UniqFM [Rewrite Universe])
patternSynonymsToRewrites [(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 :: UniqFM [Rewrite a] -> UniqFM [Rewrite Universe]
promote = ([Rewrite a] -> [Rewrite Universe])
-> UniqFM [Rewrite a] -> UniqFM [Rewrite Universe]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Rewrite a -> Rewrite Universe)
-> [Rewrite a] -> [Rewrite Universe]
forall a b. (a -> b) -> [a] -> [b]
map Rewrite a -> Rewrite Universe
forall ast. Matchable ast => Rewrite ast -> Rewrite Universe
toURewrite)

parseQualified :: String -> Either String (FilePath, FastString)
parseQualified :: String -> Either String (String, FastString)
parseQualified [] = String -> Either String (String, FastString)
forall a b. a -> Either a b
Left String
"qualified name is empty"
parseQualified String
fqName =
  case (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span Char -> Bool
isHsSymbol String
reversed of
    (String
_,[]) -> String -> Either String (String, FastString)
forall b. String -> Either String b
mkError String
"unqualified operator name"
    ([],String
_) ->
      case (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/=Char
'.') String
reversed of
        (String
_,[]) -> String -> Either String (String, FastString)
forall b. String -> Either String b
mkError String
"unqualified function name"
        (String
rname,Char
_:String
rmod) -> String -> String -> Either String (String, FastString)
forall a. String -> String -> Either a (String, FastString)
mkResult (String -> String
forall a. [a] -> [a]
reverse String
rmod) (String -> String
forall a. [a] -> [a]
reverse String
rname)
    (String
rop,String
rmod) ->
      case String -> String
forall a. [a] -> [a]
reverse String
rop of
        Char
'.':String
op -> String -> String -> Either String (String, FastString)
forall a. String -> String -> Either a (String, FastString)
mkResult (String -> String
forall a. [a] -> [a]
reverse String
rmod) String
op
        String
_ -> String -> Either String (String, FastString)
forall b. String -> Either String b
mkError String
"malformed qualified operator"
  where
    reversed :: String
reversed = String -> String
forall a. [a] -> [a]
reverse String
fqName
    mkError :: String -> Either String b
mkError String
str = String -> Either String b
forall a b. a -> Either a b
Left (String -> Either String b) -> String -> Either String b
forall a b. (a -> b) -> a -> b
$ String
str String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
fqName
    mkResult :: String -> String -> Either a (String, FastString)
mkResult String
moduleNameStr String
occNameStr = (String, FastString) -> Either a (String, FastString)
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 = (Char -> String -> Bool
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
"!#$%&*+./<=>?@\\^|-~"