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 ""
parseRoute :: (Persistable l,
Reify l from) => Bool -> String -> Maybe (RestoredRoute l from)
parseRoute b = ((error . show) ||| Just) . parse (routeParser b) ""
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