{-# 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 [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
  :: 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)])])]
adhocRules :: ClassifiedRewrites -> [String]
adhocPatterns :: ClassifiedRewrites -> [String]
adhocTypes :: ClassifiedRewrites -> [String]
fileBased :: ClassifiedRewrites
-> [(String, [(FileBasedTy, [(FastString, Direction)])])]
adhocRules :: [String]
adhocPatterns :: [String]
adhocTypes :: [String]
fileBased :: [(String, [(FileBasedTy, [(FastString, Direction)])])]
..} <- [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)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence
    [ case RewriteSpec
spec of
        Adhoc String
rule -> ClassifiedRewrites -> IO ClassifiedRewrites
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ClassifiedRewrites
forall a. Monoid a => a
mempty{adhocRules = [rule]}
        AdhocPattern String
pSyn -> ClassifiedRewrites -> IO ClassifiedRewrites
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ClassifiedRewrites
forall a. Monoid a => a
mempty{adhocPatterns = [pSyn]}
        AdhocType String
tySyn -> ClassifiedRewrites -> IO ClassifiedRewrites
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ClassifiedRewrites
forall a. Monoid a => a
mempty{adhocTypes = [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)
  [Rewrite Universe] -> IO [Rewrite Universe]
forall a. a -> IO a
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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ClassifiedRewrites
forall a. Monoid a => a
mempty{fileBased = [(fp, [(ty, [(fs, 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
$c== :: FileBasedTy -> FileBasedTy -> Bool
== :: FileBasedTy -> FileBasedTy -> Bool
$c/= :: FileBasedTy -> FileBasedTy -> Bool
/= :: 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
$ccompare :: FileBasedTy -> FileBasedTy -> Ordering
compare :: FileBasedTy -> FileBasedTy -> Ordering
$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
>= :: FileBasedTy -> FileBasedTy -> Bool
$cmax :: FileBasedTy -> FileBasedTy -> FileBasedTy
max :: FileBasedTy -> FileBasedTy -> FileBasedTy
$cmin :: FileBasedTy -> FileBasedTy -> FileBasedTy
min :: FileBasedTy -> FileBasedTy -> FileBasedTy
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)
_ [] = [Rewrite Universe] -> IO [Rewrite Universe]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []
parseFileBased String
libdir 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)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [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 :: forall a b. Ord a => [(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)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [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
$ String
-> CPP AnnotatedModule
-> FileBasedTy
-> [(FastString, Direction)]
-> IO [Rewrite Universe]
constructRewrites String
libdir CPP AnnotatedModule
cpp) ([(FileBasedTy, [(FastString, Direction)])]
-> [(FileBasedTy, [(FastString, Direction)])]
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
_ [] = [Rewrite Universe] -> IO [Rewrite Universe]
forall a. a -> IO a
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 <-
    (String -> IO AnnotatedModule) -> Text -> IO (CPP AnnotatedModule)
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
'=' Char -> String -> Bool
forall a. Eq a => a -> [a] -> 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)
      ]


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) = Annotated ast -> String
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
_ [] = [Rewrite Universe] -> IO [Rewrite Universe]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []
parseAdhocTypes String
libdir 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 (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) = [((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 :: LibDir -> FixityEnv -> [String] -> IO [Rewrite Universe]
parseAdhocPatterns :: String -> FixityEnv -> [String] -> IO [Rewrite Universe]
parseAdhocPatterns String
_ FixityEnv
_ [] = [Rewrite Universe] -> IO [Rewrite Universe]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []
parseAdhocPatterns String
libdir 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 (String -> FixityEnv -> String -> String -> IO AnnotatedModule
parseContent String
libdir 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)
  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) = [((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
  :: 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 <- (AnnotatedModule -> IO (UniqFM FastString [Rewrite Universe]))
-> CPP AnnotatedModule
-> IO (CPP (UniqFM FastString [Rewrite Universe]))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> CPP a -> f (CPP 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 = 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 -> 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 = (UniqFM FastString [Rewrite Universe]
 -> UniqFM FastString [Rewrite Universe]
 -> UniqFM FastString [Rewrite Universe])
-> UniqFM FastString [Rewrite Universe]
-> CPP (UniqFM FastString [Rewrite Universe])
-> UniqFM FastString [Rewrite Universe]
forall a b. (a -> b -> b) -> b -> CPP a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (([Rewrite Universe] -> [Rewrite Universe] -> [Rewrite Universe])
-> UniqFM FastString [Rewrite Universe]
-> UniqFM FastString [Rewrite Universe]
-> UniqFM FastString [Rewrite Universe]
forall elt key.
(elt -> elt -> elt)
-> UniqFM key elt -> UniqFM key elt -> UniqFM key elt
plusUFM_C [Rewrite Universe] -> [Rewrite Universe] -> [Rewrite Universe]
forall a. [a] -> [a] -> [a]
(++)) UniqFM FastString [Rewrite Universe]
forall key elt. UniqFM key elt
emptyUFM CPP (UniqFM FastString [Rewrite Universe])
cppM

  ([[Rewrite Universe]] -> [Rewrite Universe])
-> IO [[Rewrite Universe]] -> IO [Rewrite Universe]
forall a b. (a -> b) -> IO a -> IO b
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 FastString [Rewrite Universe]
-> FastString -> Maybe [Rewrite Universe]
forall key elt. Uniquable key => UniqFM key elt -> key -> Maybe elt
lookupUFM UniqFM FastString [Rewrite Universe]
m FastString
fs of
      Maybe [Rewrite Universe]
Nothing ->
        String -> IO [Rewrite Universe]
forall a. String -> IO a
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 {a}. IsString a => FileBasedTy -> a
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 -> do
        -- debugPrint Loud "constructRewrites:cppM" ["enter"]
        [Rewrite Universe] -> IO [Rewrite Universe]
forall a. a -> IO a
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 = UniqFM FastString [Rewrite (GenLocated SrcSpanAnnA (HsExpr GhcPs))]
-> UniqFM FastString [Rewrite Universe]
forall a k.
Matchable a =>
UniqFM k [Rewrite a] -> UniqFM k [Rewrite Universe]
promote (UniqFM
   FastString [Rewrite (GenLocated SrcSpanAnnA (HsExpr GhcPs))]
 -> UniqFM FastString [Rewrite Universe])
-> IO
     (UniqFM
        FastString [Rewrite (GenLocated SrcSpanAnnA (HsExpr GhcPs))])
-> IO (UniqFM FastString [Rewrite Universe])
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 = UniqFM FastString [Rewrite (GenLocated SrcSpanAnnA (HsExpr GhcPs))]
-> UniqFM FastString [Rewrite Universe]
forall a k.
Matchable a =>
UniqFM k [Rewrite a] -> UniqFM k [Rewrite Universe]
promote (UniqFM
   FastString [Rewrite (GenLocated SrcSpanAnnA (HsExpr GhcPs))]
 -> UniqFM FastString [Rewrite Universe])
-> IO
     (UniqFM
        FastString [Rewrite (GenLocated SrcSpanAnnA (HsExpr GhcPs))])
-> IO (UniqFM FastString [Rewrite Universe])
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 = UniqFM FastString [Rewrite (GenLocated SrcSpanAnnA (HsType GhcPs))]
-> UniqFM FastString [Rewrite Universe]
forall a k.
Matchable a =>
UniqFM k [Rewrite a] -> UniqFM k [Rewrite Universe]
promote (UniqFM
   FastString [Rewrite (GenLocated SrcSpanAnnA (HsType GhcPs))]
 -> UniqFM FastString [Rewrite Universe])
-> IO
     (UniqFM
        FastString [Rewrite (GenLocated SrcSpanAnnA (HsType GhcPs))])
-> IO (UniqFM FastString [Rewrite Universe])
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 = ([Rewrite a] -> [Rewrite Universe])
-> UniqFM k [Rewrite a] -> UniqFM k [Rewrite Universe]
forall a b. (a -> b) -> UniqFM k a -> UniqFM k b
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 a. Eq a => a -> [a] -> 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
"!#$%&*+./<=>?@\\^|-~"