content: module DerivingDrift.Drift(driftDerive,driftResolvedNames) where
  
  import Data.Char
  import qualified Data.Map as Map
  
  import DerivingDrift.DataP
  import DerivingDrift.StandardRules
  import FrontEnd.Class
  import FrontEnd.HsParser
  import FrontEnd.HsSyn
  import FrontEnd.ParseMonad
  import Name.Name
  import Text.PrettyPrint.HughesPJ(render)
  
  driftDerive :: HsModule -> [HsDecl]
  driftDerive hsModule = if null ss then [] else hsModuleDecls hsMod
    where
      --hsMod = case parse (unlines ss) (SrcLoc (show $ hsModuleName hsModule) 1 1) 0 [] of
      hsMod = case snd $ runParser parse ss  of
          ParseOk e -> e
          ParseFailed sl err -> error $ "internal parse error(driftDerive): " ++ show sl ++ err  ++ "\n" ++ ss
      ss = unlines [ n | Just n <- map driftDerive' $ hsModuleDecls hsModule, any (not . isSpace) n ]
  
  driftDerive' :: Monad m => HsDecl -> m String
  driftDerive' HsDataDecl { hsDeclName = name, hsDeclArgs = args, hsDeclCons = condecls, hsDeclDerives = derives } = do
          let d = unrenameTyVars $ toData  name args condecls derives
              isEnum = length condecls > 1 && null (concatMap hsConDeclArgs condecls)
          xs <- return $  map (derive isEnum d) derives
          return $ unlines xs
  --driftDerive' (HsNewTypeDecl sloc cntxt name args condecl derives) = do
  --        let d =  unrenameTyVars $ toData  name args [condecl] derives
  --        xs <- return $ map (derive False d) derives
  --        return $ unlines xs
  
  driftDerive' _ = fail "Nothing to derive"
  
  unrenameTyVars :: Data -> Data
  unrenameTyVars d = d{
      vars = map (m Map.!) (vars d),
      constraints = map (\(c,v) -> (c, m Map.! v)) (constraints d)
    }
   where m = Map.fromList $ zip (vars d) tyVars
         tyVars = map (('a':) . show) [1::Int ..]
  
  toData :: HsName -> [HsName] -> [HsConDecl] -> [HsName] -> Data
  toData name args cons derives = ans where
      f c = Body { constructor = pp (getIdent $ hsConDeclName c), types = hsConDeclArgs c, labels = lb c }
      pp xs@(x:_) | isAlpha x = xs
      pp xs = '(':xs++")"
      lb HsConDecl {} = []
      lb  r = concatMap fst (hsConDeclRecArg r)
      ans = D { statement = DataStmt, vars = map show args, constraints = [], name = name,  derives = map show derives, body = map f cons }
  
  derive True d wh | wh `elem` enumDerivableClasses ++ map toUnqualified enumDerivableClasses = "-- generated instance  " ++ show wh ++ " " ++ getIdent (name d)
  derive _ d wh | Just fn <- Map.lookup wh standardRules = render $ fn d
                | Just _  <- Map.lookup (show wh) shortRuleNames = error (msg ++ " " ++ show wh ++ " not in scope.")
                | otherwise  = error msg
    where msg = "Can't make a derived instance '" ++ show wh ++ " " ++ getIdent (name d) ++ "'."
  
  shortRuleNames = Map.mapKeys getIdent standardRules
  