Skip to content

Instantly share code, notes, and snippets.

@max630
Last active August 29, 2015 14:07
Show Gist options
  • Save max630/7f4b2e7834535cf47ee4 to your computer and use it in GitHub Desktop.
Save max630/7f4b2e7834535cf47ee4 to your computer and use it in GitHub Desktop.
simulation of ocaml's modules with typeclasses with type families
{-# 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)
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment