{-# LANGUAGE CPP #-}
module Seminal.Enumerator.Types (enumerateChangeInType) where
import Seminal.Compiler.API
import Seminal.Enumerator.Enumerator (Enumerator)
import Seminal.Change (ChangeType(..), node, Change (Change, src, message), (<&&>), forceRewrite)
import Data.Functor ((<&>))
import Text.Printf (printf)
import Data.List.HT (splitEverywhere)
import Data.List (permutations)
enumerateChangeInType :: Enumerator (HsType GhcPs)
enumerateChangeInType :: Enumerator (HsType GhcPs)
enumerateChangeInType HsType GhcPs
typ SrcSpan
loc = (case HsType GhcPs
typ of
(HsTyVar {}) -> (([HsType GhcPs] -> [[HsType GhcPs]]
forall a. [a] -> [[a]]
permutations [HsType GhcPs
wildcardType, HsType GhcPs
typ]) [[HsType GhcPs]]
-> ([HsType GhcPs] -> Change (HsType GhcPs))
-> [Change (HsType GhcPs)]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (\[HsType GhcPs]
newPerm ->
let newFunTy :: HsType GhcPs
newFunTy = [HsType GhcPs] -> HsType GhcPs
typeListToHsFunTy [HsType GhcPs]
newPerm
message_ :: String
message_ = String
"A Type is missing." in ChangeNode (HsType GhcPs)
-> [ChangeNode (HsType GhcPs)]
-> SrcSpan
-> [Change (HsType GhcPs)]
-> String
-> ChangeType
-> Change (HsType GhcPs)
forall node.
ChangeNode node
-> [ChangeNode node]
-> SrcSpan
-> [Change node]
-> String
-> ChangeType
-> Change node
Change
(HsType GhcPs -> ChangeNode (HsType GhcPs)
forall n. Outputable n => n -> ChangeNode n
node HsType GhcPs
typ) [HsType GhcPs -> ChangeNode (HsType GhcPs)
forall n. Outputable n => n -> ChangeNode n
node HsType GhcPs
newFunTy] SrcSpan
loc
((Enumerator (HsType GhcPs)
enumerateChangeInType' HsType GhcPs
newFunTy SrcSpan
loc)
[Change (HsType GhcPs)]
-> (Change (HsType GhcPs) -> Change (HsType GhcPs))
-> [Change (HsType GhcPs)]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (\Change (HsType GhcPs)
c -> Change (HsType GhcPs)
c { src :: ChangeNode (HsType GhcPs)
src = HsType GhcPs -> ChangeNode (HsType GhcPs)
forall n. Outputable n => n -> ChangeNode n
node HsType GhcPs
typ, message :: String
message = String
message_ })
[Change (HsType GhcPs)]
-> (Change (HsType GhcPs) -> Change (HsType GhcPs))
-> [Change (HsType GhcPs)]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Change (HsType GhcPs) -> Change (HsType GhcPs)
forall node. Outputable node => Change node -> Change node
forceRewrite)
String
message_
ChangeType
Wildcard
))
HsType GhcPs
_ -> []) [Change (HsType GhcPs)]
-> [Change (HsType GhcPs)] -> [Change (HsType GhcPs)]
forall a. [a] -> [a] -> [a]
++ Enumerator (HsType GhcPs)
enumerateChangeInType' HsType GhcPs
typ SrcSpan
loc
enumerateChangeInType' :: Enumerator (HsType GhcPs)
enumerateChangeInType' :: Enumerator (HsType GhcPs)
enumerateChangeInType' HsType GhcPs
typ SrcSpan
loc = Change (HsType GhcPs)
ioWrapping Change (HsType GhcPs)
-> [Change (HsType GhcPs)] -> [Change (HsType GhcPs)]
forall a. a -> [a] -> [a]
: case HsType GhcPs
typ of
(HsTyVar XTyVar GhcPs
_ PromotionFlag
_ (L SrcSpanAnnN
_ RdrName
oldtype)) -> let
filteredAtomicTypes :: [HsType GhcPs]
filteredAtomicTypes = (HsType GhcPs -> Bool) -> [HsType GhcPs] -> [HsType GhcPs]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Bool -> Bool
not (Bool -> Bool) -> (SDoc -> Bool) -> SDoc -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SDoc -> SDoc -> Bool
eqSDoc (RdrName -> SDoc
forall a. Outputable a => a -> SDoc
ppr RdrName
oldtype)) (SDoc -> Bool) -> (HsType GhcPs -> SDoc) -> HsType GhcPs -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsType GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr) [HsType GhcPs]
atomicTypes
in ([HsType GhcPs]
filteredAtomicTypes [HsType GhcPs]
-> (HsType GhcPs -> Change (HsType GhcPs))
-> [Change (HsType GhcPs)]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (\HsType GhcPs
newType ->
ChangeNode (HsType GhcPs)
-> [ChangeNode (HsType GhcPs)]
-> SrcSpan
-> [Change (HsType GhcPs)]
-> String
-> ChangeType
-> Change (HsType GhcPs)
forall node.
ChangeNode node
-> [ChangeNode node]
-> SrcSpan
-> [Change node]
-> String
-> ChangeType
-> Change node
Change (HsType GhcPs -> ChangeNode (HsType GhcPs)
forall n. Outputable n => n -> ChangeNode n
node HsType GhcPs
typ) [HsType GhcPs -> ChangeNode (HsType GhcPs)
forall n. Outputable n => n -> ChangeNode n
node HsType GhcPs
newType] SrcSpan
loc []
(HsType GhcPs -> RdrName -> String
forall a b. (Outputable a, Outputable b) => a -> b -> String
formatMessage HsType GhcPs
newType RdrName
oldtype) ChangeType
Terminal
))
(HsAppTy XAppTy GhcPs
x LHsType GhcPs
lparent LHsType GhcPs
lchild) -> ([Change (HsType GhcPs)]
removeParent [Change (HsType GhcPs)]
-> [Change (HsType GhcPs)] -> [Change (HsType GhcPs)]
forall a. [a] -> [a] -> [a]
++ [Change (HsType GhcPs)]
monadSubstitutions [Change (HsType GhcPs)]
-> [Change (HsType GhcPs)] -> [Change (HsType GhcPs)]
forall a. [a] -> [a] -> [a]
++ [Change (HsType GhcPs)]
childEnumeration [Change (HsType GhcPs)]
-> [Change (HsType GhcPs)] -> [Change (HsType GhcPs)]
forall a. [a] -> [a] -> [a]
++ [Change (HsType GhcPs)]
swapChildren) [Change (HsType GhcPs)]
-> (Change (HsType GhcPs) -> Change (HsType GhcPs))
-> [Change (HsType GhcPs)]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Change (HsType GhcPs) -> Change (HsType GhcPs)
forall node. Outputable node => Change node -> Change node
forceRewrite
where
(L SrcSpanAnnA
lp HsType GhcPs
parent) = LHsType GhcPs
lparent
(L SrcSpanAnnA
_ HsType GhcPs
child) = LHsType GhcPs
lchild
filteredMonads :: [RdrName]
filteredMonads = (RdrName -> Bool) -> [RdrName] -> [RdrName]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Bool -> Bool
not (Bool -> Bool) -> (SDoc -> Bool) -> SDoc -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SDoc -> SDoc -> Bool
eqSDoc (HsType GhcPs -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsType GhcPs
monad)) (SDoc -> Bool) -> (RdrName -> SDoc) -> RdrName -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RdrName -> SDoc
forall a. Outputable a => a -> SDoc
ppr) [RdrName]
topMonads
monadSubstitutions :: [Change (HsType GhcPs)]
monadSubstitutions = RdrName -> HsType GhcPs
buildType (RdrName -> HsType GhcPs) -> [RdrName] -> [HsType GhcPs]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [RdrName]
filteredMonads [HsType GhcPs]
-> (HsType GhcPs -> Change (HsType GhcPs))
-> [Change (HsType GhcPs)]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (\HsType GhcPs
newM -> ChangeNode (HsType GhcPs)
-> [ChangeNode (HsType GhcPs)]
-> SrcSpan
-> [Change (HsType GhcPs)]
-> String
-> ChangeType
-> Change (HsType GhcPs)
forall node.
ChangeNode node
-> [ChangeNode node]
-> SrcSpan
-> [Change node]
-> String
-> ChangeType
-> Change node
Change
(HsType GhcPs -> ChangeNode (HsType GhcPs)
forall n. Outputable n => n -> ChangeNode n
node HsType GhcPs
typ) [HsType GhcPs -> ChangeNode (HsType GhcPs)
forall n. Outputable n => n -> ChangeNode n
node (HsType GhcPs -> ChangeNode (HsType GhcPs))
-> HsType GhcPs -> ChangeNode (HsType GhcPs)
forall a b. (a -> b) -> a -> b
$ XAppTy GhcPs -> LHsType GhcPs -> LHsType GhcPs -> HsType GhcPs
forall pass.
XAppTy pass -> LHsType pass -> LHsType pass -> HsType pass
HsAppTy XAppTy GhcPs
x (SrcSpanAnnA
-> HsType GhcPs -> GenLocated SrcSpanAnnA (HsType GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
lp HsType GhcPs
newM) LHsType GhcPs
lchild] SrcSpan
loc []
(HsType GhcPs -> HsType GhcPs -> String
forall a b. (Outputable a, Outputable b) => a -> b -> String
formatMessage HsType GhcPs
newM HsType GhcPs
parent)
ChangeType
Terminal
)
childEnumeration :: [Change (HsType GhcPs)]
childEnumeration = [[Change (HsType GhcPs)]] -> [Change (HsType GhcPs)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Change (HsType GhcPs)]] -> [Change (HsType GhcPs)])
-> [[Change (HsType GhcPs)]] -> [Change (HsType GhcPs)]
forall a b. (a -> b) -> a -> b
$ [HsType GhcPs] -> [([HsType GhcPs], HsType GhcPs, [HsType GhcPs])]
forall a. [a] -> [([a], a, [a])]
splitEverywhere [HsType GhcPs]
childrenTypes
[([HsType GhcPs], HsType GhcPs, [HsType GhcPs])]
-> (([HsType GhcPs], HsType GhcPs, [HsType GhcPs])
-> [Change (HsType GhcPs)])
-> [[Change (HsType GhcPs)]]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (\([HsType GhcPs]
h, HsType GhcPs
childType, [HsType GhcPs]
t) -> Enumerator (HsType GhcPs)
enumerateChangeInType' HsType GhcPs
childType SrcSpan
loc
[Change (HsType GhcPs)]
-> (HsType GhcPs -> [HsType GhcPs]) -> [Change [HsType GhcPs]]
forall a b. [Change a] -> (a -> b) -> [Change b]
<&&> (\HsType GhcPs
newChild -> (HsType GhcPs
monadHsType GhcPs -> [HsType GhcPs] -> [HsType GhcPs]
forall a. a -> [a] -> [a]
:[HsType GhcPs]
h [HsType GhcPs] -> [HsType GhcPs] -> [HsType GhcPs]
forall a. [a] -> [a] -> [a]
++ HsType GhcPs
newChildHsType GhcPs -> [HsType GhcPs] -> [HsType GhcPs]
forall a. a -> [a] -> [a]
:[HsType GhcPs]
t))
[Change [HsType GhcPs]]
-> ([HsType GhcPs] -> HsType GhcPs) -> [Change (HsType GhcPs)]
forall a b. [Change a] -> (a -> b) -> [Change b]
<&&> [HsType GhcPs] -> HsType GhcPs
typeListToHsAppTy
)
removeParent :: [Change (HsType GhcPs)]
removeParent = [
ChangeNode (HsType GhcPs)
-> [ChangeNode (HsType GhcPs)]
-> SrcSpan
-> [Change (HsType GhcPs)]
-> String
-> ChangeType
-> Change (HsType GhcPs)
forall node.
ChangeNode node
-> [ChangeNode node]
-> SrcSpan
-> [Change node]
-> String
-> ChangeType
-> Change node
Change (HsType GhcPs -> ChangeNode (HsType GhcPs)
forall n. Outputable n => n -> ChangeNode n
node HsType GhcPs
typ) [HsType GhcPs -> ChangeNode (HsType GhcPs)
forall n. Outputable n => n -> ChangeNode n
node HsType GhcPs
child] SrcSpan
loc [] ((HsType GhcPs -> HsType GhcPs -> String
forall a b. (Outputable a, Outputable b) => a -> b -> String
formatMessage HsType GhcPs
child HsType GhcPs
typ) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" Maybe you forgot to use `return`?") ChangeType
Terminal
| [HsType GhcPs] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [HsType GhcPs]
childrenTypes Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1]
swapChildren :: [Change (HsType GhcPs)]
swapChildren = if [HsType GhcPs] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [HsType GhcPs]
childrenTypes Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1
then (HsType GhcPs
monadHsType GhcPs -> [HsType GhcPs] -> [HsType GhcPs]
forall a. a -> [a] -> [a]
:) ([HsType GhcPs] -> [HsType GhcPs])
-> [[HsType GhcPs]] -> [[HsType GhcPs]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [HsType GhcPs] -> [[HsType GhcPs]]
forall a. [a] -> [[a]]
permutations [HsType GhcPs]
childrenTypes [[HsType GhcPs]]
-> ([HsType GhcPs] -> Change (HsType GhcPs))
-> [Change (HsType GhcPs)]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (\[HsType GhcPs]
permutation -> ChangeNode (HsType GhcPs)
-> [ChangeNode (HsType GhcPs)]
-> SrcSpan
-> [Change (HsType GhcPs)]
-> String
-> ChangeType
-> Change (HsType GhcPs)
forall node.
ChangeNode node
-> [ChangeNode node]
-> SrcSpan
-> [Change node]
-> String
-> ChangeType
-> Change node
Change
(HsType GhcPs -> ChangeNode (HsType GhcPs)
forall n. Outputable n => n -> ChangeNode n
node HsType GhcPs
typ)
[HsType GhcPs -> ChangeNode (HsType GhcPs)
forall n. Outputable n => n -> ChangeNode n
node (HsType GhcPs -> ChangeNode (HsType GhcPs))
-> HsType GhcPs -> ChangeNode (HsType GhcPs)
forall a b. (a -> b) -> a -> b
$ [HsType GhcPs] -> HsType GhcPs
typeListToHsAppTy [HsType GhcPs]
permutation] SrcSpan
loc []
String
"Wrong order of Type Argument." ChangeType
Terminal
)
else []
monad :: HsType GhcPs
monad = [HsType GhcPs] -> HsType GhcPs
forall a. HasCallStack => [a] -> a
head [HsType GhcPs]
typeList
childrenTypes :: [HsType GhcPs]
childrenTypes = [HsType GhcPs] -> [HsType GhcPs]
forall a. HasCallStack => [a] -> [a]
tail [HsType GhcPs]
typeList
typeList :: [HsType GhcPs]
typeList = (HsType GhcPs -> [HsType GhcPs]
hsAppTyToList HsType GhcPs
parent) [HsType GhcPs] -> [HsType GhcPs] -> [HsType GhcPs]
forall a. [a] -> [a] -> [a]
++ [HsType GhcPs
child]
(HsTupleTy XTupleTy GhcPs
_ HsTupleSort
_ []) -> [HsType GhcPs]
atomicTypes [HsType GhcPs]
-> (HsType GhcPs -> Change (HsType GhcPs))
-> [Change (HsType GhcPs)]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (\HsType GhcPs
newType ->
ChangeNode (HsType GhcPs)
-> [ChangeNode (HsType GhcPs)]
-> SrcSpan
-> [Change (HsType GhcPs)]
-> String
-> ChangeType
-> Change (HsType GhcPs)
forall node.
ChangeNode node
-> [ChangeNode node]
-> SrcSpan
-> [Change node]
-> String
-> ChangeType
-> Change node
Change (HsType GhcPs -> ChangeNode (HsType GhcPs)
forall n. Outputable n => n -> ChangeNode n
node HsType GhcPs
typ) [HsType GhcPs -> ChangeNode (HsType GhcPs)
forall n. Outputable n => n -> ChangeNode n
node HsType GhcPs
newType] SrcSpan
loc []
(HsType GhcPs -> HsType GhcPs -> String
forall a b. (Outputable a, Outputable b) => a -> b -> String
formatMessage HsType GhcPs
newType HsType GhcPs
typ) ChangeType
Terminal
)
(HsListTy XListTy GhcPs
xlist (L SrcSpanAnnA
lchild HsType GhcPs
child)) -> Change (HsType GhcPs)
bracketsRemoval Change (HsType GhcPs)
-> [Change (HsType GhcPs)] -> [Change (HsType GhcPs)]
forall a. a -> [a] -> [a]
: [Change (HsType GhcPs)]
childEnumeration
where
bracketsRemoval :: Change (HsType GhcPs)
bracketsRemoval = ChangeNode (HsType GhcPs)
-> [ChangeNode (HsType GhcPs)]
-> SrcSpan
-> [Change (HsType GhcPs)]
-> String
-> ChangeType
-> Change (HsType GhcPs)
forall node.
ChangeNode node
-> [ChangeNode node]
-> SrcSpan
-> [Change node]
-> String
-> ChangeType
-> Change node
Change (HsType GhcPs -> ChangeNode (HsType GhcPs)
forall n. Outputable n => n -> ChangeNode n
node HsType GhcPs
typ) [HsType GhcPs -> ChangeNode (HsType GhcPs)
forall n. Outputable n => n -> ChangeNode n
node HsType GhcPs
child] SrcSpan
loc []
((HsType GhcPs -> HsType GhcPs -> String
forall a b. (Outputable a, Outputable b) => a -> b -> String
formatMessage HsType GhcPs
child HsType GhcPs
typ) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" Maybe you forgot to remove the brackets.")
ChangeType
Wrapping
childEnumeration :: [Change (HsType GhcPs)]
childEnumeration = Enumerator (HsType GhcPs)
enumerateChangeInType' HsType GhcPs
child (SrcSpanAnnA -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
lchild)
[Change (HsType GhcPs)]
-> (HsType GhcPs -> HsType GhcPs) -> [Change (HsType GhcPs)]
forall a b. [Change a] -> (a -> b) -> [Change b]
<&&> (XListTy GhcPs -> LHsType GhcPs -> HsType GhcPs
forall pass. XListTy pass -> LHsType pass -> HsType pass
HsListTy XListTy GhcPs
xlist (GenLocated SrcSpanAnnA (HsType GhcPs) -> HsType GhcPs)
-> (HsType GhcPs -> GenLocated SrcSpanAnnA (HsType GhcPs))
-> HsType GhcPs
-> HsType GhcPs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpanAnnA
-> HsType GhcPs -> GenLocated SrcSpanAnnA (HsType GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
lchild)
[Change (HsType GhcPs)]
-> (Change (HsType GhcPs) -> Change (HsType GhcPs))
-> [Change (HsType GhcPs)]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Change (HsType GhcPs) -> Change (HsType GhcPs)
forall node. Outputable node => Change node -> Change node
forceRewrite
(HsParTy XParTy GhcPs
x (L SrcSpanAnnA
l HsType GhcPs
child)) -> Enumerator (HsType GhcPs)
enumerateChangeInType' HsType GhcPs
child (SrcSpanAnnA -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
l)
[Change (HsType GhcPs)]
-> (HsType GhcPs -> HsType GhcPs) -> [Change (HsType GhcPs)]
forall a b. [Change a] -> (a -> b) -> [Change b]
<&&> (XParTy GhcPs -> LHsType GhcPs -> HsType GhcPs
forall pass. XParTy pass -> LHsType pass -> HsType pass
HsParTy XParTy GhcPs
x (GenLocated SrcSpanAnnA (HsType GhcPs) -> HsType GhcPs)
-> (HsType GhcPs -> GenLocated SrcSpanAnnA (HsType GhcPs))
-> HsType GhcPs
-> HsType GhcPs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpanAnnA
-> HsType GhcPs -> GenLocated SrcSpanAnnA (HsType GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
l)
[Change (HsType GhcPs)]
-> (Change (HsType GhcPs) -> Change (HsType GhcPs))
-> [Change (HsType GhcPs)]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Change (HsType GhcPs) -> Change (HsType GhcPs)
forall node. Outputable node => Change node -> Change node
forceRewrite
(HsFunTy {}) -> [Change (HsType GhcPs)]
removals [Change (HsType GhcPs)]
-> [Change (HsType GhcPs)] -> [Change (HsType GhcPs)]
forall a. [a] -> [a] -> [a]
++ [Change (HsType GhcPs)]
insertions [Change (HsType GhcPs)]
-> [Change (HsType GhcPs)] -> [Change (HsType GhcPs)]
forall a. [a] -> [a] -> [a]
++ [Change (HsType GhcPs)]
swaps [Change (HsType GhcPs)]
-> [Change (HsType GhcPs)] -> [Change (HsType GhcPs)]
forall a. [a] -> [a] -> [a]
++ [Change (HsType GhcPs)]
childEnumerations
where
insertions :: [Change (HsType GhcPs)]
insertions = [HsType GhcPs] -> [([HsType GhcPs], HsType GhcPs, [HsType GhcPs])]
forall a. [a] -> [([a], a, [a])]
splitEverywhere [HsType GhcPs]
typeList
[([HsType GhcPs], HsType GhcPs, [HsType GhcPs])]
-> (([HsType GhcPs], HsType GhcPs, [HsType GhcPs])
-> Change (HsType GhcPs))
-> [Change (HsType GhcPs)]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (\([HsType GhcPs]
h, HsType GhcPs
child, [HsType GhcPs]
t) -> ChangeNode (HsType GhcPs)
-> [ChangeNode (HsType GhcPs)]
-> SrcSpan
-> [Change (HsType GhcPs)]
-> String
-> ChangeType
-> Change (HsType GhcPs)
forall node.
ChangeNode node
-> [ChangeNode node]
-> SrcSpan
-> [Change node]
-> String
-> ChangeType
-> Change node
Change
(HsType GhcPs -> ChangeNode (HsType GhcPs)
forall n. Outputable n => n -> ChangeNode n
node HsType GhcPs
typ)
[HsType GhcPs -> ChangeNode (HsType GhcPs)
forall n. Outputable n => n -> ChangeNode n
node (HsType GhcPs -> ChangeNode (HsType GhcPs))
-> HsType GhcPs -> ChangeNode (HsType GhcPs)
forall a b. (a -> b) -> a -> b
$ [HsType GhcPs] -> HsType GhcPs
typeListToHsFunTy ([HsType GhcPs]
h [HsType GhcPs] -> [HsType GhcPs] -> [HsType GhcPs]
forall a. [a] -> [a] -> [a]
++ [HsType GhcPs
child, HsType GhcPs
wildcardType] [HsType GhcPs] -> [HsType GhcPs] -> [HsType GhcPs]
forall a. [a] -> [a] -> [a]
++ [HsType GhcPs]
t)] SrcSpan
loc
([HsType GhcPs]
atomicTypes [HsType GhcPs]
-> (HsType GhcPs -> Change (HsType GhcPs))
-> [Change (HsType GhcPs)]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (\HsType GhcPs
newType -> ChangeNode (HsType GhcPs)
-> [ChangeNode (HsType GhcPs)]
-> SrcSpan
-> [Change (HsType GhcPs)]
-> String
-> ChangeType
-> Change (HsType GhcPs)
forall node.
ChangeNode node
-> [ChangeNode node]
-> SrcSpan
-> [Change node]
-> String
-> ChangeType
-> Change node
Change
(HsType GhcPs -> ChangeNode (HsType GhcPs)
forall n. Outputable n => n -> ChangeNode n
node HsType GhcPs
typ) [HsType GhcPs -> ChangeNode (HsType GhcPs)
forall n. Outputable n => n -> ChangeNode n
node (HsType GhcPs -> ChangeNode (HsType GhcPs))
-> HsType GhcPs -> ChangeNode (HsType GhcPs)
forall a b. (a -> b) -> a -> b
$ [HsType GhcPs] -> HsType GhcPs
typeListToHsFunTy ([HsType GhcPs]
h [HsType GhcPs] -> [HsType GhcPs] -> [HsType GhcPs]
forall a. [a] -> [a] -> [a]
++ [HsType GhcPs
child, HsType GhcPs
newType] [HsType GhcPs] -> [HsType GhcPs] -> [HsType GhcPs]
forall a. [a] -> [a] -> [a]
++ [HsType GhcPs]
t)] SrcSpan
loc []
(String -> String -> String
forall r. PrintfType r => String -> r
printf String
"A Type is missing: %s" (HsType GhcPs -> String
forall a. Outputable a => a -> String
showPprUnsafe HsType GhcPs
newType))
ChangeType
Terminal
))
String
"A Type is missing." ChangeType
Terminal
)
childEnumerations :: [Change (HsType GhcPs)]
childEnumerations = [[Change (HsType GhcPs)]] -> [Change (HsType GhcPs)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Change (HsType GhcPs)]] -> [Change (HsType GhcPs)])
-> [[Change (HsType GhcPs)]] -> [Change (HsType GhcPs)]
forall a b. (a -> b) -> a -> b
$ [HsType GhcPs] -> [([HsType GhcPs], HsType GhcPs, [HsType GhcPs])]
forall a. [a] -> [([a], a, [a])]
splitEverywhere [HsType GhcPs]
typeList
[([HsType GhcPs], HsType GhcPs, [HsType GhcPs])]
-> (([HsType GhcPs], HsType GhcPs, [HsType GhcPs])
-> [Change (HsType GhcPs)])
-> [[Change (HsType GhcPs)]]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (\([HsType GhcPs]
h, HsType GhcPs
child, [HsType GhcPs]
t) -> Enumerator (HsType GhcPs)
enumerateChangeInType' HsType GhcPs
child SrcSpan
loc
[Change (HsType GhcPs)]
-> (HsType GhcPs -> HsType GhcPs) -> [Change (HsType GhcPs)]
forall a b. [Change a] -> (a -> b) -> [Change b]
<&&> (\HsType GhcPs
newChild -> [HsType GhcPs] -> HsType GhcPs
typeListToHsFunTy ([HsType GhcPs] -> HsType GhcPs) -> [HsType GhcPs] -> HsType GhcPs
forall a b. (a -> b) -> a -> b
$ [HsType GhcPs]
h [HsType GhcPs] -> [HsType GhcPs] -> [HsType GhcPs]
forall a. [a] -> [a] -> [a]
++ [HsType GhcPs
newChild] [HsType GhcPs] -> [HsType GhcPs] -> [HsType GhcPs]
forall a. [a] -> [a] -> [a]
++ [HsType GhcPs]
t))
swaps :: [Change (HsType GhcPs)]
swaps = let filteredSwaps :: [[HsType GhcPs]]
filteredSwaps = ([HsType GhcPs] -> Bool) -> [[HsType GhcPs]] -> [[HsType GhcPs]]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Bool -> Bool
not (Bool -> Bool) -> (SDoc -> Bool) -> SDoc -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SDoc -> SDoc -> Bool
eqSDoc ([HsType GhcPs] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [HsType GhcPs]
typeList)) (SDoc -> Bool)
-> ([HsType GhcPs] -> SDoc) -> [HsType GhcPs] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [HsType GhcPs] -> SDoc
forall a. Outputable a => a -> SDoc
ppr) ([HsType GhcPs] -> [[HsType GhcPs]]
forall a. [a] -> [[a]]
permutations [HsType GhcPs]
typeList) in
[[HsType GhcPs]]
filteredSwaps [[HsType GhcPs]]
-> ([HsType GhcPs] -> Change (HsType GhcPs))
-> [Change (HsType GhcPs)]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (\[HsType GhcPs]
newType -> ChangeNode (HsType GhcPs)
-> [ChangeNode (HsType GhcPs)]
-> SrcSpan
-> [Change (HsType GhcPs)]
-> String
-> ChangeType
-> Change (HsType GhcPs)
forall node.
ChangeNode node
-> [ChangeNode node]
-> SrcSpan
-> [Change node]
-> String
-> ChangeType
-> Change node
Change
(HsType GhcPs -> ChangeNode (HsType GhcPs)
forall n. Outputable n => n -> ChangeNode n
node HsType GhcPs
typ)
[HsType GhcPs -> ChangeNode (HsType GhcPs)
forall n. Outputable n => n -> ChangeNode n
node (HsType GhcPs -> ChangeNode (HsType GhcPs))
-> HsType GhcPs -> ChangeNode (HsType GhcPs)
forall a b. (a -> b) -> a -> b
$ [HsType GhcPs] -> HsType GhcPs
typeListToHsFunTy [HsType GhcPs]
newType] SrcSpan
loc []
String
"The order of the types is wrong" ChangeType
Terminal
)
removals :: [Change (HsType GhcPs)]
removals = [HsType GhcPs] -> [([HsType GhcPs], HsType GhcPs, [HsType GhcPs])]
forall a. [a] -> [([a], a, [a])]
splitEverywhere [HsType GhcPs]
typeList [([HsType GhcPs], HsType GhcPs, [HsType GhcPs])]
-> (([HsType GhcPs], HsType GhcPs, [HsType GhcPs])
-> Change (HsType GhcPs))
-> [Change (HsType GhcPs)]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (\([HsType GhcPs]
h, HsType GhcPs
_, [HsType GhcPs]
t) -> ChangeNode (HsType GhcPs)
-> [ChangeNode (HsType GhcPs)]
-> SrcSpan
-> [Change (HsType GhcPs)]
-> String
-> ChangeType
-> Change (HsType GhcPs)
forall node.
ChangeNode node
-> [ChangeNode node]
-> SrcSpan
-> [Change node]
-> String
-> ChangeType
-> Change node
Change
(HsType GhcPs -> ChangeNode (HsType GhcPs)
forall n. Outputable n => n -> ChangeNode n
node HsType GhcPs
typ)
[HsType GhcPs -> ChangeNode (HsType GhcPs)
forall n. Outputable n => n -> ChangeNode n
node (HsType GhcPs -> ChangeNode (HsType GhcPs))
-> HsType GhcPs -> ChangeNode (HsType GhcPs)
forall a b. (a -> b) -> a -> b
$ [HsType GhcPs] -> HsType GhcPs
typeListToHsFunTy ([HsType GhcPs]
h [HsType GhcPs] -> [HsType GhcPs] -> [HsType GhcPs]
forall a. [a] -> [a] -> [a]
++ [HsType GhcPs]
t)] SrcSpan
loc []
String
"The removed Type is superfluous. Please, remove it." ChangeType
Terminal
)
typeList :: [HsType GhcPs]
typeList = HsType GhcPs -> [HsType GhcPs]
hsFunTyToList HsType GhcPs
typ
(HsWildCardTy XWildCardTy GhcPs
_) -> ([HsType GhcPs]
atomicTypes [HsType GhcPs]
-> (HsType GhcPs -> Change (HsType GhcPs))
-> [Change (HsType GhcPs)]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (\HsType GhcPs
newType ->
ChangeNode (HsType GhcPs)
-> [ChangeNode (HsType GhcPs)]
-> SrcSpan
-> [Change (HsType GhcPs)]
-> String
-> ChangeType
-> Change (HsType GhcPs)
forall node.
ChangeNode node
-> [ChangeNode node]
-> SrcSpan
-> [Change node]
-> String
-> ChangeType
-> Change node
Change (HsType GhcPs -> ChangeNode (HsType GhcPs)
forall n. Outputable n => n -> ChangeNode n
node HsType GhcPs
typ) [HsType GhcPs -> ChangeNode (HsType GhcPs)
forall n. Outputable n => n -> ChangeNode n
node HsType GhcPs
newType] SrcSpan
loc []
(HsType GhcPs -> HsType GhcPs -> String
forall a b. (Outputable a, Outputable b) => a -> b -> String
formatMessage HsType GhcPs
newType HsType GhcPs
typ) ChangeType
Terminal
))
HsType GhcPs
_ -> []
where
ioWrapping :: Change (HsType GhcPs)
ioWrapping = ChangeNode (HsType GhcPs)
-> [ChangeNode (HsType GhcPs)]
-> SrcSpan
-> [Change (HsType GhcPs)]
-> String
-> ChangeType
-> Change (HsType GhcPs)
forall node.
ChangeNode node
-> [ChangeNode node]
-> SrcSpan
-> [Change node]
-> String
-> ChangeType
-> Change node
Change
(HsType GhcPs -> ChangeNode (HsType GhcPs)
forall n. Outputable n => n -> ChangeNode n
node HsType GhcPs
typ)
[HsType GhcPs -> ChangeNode (HsType GhcPs)
forall n. Outputable n => n -> ChangeNode n
node (XAppTy GhcPs -> LHsType GhcPs -> LHsType GhcPs -> HsType GhcPs
forall pass.
XAppTy pass -> LHsType pass -> LHsType pass -> HsType pass
HsAppTy XAppTy GhcPs
NoExtField
NoExtField (HsType GhcPs -> GenLocated SrcSpanAnnA (HsType GhcPs)
forall a an. a -> LocatedAn an a
noLocA (HsType GhcPs -> GenLocated SrcSpanAnnA (HsType GhcPs))
-> HsType GhcPs -> GenLocated SrcSpanAnnA (HsType GhcPs)
forall a b. (a -> b) -> a -> b
$ String -> HsType GhcPs
buildTypeStr String
"IO") (HsType GhcPs -> GenLocated SrcSpanAnnA (HsType GhcPs)
forall a an. a -> LocatedAn an a
noLocA HsType GhcPs
typ))]
SrcSpan
loc []
String
"The type was not wrapped with IO." ChangeType
Terminal
atomicTypes :: [HsType GhcPs]
atomicTypes :: [HsType GhcPs]
atomicTypes = HsType GhcPs
unitType HsType GhcPs -> [HsType GhcPs] -> [HsType GhcPs]
forall a. a -> [a] -> [a]
: (String -> HsType GhcPs
buildTypeStr (String -> HsType GhcPs) -> [String] -> [HsType GhcPs]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [
String
"Double",
String
"Float",
String
"Integer",
String
"Int",
String
"Char",
String
"String",
String
"Bool"
])
topMonads :: [RdrName]
topMonads :: [RdrName]
topMonads = (OccName -> RdrName
mkRdrUnqual (OccName -> RdrName) -> (String -> OccName) -> String -> RdrName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> OccName
mkTcOcc) (String -> RdrName) -> [String] -> [RdrName]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [
String
"IO",
String
"Maybe"
]
unitType :: HsType GhcPs
unitType :: HsType GhcPs
unitType = XTupleTy GhcPs -> HsTupleSort -> [LHsType GhcPs] -> HsType GhcPs
forall pass.
XTupleTy pass -> HsTupleSort -> [LHsType pass] -> HsType pass
HsTupleTy XTupleTy GhcPs
EpAnn AnnParen
forall ann. EpAnn ann
EpAnnNotUsed HsTupleSort
HsBoxedOrConstraintTuple []
buildType :: RdrName -> HsType GhcPs
buildType :: RdrName -> HsType GhcPs
buildType = XTyVar GhcPs -> PromotionFlag -> LIdP GhcPs -> HsType GhcPs
forall pass.
XTyVar pass -> PromotionFlag -> LIdP pass -> HsType pass
HsTyVar XTyVar GhcPs
EpAnn [AddEpAnn]
forall ann. EpAnn ann
EpAnnNotUsed PromotionFlag
NotPromoted (GenLocated SrcSpanAnnN RdrName -> HsType GhcPs)
-> (RdrName -> GenLocated SrcSpanAnnN RdrName)
-> RdrName
-> HsType GhcPs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RdrName -> GenLocated SrcSpanAnnN RdrName
forall a an. a -> LocatedAn an a
noLocA
buildTypeStr :: String -> HsType GhcPs
buildTypeStr :: String -> HsType GhcPs
buildTypeStr = XTyVar GhcPs -> PromotionFlag -> LIdP GhcPs -> HsType GhcPs
forall pass.
XTyVar pass -> PromotionFlag -> LIdP pass -> HsType pass
HsTyVar XTyVar GhcPs
EpAnn [AddEpAnn]
forall ann. EpAnn ann
EpAnnNotUsed PromotionFlag
NotPromoted (GenLocated SrcSpanAnnN RdrName -> HsType GhcPs)
-> (String -> GenLocated SrcSpanAnnN RdrName)
-> String
-> HsType GhcPs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RdrName -> GenLocated SrcSpanAnnN RdrName
forall a an. a -> LocatedAn an a
noLocA (RdrName -> GenLocated SrcSpanAnnN RdrName)
-> (String -> RdrName) -> String -> GenLocated SrcSpanAnnN RdrName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OccName -> RdrName
mkRdrUnqual (OccName -> RdrName) -> (String -> OccName) -> String -> RdrName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> OccName
mkTcOcc
formatMessage :: Outputable a => Outputable b => a -> b -> String
formatMessage :: forall a b. (Outputable a, Outputable b) => a -> b -> String
formatMessage a
expected b
got = String -> String -> String -> String
forall r. PrintfType r => String -> r
printf
String
"Expected Type `%s`, got `%s`."
(a -> String
forall a. Outputable a => a -> String
showPprUnsafe a
expected) (b -> String
forall a. Outputable a => a -> String
showPprUnsafe b
got)
hsAppTyToList :: (HsType GhcPs) -> [HsType GhcPs]
hsAppTyToList :: HsType GhcPs -> [HsType GhcPs]
hsAppTyToList (HsAppTy XAppTy GhcPs
_ (L SrcSpanAnnA
_ HsType GhcPs
func) (L SrcSpanAnnA
_ HsType GhcPs
param)) = HsType GhcPs -> [HsType GhcPs]
hsAppTyToList HsType GhcPs
func [HsType GhcPs] -> [HsType GhcPs] -> [HsType GhcPs]
forall a. [a] -> [a] -> [a]
++ [HsType GhcPs
param]
hsAppTyToList HsType GhcPs
e = [HsType GhcPs
e]
typeListToHsAppTy :: [HsType GhcPs] -> (HsType GhcPs)
typeListToHsAppTy :: [HsType GhcPs] -> HsType GhcPs
typeListToHsAppTy [] = HsType GhcPs
forall a. HasCallStack => a
undefined
typeListToHsAppTy [HsType GhcPs
e] = HsType GhcPs
e
typeListToHsAppTy [HsType GhcPs
f, HsType GhcPs
p] = XAppTy GhcPs -> LHsType GhcPs -> LHsType GhcPs -> HsType GhcPs
forall pass.
XAppTy pass -> LHsType pass -> LHsType pass -> HsType pass
HsAppTy XAppTy GhcPs
NoExtField
NoExtField (Located (HsType GhcPs) -> GenLocated SrcSpanAnnA (HsType GhcPs)
forall e ann. Located e -> LocatedAn ann e
reLocA (Located (HsType GhcPs) -> GenLocated SrcSpanAnnA (HsType GhcPs))
-> Located (HsType GhcPs) -> GenLocated SrcSpanAnnA (HsType GhcPs)
forall a b. (a -> b) -> a -> b
$ HsType GhcPs -> Located (HsType GhcPs)
forall e. e -> Located e
noLoc HsType GhcPs
f) (Located (HsType GhcPs) -> GenLocated SrcSpanAnnA (HsType GhcPs)
forall e ann. Located e -> LocatedAn ann e
reLocA (Located (HsType GhcPs) -> GenLocated SrcSpanAnnA (HsType GhcPs))
-> Located (HsType GhcPs) -> GenLocated SrcSpanAnnA (HsType GhcPs)
forall a b. (a -> b) -> a -> b
$ HsType GhcPs -> Located (HsType GhcPs)
forall e. e -> Located e
noLoc HsType GhcPs
p)
typeListToHsAppTy [HsType GhcPs]
list = XAppTy GhcPs -> LHsType GhcPs -> LHsType GhcPs -> HsType GhcPs
forall pass.
XAppTy pass -> LHsType pass -> LHsType pass -> HsType pass
HsAppTy XAppTy GhcPs
NoExtField
NoExtField (Located (HsType GhcPs) -> GenLocated SrcSpanAnnA (HsType GhcPs)
forall e ann. Located e -> LocatedAn ann e
reLocA (Located (HsType GhcPs) -> GenLocated SrcSpanAnnA (HsType GhcPs))
-> Located (HsType GhcPs) -> GenLocated SrcSpanAnnA (HsType GhcPs)
forall a b. (a -> b) -> a -> b
$ HsType GhcPs -> Located (HsType GhcPs)
forall e. e -> Located e
noLoc (HsType GhcPs -> Located (HsType GhcPs))
-> HsType GhcPs -> Located (HsType GhcPs)
forall a b. (a -> b) -> a -> b
$ [HsType GhcPs] -> HsType GhcPs
typeListToHsAppTy ([HsType GhcPs] -> [HsType GhcPs]
forall a. HasCallStack => [a] -> [a]
init [HsType GhcPs]
list)) (Located (HsType GhcPs) -> GenLocated SrcSpanAnnA (HsType GhcPs)
forall e ann. Located e -> LocatedAn ann e
reLocA (Located (HsType GhcPs) -> GenLocated SrcSpanAnnA (HsType GhcPs))
-> Located (HsType GhcPs) -> GenLocated SrcSpanAnnA (HsType GhcPs)
forall a b. (a -> b) -> a -> b
$ HsType GhcPs -> Located (HsType GhcPs)
forall e. e -> Located e
noLoc (HsType GhcPs -> Located (HsType GhcPs))
-> HsType GhcPs -> Located (HsType GhcPs)
forall a b. (a -> b) -> a -> b
$ [HsType GhcPs] -> HsType GhcPs
forall a. HasCallStack => [a] -> a
last [HsType GhcPs]
list)
hsFunTyToList :: (HsType GhcPs) -> [HsType GhcPs]
hsFunTyToList :: HsType GhcPs -> [HsType GhcPs]
hsFunTyToList (HsFunTy XFunTy GhcPs
_ HsArrow GhcPs
_ (L SrcSpanAnnA
_ HsType GhcPs
left) (L SrcSpanAnnA
_ HsType GhcPs
right)) = HsType GhcPs
leftHsType GhcPs -> [HsType GhcPs] -> [HsType GhcPs]
forall a. a -> [a] -> [a]
:HsType GhcPs -> [HsType GhcPs]
hsFunTyToList HsType GhcPs
right
hsFunTyToList HsType GhcPs
e = [HsType GhcPs
e]
wildcardType :: HsType GhcPs
wildcardType :: HsType GhcPs
wildcardType = XWildCardTy GhcPs -> HsType GhcPs
forall pass. XWildCardTy pass -> HsType pass
HsWildCardTy XWildCardTy GhcPs
NoExtField
NoExtField
typeListToHsFunTy :: [HsType GhcPs] -> (HsType GhcPs)
typeListToHsFunTy :: [HsType GhcPs] -> HsType GhcPs
typeListToHsFunTy [] = HsType GhcPs
forall a. HasCallStack => a
undefined
typeListToHsFunTy [HsType GhcPs
e] = HsType GhcPs
e
typeListToHsFunTy (HsType GhcPs
left:[HsType GhcPs]
right) = XFunTy GhcPs
-> HsArrow GhcPs -> LHsType GhcPs -> LHsType GhcPs -> HsType GhcPs
forall pass.
XFunTy pass
-> HsArrow pass -> LHsType pass -> LHsType pass -> HsType pass
HsFunTy XFunTy GhcPs
EpAnn NoEpAnns
forall ann. EpAnn ann
EpAnnNotUsed
#if MIN_VERSION_ghc(9,4,1)
(LHsUniToken "->" "\8594" GhcPs -> HsArrow GhcPs
forall pass. LHsUniToken "->" "\8594" pass -> HsArrow pass
HsUnrestrictedArrow (LHsUniToken "->" "\8594" GhcPs -> HsArrow GhcPs)
-> LHsUniToken "->" "\8594" GhcPs -> HsArrow GhcPs
forall a b. (a -> b) -> a -> b
$ TokenLocation
-> HsUniToken "->" "\8594"
-> GenLocated TokenLocation (HsUniToken "->" "\8594")
forall l e. l -> e -> GenLocated l e
L TokenLocation
NoTokenLoc HsUniToken "->" "\8594"
forall (tok :: Symbol) (utok :: Symbol). HsUniToken tok utok
HsUnicodeTok)
#else
(HsUnrestrictedArrow UnicodeSyntax)
#endif
(HsType GhcPs -> GenLocated SrcSpanAnnA (HsType GhcPs)
forall a an. a -> LocatedAn an a
noLocA HsType GhcPs
left) (HsType GhcPs -> GenLocated SrcSpanAnnA (HsType GhcPs)
forall a an. a -> LocatedAn an a
noLocA ([HsType GhcPs] -> HsType GhcPs
typeListToHsFunTy [HsType GhcPs]
right))