packages feed

uom-plugin 0.2.0.1 → 0.3.0.0

raw patch · 17 files changed

+411/−127 lines, 17 filesdep +hlintdep ~basedep ~ghcdep ~tasty

Dependencies added: hlint

Dependency ranges changed: base, ghc, tasty, tasty-hunit, template-haskell

Files

changelog view
@@ -1,5 +1,12 @@ -*-change-log-*- +0.3.0.0 Adam Gundry <adam@well-typed.com> June 2018+	* Support building on GHC 8.2 (but not yet 8.4)+	* Fix unit safety bug in GHC 8.0 and later (see #22)+	* Expose toRational' in Data.UnitsOfMeasure+	* Add hlint test suite (thanks to Phil de Joux)+	* Packaging improvements+ 0.2.0.1 Adam Gundry <adam@well-typed.com> May 2016 	* Support building on GHC 8.0
+ hlint/HLint.hs view
@@ -0,0 +1,19 @@+module Main (main) where++import Language.Haskell.HLint (hlint)+import System.Exit (exitFailure, exitSuccess)++arguments :: [String]+arguments =+    [ "lint"+    , "--ignore=Parse error"+    , "--ignore=Use fewer imports"  -- This is a pain for the CPP in TcPluginExtras+    , "src"+    , "tests"+    , "hlint"+    ]++main :: IO ()+main = do+    hints <- hlint arguments+    if null hints then exitSuccess else exitFailure
+ package.yaml view
@@ -0,0 +1,75 @@+# This YAML file describes your package. Stack will automatically generate a+# Cabal file when you run `stack build`. See the hpack website for help with+# this file: <https://github.com/sol/hpack>.+author: Adam Gundry <adam@well-typed.com>+maintainer: Adam Gundry <adam@well-typed.com>+name: uom-plugin+synopsis: Units of measure as a GHC typechecker plugin+description: |-+    The @uom-plugin@ library adds support for units of measure to GHC+    using the new experimental facility for typechecker plugins, which+    is available in GHC 7.10 and later.  See+    "Data.UnitsOfMeasure.Tutorial" for an introduction to the library.+category: Type System+license: BSD3+license-file: LICENSE+stability: experimental+github: adamgundry/uom-plugin+copyright: Copyright (c) 2014-2018, Adam Gundry+tested-with: >++  GHC == 7.10.3,+  GHC == 8.0.2,+  GHC == 8.2.2+extra-source-files:+- package.yaml+- changelog+ghc-options:+- -Wall+- -fno-warn-unticked-promoted-constructors+library:+  dependencies:+  - base >=4.7 && <5+  - deepseq >=1.3 && <1.5+  - ghc >= 7.9 && <8.4+  - ghc-tcplugins-extra >=0.1 && <0.3+  - template-haskell >=2.9 && <2.13+  - containers >=0.5 && <0.6+  - units-parser >=0.1 && <0.2+  source-dirs: src+  exposed-modules:+  - Data.UnitsOfMeasure+  - Data.UnitsOfMeasure.Convert+  - Data.UnitsOfMeasure.Defs+  - Data.UnitsOfMeasure.Internal+  - Data.UnitsOfMeasure.Plugin+  - Data.UnitsOfMeasure.Read+  - Data.UnitsOfMeasure.Show+  - Data.UnitsOfMeasure.Singleton+  - Data.UnitsOfMeasure.Tutorial+tests:+  units:+    dependencies:+    - base+    - uom-plugin+    - tasty >=0.10 && <1.1+    - tasty-hunit >=0.9 && <0.10.1+    ghc-options:+    - -O0+    other-extensions: TemplateHaskell+    main: Tests.hs+    source-dirs:+    - tests+  hlint:+    dependencies:+    - base+    - hlint >= 1.7 && <2.2+    ghc-options:+    - -Wall+    - -O0+    - -rtsopts+    - -threaded+    - -with-rtsopts=-N+    main: HLint.hs+    source-dirs:+    - hlint+version: '0.3.0.0'
src/Data/UnitsOfMeasure.hs view
@@ -1,13 +1,9 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE MagicHash #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RoleAnnotations #-}-{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-}@@ -41,6 +37,9 @@     , (/:)     , recip'     , fromRational'++      -- * Unit-safe 'Real' operations+    , toRational'        -- * Unit-safe 'Floating' operations     , sqrt'
src/Data/UnitsOfMeasure/Convert.hs view
@@ -4,7 +4,6 @@ {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE PolyKinds #-}-{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-}@@ -91,7 +90,7 @@   -- | The conversion ratio between this base unit and its canonical   -- base unit.  If @b@ is canonical then this ratio is @1@.   conversionBase :: proxy b -> Quantity Rational (Base b /: CanonicalBaseUnit b)-  default conversionBase :: (Base b ~ CanonicalBaseUnit b) => proxy b -> Quantity Rational (Base b /: Base b)+  default conversionBase :: (Base b ~ CanonicalBaseUnit b) => proxy b -> Quantity Rational (Base b /: CanonicalBaseUnit b)   conversionBase _ = 1  -- | Convert a unit into its canonical representation, where units are
src/Data/UnitsOfMeasure/Internal.hs view
@@ -42,6 +42,9 @@     , recip'     , fromRational' +      -- * Unit-safe 'Real' operations+    , toRational'+       -- * Unit-safe 'Floating' operations     , sqrt' @@ -186,6 +189,10 @@ -- | Convert a 'Rational' quantity into any 'Fractional' type ('fromRational'). fromRational' :: Fractional a => Quantity Rational u -> Quantity a u fromRational' (MkQuantity x) = MkQuantity (fromRational x)++-- | Convert any 'Real' quantity into a 'Rational' type ('toRational').+toRational' :: Real a => Quantity a u -> Quantity Rational u+toRational' (MkQuantity x) = MkQuantity (toRational x)   -- | Taking the square root ('sqrt') of a quantity requires its units
src/Data/UnitsOfMeasure/Plugin.hs view
@@ -56,10 +56,12 @@ plugin = defaultPlugin { tcPlugin = const $ Just uomPlugin }  uomPlugin :: TcPlugin-uomPlugin = tracePlugin "uom-plugin" $ TcPlugin { tcPluginInit  = lookupUnitDefs-                                               , tcPluginSolve = unitsOfMeasureSolver-                                               , tcPluginStop  = const $ return ()-                                               }+uomPlugin = tracePlugin+                "uom-plugin"+                TcPlugin { tcPluginInit  = lookupUnitDefs+                         , tcPluginSolve = unitsOfMeasureSolver+                         , tcPluginStop  = const $ return ()+                         }   unitsOfMeasureSolver :: UnitDefs -> [Ct] -> [Ct] -> [Ct] -> TcPluginM TcPluginResult@@ -71,10 +73,10 @@       (_:_) -> do         sr <- simplifyUnits uds $ map snd unit_givens         tcPluginTrace "unitsOfMeasureSolver simplified givens only" $ ppr sr-        return $ case sr of+        case sr of           -- Simplified tvs []    evs eqs -> TcPluginOk (map (solvedGiven . fst) unit_givens) []-          Simplified _    -> TcPluginOk [] []-          Impossible eq _ -> TcPluginContradiction [fromUnitEquality eq]+          Simplified _    -> return $ TcPluginOk [] []+          Impossible eq _ -> reportContradiction uds eq   where     foo :: Ct -> Either UnitEquality Ct -> Either (Ct, UnitEquality) Ct     foo ct (Left x)    = Left (ct, x)@@ -85,9 +87,7 @@  unitsOfMeasureSolver uds givens _deriveds wanteds = do   xs <- lookForUnpacks uds givens wanteds-  case null xs of-   False -> return $ TcPluginOk [] xs-   True  -> do+  if not $ null xs then return $ TcPluginOk [] xs else do     let (unit_wanteds, _) = partitionEithers $ map (toUnitEquality uds) wanteds     case unit_wanteds of       []    -> return $ TcPluginOk [] []@@ -96,15 +96,29 @@         sr <- simplifyUnits uds unit_givens         tcPluginTrace "unitsOfMeasureSolver simplified givens" $ ppr sr         case sr of-          Impossible eq _ -> return $ TcPluginContradiction [fromUnitEquality eq]+          Impossible eq _ -> reportContradiction uds eq           Simplified ss   -> do sr' <- simplifyUnits uds $ map (substsUnitEquality (simplifySubst ss)) unit_wanteds                                 tcPluginTrace "unitsOfMeasureSolver simplified wanteds" $ ppr sr'                                 case sr' of-                                  Impossible eq _ -> return $ TcPluginContradiction [fromUnitEquality $ substsUnitEquality (simplifyUnsubst ss) eq]+                                  Impossible _eq _ -> return $ TcPluginOk [] [] -- Don't report a contradiction, see #22                                   Simplified ss'  -> TcPluginOk [ (evMagic uds ct, ct) | eq <- simplifySolved ss', let ct = fromUnitEquality eq ]                                                          <$> mapM (substItemToCt uds) (filter (isWanted . ctEvidence . siCt) (substsSubst (simplifyUnsubst ss) (simplifySubst ss')))  +reportContradiction :: UnitDefs -> UnitEquality -> TcPluginM TcPluginResult+reportContradiction uds eq = TcPluginContradiction . pure <$> fromUnitEqualityForContradiction uds eq++-- See #22 for why we need this+fromUnitEqualityForContradiction :: UnitDefs -> UnitEquality -> TcPluginM Ct+fromUnitEqualityForContradiction uds (UnitEquality ct u v) = case classifyPredType $ ctEvPred $ ctEvidence ct of+    EqPred NomEq _ _ -> return ct+    _ | isGivenCt ct -> newGivenCt  (ctLoc ct) (mkEqPred u' v') (mkFunnyEqEvidence (ctPred ct) u' v')+      | otherwise    -> newWantedCt (ctLoc ct) (mkEqPred u' v')+  where+    u' = reifyUnit uds u+    v' = reifyUnit uds v++ substItemToCt :: UnitDefs -> SubstItem -> TcPluginM Ct substItemToCt uds si       | isGiven (ctEvidence ct) = newGivenCt loc prd $ evByFiat "units" ty1 ty2@@ -152,24 +166,6 @@     cons_tycon = promoteDataCon consDataCon  --- Extract the unit equality constraints-toUnitEquality :: UnitDefs -> Ct -> Either UnitEquality Ct-toUnitEquality uds ct = case classifyPredType $ ctEvPred $ ctEvidence ct of-    EqPred NomEq t1 t2-      | isUnitKind uds (typeKind t1) || isUnitKind uds (typeKind t1)-      , Just u1 <- normaliseUnit uds t1-      , Just u2 <- normaliseUnit uds t2 -> Left (ct, u1, u2)-    IrredPred t-      | Just (tc, [t1,t2]) <- splitTyConApp_maybe t-      , tc == equivTyCon uds-      , Just u1 <- normaliseUnit uds t1-      , Just u2 <- normaliseUnit uds t2 -> Left (ct, u1, u2)-    _                                   -> Right ct--fromUnitEquality :: UnitEquality -> Ct-fromUnitEquality (ct, _, _) = ct-- lookupUnitDefs :: TcPluginM UnitDefs lookupUnitDefs = do     md <- lookupModule myModule myPackage@@ -217,8 +213,11 @@   #if __GLASGOW_HASKELL__ >= 800++#if __GLASGOW_HASKELL__ < 802 pattern FunTy :: Type -> Type -> Type pattern FunTy t v = ForAllTy (Anon t) v+#endif  mkEqPred :: Type -> Type -> Type mkEqPred = mkPrimEqPred
src/Data/UnitsOfMeasure/Plugin/Convert.hs view
@@ -9,7 +9,11 @@  import TyCon import Type+#if __GLASGOW_HASKELL__ > 802+import TcType ()+#else import TcType+#endif  #if __GLASGOW_HASKELL__ > 710 import TyCoRep
src/Data/UnitsOfMeasure/Plugin/NormalForm.hs view
@@ -45,7 +45,9 @@ import Data.Maybe import Data.Ord +import TcPluginExtras + -- | Base units are just represented as strings, for simplicity type BaseUnit = FastString @@ -55,7 +57,7 @@ data Atom = BaseAtom Type | VarAtom TyVar | FamAtom TyCon [Type]  instance Eq Atom where-  a == b = compare a b == EQ+  a == b = a == b  -- TODO: using cmpTypes here probably isn't ideal, but does it matter? instance Ord Atom where@@ -64,7 +66,7 @@   compare (VarAtom  _)    (BaseAtom _)      = GT   compare (VarAtom  a)    (VarAtom  b)      = compare a b   compare (VarAtom  _)    (FamAtom _ _)     = LT-  compare (FamAtom f tys) (FamAtom f' tys') = compare f f' `thenCmp` cmpTypes tys tys'+  compare (FamAtom f tys) (FamAtom f' tys') = cmpTyCon f f' `thenCmp` cmpTypes tys tys'   compare (FamAtom _ _)   _                 = GT  instance Outputable Atom where
src/Data/UnitsOfMeasure/Plugin/Unify.hs view
@@ -2,7 +2,9 @@   ( SubstItem(..)   , substsSubst   , substsUnitEquality-  , UnitEquality+  , UnitEquality(..)+  , toUnitEquality+  , fromUnitEquality   , SimplifyState(..)   , SimplifyResult(..)   , simplifyUnits@@ -11,7 +13,7 @@ import FastString import Name import Outputable-import TcRnMonad ( Ct, isGiven, ctEvidence )+import TcRnMonad ( Ct, isGiven, ctEvidence, ctEvPred ) import TcType import Type import Var@@ -36,16 +38,15 @@   ppr si = ppr (siVar si) <+> text " := " <+> ppr (siUnit si) <+> text "  {" <+> ppr (siCt si) <+> text "}"  -- | Apply a substitution to a single normalised unit-substsUnit :: TySubst -> NormUnit -> NormUnit-substsUnit []     u = u-substsUnit (si:s) u = substsUnit s (substUnit (siVar si) (siUnit si) u)+substsUnit :: NormUnit -> TySubst -> NormUnit+substsUnit = foldl (\ u si -> substUnit (siVar si) (siUnit si) u)  -- | Compose two substitutions substsSubst :: TySubst -> TySubst -> TySubst-substsSubst s = map $ \ si -> si { siUnit = substsUnit s (siUnit si) }+substsSubst s = map $ \ si -> si { siUnit = substsUnit (siUnit si) s }  substsUnitEquality :: TySubst -> UnitEquality -> UnitEquality-substsUnitEquality s (ct, u, v) = (ct, substsUnit s u, substsUnit s v)+substsUnitEquality s (UnitEquality ct u v) = UnitEquality ct (substsUnit u s) (substsUnit v s)  extendSubst :: SubstItem -> TySubst -> TySubst extendSubst si s = si : substsSubst [si] s@@ -68,8 +69,8 @@ -- substitution.  The 'Ct' is the equality between the non-normalised -- (and perhaps less substituted) unit type expressions. unifyUnits :: UnitDefs -> UnitEquality -> TcPluginM UnifyResult-unifyUnits uds (ct, u0, v0) = do tcPluginTrace "unifyUnits" (ppr u0 $$ ppr v0)-                                 unifyOne uds ct [] [] [] (u0 /: v0)+unifyUnits uds (UnitEquality ct u0 v0) = do tcPluginTrace "unifyUnits" (ppr u0 $$ ppr v0)+                                            unifyOne uds ct [] [] [] (u0 /: v0)  unifyOne :: UnitDefs -> Ct -> [TyVar] -> TySubst -> TySubst -> NormUnit -> TcPluginM UnifyResult unifyOne uds ct tvs subst unsubst u@@ -111,7 +112,28 @@             return $ mkTcTyVar name kind vanillaSkolemTv  -type UnitEquality = (Ct, NormUnit, NormUnit)+data UnitEquality = UnitEquality Ct NormUnit NormUnit++instance Outputable UnitEquality where+  ppr (UnitEquality ct u v) = text "UnitEquality" $$ ppr ct $$ ppr u $$ ppr v++-- Extract the unit equality constraints+toUnitEquality :: UnitDefs -> Ct -> Either UnitEquality Ct+toUnitEquality uds ct = case classifyPredType $ ctEvPred $ ctEvidence ct of+    EqPred NomEq t1 t2+      | isUnitKind uds (typeKind t1) || isUnitKind uds (typeKind t1)+      , Just u1 <- normaliseUnit uds t1+      , Just u2 <- normaliseUnit uds t2 -> Left (UnitEquality ct u1 u2)+    IrredPred t+      | Just (tc, [t1,t2]) <- splitTyConApp_maybe t+      , tc == equivTyCon uds+      , Just u1 <- normaliseUnit uds t1+      , Just u2 <- normaliseUnit uds t2 -> Left (UnitEquality ct u1 u2)+    _                                   -> Right ct++fromUnitEquality :: UnitEquality -> Ct+fromUnitEquality (UnitEquality ct _ _) = ct+  data SimplifyState   = SimplifyState { simplifyFreshVars :: [TyVar]
src/Data/UnitsOfMeasure/Read.hs view
@@ -4,7 +4,6 @@ {-# LANGUAGE PartialTypeSignatures #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE StandaloneDeriving #-} {-# OPTIONS_GHC -fno-warn-partial-type-signatures #-} {-# OPTIONS_GHC -fno-warn-orphans #-}
src/Data/UnitsOfMeasure/Show.hs view
@@ -1,17 +1,12 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE MagicHash #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RoleAnnotations #-}-{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-}  {-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}@@ -34,7 +29,7 @@ import Data.UnitsOfMeasure.Internal import Data.UnitsOfMeasure.Singleton -import Data.List (intercalate, group)+import Data.List (group)  instance (Show a, KnownUnit (Unpack u)) => Show (Quantity a u) where   show x = "[u| " ++ showQuantity x ++ " |]"@@ -61,10 +56,10 @@ showUnitBits (xs :/ ys) = showPos xs ++ " / " ++ showPos ys  showPos :: [String] -> String-showPos = intercalate " " . map (\ xs -> showAtom (head xs, length xs)) . group+showPos = unwords . map (\ xs -> showAtom (head xs, length xs)) . group  showNeg :: [String] -> String-showNeg = intercalate " " . map (\ xs -> showAtom (head xs, negate $ length xs)) . group+showNeg = unwords . map (\ xs -> showAtom (head xs, negate $ length xs)) . group  showAtom :: (String, Int) -> String showAtom (s, 1) = s
src/Data/UnitsOfMeasure/Singleton.hs view
@@ -1,17 +1,13 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE KindSignatures #-}-{-# LANGUAGE MagicHash #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RoleAnnotations #-}-{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-}  {-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}
src/TcPluginExtras.hs view
@@ -1,30 +1,41 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE RecordWildCards #-}  module TcPluginExtras   ( -- * Wrappers     newUnique   , newWantedCt   , newGivenCt++    -- * GHC API changes+  , cmpType+  , cmpTypes+  , cmpTyCon   ) where -import TcPluginM  ( TcPluginM ) import TcEvidence ( EvTerm ) import TcRnTypes  ( mkNonCanonical ) import TcRnMonad  ( Ct, CtLoc ) import Type       ( PredType )+import TyCon      ( TyCon )  import GHC.TcPluginM.Extra  #if __GLASGOW_HASKELL__ < 711 import Unique     ( Unique ) import qualified TcRnMonad-import TcPluginM ( unsafeTcPluginTcM )+import TcPluginM ( TcPluginM, unsafeTcPluginTcM ) #else-import TcPluginM ( newUnique )+import TcPluginM ( TcPluginM, newUnique ) #endif +#if __GLASGOW_HASKELL__ < 802+import Type ( cmpType, cmpTypes )+#else+import Type ( Type, nonDetCmpType, nonDetCmpTypes )+import Unique ( getUnique, nonDetCmpUnique )+#endif + #if __GLASGOW_HASKELL__ < 711 newUnique :: TcPluginM Unique newUnique = unsafeTcPluginTcM TcRnMonad.newUnique@@ -34,4 +45,18 @@ newWantedCt loc = fmap mkNonCanonical . newWanted loc  newGivenCt :: CtLoc -> PredType -> EvTerm -> TcPluginM Ct-newGivenCt loc prd ev = fmap mkNonCanonical $ newGiven loc prd ev+newGivenCt loc prd ev = mkNonCanonical <$> newGiven loc prd ev++#if __GLASGOW_HASKELL__ < 802+cmpTyCon :: TyCon -> TyCon -> Ordering+cmpTyCon = compare+#else+cmpType :: Type -> Type -> Ordering+cmpType = nonDetCmpType++cmpTypes :: [Type] -> [Type] -> Ordering+cmpTypes = nonDetCmpTypes++cmpTyCon :: TyCon -> TyCon -> Ordering+cmpTyCon a b = getUnique a `nonDetCmpUnique` getUnique b+#endif
tests/ErrorTests.hs view
@@ -69,3 +69,52 @@                 , [ "Could not deduce: Base \"s\" ~ a"                   , "from the context: (a ^: 2) ~ (b ^: 3)" ]                 ]++op_a1 :: Quantity Double [u| m |]+op_a1 = (1 :: Quantity Int One) *: ([u| 1 m |] :: (Quantity Double (Base "m")))++op_a2 :: Quantity Double [u| m |]+op_a2 = (1 :: Quantity Integer One) *: ([u| 1 m |] :: (Quantity Double (Base "m")))++op_a3 :: Quantity Double [u| m |]+op_a3 = (1 :: Quantity Rational One) *: ([u| 1 m |] :: (Quantity Double (Base "m")))++op_b1 :: Quantity Int [u| m |]+op_b1 = (1 :: Quantity Double One) *: ([u| 1 m |] :: (Quantity Int (Base "m")))++op_b2 :: Quantity Int [u| m |]+op_b2 = (1 :: Quantity Integer One) *: ([u| 1 m |] :: (Quantity Int (Base "m")))++op_b3 :: Quantity Int [u| m |]+op_b3 = (1 :: Quantity Rational One) *: ([u| 1 m |] :: (Quantity Int (Base "m")))++op_c1 :: Quantity Integer [u| m |]+op_c1 = (1 :: Quantity Double One) *: ([u| 1 m |] :: (Quantity Integer (Base "m")))++op_c2 :: Quantity Integer [u| m |]+op_c2 = (1 :: Quantity Int One) *: ([u| 1 m |] :: (Quantity Integer (Base "m")))++op_c3 :: Quantity Integer [u| m |]+op_c3 = (1 :: Quantity Rational One) *: ([u| 1 m |] :: (Quantity Integer (Base "m")))++op_d1 :: Quantity Rational [u| m |]+op_d1 = (1 :: Quantity Double One) *: ([u| 1 m |] :: (Quantity Rational (Base "m")))++op_d2 :: Quantity Rational [u| m |]+op_d2 = (1 :: Quantity Int One) *: ([u| 1 m |] :: (Quantity Rational (Base "m")))++op_d3 :: Quantity Rational [u| m |]+op_d3 = (1 :: Quantity Integer One) *: ([u| 1 m |] :: (Quantity Rational (Base "m")))++opErrors :: String -> String -> String -> [[String]]+opErrors a b c =+#if __GLASGOW_HASKELL__ > 710 +  [ [ "Couldn't match type ‘" ++ a ++ "’ with ‘" ++ b ++ "’"+    , "Expected type: Quantity " ++ c ++ " (Base \"m\")"+    ]+  ]+#else+  [ [ "Couldn't match type ‘" ++ b ++ "’ with ‘" ++ a ++ "’"+    ]+  ]+#endif
tests/Tests.hs view
@@ -13,11 +13,15 @@  import Data.UnitsOfMeasure import Data.UnitsOfMeasure.Convert+import Data.UnitsOfMeasure.Internal (fromRational') import Data.UnitsOfMeasure.Defs () import Data.UnitsOfMeasure.Show +import Control.Monad (unless) import Control.Exception import Data.List+import Data.Ratio ((%))+import GHC.Real (Ratio(..))  import Test.Tasty import Test.Tasty.HUnit@@ -51,7 +55,7 @@   where     _G = [u| 6.67384e-11 N*m^2/kg^2 |] -sum' xs = foldr (+:) zero xs+sum' = foldr (+:) zero mean xs = sum' xs /: mk (genericLength xs)  foo x y = x *: y +: y *: x@@ -117,6 +121,12 @@  -- Inferring this type used to lead to unit equations with occur-check -- failures, because it involves things like Pack (Unpack u) ~ u+-- The type signature is intentionally left off here to check that the+-- compiler can infer it.+-- z :: forall a (u :: Unit) (v :: Unit). (Fractional a, Convertible u v)+--   => Quantity a u+--   -> Quantity a v+{-# ANN z "HLint: ignore Eta reduce" #-} z q = convert q  -- Pattern splices are supported, albeit with restricted types@@ -173,6 +183,54 @@     , testCase "polymorphic zero"        $ [u| 0 |] @?= [u| 0 m |]     , testCase "polymorphic frac zero"   $ [u| 0.0 |] @?= [u| 0.0 N / m |]     ]+  , testGroup "Literal 1 (*:) Quantity _ u"+    [ testCase "_ = Double"+        $ 1 *: ([u| 1 m |] :: (Quantity Double (Base "m"))) @?= [u| 1 m |]+    , testCase "_ = Int"+        $ 1 *: ([u| 1 m |] :: (Quantity Int (Base "m"))) @?= [u| 1 m |]+    , testCase "_ = Integer"+        $ 1 *: ([u| 1 m |] :: (Quantity Integer (Base "m"))) @?= [u| 1 m |]+    , testCase "_ = Rational, 1 *: [u| 1 m |]"+        $ 1 *: ([u| 1 m |] :: (Quantity Rational (Base "m"))) @?= [u| 1 m |]+    , testCase "_ = Rational, mk (1 % 1) *: [u| 1 m |]"+        $ mk (1 % 1) *: ([u| 1 m |] :: (Quantity Rational (Base "m"))) @?= [u| 1 m |]+    , testCase "_ = Rational, 1 *: [u| 1 % 1 m |]"+        $ 1 *: ([u| 1 % 1 m |] :: (Quantity Rational (Base "m"))) @?= [u| 1 m |]+    , testCase "_ = Rational, mk (1 % 1) *: [u| 1 % 1 m |]"+        $ mk (1 % 1) *: ([u| 1 % 1 m |] :: (Quantity Rational (Base "m"))) @?= [u| 1 m |]+    ]+  , testGroup "(1 :: Quantity _ One) (*:) Quantity _ u"+    [ testCase "_ = Double"+        $ (1 :: Quantity Double One) *: ([u| 1 m |] :: (Quantity Double (Base "m"))) @?= [u| 1 m |]+    , testCase "_ = Int"+        $ (1 :: Quantity Int One) *: ([u| 1 m |] :: (Quantity Int (Base "m"))) @?= [u| 1 m |]+    , testCase "_ = Integer"+        $ (1 :: Quantity Integer One) *: ([u| 1 m |] :: (Quantity Integer (Base "m"))) @?= [u| 1 m |]+    , testCase "_ = Int"+        $ (1 :: Quantity Rational One) *: ([u| 1 m |] :: (Quantity Rational (Base "m"))) @?= [u| 1 m |]+    ]+  , testGroup "errors when a /= b, (1 :: Quantity a One) (*:) Quantity b u"+    [ testGroup "b = Double"+      [ testCase "a = Int" $ op_a1 `throws` opErrors "Double" "Int" "Int"+      , testCase "a = Integer" $ op_a2 `throws` opErrors "Double" "Integer" "Integer"+      , testCase "a = Rational" $ op_a3 `throws` opErrors "Double" "GHC.Real.Ratio Integer" "Rational"+      ]+    , testGroup "b = Int"+      [ testCase "a = Double" $ op_b1 `throws` opErrors "Int" "Double" "Double"+      , testCase "a = Integer" $ op_b2 `throws` opErrors "Int" "Integer" "Integer"+      , testCase "a = Rational" $ op_b3 `throws` opErrors "Int" "GHC.Real.Ratio Integer" "Rational"+      ]+    , testGroup "b = Integer"+      [ testCase "a = Double" $ op_c1 `throws` opErrors "Integer" "Double" "Double"+      , testCase "a = Int" $ op_c2 `throws` opErrors "Integer" "Int" "Int"+      , testCase "a = Rational" $ op_c3 `throws` opErrors "Integer" "GHC.Real.Ratio Integer" "Rational"+      ]+    , testGroup "b = Rational"+      [ testCase "a = Double" $ op_d1 `throws` opErrors "GHC.Real.Ratio Integer" "Double" "Double"+      , testCase "a = Int" $ op_d2 `throws` opErrors "GHC.Real.Ratio Integer" "Int" "Int"+      , testCase "a = Integer" $ op_d3 `throws` opErrors "GHC.Real.Ratio Integer" "Integer" "Integer"+      ]+    ]   , testGroup "showQuantity"     [ testCase "myMass"         $ showQuantity myMass         @?= "65.0 kg"     , testCase "gravityOnEarth" $ showQuantity gravityOnEarth @?= "9.808 m / s^2"@@ -216,5 +274,5 @@ -- lists of substrings. throws :: a -> [[String]] -> Assertion throws v xs =-    (evaluate v >> assertFailure "No exception!")-  `catch` \ (e :: SomeException) -> if any (all (`isInfixOf` show e)) xs then return () else throw e+    (evaluate v >> assertFailure "No exception!") `catch` \ (e :: SomeException) ->+        unless (any (all (`isInfixOf` show e)) xs) $ throw e
uom-plugin.cabal view
@@ -1,65 +1,94 @@-name:                uom-plugin-version:             0.2.0.1-synopsis:            Units of measure as a GHC typechecker plugin-category:            Type System-description:         A prototype typechecker plugin for GHC with support for units of measure-license:             BSD3-license-file:        LICENSE-author:              Adam Gundry <adam@well-typed.com>-maintainer:          Adam Gundry <adam@well-typed.com>-homepage:            https://github.com/adamgundry/uom-plugin-bug-reports:         https://github.com/adamgundry/uom-plugin/issues-stability:           experimental-copyright:           Copyright (c) 2014-2016, Adam Gundry-build-type:          Simple-cabal-version:       >=1.10-description:+-- This file has been generated from package.yaml by hpack version 0.28.2.+--+-- see: https://github.com/sol/hpack+--+-- hash: d110f2f74fb66155437b924f27283bd9b16991b4f2be45693731488d98f4938c -    The @uom-plugin@ library adds support for units of measure to GHC-    using the new experimental facility for typechecker plugins, which-    is available in GHC 7.10 and later.  See-    "Data.UnitsOfMeasure.Tutorial" for an introduction to the library.+name:           uom-plugin+version:        0.3.0.0+synopsis:       Units of measure as a GHC typechecker plugin+description:    The @uom-plugin@ library adds support for units of measure to GHC+                using the new experimental facility for typechecker plugins, which+                is available in GHC 7.10 and later.  See+                "Data.UnitsOfMeasure.Tutorial" for an introduction to the library.+category:       Type System+stability:      experimental+homepage:       https://github.com/adamgundry/uom-plugin#readme+bug-reports:    https://github.com/adamgundry/uom-plugin/issues+author:         Adam Gundry <adam@well-typed.com>+maintainer:     Adam Gundry <adam@well-typed.com>+copyright:      Copyright (c) 2014-2018, Adam Gundry+license:        BSD3+license-file:   LICENSE+tested-with:    GHC == 7.10.3, GHC == 8.0.2, GHC == 8.2.2 -extra-source-files:  changelog+build-type:     Simple+cabal-version:  >= 1.10+extra-source-files:+    changelog+    package.yaml  source-repository head-  type:     git-  location: https://github.com/adamgundry/uom-plugin.git+  type: git+  location: https://github.com/adamgundry/uom-plugin  library-  exposed-modules:     Data.UnitsOfMeasure,-                       Data.UnitsOfMeasure.Convert,-                       Data.UnitsOfMeasure.Defs,-                       Data.UnitsOfMeasure.Internal,-                       Data.UnitsOfMeasure.Plugin,-                       Data.UnitsOfMeasure.Read,-                       Data.UnitsOfMeasure.Show,-                       Data.UnitsOfMeasure.Singleton,-                       Data.UnitsOfMeasure.Tutorial-  other-modules:       Data.UnitsOfMeasure.Plugin.Convert,-                       Data.UnitsOfMeasure.Plugin.NormalForm,-                       Data.UnitsOfMeasure.Plugin.Unify,-                       Data.UnitsOfMeasure.TH,-                       TcPluginExtras-  other-extensions:    TemplateHaskell-  build-depends:       base >=4.7 && <5,-                       deepseq >=1.3 && <1.5,-                       ghc >= 7.9 && <8.2,-                       ghc-tcplugins-extra >=0.1 && <0.3,-                       template-haskell >=2.9 && <2.12,-                       containers >=0.5 && <0.6,-                       units-parser >=0.1 && <0.2-  hs-source-dirs:      src-  default-language:    Haskell2010-  ghc-options:         -Wall -fno-warn-unticked-promoted-constructors+  exposed-modules:+      Data.UnitsOfMeasure+      Data.UnitsOfMeasure.Convert+      Data.UnitsOfMeasure.Defs+      Data.UnitsOfMeasure.Internal+      Data.UnitsOfMeasure.Plugin+      Data.UnitsOfMeasure.Read+      Data.UnitsOfMeasure.Show+      Data.UnitsOfMeasure.Singleton+      Data.UnitsOfMeasure.Tutorial+  other-modules:+      Data.UnitsOfMeasure.Plugin.Convert+      Data.UnitsOfMeasure.Plugin.NormalForm+      Data.UnitsOfMeasure.Plugin.Unify+      Data.UnitsOfMeasure.TH+      TcPluginExtras+      Paths_uom_plugin+  hs-source-dirs:+      src+  ghc-options: -Wall -fno-warn-unticked-promoted-constructors+  build-depends:+      base >=4.7 && <5+    , containers >=0.5 && <0.6+    , deepseq >=1.3 && <1.5+    , ghc >=7.9 && <8.4+    , ghc-tcplugins-extra >=0.1 && <0.3+    , template-haskell >=2.9 && <2.13+    , units-parser >=0.1 && <0.2+  default-language: Haskell2010 -test-suite test-uom-plugin-  type:                exitcode-stdio-1.0-  main-is:             Tests.hs-  other-modules:       ErrorTests-  other-extensions:    TemplateHaskell-  build-depends:       base, uom-plugin,-                       tasty >=0.10 && <0.12, tasty-hunit >=0.9 && <0.10-  hs-source-dirs:      tests-  default-language:    Haskell2010-  ghc-options:         -O0+test-suite hlint+  type: exitcode-stdio-1.0+  main-is: HLint.hs+  other-modules:+      Paths_uom_plugin+  hs-source-dirs:+      hlint+  ghc-options: -Wall -fno-warn-unticked-promoted-constructors -Wall -O0 -rtsopts -threaded -with-rtsopts=-N+  build-depends:+      base+    , hlint >=1.7 && <2.2+  default-language: Haskell2010++test-suite units+  type: exitcode-stdio-1.0+  main-is: Tests.hs+  other-modules:+      ErrorTests+      Paths_uom_plugin+  hs-source-dirs:+      tests+  other-extensions: TemplateHaskell+  ghc-options: -Wall -fno-warn-unticked-promoted-constructors -O0+  build-depends:+      base+    , tasty >=0.10 && <1.1+    , tasty-hunit >=0.9 && <0.10.1+    , uom-plugin+  default-language: Haskell2010