{-# LANGUAGE TemplateHaskell, PatternSignatures #-}
{-# OPTIONS_GHC -Wall -fno-warn-name-shadowing #-}
module Data.Cursor.CLASE.Gen.Adapters(adapterGen) where

import Data.List
import Data.Maybe
import Data.Cursor.CLASE.Gen.Util
import Language.Haskell.TH
import Data.Cursor.CLASE.Gen.PrintM
import System.FilePath
import System.IO

import qualified Data.Map as Map
import Data.Map (Map)

adapterGen :: [String] -> Name -> [Name] -> String -> Q [Dec]
adapterGen moduleNames rootName acceptableNames gendLanguage = do
  nameMap <- buildMap acceptableNames

  fileOut <- runIO $ openFile (joinPath moduleNames <.> "hs") WriteMode

  let rootNameModule = nameModule rootName
  let moduleName = concat . intersperse "." $ moduleNames


  runIO . runPrint fileOut $ do
    printHeader moduleName (fromMaybe "" rootNameModule) gendLanguage

    printClasses rootName nameMap

    printVisitCursor rootName

    printInstanceHeader rootName acceptableNames

    let contextCtrs = buildContextCtrs nameMap

    printVisitStep rootName nameMap contextCtrs

    printVisitPartial rootName acceptableNames contextCtrs

    printCursor
  runIO $ hFlush fileOut
  runIO $ hClose fileOut

  return [] 

printHeader :: String -> String -> String -> PrintM ()
printHeader modName rootModName rootLangModName = do
  printLn . unlines $ [ "{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, FlexibleContexts,"
    , "             UndecidableInstances, RankNTypes, GADTs, TypeFamilies #-}"
    , "{-# OPTIONS_GHC -Wall -fno-warn-orphans -fno-warn-name-shadowing #-}"

    , "module " ++ modName ++ " where"
    , "{- AUTOGENERATED (See Data.Cursor.CLASE.Gen.Adapters) -}"
    , ""
    , "import " ++ rootModName 
    , "import " ++ rootLangModName
    , "import Data.Cursor.CLASE.Language"
    , "import Data.Cursor.CLASE.Bound"
    , "import Data.Cursor.CLASE.Traversal"
    ]

printClasses :: Name -> Map Name DataType -> PrintM ()
printClasses rootName = mapM_ (uncurry printClass) . Map.toList
  where
    rootNameS = nameBase rootName

    printClass :: Name -> DataType -> PrintM ()
    printClass clNam (DataType _ ctrs) = do
      printLn $ "class " ++ rootNameS ++ "TraversalAdapter" ++ clNamS ++ " t where"
      mapM_ printCases ctrs
      printLn ""
      where
        clNamS = nameBase clNam

        printCases :: Constructor -> PrintM ()
        printCases ctr = do
          printLn $ "  visit" ++ ctrNameS ++ " :: " ++ tipe
            where
              tipe = concat . intersperse " -> " $ clNamS : 
                (map (const "t") . filter isNavigable . ctrKids $ ctr) ++ ["t"]
              ctrNameS = nameBase .ctrName $ ctr 

    printClass _ _ = error "printClass for wraps list not supported [yet]!"
  
   

printVisitCursor :: Name -> PrintM ()
printVisitCursor nam = do
  printLn . unlines $ 
    [ "class " ++ (nameBase nam) ++ "TraversalAdapterCursor t where"
    , "  visitCursor :: " ++ (nameBase nam) ++ " -> t -> t"
    ]

printInstanceHeader :: Name -> [Name] -> PrintM ()
printInstanceHeader rootName okNames = do
  printLn $ "instance (" ++ preconds ++
            "\n          " ++ rootNameS ++ "TraversalAdapterCursor t," ++
            "\n          Bound " ++ rootNameS ++ " t) => Traversal " ++ rootNameS ++ " t where\n"
  where
    preconds = concat . intersperse "\n          " . 
                        map (\n -> rootNameS ++ "TraversalAdapter" ++ n ++ " t,") $ okNameS

    rootNameS = nameBase rootName
    okNameS = map nameBase okNames
  

printVisitStep :: Name -> Map Name DataType -> [ContextCtr] -> PrintM ()
printVisitStep rootName nameMap ctxCtrs = do
  printLn . unlines $ 
    [ "  visitStep it recurse = case reify it of"
    , "    TW x -> visitStep' x it recurse"
    , "    where"
    , "      visitStep' :: (" ++ preconds ++ ") =>"
    , "                    TypeRepI a -> a -> (forall b . Reify " ++ rootNameS ++ " b => Movement " ++ rootNameS ++ " Down a b -> t) -> t"
    ]
  mapM_ (uncurry printVisitStepCase) (Map.toList nameMap)
  printLn ""
  where
    preconds = concat . intersperse ",\n                     " . 
                        map (\n -> rootNameS ++ "TraversalAdapter" ++ n ++ " t") .
                        map nameBase . 
                        Map.keys $ nameMap
    rootNameS = nameBase rootName

    printVisitStepCase :: Name -> DataType -> PrintM ()
    printVisitStepCase tipe (DataType _ ctrs) = do
      printLn $ "      visitStep' " ++ tipeS ++ "T it recurse = case it of"
      mapM_ printVisitStepCtrCase ctrs
        where
          tipeS = nameBase tipe

          printVisitStepCtrCase (Ctr ctrName kids) = do
            printLn $ "        " ++ ctrNameS ++ " " ++ underscorePattern ++ " -> visit" ++ ctrNameS ++ " it " ++ recursePatterns
              where
                ctrNameS = nameBase ctrName
                underscorePattern = unwords $ replicate (length kids) "_" 
                recursePatterns =  unwords . map (\k -> "(recurse (MW " ++ (downCtrName k) ++ "))") . filter ( (== ctrName) . ctxCtrCtrTo) $ ctxCtrs
                --recursePatterns = unwords . map (\k -> "(recurse (MW M" ++ ctrNameS ++ "To" ++ (nameBase . childType $ k) ++ "))") . filter isNavigable $ kids
  
    printVisitStepCase _ _ = error "Can't prinit visitStep case for list dts yet"


printVisitPartial :: Name -> [Name] -> [ContextCtr] -> PrintM ()
printVisitPartial rootName okNames ctxCtrs = do
  printLn . unlines $ 
    [ "  visitPartial (CW ctx) = visitPartial' ctx"
    , "    where"
    , "      visitPartial' :: (" ++ preconds ++ ") =>"
    , "          ContextI a b -> b -> t -> (forall c . Reify " ++ rootNameS ++ " c => Movement " ++ rootNameS ++ " Down b c -> t) -> t"
    , "      visitPartial' ctx it hole recurse = case ctx of"
    ]
  mapM_ printCtrCase ctxCtrs
  printLn ""
  where
    rootNameS :: String
    rootNameS = nameBase rootName

    preconds :: String
    preconds = concat . intersperse ",\n                        " . 
                        map (\n -> rootNameS ++ "TraversalAdapter" ++ n ++ " t") $ okNameS
    okNameS = map nameBase okNames

    printCtrCase :: ContextCtr -> PrintM ()
    printCtrCase cc = do
      printLn $ "          " ++ (ctxCtrName cc) ++ " " ++ underscores ++ " -> visit" ++ (nameBase . ctxCtrCtrTo $ cc) ++ " it " ++ recursePatterns
        where
          underscores = unwords $ replicate (numCCArgs cc) "_"
          recursePatterns =  unwords . map (\k -> if k == cc 
                                                    then "hole"
                                                    else "(recurse (MW " ++ (downCtrName k) ++ "))") . filter ( (==(ctxCtrCtrTo cc) ) . ctxCtrCtrTo) $ ctxCtrs

printCursor :: PrintM ()
printCursor = printLn $ "  cursor = visitCursor"