graphicstools-0.2.1: Utils/Persist.hs

{-#LANGUAGE DeriveGeneric, FlexibleInstances, FlexibleContexts,ScopedTypeVariables, TypeOperators, DefaultSignatures, TypeFamilies#-}
module Utils.Persist where
import GHC.Generics
import qualified Data.Map as M
import Data.Map (Map, (!))

class Default a where
   def :: a
   default def :: (Generic a, Defaulting (Rep a)) => a
   def = to deff

instance Default Int where
   def = 1

instance Default Bool where
   def = False

instance Default Double where
   def = 1.0

class Defaulting f where
   deff :: f a

instance Defaulting U1 where
   deff = U1

instance (Defaulting a, Defaulting b) => Defaulting (a :*: b) where
   deff = deff :*: deff

instance (Defaulting a, Defaulting b) => Defaulting (a :+: b) where
   deff = L1 deff

instance (Defaulting a) => Defaulting (M1 i c a) where
  deff  = M1 $ deff

instance (Default a) => Defaulting (K1 i a) where
  deff  = K1 def


lookupDef :: (Read a, Default a) => String -> Map String String -> a
lookupDef path map = case M.lookup path map of
                      Nothing -> def
                      Just  s -> read s

class Persistent f where
   persist :: String -> f a -> Map String String
   restore :: String -> Map String String -> f a

instance Persist Int where
   put path i = M.singleton (path++"/int") (show i)
   get path = lookupDef (path++"/int")

instance Persist Bool where
   put path i = M.singleton (path++"/bool") (show i)
   get path = lookupDef (path++"/bool")

instance Persist Double where
   put path i = M.singleton (path++"/double") (show i)
   get path = lookupDef (path++"/double")

instance Persist f => Persistent (K1 R f) where
   persist path i = put path (unK1 i)
   restore path map  = K1 $ get path map

instance (Selector s1, Persistent a) => Persistent (M1 S s1 a) where
   persist path a = persist (path++"/"++selName a) (unM1 $ a)
   restore path map = M1 $ restore (path++"/"++selName (undefined :: M1 S s1 a x)) map

instance (Constructor c1, Persistent f) => Persistent (M1 C c1 f) where
   persist path a = persist (path++"/"++conName a) (unM1 $ a)
   restore path map = M1 (restore (path++"/"++conName (undefined :: M1 C c1 f a)) map)

instance (Datatype c1, Persistent f) => Persistent (M1 D c1 f) where
   persist path a = persist (path++"/"++datatypeName a) (unM1 $ a)
   restore path map = M1 (restore (path++"/"++datatypeName (undefined :: M1 D c1 f a)) map)

instance (Persistent a, Persistent b) => Persistent (a :*: b) where
   persist path (a:*:b) = M.union (persist path a) (persist path b)
   restore path map = restore path map :*: restore path map

class Persist a where
   put :: String -> a -> Map String String
   default put :: (Generic a, Persistent (Rep a)) => String -> a -> Map String String
   put s a = persist s (from a)
   get :: String -> Map String String -> a
   default get :: (Generic a, Persistent (Rep a)) => String -> Map String String -> a
   get s m = to (restore s m)

type Store = Map String String
migrate :: (Default a, Default b, Persist a, Persist b) => a -> b
migrate = get "" . put ""