HaRe-0.6: refactorer/RefacTypeSig.hs

-----------------------------------------------------------------------------
-- |
-- Module      :  RefacTypeSig
-- Copyright   :  (c) Christopher Brown 2006
--
-- Maintainer  :  cmb21@kent.ac.uk
-- Stability   :  provisional
-- Portability :  portable
--
-- This module contains a transformation for HaRe.
-- Add type signatures for top-level function definitions

-----------------------------------------------------------------------------

module RefacTypeSig where
 
import PrettyPrint
import PrettyPrint
import PosSyntax
import AbstractIO
import Maybe
import TypedIds
import UniqueNames hiding (srcLoc)
import PNT
import TiPNT
import List
import RefacUtils
import PFE0 (findFile)
import MUtils (( # ))
import RefacLocUtils
import System
import IO

refacTypeSig args
  = do let fileName   = args!!0

       AbstractIO.putStrLn "refacTypeSig"
       modName1 <- fileNameToModName fileName 

       let modName = convertModName modName1

       -- Parse the input file.
       (inscps, exps, mod, tokList) <- parseSourceFile fileName
       
       let newRefactoredDecls = hsDecls mod
       sigs <- mapM (getSig fileName modName) (filter (/="") (map declToName newRefactoredDecls))

       res <- applyRefac (addTypes (dropWhile (\x -> x == defaultPN) (map (declToPName (map declToName newRefactoredDecls)) newRefactoredDecls)) sigs) (Just (inscps, exps, mod, tokList)) fileName
       -- ((_,m), (newToks, newMod)) <- applyRefac (addType ses modName ) (Just (inscps, exps, mod, tokList)) fileName
           
           
    --   res <- findDefsWithType ses mod
       
    --   AbstractIO.putStrLn $ show res    
        
       writeRefactoredFiles True [res]
       
       (inscps5, exps5, mod5, tokList5) <- parseSourceFile fileName

              
       (mod',((tokList'',modified),_))<-(doCommenting (dropWhile (\x -> x == defaultPN) (map (declToPName (map declToName newRefactoredDecls)) newRefactoredDecls))) fileName mod5 tokList5
              
              
       writeRefactoredFiles True [((fileName, True), (tokList'', mod'))]
           
       AbstractIO.putStrLn "Completed."


doCommenting (x:xs) fileName mod tokList 
    =  runStateT (applyTP ((once_tdTP (failTP `adhocTP` (rmInMod (x:xs) )
                                              ))) mod)
                                                         ((tokList,unmodified),fileName)
                       
           where          
             --1. The definition to be removed is one of the module's top level declarations.
             rmInMod [] mod = return mod
             rmInMod (p:ps) (mod@(HsModule loc name exps imps ds):: HsModuleP)  
                = do ds'<-commentOutTypeSig p ds
                     res2 <- rmInMod ps (HsModule loc name exps imps ds')
                     return res2

addTypes [] _ (_,_,mod) = return mod
addTypes _ [] (_,_,mod) = return mod
addTypes (x:xs) (y:ys) (a,b,mod) = do

                                      mod' <- addTypeSigDecl mod (Just x) ([y], Nothing) True 
                                      
                                      -- commentOutTypeSig x (y:ys)                                   
                                      res <- addTypes xs ys (a,b,mod')
                                      return mod'


{- declToName :: HsDeclP -> String
declToName (Dec (HsFunBind _ ((HsMatch _ pnt _ _ _):xs)))  
 = pNTtoName pnt
declToName (Dec (HsPatBind _ pnt _ _)) = pNTtoName (patToPNT pnt)
declToName _ = "" -}

{- declToPName ::  [ String  ] -> HsDeclP -> PName
declToPName [] _ = defaultPN
declToPName (name: names) d@(Dec (HsFunBind _ ((HsMatch _ pnt _ _ _):xs))) 
 | name == pNTtoName pnt = pNTtoPN pnt
 | otherwise = declToPName  names d
declToPName (name:names) d@(Dec (HsPatBind _ pnt _ _))  -- = pNTtoPN (patToPNT pnt)
 | name == pNTtoName (patToPNT pnt) = pNTtoPN (patToPNT pnt)
 | otherwise = declToPName  names d
declToPName _ _ = defaultPN

-}       
addType ses modName (inscps, exps, mod)
  = do
       res <- findDefsWithType ses mod modName
       return res

convertModName (PlainModule s) = s
convertModName m@(MainModule f) = modNameToStr m        
       
findDefsWithType ses t modName
  = applyTP (stop_tdTP (failTP `adhocTP` inMatch)) t
      where
       inMatch (mat@(Dec (HsFunBind _ ((HsMatch loc1  pnt pats (HsBody e) ds):xs)))::HsDeclP)
         = do
              res3 <- findType pnt t 
              if res3 == [True]
                then do
                       addTypeSigDecl t Nothing ([], Nothing) True

                else do
                        -- create a type signature!
                        res <- getSig  ses modName (pNTtoName pnt)
                        
                        -- addTypeDecl  mat (Just (pNTtoPN pnt))  ([res], Nothing) True
                        
                        addTypeSigDecl t (Just (declToPName [declToName mat] mat)) ([res], Nothing) True
                        --    return [res2]
                       --     inMatch _ = fail "" 
       inMatch (dec@(Dec (HsPatBind _ pnt _ _))::HsDeclP)
         = do
              res3 <- findType (patToPNT pnt) t
              if res3 == [True]
                then
                  return dec
                else do
                  -- create a type signature!
                  res <- getSig  ses modName (pNTtoName (patToPNT pnt))
                        
                  -- addTypeDecl dec (Just (pNTtoPN (patToPNT pnt))) ([res], Nothing) True
                  addTypeSigDecl dec (Just (declToPName [declToName dec] dec)) ([res], Nothing) True

                  
                 --   return [res2]
       inMatch _ = fail ""
{- getSig ses modName name 
 = do
      let types = getTypes name ses modName
      -- error $ show types
      let types1 = cleanTypes (tail types)

      let (context, l) = getContext (head types)
      let types2 = l : types1
   --   let context2 = init context
      let types3 = map (filter (/= '\n')) types2
      let newSig = createTypeSig name context types3
     -- error $ show newSig
      
      return newSig       
getSig name ses modName
 = do
      let types = getTypes name ses modName
      let types1 = cleanTypes (tail types) -- modName

      let (context, l) = getContext (head types) -- modName
      let types2 = l : types1
   --   let context2 = init context
      let newSig = createTypeSig name context types2
     -- error $ show newSig
      
      return newSig -}


 
--createTypeSig :: String -> [String] -> [String] -> HsDeclP
createTypeSig name [] types 
 = Dec (HsTypeSig loc0 [nameToPNT name] [] (createApplication types)) 
createTypeSig name context types  
 = Dec (HsTypeSig loc0 [nameToPNT name] [(Typ (HsTyVar (nameToPNT context)))] (createApplication types)) 
 
 -- (Typ (HsTyVar (nameToTypePNT (head types))) ) )
 

nameToTypePNT :: String -> PNT 
nameToTypePNT id = (PNT (PN (UnQual id) (S loc0)) (Type (TypeInfo {defType = Nothing, constructors = [], fields = []})) (N (Just loc0)))


createApplication [var]
 = (Typ (HsTyVar (nameToTypePNT var)))
createApplication (var:vars)
 = createApplication' (Typ (HsTyVar (nameToTypePNT var))) vars
 
createApplication' x [y]
  = (Typ (HsTyFun x (Typ (HsTyVar (nameToTypePNT y)))))
createApplication' x (y:ys)
  = (createApplication' (Typ (HsTyFun x (Typ (HsTyVar (nameToTypePNT y))))) ys)
       
findType pnt t
  = applyTU (stop_tdTU (failTU `adhocTU` inSig)) t
      where
        inSig (dec@(Dec (HsTypeSig _ _ _ _))::HsDeclP)
          = do
               let res = definesTypeSig (pNTtoPN pnt) dec
               if res == True
                  then return [True]
                  else fail ""
          
        inSig _ = fail ""