diff --git a/episode028-type-families-overlapping/Flatten'.hs b/episode028-type-families-overlapping/Flatten'.hs new file mode 100644 index 0000000..452ef32 --- /dev/null +++ b/episode028-type-families-overlapping/Flatten'.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +module Flatten' where + +import Data.Kind +import Data.Proxy +import Data.Foldable + +class Flatten a where + type Flattened a :: Type + flatten :: a -> Flattened a + +instance Flatten Bool where + type Flattened Bool = Bool + flatten x = x + +type family IsList (a :: Type) :: Bool where + IsList [a] = 'True + IsList _ = 'False + +instance Flatten' (IsList (Flattened a)) [a] => Flatten [a] where + type Flattened [a] = Flattened' (IsList (Flattened a)) [a] + flatten xs = flatten' (Proxy @(IsList (Flattened a))) xs + +class Flatten' (b :: Bool) a where + type Flattened' b a :: Type + flatten' :: Proxy b -> a -> Flattened' b a + +instance Flatten a => Flatten' False [a] where + type Flattened' False [a] = [Flattened a] + flatten' _ xs = map flatten xs + +instance (Flattened a ~ [b], Flatten a) => Flatten' True [a] where + type Flattened' True [a] = Flattened a + flatten' _ xs = concatMap flatten xs + +instance Flatten (Maybe a) where + type Flattened (Maybe a) = [a] + flatten Nothing = [] + flatten (Just x) = [x] + +-- >>> flatten [[False, True],[True], [False, False]] +-- [False,True,True,False,False] + +-- >>> flatten [Just False, Just True] +-- [False,True] diff --git a/episode028-type-families-overlapping/Flatten.hs b/episode028-type-families-overlapping/Flatten.hs new file mode 100644 index 0000000..ed64ec5 --- /dev/null +++ b/episode028-type-families-overlapping/Flatten.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +module Flatten where + +import Data.Kind +import Data.Proxy +import Data.Foldable + +class Flatten a where + type Flattened a :: Type + flatten :: a -> Flattened a + +instance Flatten Bool where + type Flattened Bool = Bool + flatten x = x + +type family IsList (a :: Type) :: Bool where + IsList [a] = 'True + IsList _ = 'False + +instance Flatten' (IsList a) [a] => Flatten [a] where + type Flattened [a] = Flattened' (IsList a) [a] + flatten xs = flatten' (Proxy @(IsList a)) xs + +class Flatten' (b :: Bool) a where + type Flattened' b a :: Type + flatten' :: Proxy b -> a -> Flattened' b a + +instance Flatten a => Flatten' False [a] where + type Flattened' False [a] = [Flattened a] + flatten' _ xs = map flatten xs + +instance (Flattened [a] ~ [b], Flatten [a]) => Flatten' True [[a]] where + type Flattened' True [[a]] = Flattened [a] + flatten' _ xss = concatMap flatten xss + +{- +instance Flatten a => Flatten [a] where + type Flattened [a] = [Flattened a] + flatten xs = map flatten xs + +instance Flatten a => Flatten [[a]] where + type Flattened [[a]] = [Flattened a] + flatten xss = concatMap flatten xss +-} + +-- >>> flatten [[False, True],[True], [False, False]] +-- [False,True,True,False,False] diff --git a/episode028-type-families-overlapping/LICENSE b/episode028-type-families-overlapping/LICENSE new file mode 100644 index 0000000..8b14ad8 --- /dev/null +++ b/episode028-type-families-overlapping/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2023, Well-Typed LLP + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Well-Typed LLP nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/episode028-type-families-overlapping/Show'.hs b/episode028-type-families-overlapping/Show'.hs new file mode 100644 index 0000000..bafc952 --- /dev/null +++ b/episode028-type-families-overlapping/Show'.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +module Show' where + +import Data.List +import Data.Kind +import Data.Proxy + +class MyShow a where + myshow :: a -> String + +instance MyShow Char where myshow = show +instance MyShow Bool where myshow = show + +instance MyShow' (IsString [a]) [a] => MyShow [a] where + myshow = myshow' (Proxy @(IsString [a])) + +type family IsString (a :: Type) :: Bool where + IsString String = True + IsString _ = False + +class MyShow' (b :: Bool) a where + myshow' :: Proxy b -> a -> String + +instance MyShow a => MyShow' False [a] where + myshow' _ xs = "[" ++ intercalate "," (map myshow xs) ++ "]" + +-- instance MyShow' True String where +instance a ~ Char => MyShow' True [a] where + myshow' _ xs = "\"" ++ xs ++ "\"" + + +example' :: MyShow [a] => [a] -> String +example' xs = myshow (xs ++ xs) + +-- >>> myshow [False, True, False] +-- "[False,True,False]" +-- >>> example' "unfolder" +-- "\"unfolderunfolder\"" diff --git a/episode028-type-families-overlapping/Show.hs b/episode028-type-families-overlapping/Show.hs new file mode 100644 index 0000000..3883851 --- /dev/null +++ b/episode028-type-families-overlapping/Show.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE UndecidableInstances #-} + +module Show where + +import Data.List +import Data.Kind +import Data.Proxy + +class MyShow a where + myshow :: a -> String + +instance MyShow Char where myshow = show +instance MyShow Bool where myshow = show + +instance MyShow a => MyShow [a] where + myshow xs = "[" ++ intercalate "," (map myshow xs) ++ "]" + +instance {-# OVERLAPPING #-} MyShow String where + myshow xs = "\"" ++ xs ++ "\"" + +example xs = myshow (xs ++ xs) + +-- >>> myshow [False, True, False] +-- "[False,True,False]" +-- >>> example "unfolder" +-- "\"unfolderunfolder\"" diff --git a/episode028-type-families-overlapping/episode028-type-families-overlapping.cabal b/episode028-type-families-overlapping/episode028-type-families-overlapping.cabal new file mode 100644 index 0000000..6fa3150 --- /dev/null +++ b/episode028-type-families-overlapping/episode028-type-families-overlapping.cabal @@ -0,0 +1,17 @@ +cabal-version: 3.0 +name: episode028-unfoldr +author: Andres Löh +maintainer: unfolder@well-typed.com +version: 1 +build-type: Simple +license: BSD-3-Clause +license-file: LICENSE + +library + default-language: GHC2021 + build-depends: base + exposed-modules: + Flatten + Flatten' + Show + Show'