{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE PatternSignatures #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE GADTs #-}
{-# OPTIONS_GHC -Wall -fno-warn-name-shadowing #-}
module Data.Cursor.CLASE.Persistence(
  showCursor,
  showRoute,
  parseCursor,
  parseRoute,
  Persistable(..),
  PersistenceAdapter(..),
  RestoredCursor(..),
  RestoredRoute(..),
  RestoredPath(..),
  readParser
) where

import Data.Cursor.CLASE.Language
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
import Control.Monad
import Control.Arrow

class (Language l, 
       PersistenceAdapter l, 
       Reify l l) => Persistable l where
  
  showMovement :: (Movement l d from to) -> String

  movementParser :: Reify l a => DirectionT d -> Parser ((ExistsR l (Movement l d a)))

  showTypeRep :: TypeRep l a -> String

  typeRepParser :: Parser (Exists (TypeRep l))

  typeRepEq :: TypeRep l a -> TypeRep l b -> Maybe (TyEq a b)


class PersistenceAdapter l where
  showL :: l -> String
  parseL :: Parser l

data RestoredCursor l where
  RestoredCursor :: (Reify l x) => Cursor l x a -> RestoredCursor l

data RestoredRoute l from where
  RestoredRoute :: (Reify l to) => Route l from to -> RestoredRoute l from

data RestoredPath l r a where
  RestoredPath :: (Reify l b) => Path l r a b -> RestoredPath l r a

readParser :: (Show a, Read a) => Bool -> Parser a
readParser b
  | b = readParserP 11
  | otherwise = readParserP 0

readParserP :: (Show a, Read a) => Int -> Parser a 
readParserP n = do
  cString <- getInput
  case readsPrec n cString of
    [(val, rest)] -> do
      setInput rest
      return val
    x -> error $ "readParser fail: " ++ show x ++ " - " ++ show cString

showCursor :: forall l x a . (Persistable l) => Cursor l x a -> String
showCursor cursor@(Cursor it _ log) = "Cursor { root = " ++ lS ++ ", " ++
                                               "locationRep = " ++ itRepS ++ ", " ++ 
                                               "location = " ++ locS ++ ", " ++
                                               "log = " ++ logS ++ 
                                               "}"
  where
    (Cursor root _ location) = moveToRoot $ resetLog cursor
    lS = showL root
    itRepS = showTypeRep ((reify it) :: TypeRep l a)
    locS = showRoute location
    logS = showRoute log


showPath :: (Persistable l) => (forall a b . r a b -> Bool -> String) -> 
                                          Path l r from to -> Bool -> String
showPath _ Stop _ = "Stop"
showPath contents (Step c nxt) b
  | b         = "(" ++ line ++ ")"
  | otherwise = line
  where
    line = "Step " ++ (contents c True) ++ " " ++ showPath contents nxt True 

showRoute :: (Persistable l) => Route l from to -> String
showRoute (Route mups mdowns) = "Route " ++ 
                                showPath (const . showMovement) mups True ++ " " ++
                                showPath (const . showMovement) mdowns True

parseCursor :: (Persistable l) => String -> Maybe (RestoredCursor l)
parseCursor = ((error . show) ||| Just) . parse cursorParser "" 
-- TODO: error . show == Nothing

parseRoute :: (Persistable l, 
               Reify l from) => Bool -> String -> Maybe (RestoredRoute l from)
parseRoute b = ((error . show) ||| Just) . parse (routeParser b) ""
-- TODO: error . show == Nothing

cursorParser :: forall l . (Persistable l) => Parser (RestoredCursor l)
cursorParser = do
  symbol "Cursor"
  braces $ do
    symbol "root" >> symbol "="
    (root :: l) <- parseL
    comma
    
    symbol "locationRep" >> symbol "="
    (Exists (itRep :: TypeRep l from)) <- (typeRepParser :: Parser (Exists (TypeRep l)))
    comma

    symbol "location" >> symbol "="
    (RestoredRoute (loc :: Route l l from')) <- (routeParser False :: Parser (RestoredRoute l l))
    (locFrom :: TypeRep l from') <- return (reify (undefined :: from'))
    (Just (Eq :: TyEq from from')) <- return (itRep `typeRepEq` locFrom)

    comma

    symbol "log" >> symbol "="
    (RestoredRoute (log :: Route l from x)) <- (routeParser False :: Parser (RestoredRoute l from))

    maybe (fail "Couldn't build cursor") (return . RestoredCursor) $ process root loc log
    where
      process :: l -> Route l l from -> Route l from x -> Maybe (Cursor l x from)
      process l loc log = do
        let cursorAtRoot = Cursor l Stop (Route Stop Stop)
        (Cursor endPos ctx _) <- followRoute cursorAtRoot loc
        return $ Cursor endPos ctx log

pathParser :: forall a r l . (Reify l a) => Bool -> (forall b . (Reify l b) => Parser ((ExistsR l (r b)))) -> Parser (RestoredPath l r a)
pathParser b cargoParser = (try stopParser) <|> (if' b parens id stepParser)
  where
    stopParser = symbol "Stop" >> return (RestoredPath Stop)
    stepParser = do
      symbol "Step"
      (ExistsR part) <- cargoParser
      (RestoredPath rest) <- pathParser True cargoParser 
      return $ RestoredPath (Step part rest)

routeParser :: forall l a . (Persistable l, Reify l a) => Bool -> Parser (RestoredRoute l a)
routeParser b = (if' b parens id) $ do
  symbol "Route"
  (RestoredPath upMovs) <- pathParser True (movementParser UpT)
  (RestoredPath downMovs) <- pathParser True (movementParser DownT)

  let route = Route upMovs downMovs

  guard (route_invariant route)

  return $ RestoredRoute route


haskellParser ::  P.TokenParser st
haskellParser = P.makeTokenParser P.haskellDef

symbol ::  String -> CharParser st String
symbol = P.symbol haskellParser
parens ::  CharParser st a -> CharParser st a
parens = P.parens haskellParser
braces ::  CharParser st a -> CharParser st a
braces = P.braces haskellParser
comma ::  CharParser st String
comma = P.comma haskellParser