{-# LANGUAGE RecordWildCards #-}
{-# 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
type QualifiedName = String
data RewriteSpec
= Adhoc String
| AdhocPattern String
| AdhocType String
| Fold QualifiedName
| RuleBackward QualifiedName
| RuleForward QualifiedName
| TypeBackward QualifiedName
| TypeForward QualifiedName
| Unfold QualifiedName
| PatternForward QualifiedName
| PatternBackward QualifiedName
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
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
( 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)
where
symbols :: String
symbols :: String
symbols = String
"!#$%&*+./<=>?@\\^|-~"