-
-
Save aspiwack/6d6d69463abe95817453eed1198e6f1b to your computer and use it in GitHub Desktop.
Sources for Tweag I/O's reflection tutorial blog post
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
-- | This is the source file for the blog post found at Tweag I/O's blog: | |
-- <http://www.tweag.io/posts/2017-12-21-reflection-tutorial.html>. | |
{-# LANGUAGE FlexibleContexts #-} | |
{-# LANGUAGE ScopedTypeVariables #-} | |
{-# LANGUAGE UndecidableInstances #-} | |
module Reflection where | |
import Data.Proxy | |
import Data.Reflection | |
-- * Sorted list abstraction | |
newtype SortedList a = Sorted [a] | |
forget :: SortedList a -> [a] | |
forget (Sorted l) = l | |
nil :: SortedList a | |
nil = Sorted [] | |
singleton :: a -> SortedList a | |
singleton a = Sorted [a] | |
merge :: Ord a => SortedList a -> SortedList a -> SortedList a | |
merge (Sorted left0) (Sorted right0) = Sorted $ mergeList left0 right0 | |
where | |
-- 'mergeList l1 l2' returns a sorted permutation of 'l1++l2' provided | |
-- that 'l1' and 'l2' are sorted. | |
mergeList :: Ord a => [a] -> [a] -> [a] | |
mergeList [] right = right | |
mergeList left [] = left | |
mergeList left@(a:l) right@(b:r) = | |
if a <= b then | |
a : (mergeList l right) | |
else | |
b : (mergeList left r) | |
-- * Safely sorting with type classes | |
fromList :: Ord a => [a] -> SortedList a | |
fromList [] = nil | |
fromList [a] = singleton a | |
fromList l = merge orderedLeft orderedRight | |
where | |
orderedLeft = fromList left | |
orderedRight = fromList right | |
(left,right) = splitAt (div (length l) 2) l | |
-- | Safely sorts, but bound by the 'Ord' instance | |
sort :: Ord a => [a] -> [a] | |
sort l = forget (fromList l) | |
-- * Generic sorting with reflection | |
newtype ReflectedOrd s a = ReflectOrd a | |
-- | Like `ReflectOrd` but takes a `Proxy` argument to help GHC with unification | |
reflectOrd :: Proxy s -> a -> ReflectedOrd s a | |
reflectOrd _ a = ReflectOrd a | |
unreflectOrd :: ReflectedOrd s a -> a | |
unreflectOrd (ReflectOrd a) = a | |
data ReifiedOrd a = ReifiedOrd { | |
reifiedEq :: a -> a -> Bool, | |
reifiedCompare :: a -> a -> Ordering } | |
instance Reifies s (ReifiedOrd a) => Eq (ReflectedOrd s a) where | |
(==) (ReflectOrd x) (ReflectOrd y) = | |
reifiedEq (reflect (Proxy :: Proxy s)) x y | |
instance Reifies s (ReifiedOrd a) => Ord (ReflectedOrd s a) where | |
compare (ReflectOrd x) (ReflectOrd y) = | |
reifiedCompare (reflect (Proxy :: Proxy s)) x y | |
-- | Creates a `ReifiedOrd` with a comparison function. The equality function | |
-- is deduced from the comparison. | |
fromCompare :: (a -> a -> Ordering) -> ReifiedOrd a | |
fromCompare ord = ReifiedOrd { | |
reifiedEq = \x y -> ord x y == EQ, | |
reifiedCompare = ord } | |
-- | The generic sorting function | |
sortBy :: (a->a->Ordering) -> [a] -> [a] | |
sortBy ord l = | |
reify (fromCompare ord) $ \ p -> | |
map unreflectOrd . sort . map (reflectOrd p) $ l |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment