packages feed

th-instance-reification (empty) → 0.1.0

raw patch · 7 files changed

+399/−0 lines, 7 filesdep +HTFdep +HUnitdep +QuickChecksetup-changed

Dependencies added: HTF, HUnit, QuickCheck, QuickCheck-GenT, base, containers, loch-th, placeholders, quickcheck-instances, template-haskell

Files

+ LICENSE view
@@ -0,0 +1,22 @@+Copyright (c) 2014, Nikita Volkov++Permission is hereby granted, free of charge, to any person+obtaining a copy of this software and associated documentation+files (the "Software"), to deal in the Software without+restriction, including without limitation the rights to use,+copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the+Software is furnished to do so, subject to the following+conditions:++The above copyright notice and this permission notice shall be+included in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES+OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT+HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,+WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING+FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR+OTHER DEALINGS IN THE SOFTWARE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ src/HTFTestSuite.hs view
@@ -0,0 +1,44 @@+{-# OPTIONS_GHC -F -pgmF htfpp #-}++import Test.Framework+import THInstanceReification.Prelude.Basic+import THInstanceReification.Prelude.TH+import THInstanceReification++main = htfMain $ htf_thisModulesTests+++data A = A++test_existingInstance = do+  assertBool $ read $( do+      t <- [t| (Int, Int) |]+      r <- isProperInstance ''Show [t]+      stringE $ show $ r+    )++test_nonExistingInstance = do+  assertBool $ not $ read $( do+      t <- [t| (Int, A) |]+      r <- isProperInstance ''Show [t]+      stringE $ show $ r+    )+++class MultiParamClass a b c+instance (Eq a) => MultiParamClass a Int Char++test_existingInstanceOnMultiParamClass = do+  assertBool $ read $( do+      int <- [t|Int|]+      char <- [t|Char|]+      stringE . show =<< isProperInstance ''MultiParamClass [int, int, char]+    )++test_nonExistingInstanceOnMultiParamClass = do+  assertBool $ not $ read $( do+      int <- [t|Int|]+      char <- [t|Char|]+      a <- [t|A|]+      stringE . show =<< isProperInstance ''MultiParamClass [a, int, char]+    )
+ src/THInstanceReification.hs view
@@ -0,0 +1,73 @@+-- |+-- Fixed versions of 'reifyInstances' and 'isInstance' as per+-- the following ghc issue:+-- <https://ghc.haskell.org/trac/ghc/ticket/7066>.+module THInstanceReification+(+  reifyProperInstances,+  isProperInstance,+  typesSatisfyDecConstraints,+)+where++import THInstanceReification.Prelude.Basic+import THInstanceReification.Prelude.TH+import qualified Data.Map as Map+++-- |+-- Same as 'reifyInstances', but also checks the constraints.+reifyProperInstances :: Name -> [Type] -> Q [InstanceDec]+reifyProperInstances n tl = +  reifyInstances n tl >>= filterM (typesSatisfyDecConstraints tl)++-- |+-- Same as 'isInstance', but also checks the constraints.+isProperInstance :: Name -> [Type] -> Q Bool+isProperInstance n tl = +  not . null <$> reifyProperInstances n tl++-- |+-- Analyze the constraints of the provided instance dec to be satisfied +-- by the provided types.+-- +-- Note that this function does not analyze the equality constraints (@F a ~ Bool@).+-- It simply considers them to be true.+typesSatisfyDecConstraints :: [Type] -> InstanceDec -> Q Bool+typesSatisfyDecConstraints tl = \case+  InstanceD c it _ -> let+    ([ConT n], htl) = splitAt 1 $ reverse $ unapplyType it+    in analyze c n htl+  d -> fail $ "Not an instance dec: " <> show d+  where+    analyze c n htl = and <$> mapM analyzeConstraint c+      where+        actualTypeByVarName = \n ->+          Map.lookup n m ?: +          ($bug $ "Unexpected key: " <> show n <> ", in a map: " <> show m)+          where+            m = Map.fromList $ concat $ map accRecords $ zip tl htl+              where+                accRecords = \case+                  (AppT al ar, AppT hl hr) -> accRecords (al, hl) ++ accRecords (ar, hr)+                  (a, VarT n) -> [(n, a)]+                  (a, h) | a /= h -> fail $ "Unmatching types: " <> show a <> ", " <> show h+                  _ -> []+        analyzeConstraint = \case+          EqualP _ _ -> return True+          ClassP n tl -> do+            let tl' = map (replaceTypeVars actualTypeByVarName) tl+            isProperInstance n tl'++unapplyType :: Type -> [Type]+unapplyType = \case+  AppT l r -> r : unapplyType l+  t -> [t]++-- | Deeply traverse the type signature and replace all vars in it.+replaceTypeVars :: (Name -> Type) -> Type -> Type+replaceTypeVars f = \case+  AppT l r -> AppT (replaceTypeVars f l) (replaceTypeVars f r)+  VarT n -> f n+  t -> t+
+ src/THInstanceReification/Prelude/Basic.hs view
@@ -0,0 +1,88 @@+module THInstanceReification.Prelude.Basic+( +  module Exports,++  traceM,+  bug,+  bottom,++  (?:),+  (|>),+  (<|),+  (|$>),+)+where++-- base+import Prelude as Exports hiding (concat, foldr, mapM_, sequence_, foldl1, maximum, minimum, product, sum, all, and, any, concatMap, elem, foldl, foldr1, notElem, or, mapM, sequence, FilePath, id, (.))+import Control.Monad as Exports hiding (mapM_, sequence_, forM_, msum, mapM, sequence, forM)+import Control.Applicative as Exports+import Control.Arrow as Exports hiding (left, right)+import Control.Category as Exports+import Data.Monoid as Exports+import Data.Foldable as Exports+import Data.Traversable as Exports hiding (for)+import Data.Maybe as Exports+import Data.Either as Exports+import Data.List as Exports hiding (concat, foldr, foldl1, maximum, minimum, product, sum, all, and, any, concatMap, elem, foldl, foldr1, notElem, or, find, maximumBy, minimumBy, mapAccumL, mapAccumR, foldl')+import Data.Tuple as Exports+import Data.Ord as Exports (Down(..))+import Data.String as Exports+import Data.Int as Exports+import Data.Word as Exports+import Data.Ratio as Exports+import Data.Fixed as Exports+import Data.Ix as Exports+import Data.Data as Exports+import Text.Read as Exports (readMaybe, readEither)+import Control.Exception as Exports hiding (tryJust, try, assert)+import Control.Concurrent as Exports hiding (yield)+import System.Mem.StableName as Exports+import System.Timeout as Exports+import System.Exit as Exports+import System.IO.Unsafe as Exports+import System.IO as Exports (Handle, hClose)+import System.IO.Error as Exports+import Unsafe.Coerce as Exports+import GHC.Exts as Exports hiding (Any, traceEvent)+import GHC.Generics as Exports (Generic)+import GHC.IO.Exception as Exports+import Data.IORef as Exports+import Data.STRef as Exports+import Control.Monad.ST as Exports+import Debug.Trace as Exports++-- placeholders+import Development.Placeholders as Exports+++import qualified Debug.Trace.LocationTH++traceM :: (Monad m) => String -> m ()+traceM s = trace s $ return ()++bug = [e| $(Debug.Trace.LocationTH.failure) . (msg <>) |]+  where+    msg = "A \"th-instance-reification\" package bug: " :: String++bottom = [e| $bug "Bottom evaluated" |]++(?:) :: Maybe a -> a -> a+maybeA ?: b = fromMaybe b maybeA+{-# INLINE (?:) #-}++(|>) :: a -> (a -> b) -> b+a |> aToB = aToB a+{-# INLINE (|>) #-}++(<|) :: (a -> b) -> a -> b+aToB <| a = aToB a+{-# INLINE (<|) #-}++-- | +-- The following are all the same:+-- fmap f a == f <$> a == a |> fmap f == a |$> f+-- +-- This operator accomodates the left-to-right operators: >>=, >>>, |>.+(|$>) = flip fmap+{-# INLINE (|$>) #-}
+ src/THInstanceReification/Prelude/TH.hs view
@@ -0,0 +1,18 @@+module THInstanceReification.Prelude.TH+(+  module Exports,++  purify,+  tryToReify,+)+where++import THInstanceReification.Prelude.Basic+import Language.Haskell.TH as Exports+++purify :: Q a -> a+purify = unsafePerformIO . runQ++tryToReify :: Name -> Q (Maybe Info)+tryToReify n = recover (return Nothing) (fmap Just $ reify n)
+ th-instance-reification.cabal view
@@ -0,0 +1,152 @@+name:+  th-instance-reification+version:+  0.1.0+synopsis:+  Fixed versions of instances reification functions+description:+  Provides fixed versions of 'reifyInstances' and 'isInstance' as per+  the following ghc issue:+  <https://ghc.haskell.org/trac/ghc/ticket/7066>.+category:+  Template Haskell+homepage:+  https://github.com/nikita-volkov/th-instance-reification +bug-reports:+  https://github.com/nikita-volkov/th-instance-reification/issues +author:+  Nikita Volkov <nikita.y.volkov@mail.ru>+maintainer:+  Nikita Volkov <nikita.y.volkov@mail.ru>+copyright:+  (c) 2014, Nikita Volkov+license:+  MIT+license-file:+  LICENSE+build-type:+  Simple+cabal-version:+  >=1.10+++source-repository head+  type:+    git+  location:+    git://github.com/nikita-volkov/th-instance-reification.git+++library+  hs-source-dirs:+    src+  other-modules:+    THInstanceReification.Prelude.Basic+    THInstanceReification.Prelude.TH+  exposed-modules:+    THInstanceReification+  build-depends:+    -- data:+    containers,+    -- debugging:+    loch-th == 0.2.*,+    placeholders == 0.1.*,+    -- general:+    template-haskell,+    base >= 4.5 && < 5+  default-extensions:+    Arrows+    BangPatterns+    ConstraintKinds+    DataKinds+    DefaultSignatures+    DeriveDataTypeable+    DeriveGeneric+    EmptyDataDecls+    FlexibleContexts+    FlexibleInstances+    FunctionalDependencies+    GADTs+    GeneralizedNewtypeDeriving+    ImpredicativeTypes+    LambdaCase+    LiberalTypeSynonyms+    MultiParamTypeClasses+    MultiWayIf+    NoImplicitPrelude+    NoMonomorphismRestriction+    OverloadedStrings+    PatternGuards+    QuasiQuotes+    RankNTypes+    RecordWildCards+    ScopedTypeVariables+    StandaloneDeriving+    TemplateHaskell+    TupleSections+    TypeFamilies+    TypeOperators+  default-language:+    Haskell2010+++test-suite th-instance-reification-htf-test-suite+  type:             +    exitcode-stdio-1.0+  hs-source-dirs:   +    src+  main-is:          +    HTFTestSuite.hs+  ghc-options:+    -threaded+    "-with-rtsopts=-N"+  build-depends:+    -- testing:+    quickcheck-instances,+    QuickCheck-GenT == 0.1.*,+    QuickCheck,+    HUnit,+    HTF == 0.11.*,+    -- data:+    containers,+    -- debugging:+    loch-th == 0.2.*,+    placeholders == 0.1.*,+    -- general:+    template-haskell,+    base >= 4.5 && < 5+  default-extensions:+    Arrows+    BangPatterns+    ConstraintKinds+    DataKinds+    DefaultSignatures+    DeriveDataTypeable+    DeriveGeneric+    EmptyDataDecls+    FlexibleContexts+    FlexibleInstances+    FunctionalDependencies+    GADTs+    GeneralizedNewtypeDeriving+    ImpredicativeTypes+    LambdaCase+    LiberalTypeSynonyms+    MultiParamTypeClasses+    MultiWayIf+    NoImplicitPrelude+    NoMonomorphismRestriction+    OverloadedStrings+    PatternGuards+    QuasiQuotes+    RankNTypes+    RecordWildCards+    ScopedTypeVariables+    StandaloneDeriving+    TemplateHaskell+    TupleSections+    TypeFamilies+    TypeOperators+  default-language:+    Haskell2010+