{-# LANGUAGE FlexibleInstances,
             MultiParamTypeClasses,
             FunctionalDependencies,
             UndecidableInstances,
             ScopedTypeVariables #-}

module DBData
    (Reference,
     toUID,
     CreatureRef,
     PlaneRef,
     ToolRef,
     BuildingRef,
     TheUniverse(..),
     the_universe,
     (=:=), (=/=),
     GenericReference(..),
     ReferenceType(..),
     LocationChild(..),
     LocationParent(..),
     Location,
     Position(..),
     Standing(..),
     Dropped(..),
     Inventory(..),
     Wielded(..),
     Constructed(..),
     Subsequent(..),
     Beneath(..),
     Type,
     _nullary,
     _creature,
     _tool,
     _plane,
     _building,
     _standing,
     _dropped,
     _inventory,
     _wielded,
     _constructed,
     _subsequent,
     _beneath,
     _position,
     _multiposition,
     _facing,
     _the_universe,
     asLocationTyped,
     asType,
     parent,
     child,
     coerceReferenceTyped,
     isReferenceTyped,
     coerceParentTyped,
     isParentTyped,
     coerceChildTyped,
     isChildTyped,
     coerceLocationRecord,
     coerceParent,
     coerceChild,
     genericParent,
     genericChild,
     generalizeParent,
     generalizeChild,
     generalizeLocation,
     toStanding,
     toDropped,
     toInventory,
     toWielded,
     returnToInventory,
     shuntToTheUniverse)
    where

import Facing
import DBPrivate
import ToolData
import CreatureData
import PlaneData
import BuildingData
import Data.Maybe
import Control.Monad
import Position

--
-- Type Instances
--
newtype Type a = Type a

_nullary :: Type (Reference ())
_nullary = Type $ error "_nullary: undefined"

_creature :: Type CreatureRef
_creature = Type $ error "_creature: undefined"

_tool :: Type ToolRef
_tool = Type $ error "_tool: undefined"

_plane :: Type PlaneRef
_plane = Type $ error "_plane: undefined"

_building :: Type BuildingRef
_building = Type $ error "_building: undefined"

_standing :: Type Standing
_standing = Type $ error "_standing: undefined"

_dropped :: Type Dropped
_dropped = Type $ error "_dropped: undefined"

_inventory :: Type Inventory
_inventory = Type $ error "_inventory: undefined"

_wielded :: Type Wielded
_wielded = Type $ error "_wielded: undefined"

_constructed :: Type Constructed
_constructed = Type $ error "_constructed: undefined"

_subsequent :: Type Subsequent
_subsequent = Type $ error "_subsequent: undefined"

_beneath :: Type Beneath
_beneath = Type $ error "_subsequent: undefined"

_position :: Type Position
_position = Type $ error "_position: undefined"

_multiposition :: Type MultiPosition
_multiposition = Type $ error "_multiposition: undefined"

_facing :: Type Facing
_facing = Type $ error "_facing: undefined"

_the_universe :: Type (Reference TheUniverse)
_the_universe = Type $ error "_the_universe: undefined"

--
-- Getting References generically.
--
class GenericReference a where
    fromLocation :: (ReferenceType x) => Location (Reference x) b -> Maybe a
    generalizeReference :: a -> Reference ()

instance (GenericReference a,GenericReference b) => GenericReference (Either a b) where
    fromLocation x = case (fromLocation x,fromLocation x) of
            (Just a,_) -> Just $ Left a
            (_,Just b) -> Just $ Right b
            _ | otherwise -> Nothing
    generalizeReference = either generalizeReference generalizeReference

instance (ReferenceType a) => GenericReference (Reference a) where
    fromLocation = coerceReference . genericChild
    generalizeReference = unsafeReference

instance (LocationChild c,LocationParent p) => GenericReference (Location c p) where
    fromLocation = coerceLocationRecord
    generalizeReference = genericChild

--
-- Reference Equality
--
(=:=) :: (GenericReference a,GenericReference b) => a -> b -> Bool
a =:= b = generalizeReference a == generalizeReference b

(=/=) :: (GenericReference a,GenericReference b) => a -> b -> Bool
a =/= b = not $ a =:= b

--
-- References
--

the_universe :: Reference TheUniverse
the_universe = UniverseRef

coerceReferenceTyped :: (ReferenceType a) => Type (Reference a) -> Reference x -> Maybe (Reference a)
coerceReferenceTyped = const coerceReference

isReferenceTyped :: (ReferenceType a) => Type (Reference a) -> Reference x -> Bool
isReferenceTyped a = isJust . coerceReferenceTyped a

class ReferenceType a where
    coerceReference :: Reference x -> Maybe (Reference a)

instance ReferenceType () where
    coerceReference = Just . unsafeReference

instance ReferenceType Plane where
    coerceReference (PlaneRef ref) = Just $ PlaneRef ref
    coerceReference _ = Nothing

instance ReferenceType Tool where
    coerceReference (ToolRef ref) = Just $ ToolRef ref
    coerceReference _ = Nothing

instance ReferenceType Creature where
    coerceReference (CreatureRef ref) = Just $ CreatureRef ref
    coerceReference _ = Nothing

instance ReferenceType Building where
    coerceReference (BuildingRef ref) = Just $ BuildingRef ref
    coerceReference _ = Nothing

instance ReferenceType TheUniverse where
    coerceReference UniverseRef = Just UniverseRef
    coerceReference _ = Nothing

--
-- Locations
--
generalizeLocation :: Location e t -> Location (Reference ()) ()
generalizeLocation = unsafeLocation

generalizeParent :: Location e t -> Location e ()
generalizeParent = unsafeLocation

generalizeChild :: Location e t -> Location (Reference ()) t
generalizeChild = unsafeLocation

genericParent :: Location e t -> Reference ()
genericParent (IsStanding _ s) = unsafeReference $ standing_plane s
genericParent (IsDropped _ d) = unsafeReference $ dropped_plane d
genericParent (InInventory _ c) = unsafeReference $ inventory_creature c
genericParent (IsWielded _ c) = unsafeReference $ wielded_creature c
genericParent (IsConstructed _ c) = unsafeReference $ constructed_plane c
genericParent (InTheUniverse _) = unsafeReference UniverseRef
genericParent (IsSubsequent _ b) = unsafeReference $ subsequent_to b
genericParent (IsBeneath _ b) = unsafeReference $ beneath_of b

genericChild :: Location e t -> Reference ()
genericChild (IsStanding r _) = unsafeReference r
genericChild (IsDropped r _) = unsafeReference r
genericChild (InInventory r _) = unsafeReference r
genericChild (IsWielded r _) = unsafeReference r
genericChild (IsConstructed r _) = unsafeReference r
genericChild (InTheUniverse r) = unsafeReference r
genericChild (IsSubsequent r _) = unsafeReference r
genericChild (IsBeneath r _) = unsafeReference r

asLocationTyped :: (LocationChild e,LocationParent t) =>
                   Type e -> Type t -> Location e t -> Location e t
asLocationTyped _ _ = id

asType :: Type e -> e -> e
asType _ = id

coerceParentTyped :: (LocationParent p) =>
                       Type p -> Location c x -> Maybe (Location c p)
coerceParentTyped = const coerceParent

isParentTyped :: (LocationParent p) => Type p -> Location c x -> Bool
isParentTyped t = isJust . coerceParentTyped t

coerceChildTyped :: (LocationChild c) =>
                     Type c -> Location x p -> Maybe (Location c p)
coerceChildTyped = const coerceChild

isChildTyped :: (LocationChild c) => Type c -> Location x p -> Bool
isChildTyped t  = isJust . coerceChildTyped t

coerceParent :: forall c x p. (LocationParent p) =>
                Location c x -> Maybe (Location c p)
coerceParent l =
    do (_ :: p) <- extractParent l
       return $ unsafeLocation l

coerceChild :: forall x p c. (LocationChild c) =>
                Location x p -> Maybe (Location c p)
coerceChild l =
    do (_ :: c) <- extractChild l
       return $ unsafeLocation l

coerceLocationRecord :: forall x y c p. (LocationChild c,LocationParent p) =>
                        Location x y -> Maybe (Location c p)
coerceLocationRecord l =
    do (_ :: p) <- extractParent l
       (_ :: c) <- extractChild l
       return $ unsafeLocation l

parent :: (LocationParent p) => Location c p -> p
parent l = fromMaybe (error "parent: type error") $ extractParent l

child :: (LocationChild c) => Location c p -> c
child l = fromMaybe (error "child: type error") $ extractChild l

class (Eq a,Ord a) => LocationParent a where
    extractParent :: Location e t -> Maybe a

class (Eq a,Ord a) => LocationChild a where
    extractChild :: Location e t -> Maybe a

instance LocationParent Standing where
    extractParent (IsStanding _ s) = Just s
    extractParent _ = Nothing

instance LocationParent Dropped where
    extractParent (IsDropped _ d) = Just d
    extractParent _ = Nothing

instance LocationParent Inventory where
    extractParent (InInventory _ i) = Just i
    extractParent _ = Nothing

instance LocationParent Wielded where
    extractParent (IsWielded _ i) = Just i
    extractParent _ = Nothing

instance LocationParent Constructed where
    extractParent (IsConstructed _ i) = Just i
    extractParent _ = Nothing

instance LocationParent TheUniverse where
    extractParent (InTheUniverse {}) = Just TheUniverse
    extractParent _ = Nothing

instance LocationParent Subsequent where
    extractParent (IsSubsequent _ i) = Just i
    extractParent _ = Nothing

instance LocationParent Beneath where
    extractParent (IsBeneath _ i) = Just i
    extractParent _ = Nothing

instance LocationParent () where
    extractParent = const $ Just ()

instance LocationParent Position where
    extractParent (IsStanding _ s) = Just $ standing_position s
    extractParent (IsDropped _ d) = Just $ dropped_position d
    extractParent (InInventory {}) = Nothing
    extractParent (IsWielded {}) = Nothing
    extractParent (IsConstructed _ c) = Just $ constructed_position c
    extractParent (InTheUniverse {}) = Nothing
    extractParent (IsSubsequent {}) = Nothing
    extractParent (IsBeneath {}) = Nothing

instance LocationParent MultiPosition where
    extractParent (IsConstructed _ c) = Just $ multiPosition (constructed_position c) (buildingOccupies $ constructed_type c)
    extractParent x = fmap (toMultiPosition :: Position -> MultiPosition) $ extractParent x

instance LocationParent Facing where
    extractParent (IsStanding _ s) = Just $ standing_facing s
    extractParent (IsDropped {}) = Nothing
    extractParent (InInventory {}) = Nothing
    extractParent (IsWielded {}) = Nothing
    extractParent (IsConstructed {}) = Nothing
    extractParent (InTheUniverse {}) = Nothing
    extractParent (IsSubsequent {}) = Nothing
    extractParent (IsBeneath {}) = Nothing

instance ReferenceType a => LocationParent (Reference a) where
    extractParent = coerceReference . genericParent

instance ReferenceType a => LocationChild (Reference a) where
    extractChild = coerceReference . genericChild

instance (LocationParent a,LocationParent b) => LocationParent (a,b) where
    extractParent l = liftM2 (,) (extractParent l) (extractParent l)

instance (LocationChild a,LocationChild b) => LocationChild (a,b) where
    extractChild l = liftM2 (,) (extractChild l) (extractChild l)

--
-- Manipulating Locations
--
toStanding :: (LocationParent t) =>
              Standing ->
              Location CreatureRef t ->
              Location CreatureRef Standing
toStanding s l | isChildTyped _creature l = IsStanding (child l) s
toStanding _ _ = error "toStanding: type error"

toDropped :: (LocationParent t) => Dropped -> Location ToolRef t -> Location ToolRef Dropped
toDropped d l | isChildTyped _tool l = IsDropped (child l) d
toDropped _ _ = error "toDropped: type error"

toInventory :: (LocationParent t) => Inventory -> Location ToolRef t -> Location ToolRef Inventory
toInventory i l | isChildTyped _tool l = InInventory (child l) i
toInventory _ _ = error "toInventory: type error"

toWielded :: (LocationParent t) => Wielded -> Location ToolRef t -> Location ToolRef Wielded
toWielded i l | isChildTyped _tool l = IsWielded (child l) i
toWielded _ _ = error "toWielded: type error"

returnToInventory :: Location ToolRef Wielded -> Location ToolRef Inventory
returnToInventory l = InInventory (child l) (Inventory c)
    where Wielded c = parent l

shuntToTheUniverse :: Type p ->
                      Location PlaneRef p ->
                      Location PlaneRef TheUniverse
shuntToTheUniverse _ l = InTheUniverse (child l)