simulation of ocaml's modules with typeclasses with type families

OMSet.hs

{-# LANGUAGE TypeFamilies, ScopedTypeVariables, ExistentialQuantification, GADTs, Rank2Types #-}
{-# LANGUAGE FlexibleContexts #-}
module OMSet where

import System.Environment (getArgs)

import qualified Data.Set as DS

-- ocaml modules always used exlpicitly, without inferring from arguments
-- simulate it by adding bogus argument to all typeclass types and methods

-- module signatures are typeclasses
class OrderedType otKey where
  type OTType otKey :: *
  otCompare :: otKey -> (OTType otKey) -> (OTType otKey) -> Ordering

class S sKey where
  type SElt sKey :: *
  type SType sKey :: *
  empty :: sKey -> SType sKey
  add :: sKey -> SElt sKey -> SType sKey -> SType sKey
  remove :: sKey -> SElt sKey -> SType sKey -> SType sKey
  contains :: sKey -> SElt sKey -> SType sKey -> Bool
  toList :: sKey -> SType sKey -> [SElt sKey]

-- functors are typeclass instances
newtype MakeDumb otKey = MakeDumb otKey
instance OrderedType otKey => S (MakeDumb otKey) where
  type SElt (MakeDumb otKey) = OTType otKey
  type SType (MakeDumb otKey) = [OTType otKey]
  empty = const []
  add sKey@(MakeDumb otKey) el els = if (contains sKey el els) then els else (el : els)
  remove (MakeDumb otKey) el els = filter ((/= EQ) . otCompare otKey el) els
  contains (MakeDumb otKey) el els = any ((== EQ) . otCompare otKey el) els
  toList (MakeDumb otKey) els = els

newtype TrivialOT otKey = TrivialOT otKey
instance Ord a => OrderedType (TrivialOT a) where
  type OTType (TrivialOT a) = a
  otCompare (TrivialOT a) = compare

newtype MakeSet otKey = MakeSet otKey
newtype OrdFromOT key a = OrdFromOT a
instance (OrderedType a, b ~ OTType a) => Eq (OrdFromOT a b) where
  (OrdFromOT a1) == (OrdFromOT a2 :: OrdFromOT a b) = otCompare (undefined :: a) a1 a2 == EQ
instance (OrderedType a, b ~ OTType a) => Ord (OrdFromOT a b) where
  compare (OrdFromOT a1) (OrdFromOT a2) = otCompare (undefined :: a) a1 a2
instance OrderedType otKey => S (MakeSet otKey) where
  type SElt (MakeSet otKey) = OTType otKey
  type SType (MakeSet otKey) = DS.Set (OrdFromOT otKey (OTType otKey))
  empty = const DS.empty
  add (MakeSet otKey) el els = DS.insert (OrdFromOT el) els
  remove (MakeSet otKey) el els = DS.delete (OrdFromOT el) els
  contains (MakeSet otKey) el els = DS.member (OrdFromOT el) els
  toList (MakeSet otKey) els = map (\(OrdFromOT el) -> el) (DS.toList els)

-- it is possible to pick concrete implementation at runtime
data SWrapper ot = forall key . (S key, OTType ot ~ SElt key) => SWrapper { selectSet :: key }

-- does it look like functor type? With restriction!
newtype SFType et = SFType ((OrderedType ot, OTType ot ~ et) => ot -> SWrapper ot)

pickSelector "dumb" = SFType (SWrapper . MakeDumb)
pickSelector "tree" = SFType (SWrapper . MakeSet)

class {- fail (OrderedType ot => S (SMSet sMaker ot)) => -} SMaker smKey where
  type SMSet smKey ot :: *
  smSKey :: (S (SMSet smKey otKey), OrderedType otKey, OTType otKey ~ SElt (SMSet smKey otKey)) => smKey -> otKey -> (SMSet smKey otKey)

data MakeDumb1 = MakeDumb1
instance SMaker MakeDumb1 where
  type SMSet MakeDumb1 ot = MakeDumb ot
  smSKey MakeDumb1 ot = MakeDumb ot
data MakeSet1 = MakeSet1
instance SMaker MakeSet1 where
  type SMSet MakeSet1 ot = MakeSet ot
  smSKey MakeSet1 ot = MakeSet ot

data SWrapper1 = forall sMaker . SMaker sMaker => SWrapper1 { unWrap1 :: sMaker }

-- pickSelector1 "dumb" = SWrapper1 MakeDumb1
-- pickSelector1 "tree" = SWrapper1 MakeSet1

handle1static smKey = print (toList sKey mySet)
  where
    sKey = smSKey smKey (TrivialOT (undefined :: Int))
    mySet = remove sKey 10 $ add sKey 10 $ add sKey 5 $ empty sKey

{- Could not deduce (S (SMSet sMaker (TrivialOT Int)))
 - handle1dynamic (SWrapper1 smKey) = print (toList sKey mySet)
  where
    sKey = smSKey smKey (TrivialOT (undefined :: Int))
    mySet = remove sKey 10 $ add sKey 10 $ add sKey 5 $ empty sKey-}

handle :: SFType Int -> IO ()
handle (SFType sel1) =
              case sel1 (TrivialOT (undefined :: Int)) of
                (SWrapper key) -> print (toList key mySet)
                                      where
                                        mySet = remove key 10 $ add key 10 $ add key 5 $ empty key

main = do
  [setType] <- getArgs
  handle (pickSelector setType)