{-# LANGUAGE DeriveDataTypeable #-}
module Seminal.Change (Change(..), node, getNode, ChangeNode(pretty), (<$$>), (<&&>), Seminal.Change.show, Seminal.Change.showWithMessage, ChangeType(..), changeTypes, forceRewrite) where

import Seminal.Compiler.API
import Text.Printf (printf)
import Data.Data (dataTypeConstrs, Data (dataTypeOf), showConstr)
type ChangeLocation = SrcSpan

-- | Sub-data, that could be either the original node, or the change 
data ChangeNode nodeType = ChangeNode {
    -- | The AST node
    forall nodeType. ChangeNode nodeType -> nodeType
astNode :: nodeType,
    -- | Pretty-print of the node
    forall nodeType. ChangeNode nodeType -> SDoc
pretty :: SDoc
}

instance Functor ChangeNode where
    fmap :: forall a b. (a -> b) -> ChangeNode a -> ChangeNode b
fmap a -> b
f ChangeNode a
n = ChangeNode a
n { astNode :: b
astNode = a -> b
f (ChangeNode a -> a
forall nodeType. ChangeNode nodeType -> nodeType
astNode ChangeNode a
n) }

-- | Builds `ChangeNode` from an AST node
node :: (Outputable n) => n -> ChangeNode n
node :: forall n. Outputable n => n -> ChangeNode n
node n
n = n -> SDoc -> ChangeNode n
forall nodeType. nodeType -> SDoc -> ChangeNode nodeType
ChangeNode n
n (n -> SDoc
forall a. Outputable a => a -> SDoc
ppr n
n)

getNode :: ChangeNode n -> n
getNode :: forall nodeType. ChangeNode nodeType -> nodeType
getNode = ChangeNode n -> n
forall nodeType. ChangeNode nodeType -> nodeType
astNode

-- | Defines a change to apply on the AST.
-- The namings are inspired by the `astRepl` (Seminal, 2006, p. 5)
data Change node = Change {
    forall node. Change node -> ChangeNode node
src :: ChangeNode node,
    -- | Run the change, returns the new node
    forall node. Change node -> [ChangeNode node]
exec :: [ChangeNode node],
    forall node. Change node -> ChangeLocation
location :: ChangeLocation,
    -- | List of subsequent changes to consider, if the `change` typechecks
    forall node. Change node -> [Change node]
followups :: [Change node],
    -- | A User-friendly message to explain why the change worked
    forall node. Change node -> String
message :: String,
    -- | Allows ranking the changes.
    forall node. Change node -> ChangeType
category :: ChangeType
}

instance Functor Change where
    fmap :: forall a b. (a -> b) -> Change a -> Change b
fmap a -> b
f Change a
c = Change a
c {
        src :: ChangeNode b
src = a -> b
f (a -> b) -> ChangeNode a -> ChangeNode b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Change a -> ChangeNode a
forall node. Change node -> ChangeNode node
src Change a
c,
        exec :: [ChangeNode b]
exec = (a -> b) -> ChangeNode a -> ChangeNode b
forall a b. (a -> b) -> ChangeNode a -> ChangeNode b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f (ChangeNode a -> ChangeNode b) -> [ChangeNode a] -> [ChangeNode b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Change a -> [ChangeNode a]
forall node. Change node -> [ChangeNode node]
exec Change a
c,
        followups :: [Change b]
followups = (a -> b) -> Change a -> Change b
forall a b. (a -> b) -> Change a -> Change b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f (Change a -> Change b) -> [Change a] -> [Change b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Change a -> [Change a]
forall node. Change node -> [Change node]
followups Change a
c
    }

forceRewrite :: Outputable node => Change node -> Change node
forceRewrite :: forall node. Outputable node => Change node -> Change node
forceRewrite Change node
change = Change node
change { 
    src :: ChangeNode node
src = node -> ChangeNode node
forall n. Outputable n => n -> ChangeNode n
node (node -> ChangeNode node)
-> (ChangeNode node -> node) -> ChangeNode node -> ChangeNode node
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChangeNode node -> node
forall nodeType. ChangeNode nodeType -> nodeType
getNode (ChangeNode node -> ChangeNode node)
-> ChangeNode node -> ChangeNode node
forall a b. (a -> b) -> a -> b
$ Change node -> ChangeNode node
forall node. Change node -> ChangeNode node
src Change node
change,
    exec :: [ChangeNode node]
exec = node -> ChangeNode node
forall n. Outputable n => n -> ChangeNode n
node (node -> ChangeNode node)
-> (ChangeNode node -> node) -> ChangeNode node -> ChangeNode node
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChangeNode node -> node
forall nodeType. ChangeNode nodeType -> nodeType
getNode (ChangeNode node -> ChangeNode node)
-> [ChangeNode node] -> [ChangeNode node]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Change node -> [ChangeNode node]
forall node. Change node -> [ChangeNode node]
exec Change node
change,
    followups :: [Change node]
followups = Change node -> Change node
forall node. Outputable node => Change node -> Change node
forceRewrite (Change node -> Change node) -> [Change node] -> [Change node]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Change node -> [Change node]
forall node. Change node -> [Change node]
followups Change node
change
} 

(<$$>) :: (a -> b) -> [Change a]  -> [Change b]
a -> b
f <$$> :: forall a b. (a -> b) -> [Change a] -> [Change b]
<$$> [Change a]
list = (a -> b) -> Change a -> Change b
forall a b. (a -> b) -> Change a -> Change b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f (Change a -> Change b) -> [Change a] -> [Change b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Change a]
list

(<&&>) :: [Change a] -> (a -> b) -> [Change b]
<&&> :: forall a b. [Change a] -> (a -> b) -> [Change b]
(<&&>) = ((a -> b) -> [Change a] -> [Change b])
-> [Change a] -> (a -> b) -> [Change b]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (a -> b) -> [Change a] -> [Change b]
forall a b. (a -> b) -> [Change a] -> [Change b]
(<$$>)

show :: ChangeNode node -> ChangeNode node -> ChangeLocation -> String
show :: forall node.
ChangeNode node -> ChangeNode node -> ChangeLocation -> String
show ChangeNode node
src_ ChangeNode node
exec_ ChangeLocation
loc  = String -> String -> String -> String -> String
forall r. PrintfType r => String -> r
printf String
"%s:\nReplace\t`%s`\nwith\t`%s`"
    (ChangeLocation -> String
forall a. Outputable a => a -> String
showPprUnsafe ChangeLocation
loc)
    (SDoc -> String
forall a. Outputable a => a -> String
showPprUnsafe (SDoc -> String) -> SDoc -> String
forall a b. (a -> b) -> a -> b
$ ChangeNode node -> SDoc
forall nodeType. ChangeNode nodeType -> SDoc
pretty ChangeNode node
src_)
    (SDoc -> String
forall a. Outputable a => a -> String
showPprUnsafe (SDoc -> String) -> SDoc -> String
forall a b. (a -> b) -> a -> b
$ ChangeNode node -> SDoc
forall nodeType. ChangeNode nodeType -> SDoc
pretty ChangeNode node
exec_)

showWithMessage :: ChangeNode node -> ChangeNode node -> ChangeLocation -> String -> String
showWithMessage :: forall node.
ChangeNode node
-> ChangeNode node -> ChangeLocation -> String -> String
showWithMessage ChangeNode node
src_ ChangeNode node
exec_ ChangeLocation
loc String
message_  = ChangeNode node -> ChangeNode node -> ChangeLocation -> String
forall node.
ChangeNode node -> ChangeNode node -> ChangeLocation -> String
Seminal.Change.show ChangeNode node
src_ ChangeNode node
exec_ ChangeLocation
loc String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\nReason: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
message_

-- | Categories of changes, that allow ordering them
data ChangeType =
    -- | The Change basically replaces the node with a wildcard.
    -- It is not a conclusive change
    Wildcard |
    -- | A Change that consist in removing a value
    Removal |
    -- | A Change that consist of wrapping the actual value
    -- E.g. `show`
    Wrapping |
    -- | The Change is good enough to terminate the search and/or
    -- be presented to the user as if
    Terminal |
    -- We add *something* in the AST to make things work.
    -- This addition is usually a wildcard, making the change not very usefull
    Addition
    deriving (ChangeType -> ChangeType -> Bool
(ChangeType -> ChangeType -> Bool)
-> (ChangeType -> ChangeType -> Bool) -> Eq ChangeType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ChangeType -> ChangeType -> Bool
== :: ChangeType -> ChangeType -> Bool
$c/= :: ChangeType -> ChangeType -> Bool
/= :: ChangeType -> ChangeType -> Bool
Eq, Int -> ChangeType -> String -> String
[ChangeType] -> String -> String
ChangeType -> String
(Int -> ChangeType -> String -> String)
-> (ChangeType -> String)
-> ([ChangeType] -> String -> String)
-> Show ChangeType
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> ChangeType -> String -> String
showsPrec :: Int -> ChangeType -> String -> String
$cshow :: ChangeType -> String
show :: ChangeType -> String
$cshowList :: [ChangeType] -> String -> String
showList :: [ChangeType] -> String -> String
Show, ReadPrec [ChangeType]
ReadPrec ChangeType
Int -> ReadS ChangeType
ReadS [ChangeType]
(Int -> ReadS ChangeType)
-> ReadS [ChangeType]
-> ReadPrec ChangeType
-> ReadPrec [ChangeType]
-> Read ChangeType
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS ChangeType
readsPrec :: Int -> ReadS ChangeType
$creadList :: ReadS [ChangeType]
readList :: ReadS [ChangeType]
$creadPrec :: ReadPrec ChangeType
readPrec :: ReadPrec ChangeType
$creadListPrec :: ReadPrec [ChangeType]
readListPrec :: ReadPrec [ChangeType]
Read, Typeable ChangeType
Typeable ChangeType
-> (forall (c :: * -> *).
    (forall d b. Data d => c (d -> b) -> d -> c b)
    -> (forall g. g -> c g) -> ChangeType -> c ChangeType)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c ChangeType)
-> (ChangeType -> Constr)
-> (ChangeType -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c ChangeType))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e))
    -> Maybe (c ChangeType))
-> ((forall b. Data b => b -> b) -> ChangeType -> ChangeType)
-> (forall r r'.
    (r -> r' -> r)
    -> r -> (forall d. Data d => d -> r') -> ChangeType -> r)
-> (forall r r'.
    (r' -> r -> r)
    -> r -> (forall d. Data d => d -> r') -> ChangeType -> r)
-> (forall u. (forall d. Data d => d -> u) -> ChangeType -> [u])
-> (forall u.
    Int -> (forall d. Data d => d -> u) -> ChangeType -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> ChangeType -> m ChangeType)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> ChangeType -> m ChangeType)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> ChangeType -> m ChangeType)
-> Data ChangeType
ChangeType -> Constr
ChangeType -> DataType
(forall b. Data b => b -> b) -> ChangeType -> ChangeType
forall a.
Typeable a
-> (forall (c :: * -> *).
    (forall d b. Data d => c (d -> b) -> d -> c b)
    -> (forall g. g -> c g) -> a -> c a)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c a)
-> (a -> Constr)
-> (a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c a))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
-> ((forall b. Data b => b -> b) -> a -> a)
-> (forall r r'.
    (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall r r'.
    (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall u. (forall d. Data d => d -> u) -> a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> a -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> Data a
forall u. Int -> (forall d. Data d => d -> u) -> ChangeType -> u
forall u. (forall d. Data d => d -> u) -> ChangeType -> [u]
forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> ChangeType -> r
forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> ChangeType -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> ChangeType -> m ChangeType
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> ChangeType -> m ChangeType
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c ChangeType
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> ChangeType -> c ChangeType
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c ChangeType)
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c ChangeType)
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> ChangeType -> c ChangeType
gfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> ChangeType -> c ChangeType
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c ChangeType
gunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c ChangeType
$ctoConstr :: ChangeType -> Constr
toConstr :: ChangeType -> Constr
$cdataTypeOf :: ChangeType -> DataType
dataTypeOf :: ChangeType -> DataType
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c ChangeType)
dataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c ChangeType)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c ChangeType)
dataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c ChangeType)
$cgmapT :: (forall b. Data b => b -> b) -> ChangeType -> ChangeType
gmapT :: (forall b. Data b => b -> b) -> ChangeType -> ChangeType
$cgmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> ChangeType -> r
gmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> ChangeType -> r
$cgmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> ChangeType -> r
gmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> ChangeType -> r
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> ChangeType -> [u]
gmapQ :: forall u. (forall d. Data d => d -> u) -> ChangeType -> [u]
$cgmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> ChangeType -> u
gmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> ChangeType -> u
$cgmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> ChangeType -> m ChangeType
gmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> ChangeType -> m ChangeType
$cgmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> ChangeType -> m ChangeType
gmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> ChangeType -> m ChangeType
$cgmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> ChangeType -> m ChangeType
gmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> ChangeType -> m ChangeType
Data)

changeTypes :: [String]
changeTypes :: [String]
changeTypes = Constr -> String
showConstr (Constr -> String) -> [Constr] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DataType -> [Constr]
dataTypeConstrs (ChangeType -> DataType
forall a. Data a => a -> DataType
dataTypeOf ChangeType
Terminal)

instance Ord ChangeType where
    -- | Ordering Change types by giving each type a number
    -- The higher the number, the better
    compare :: ChangeType -> ChangeType -> Ordering
compare ChangeType
t1 ChangeType
t2 = Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (ChangeType -> Int
n ChangeType
t1) (ChangeType -> Int
n ChangeType
t2)
        where
            n :: ChangeType -> Int
            n :: ChangeType -> Int
n ChangeType
t = case ChangeType
t of
                ChangeType
Wildcard -> Int
1
                ChangeType
Addition -> Int
2
                ChangeType
Removal -> Int
3
                ChangeType
Wrapping -> Int
4
                ChangeType
Terminal -> Int
5