diff --git a/Data/StackPrism/TH.hs b/Data/StackPrism/TH.hs --- a/Data/StackPrism/TH.hs +++ b/Data/StackPrism/TH.hs @@ -1,5 +1,6 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE LambdaCase #-} module Data.StackPrism.TH ( -- * Deriving stack prisms @@ -71,10 +72,27 @@ tNm <- newName "t" let t = VarT tNm let fromType = foldr (-:) t tys - let toType = foldl (\t' (PlainTV ty) -> AppT t' (VarT ty)) (ConT resNm) tyArgs -: t + let tyArgName = \case + PlainTV tyName -> tyName + KindedTV tyName _ -> tyName + + -- Avoid needing -XKindSignatures for deriving stack prisms for simple + -- types. It seems in recent versions of template-haskell, tyargs of kind + -- *, such as that of Maybe, are now KindedTVs instead of PlainTVs. If we + -- copy the KindedTVs straight into the output type signature, GHC + -- requires -XKindSignatures. + let simplifyTyArg = \case + KindedTV tyName StarT -> PlainTV tyName + ty -> ty + + let toType = foldl + (\t' ty -> AppT t' (VarT (tyArgName ty))) + (ConT resNm) tyArgs -: t + return $ ( name - , ForallT (PlainTV tNm:tyArgs) [] $ ConT (mkName "StackPrism") `AppT` fromType `AppT` toType + , ForallT (PlainTV tNm : (map simplifyTyArg tyArgs)) [] $ + ConT (mkName "StackPrism") `AppT` fromType `AppT` toType , stackPrismE `AppE` stackPrismCon `AppE` stackPrismDes ) diff --git a/ExampleGeneric.hs b/ExampleGeneric.hs deleted file mode 100644 --- a/ExampleGeneric.hs +++ /dev/null @@ -1,40 +0,0 @@ -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE DeriveGeneric #-} - -module Example where - -import Data.StackPrism.Generic - -import GHC.Generics - - -data Person = Person - { name :: String - , gender :: Gender - , age :: Int - , location :: Coords - } deriving (Eq, Show, Generic) - -data Gender = Male | Female - deriving (Eq, Show, Generic) - -data Coords = Coords { lat :: Float, lng :: Float } - deriving (Eq, Show, Generic) - --- The types in the first type parameter match those of the corresponding constructor's fields. -person :: StackPrism (String :- Gender :- Int :- Coords :- t) (Person :- t) -male :: StackPrism t (Gender :- t) -female :: StackPrism t (Gender :- t) -coords :: StackPrism (Float :- Float :- t) (Coords :- t) - -PrismList (P person) = mkPrismList :: StackPrisms Person -PrismList (P male :& P female) = mkPrismList :: StackPrisms Gender -PrismList (P coords) = mkPrismList :: StackPrisms Coords - - -false, true :: StackPrism t (Bool :- t) -PrismList (P false :& P true) = mkPrismList :: StackPrisms Bool - -nil :: StackPrism t ([a] :- t) -cons :: StackPrism (a :- [a] :- t) ([a] :- t) -PrismList (P nil :& P cons) = mkPrismList :: StackPrisms [a] diff --git a/ExampleTH.hs b/ExampleTH.hs deleted file mode 100644 --- a/ExampleTH.hs +++ /dev/null @@ -1,23 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} - -module Example where - -import Data.StackPrism.TH - - -data Person = Person - { name :: String - , gender :: Gender - , age :: Int - , location :: Coords - } deriving (Eq, Show) - -data Gender = Male | Female - deriving (Eq, Show) - -data Coords = Coords { lat :: Float, lng :: Float } - deriving (Eq, Show) - -deriveStackPrisms ''Person -deriveStackPrisms ''Gender -deriveStackPrisms ''Coords diff --git a/stack-prism.cabal b/stack-prism.cabal --- a/stack-prism.cabal +++ b/stack-prism.cabal @@ -1,5 +1,5 @@ Name: stack-prism -Version: 0.1.2 +Version: 0.1.3 Synopsis: Stack prisms Description: Haskell lens prisms that use stack types @@ -12,15 +12,15 @@ Bug-reports: https://github.com/MedeaMelana/stack-prism/issues -Cabal-Version: >= 1.6 +Cabal-Version: >= 1.8 License: BSD3 License-file: LICENSE Category: Data Build-type: Simple -extra-source-files: - ExampleGeneric.hs - ExampleTH.hs +Source-Repository head + Type: git + Location: https://github.com/MedeaMelana/stack-prism Library Exposed-Modules: Data.StackPrism, @@ -32,6 +32,12 @@ transformers >= 0.2 && < 0.5, template-haskell >= 2.8 && < 2.11 -Source-Repository head - Type: git - Location: https://github.com/MedeaMelana/stack-prism +Test-Suite tests + Type: exitcode-stdio-1.0 + Hs-Source-Dirs: tests + Main-Is: Tests.hs + Other-Modules: TestGeneric, + TestTH + Build-Depends: base >= 3.0 && < 5, + stack-prism, + template-haskell >= 2.8 && < 2.11 diff --git a/tests/TestGeneric.hs b/tests/TestGeneric.hs new file mode 100644 --- /dev/null +++ b/tests/TestGeneric.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE DeriveGeneric #-} + +module TestGeneric where + +import Data.StackPrism.Generic + +import GHC.Generics + + +data Person = Person + { name :: String + , gender :: Gender + , age :: Int + , location :: Coords + } deriving (Eq, Show, Generic) + +data Gender = Male | Female + deriving (Eq, Show, Generic) + +data Coords = Coords { lat :: Float, lng :: Float } + deriving (Eq, Show, Generic) + +-- The types in the first type parameter match those of the corresponding constructor's fields. +person :: StackPrism (String :- Gender :- Int :- Coords :- t) (Person :- t) +male :: StackPrism t (Gender :- t) +female :: StackPrism t (Gender :- t) +coords :: StackPrism (Float :- Float :- t) (Coords :- t) + +PrismList (P person) = mkPrismList :: StackPrisms Person +PrismList (P male :& P female) = mkPrismList :: StackPrisms Gender +PrismList (P coords) = mkPrismList :: StackPrisms Coords + + +false, true :: StackPrism t (Bool :- t) +PrismList (P false :& P true) = mkPrismList :: StackPrisms Bool + +nil :: StackPrism t ([a] :- t) +cons :: StackPrism (a :- [a] :- t) ([a] :- t) +PrismList (P nil :& P cons) = mkPrismList :: StackPrisms [a] diff --git a/tests/TestTH.hs b/tests/TestTH.hs new file mode 100644 --- /dev/null +++ b/tests/TestTH.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE TemplateHaskell #-} + +module TestTH where + +import Data.StackPrism.TH + + +data Person = Person + { name :: String + , gender :: Gender + , age :: Int + , location :: Coords + } deriving (Eq, Show) + +data Gender = Male | Female + deriving (Eq, Show) + +data Coords = Coords { lat :: Float, lng :: Float } + deriving (Eq, Show) + +deriveStackPrisms ''Person +deriveStackPrisms ''Gender +deriveStackPrisms ''Coords + +-- Regression test for https://github.com/MedeaMelana/stack-prism/issues/3 +deriveStackPrisms ''Maybe diff --git a/tests/Tests.hs b/tests/Tests.hs new file mode 100644 --- /dev/null +++ b/tests/Tests.hs @@ -0,0 +1,6 @@ +-- For now, test just that these modules compile by importing them. +import TestTH () +import TestGeneric () + +main :: IO () +main = return ()