{-# LANGUAGE TemplateHaskell, QuasiQuotes, FlexibleInstances, NamedFieldPuns #-}

module Test.MutateADT where

 
import Language.Haskell.Exts as HSE
import Language.Haskell.Exts.SrcLoc(noLoc)
import Language.Haskell.Meta.Syntax.Translate
import Control.Monad
import Data.Function
import Data.List hiding (group)

import Language.Haskell.TH.Syntax (Dec(..),Type(..),StrictType,Type
                                  ,Con(..),reify,Q(..))  
import qualified Language.Haskell.TH.Syntax as TH
import qualified Language.Haskell.TH as THH
import Test.QuickMutate.Runtime
import Debug.Trace
  
-- no context (restricted datatype/local constraints)
-- no type parameter (no type application, e.g. List Int) 
-- no symbolic name (?) 
-- no mutual recursion  
 
  
  
-- reverse (1)  
-- insert into ordered list (2)
-- insert into ordered bin tree (3)
  
data Options = Options {seed::String,useSelf::Bool,usePermutation::Bool
                       ,fakeRemoval::Bool,excludedConstructors::[String]}

defaultOptions :: Options
defaultOptions = Options { seed           = "_x"
                         , useSelf        = False
                         , usePermutation = False
                         , fakeRemoval    = False
                         , excludedConstructors = []}

mutate :: Options -> [Dec] -> [Decl]
mutate  opt@(Options {seed}) decs =
   [genChange opt (extract dcl) 
   | dcl <- decs] 
   ++ 
   [genChangeRec opt (extract dcl) 
   | dcl <- decs]

extract :: Dec -> (String,[(String,[String])])
extract (DataD _ n [] cns _) = 
  (show n
  , [(show cn
     , [show t
       |(_, t') <-sts
       ,let t = case t' of
              ConT n     -> THH.ppr t'
              VarT n     -> THH.ppr t'
              AppT t1 t2 -> THH.ppr t' 
              _ -> error "not supported type!"
       ] ) 
    | z <- cns
    , let (cn,sts) = case z of
            NormalC x y -> (x,y)
            InfixC x1 y x2 -> (y,[x1,x2])
            RecC   x y -> (x,[(s,t)
                             |(_ , s, t) <-y])
    ])

perm :: [a] -> [b] -> [[(a,b)]]
perm []     _  = [[]]
perm (x:xs) ys = concat [((x,y):) `map` (perm xs ys) | y <- ys]

comb :: [a] -> [b] -> [[(a,b)]]
comb []     _  = [[]]
comb xs'@(x:xs) ys -- | length xs' <= length ys
  = concat  
    [ ((x,y2):) `map` (comb xs  (y1 ++ y2'))   
    | (y1,y2:y2')  <- rotate ys] 
  where
    rotate :: [a] -> [([a],[a])] 
    rotate x = rotate' [] x 
      where
        rotate' ::  [a] -> [a] -> [([a],[a])] 
        rotate' ys' []     = [(ys',[])]
        rotate' ys' (y:ys) = (ys',(y:ys)):rotate' (ys'++[y]) ys 
 
solve :: ([Int] -> [Int] -> [[(Int,Int)]]) ->  
         [([Int],String)] -> [([Int],String)] -> [[(Int, Int)]]
solve combine provided required =  flatten 
                            [combine ris 
                             (case find ((==e).snd) provided of 
                                 Just (x,_) -> x
                                 Nothing    -> [])
                            | (ris,e) <- required]
  where
    flatten :: [[[a]]]->[[a]]
    flatten []       = []
    flatten (x:xs)   = flatten' x xs
      where
        flatten' :: [[a]] -> [[[a]]] -> [[a]]
        flatten' x []      = x
        flatten' x (x':xs) = flatten' (flatten'' x x') xs
        
        flatten'' :: [[a]] -> [[a]] ->[[a]]
        flatten'' x1 x2 = [a++b | a <- x1, b <- x2]
  
alts :: Bool -> [String] -> [String] -> [[(Int, Int)]]
alts isPerm provided required = ((solve (if isPerm
                                         then perm 
                                         else comb) )`on` group)  
                                provided required
  where
    group :: [String] -> [([Int],String)]              
    group ts = [ (map fst ls,snd $ head ls)
               | ls  <- groupBy ((==) `on` snd) 
                        (sortBy 
                         (compare`on`snd) 
                         (zip [1..] ts))]
 
differenceBy :: (a -> a -> Bool) -> [a] -> [a] -> [a]
differenceBy eq = foldl (flip (deleteBy eq)) 

genChange :: Options -> 
             (String,[(String,[String])]) -> Decl
             
genChange (Options { seed, fakeRemoval, useSelf
                   , usePermutation, excludedConstructors }) (m,xs') = 
 let offset = if useSelf
              then 1
              else 0
     xs = differenceBy ((==)`on`fst) xs' [(ex,[]) | ex <- excludedConstructors]
 in InstDecl noLoc [] (UnQual $ Ident "Change") [TyCon $ UnQual $ Ident m] 
    [InsDecl $ PatBind noLoc (PVar $ Ident "change") Nothing 
     (UnGuardedRhs$
      Lambda noLoc [PVar (Ident (seed ++ (show offset)))] $
      Case (Var $ UnQual $ Ident (seed ++ (show offset))) $
      [Alt noLoc (PApp (UnQual (Ident cn)) 
                  [PVar $ Ident $ seed++(show i)
                  |i<-[(1+offset)..((length ts)+offset)]] ) 
       (UnGuardedAlt $ List 
        $ nub 
        $
        delete (App (Con $ UnQual $ Ident $ "id" ) 
                  (Var $ UnQual $ Ident (seed ++ (show offset))))
        $
        delete (foldl App (Con $ UnQual $ Ident cn) 
                [Var $ UnQual $ Ident $ seed++(show i)
                |i<-[(1+offset)..((length ts)+offset)]]) 
        $
        [if cn' == "id" 
         then
           case als of
             [(r,p)] -> Var $ UnQual $ Ident $ seed ++ (show p)
             _   -> error "should not have happened!"
         else
           foldl App (Con $ UnQual $ Ident $ cn' ) 
           [ Var $ UnQual $ Ident $ seed ++ (show p)
           | (r,p) <- (sortBy (compare `on` fst)  als)]         
        |(cn',ts') <- ( xs ++ (if fakeRemoval then [("id",[m])] else []))
        , als <- alts usePermutation ((if useSelf     then [m] else [])++ts) ts']
        ++ [Con$UnQual$Ident cc |(cc,[]) <-xs] 
       ) 
       (BDecls []) 
      | (cn,ts) <- xs ]
      ++
      [Alt noLoc PWildCard (UnGuardedAlt $ List []) (BDecls []) ]) 
     (BDecls [])
    ]

genChangeRec :: Options -> 
              (String,[(String,[String])]) -> Decl
genChangeRec (Options{seed,excludedConstructors}) (m,xs') = let 
   xs =  differenceBy ((==)`on`fst) xs' [(ex,[]) | ex <- excludedConstructors]
 in 
   InstDecl noLoc [] (UnQual $ Ident "ChangeRec") [TyCon $ UnQual $ Ident m] 
    [InsDecl $ 
     PatBind noLoc (PVar $ Ident "changeRec") Nothing 
     (UnGuardedRhs$
      Lambda noLoc [PVar (Ident  (seed ++ "0"))] $ 
      InfixApp (App (Var $ UnQual $ Ident "change") 
                (Var $ UnQual (Ident  (seed ++ "0")))) 
      (QVarOp (UnQual (Symbol "++"))) $ 
      Case (Var $ UnQual $ Ident (seed ++ "0")) 
      [Alt noLoc (PApp (UnQual (Ident cn)) 
                  [PVar $ Ident $ seed++(show i)
                  |i<-[1..length ts]] ) 
       (UnGuardedAlt $ foldl 
        (\x1 x2 -> InfixApp x1 (QVarOp (UnQual (Symbol "++"))) x2 ) 
        (List [])
        [ListComp ( foldl App  (Con $ UnQual (Ident cn))
                    [Var $ UnQual $ Ident $ seed++(show i)
                    |i<-[1..length ts]]) 
         [QualStmt (Generator noLoc (PVar (Ident $ seed ++ (show j))) 
                               (App (Var (UnQual (Ident "changeRec"))) 
                                (Var (UnQual (Ident $ seed ++ (show j))))))] 
        |j <- [1..length ts]] )
       (BDecls []) 
      | (cn,ts) <- xs ]) 
     (BDecls [])
    ] 
      
genEmptyOps :: [TH.Name] -> Q [Dec]
genEmptyOps ns = liftM concat $ sequence 
  [ 
    [d| 
     instance ChangeRec $(return $ ConT n) where 
           changeRec _ = []        
    |]
  |n <- ns]
 
genMutationOpsWith :: Options -> [TH.Name] -> Q [Dec]
genMutationOpsWith opt ns = do 
  decs <-  sequence (reify `map` ns)    
  return $ 
    toDec `map` (mutate opt [d |TH.TyConI d <-decs]) 

genMutationOps = genMutationOpsWith defaultOptions

prunedMutatationsWith :: (Eq a,ChangeRec a) => ( a -> Bool) -> (a -> a) -> 
                         a -> [a]
prunedMutatationsWith pred reduce t = delete t 
  $ nub
  [t' 
  | t <- changeRec t
  , pred t         
  , let t' = reduce t ]
  
  
isRight :: Either a b -> Bool
isRight (Right _) = True
isRight _         = False  
