{-# LANGUAGE TemplateHaskell, ScopedTypeVariables #-}
{-# OPTIONS_GHC -Wall -fno-warn-name-shadowing #-}
module Data.Cursor.CLASE.Gen.Persistence(persistenceGen) where

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

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

  let contextCtrs = buildContextCtrs nameMap

  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

    printClassHeader rootName

    printShowMovement contextCtrs

    printMovementUpDownLines

    printShowTypeRep rootName acceptableNames

    printTypeRepParser rootName acceptableNames

    printTypeRepEq rootName acceptableNames

    printUpMovesParser rootName acceptableNames contextCtrs

    printDownMovesParser rootName acceptableNames contextCtrs

    printFooter

  runIO $ do
    hFlush fileOut
    hClose fileOut

  return []

printHeader :: String -> String -> String -> PrintM ()
printHeader modName rootModName rootLangModName = do
  printLn . unlines $ 
    [ "{-# LANGUAGE TypeFamilies #-}"
    , "{-# LANGUAGE GADTs #-}"
    , "{-# LANGUAGE UndecidableInstances #-}"
    , "{-# LANGUAGE FlexibleContexts #-}"
    , "{-# LANGUAGE ScopedTypeVariables #-}"
    , "{-# LANGUAGE RankNTypes #-}"
    , "{-# OPTIONS_GHC -Wall -fno-warn-name-shadowing -fno-warn-orphans -fno-warn-incomplete-patterns #-}"
    , "module " ++ modName ++ " where"
    , "{- AUTOGENERATED (See Data.Cursor.CLASE.Gen.Persistence) -}"
    , ""
    , "import " ++ rootModName
    , "import " ++ rootLangModName
    , "import Data.Cursor.CLASE.Language"
    , "import Data.Cursor.CLASE.Persistence"
    , "import qualified Text.ParserCombinators.Parsec.Language as P"
    , "import qualified Text.ParserCombinators.Parsec.Token as P"
    , "import Text.ParserCombinators.Parsec"
    , "import Data.Cursor.CLASE.Util"
    ]

printClassHeader :: Name -> PrintM ()
printClassHeader rootName = do
  printLn $ "instance (PersistenceAdapter " ++ rootNameS ++ ") => Persistable " ++ rootNameS ++ " where"
  printLn ""
    where
      rootNameS = nameBase rootName

printShowMovement :: [ContextCtr] -> PrintM ()
printShowMovement ctxCtrs = do
  printLns $
    [ "  showMovement (MW x) = show' x"
    , "    where"
    , "      show' :: MovementI dir from to -> String"
    ]

  forM_ ctxCtrs printShowUpMovement
  forM_ ctxCtrs printShowDownMovement

  printLn ""
  where
    printShowUpMovement cc = printLn $
      "      show' (MUp " ++ smupctr ++ ") = \"" ++ mupctrshown ++ "\""
      where
        smupctr = downCtrName cc
        mupctrshown = upCtrNameShown cc

    printShowDownMovement cc = printLn $
      "      show' " ++ smupctr ++ " = \"" ++ smupctr ++ "\""
        where
          smupctr = downCtrName cc

printMovementUpDownLines :: PrintM ()
printMovementUpDownLines = do
  printLns $
    [ "  movementParser UpT = upMovesParser"
    , "  movementParser DownT = downMovesParser"
    , ""
    ]

printShowTypeRep :: Name -> [Name] -> PrintM ()
printShowTypeRep rootName acceptableNames = do
  let rootNameS = nameBase rootName
  printLns $
    [ "  showTypeRep = showTypeRep'"
    , "    where"
    , "      showTypeRep' :: forall a . TypeRep " ++ rootNameS ++ " a -> String"
    ]

  forM_ acceptableNames $ \name -> do
    let nameS = nameBase name
    printLn $ "      showTypeRep' (TW (" ++ nameS ++ "T :: TypeRepI a))  = \"" ++ nameS ++ "T\""

  printLn ""


printTypeRepParser :: Name -> [Name] -> PrintM ()
printTypeRepParser rootName acceptableNames = do
  printLns $ 
    [ "  typeRepParser = choice $ map (uncurry mkParser) itReps"
    , "    where"
    , "      itReps = [" ++ itRepLines ++ "]"
    , ""
    , "      mkParser :: String -> Exists (TypeRep " ++ rootNameS ++ ") -> Parser (Exists (TypeRep " ++ rootNameS ++ "))"
    , "      mkParser s v = try $ (symbol s >> return v)"
    , ""
    ]
  where
    rootNameS = nameBase rootName
    itRepLines = concat . intersperse ",\n                " $ itReps
    
    itReps = map (\name -> let nameS = (nameBase name ++ "T") in
                            "(\"" ++ nameS ++ "\", (Exists (TW " ++ nameS ++ ")))") 
                 acceptableNames

printTypeRepEq :: Name -> [Name] -> PrintM ()
printTypeRepEq rootName acceptableNames = do
  printLns $
    [ "  typeRepEq = typeRepEq'"
    , "    where"
    , "      typeRepEq' :: forall a b . TypeRep " ++ rootNameS ++ " a -> TypeRep " ++ rootNameS ++ " b -> Maybe (TyEq a b)"
    ]

  printLns reps

  printLn "      typeRepEq' _ _ = Nothing"
  printLn ""
  where
    rootNameS = nameBase rootName
    reps = map (\name -> let nameS = (nameBase name ++ "T") in
            "      typeRepEq' (TW (" ++ nameS ++ " :: TypeRepI a)) (TW (" ++ 
              nameS ++ " :: TypeRepI b)) = Just Eq") $ acceptableNames
      
printUpMovesParser :: Name -> [Name] -> [ContextCtr] -> PrintM ()
printUpMovesParser rootName acceptableNames ctxctrs = do
  printLns $
    [ "upMovesParser :: forall a . (Reify " ++ rootNameS ++ " a) => Parser ((ExistsR " ++ rootNameS ++ " (Movement " ++ rootNameS ++ " Up a)))"
    , "upMovesParser = upMovesParser' (reify (undefined :: a))"
    , "  where"
    , "    upMovesParser' :: forall a . (Reify " ++ rootNameS ++ " a) => TypeRep " ++ rootNameS ++ " a -> "
    , "      Parser ((ExistsR " ++ rootNameS ++ " (Movement " ++ rootNameS ++ " Up a)))"
    , "    upMovesParser' (TW x) = case x of"
    ]

  printLns $ cases
  
  printLn ""
  printLns $
    [ "    use options = choice $ map (uncurry mkParser) options"
    , "    c :: forall a b . (Reify " ++ rootNameS ++ " b) => " ++
              "MovementI Up a b -> Parser (ExistsR " ++ rootNameS ++ " (Movement " ++ rootNameS ++ " Up a))"
    ,  "    c = return . ExistsR . MW"
    ,  "    mkParser p s = try (symbol s >> p)"
    ]
  printLn ""

    where
      rootNameS = nameBase rootName
      cases = concatMap mkOptions acceptableNames
      
      mkOptions :: Name -> [String]
      mkOptions name 
        | null options = [ "      (" ++ nameS ++ " :: TypeRepI a) -> use []"]
        | otherwise    = [ "      (" ++ nameS ++ " :: TypeRepI a) -> use options"
                         , "        where"
                         , "          options ="
                         , "            [ " ++ optionLines 
                         , "            ]"
                         ]
        where
          nameS = nameBase name ++ "T"
          options = filter ((== name) . ctxCtrTypeFrom) ctxctrs
          optionLines = concat . intersperse "\n            , " . map mkOptionLine $ options

          mkOptionLine ctxCtr = "(c $ (MUp " ++ dcs ++ "), \"" ++ ucs ++ "\")"
            where
              dcs = downCtrName ctxCtr
              ucs = upCtrNameShown ctxCtr


printDownMovesParser :: Name -> [Name] -> [ContextCtr] -> PrintM ()
printDownMovesParser rootName acceptableNames ctxCtrs = do
  printLns $
    [ "downMovesParser :: forall a . (Reify " ++ rootNameS ++ " a) => Parser ((ExistsR " ++ rootNameS ++ " (Movement " ++ rootNameS ++ " Down a)))"
    , "downMovesParser = downMovesParser' (reify (undefined :: a))"
    ,"  where"
    ,"    downMovesParser' :: forall a . (Reify " ++ rootNameS ++ " a) => TypeRep " ++ rootNameS ++ " a -> "
    ,"      Parser ((ExistsR " ++ rootNameS ++ " (Movement " ++ rootNameS ++ " Down a)))"
    ,"    downMovesParser' (TW x) = case x of"
    ]

  printLns $ cases

  printLn ""

  printLns $ 
    [ "    use options = choice $ map (uncurry mkParser) options"
    , "    c :: forall a b . (Reify " ++ rootNameS ++ " b) => MovementI Down a b -> Parser (ExistsR " ++ rootNameS ++ " (Movement " ++ rootNameS ++ " Down a))"
    , "    c = return . ExistsR . MW"
    , "    mkParser p s = try (symbol s >> p)"
    ]

  printLn ""

  where
    rootNameS = nameBase rootName 

    cases = concatMap mkOptions acceptableNames

    mkOptions :: Name -> [String]
    mkOptions name 
      | null options = [ "      (" ++ nameS ++ " :: TypeRepI a) -> use []"]
      | otherwise    = [ "      (" ++ nameS ++ " :: TypeRepI a) -> use options"
                       , "        where"
                       , "          options ="
                       , "            [ " ++ optionLines
                       , "            ]"
                       ]
      where
        nameS = nameBase name ++ "T"

        options = filter ((== name) . ctxCtrTypeTo) ctxCtrs
        optionLines = concat . intersperse "\n            , " . map mkOptionLine $ options

        mkOptionLine ctxCtr = "(c $ " ++ dcs ++ ", \"" ++ dcs ++ "\")"
          where
            dcs = downCtrName ctxCtr

printFooter :: PrintM ()
printFooter = printLns $
  [ "haskellParser ::  P.TokenParser st"
  , "haskellParser = P.makeTokenParser P.haskellDef"
  , ""
  , "symbol ::  String -> CharParser st String"
  , "symbol = P.symbol haskellParser"
  ]