hkt (empty) → 0.0.1

raw patch · 10 files changed

+273/−0 lines, 10 filesdep +basedep +hktdep +hspecsetup-changed

Dependencies added: base, hkt, hspec, inspection-testing, protolude, text

Files

• CHANGELOG.md +5/−0
• LICENSE +30/−0
• README.md +3/−0
• Setup.hs +2/−0
• hkt.cabal +63/−0
• src/HKT.hs +5/−0
• src/HKT/Merge.hs +39/−0
• src/HKT/Squash.hs +43/−0
• src/HKT/Type.hs +7/−0
• tests/Main.hs +76/−0

@@ -0,0 +1,5 @@+# Changelog++## 0.0.1++Initial version of the library

@@ -0,0 +1,30 @@+Copyright Elias Lawson-Fox (c) 2018++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 Elias Lawson-Fox 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.

@@ -0,0 +1,3 @@+# HKT++A library for building and manipulating higher kinded data types.

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -0,0 +1,63 @@+-- This file has been generated from package.yaml by hpack version 0.21.2.+--+-- see: https://github.com/sol/hpack+--+-- hash: 3d540efda0d046b834eb3065d5ea07eb9c0eef0313d49eb0b69c48bab4aa08c4++name:           hkt+version:        0.0.1+synopsis:       A library for higher kinded types.+description:    A library for building and manipulating higher kinded data types.+category:       web+homepage:       https://github.com/eliaslfox/hkt#readme+author:         Elias Lawson-Fox+maintainer:     eliaslfox@gmail.com+license:        BSD3+license-file:   LICENSE+build-type:     Simple+cabal-version:  >= 1.10++extra-source-files:+    CHANGELOG.md+    LICENSE+    README.md++flag reduce-core-output+  description: Reduce the amount of core outputted by inspection-testing+  manual: True+  default: False++library+  exposed-modules:+      HKT+      HKT.Merge+      HKT.Squash+      HKT.Type+  other-modules:+      Paths_hkt+  hs-source-dirs:+      src+  default-extensions: TypeFamilies DefaultSignatures MultiParamTypeClasses FlexibleContexts LambdaCase EmptyCase TypeOperators FlexibleInstances NoImplicitPrelude DeriveAnyClass+  ghc-options: -Wall+  build-depends:+      base >=4.7 && <5+    , protolude+  default-language: Haskell2010++test-suite main+  type: exitcode-stdio-1.0+  main-is: tests/Main.hs+  other-modules:+      Paths_hkt+  default-extensions: TypeFamilies DefaultSignatures MultiParamTypeClasses FlexibleContexts LambdaCase EmptyCase TypeOperators FlexibleInstances NoImplicitPrelude DeriveAnyClass DeriveGeneric DerivingStrategies KindSignatures OverloadedStrings StandaloneDeriving TemplateHaskell NamedFieldPuns+  ghc-options: -Wall+  build-depends:+      base >=4.7 && <5+    , hkt+    , hspec+    , inspection-testing+    , protolude+    , text+  if flag(reduce-core-output)+    ghc-options: -dsuppress-idinfo -dsuppress-coercions -dsuppress-type-applications -dsuppress-module-prefixes -dsuppress-type-signatures -dsuppress-uniques+  default-language: Haskell2010

@@ -0,0 +1,5 @@+module HKT (HKT, ID, Merge, Squash, merge, squash) where++import HKT.Type (HKT, ID, )+import HKT.Merge (Merge, merge)+import HKT.Squash (Squash, squash)

@@ -0,0 +1,39 @@+module HKT.Merge (Merge, merge) where++import Protolude++import HKT.Type (ID)+import GHC.Generics (Generic, Rep, M1(M1), K1(K1), V1, U1, from, to, (:*:)((:*:)))+import qualified Data.Maybe++class Merge a where+    merge :: a ID -> a Maybe -> a ID+    default merge ::+        ( Generic (a Maybe)+        , Generic (a ID)+        , GMerge (Rep (a ID)) (Rep (a Maybe))+        ) => a ID -> a Maybe -> a ID+    merge a b = to $ gmerge (from a ) (from b)++class GMerge a b where+    gmerge :: a p -> b p -> a p++instance GMerge a b => GMerge (M1 i c a) (M1 i c b) where+    gmerge (M1 a) (M1 b) = M1 $ gmerge a b+    {-# INLINE gmerge #-}++instance (GMerge a b, GMerge c d) => GMerge (a :*: c) (b :*: d) where+    gmerge (a :*: c) (b :*: d) = gmerge a b :*: gmerge c d+    {-# INLINE gmerge #-}++instance GMerge (K1 a k) (K1 a (Maybe k)) where+    gmerge (K1 a) (K1 ma) = K1 $ Data.Maybe.fromMaybe a ma+    {-# INLINE gmerge #-}++instance GMerge U1 U1 where+    gmerge U1 _ = U1+    {-# INLINE gmerge #-}++instance GMerge V1 V1 where+    gmerge _ = (\case {})+    {-# INLINE gmerge #-}

@@ -0,0 +1,43 @@+module HKT.Squash (Squash, squash) where++import Protolude++import HKT.Type (ID)+import GHC.Generics (Generic, Rep, M1(M1), K1(K1), V1, U1, from, to, (:*:)((:*:)), (:+:)(L1, R1))++class Squash a where+    squash :: a Maybe -> Maybe (a ID)+    default squash ::+        ( Generic (a Maybe)+        , Generic (a ID)+        , GSquash (Rep (a Maybe)) (Rep (a ID))+        ) => a Maybe -> Maybe (a ID)+    squash x = to <$> gsquash (from x)++class GSquash a b where+    gsquash :: a p -> Maybe (b p)++instance GSquash a b => GSquash (M1 i c a) (M1 i c b) where+    gsquash (M1 x) = M1 <$> gsquash x+    {-# INLINE gsquash #-}++instance (GSquash a b, GSquash c d) => GSquash (a :*: c) (b :*: d) where+    gsquash (a :*: b) = (:*:) <$> gsquash a <*> gsquash b+    {-# INLINE gsquash #-}++instance (GSquash a b, GSquash c d) => GSquash (a :+: c) (b :+: d) where+    gsquash (L1 x) = L1 <$> gsquash x+    gsquash (R1 x) = R1 <$> gsquash x+    {-# INLINE gsquash #-}++instance GSquash (K1 a (Maybe k)) (K1 a k) where+    gsquash (K1 k) = K1 <$> k+    {-# INLINE gsquash #-}++instance GSquash U1 U1 where+    gsquash U1 = Just U1+    {-# INLINE gsquash #-}++instance GSquash V1 V1 where+    gsquash = (\case {})+    {-# INLINE gsquash #-}

@@ -0,0 +1,7 @@+module HKT.Type (ID, HKT) where++data ID a++type family HKT a b where+    HKT ID a = a+    HKT b a = b a

@@ -0,0 +1,76 @@+{-# OPTIONS_GHC -O -fplugin Test.Inspection.Plugin #-}++module Main where++import Protolude hiding (Product)++import GHC.Generics (Generic)+import Data.Text (Text)+import Test.Hspec+import Test.Inspection (inspect, (===))+import qualified Data.Maybe++import HKT (HKT, ID, Merge, Squash, squash, merge)++data Empty (a :: * -> *)+    deriving stock Generic+    deriving anyclass (Squash, Merge) +data One (a :: * -> *) = One+    deriving stock Generic+    deriving anyclass (Squash, Merge)++data Product (a :: * -> *) =+    Product+    { first' :: HKT a Int+    , second' :: HKT a Text+    }+    deriving stock Generic+    deriving anyclass (Squash, Merge)++deriving instance Show (Product ID)+deriving instance Eq (Product ID)++data Sum (a :: * -> *) +    = SumLeft (HKT a Int) +    | SumRight (HKT a Text)+    deriving stock Generic+    deriving anyclass Squash++squash1, squash2 :: Product Maybe -> Maybe (Product ID)+squash1 = squash+squash2 Product { first', second' } = +    Product <$> first' <*> second'++inspect $ 'squash1 === 'squash2++merge1, merge2 :: Product ID -> Product Maybe -> Product ID+merge1 = merge+merge2 (Product pf pl) (Product p1f p1l) =+    Product+        (Data.Maybe.fromMaybe pf p1f)+        (Data.Maybe.fromMaybe pl p1l)++inspect $ 'merge1 === 'merge2++main :: IO ()+main = +    let+        p :: Product ID+        p = Product 5 "hello"++        p1 :: Product Maybe+        p1 = Product (Just 5) (Just "hello")+    in+    hspec $ do+        describe "Squash" $ do+            it "squashes fields properly" $ do+                squash p1 `shouldBe` Just p+            it "returns nothing when missing fields" $ do+                squash p1{first' = Nothing} `shouldBe` Nothing+        describe "Merge" $ do+            it "merges fields properly" $ do+                merge p p1 `shouldBe` p+            it "takes fields from the second argument when avaliable" $ do+                merge p{first' = 6} p1 `shouldBe` p+            it "takes fields from the first argument when missing in the second" $ do+                merge p p1{first' = Nothing, second' = Just "meh"} `shouldBe` p{second' = "meh"}