diff --git a/changelog b/changelog --- a/changelog +++ b/changelog @@ -1,5 +1,12 @@ -*-change-log-*- +0.3.0.0 Adam Gundry 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 May 2016 * Support building on GHC 8.0 diff --git a/hlint/HLint.hs b/hlint/HLint.hs new file mode 100644 --- /dev/null +++ b/hlint/HLint.hs @@ -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 diff --git a/package.yaml b/package.yaml new file mode 100644 --- /dev/null +++ b/package.yaml @@ -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: . +author: Adam Gundry +maintainer: Adam Gundry +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' diff --git a/src/Data/UnitsOfMeasure.hs b/src/Data/UnitsOfMeasure.hs --- a/src/Data/UnitsOfMeasure.hs +++ b/src/Data/UnitsOfMeasure.hs @@ -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' diff --git a/src/Data/UnitsOfMeasure/Convert.hs b/src/Data/UnitsOfMeasure/Convert.hs --- a/src/Data/UnitsOfMeasure/Convert.hs +++ b/src/Data/UnitsOfMeasure/Convert.hs @@ -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 diff --git a/src/Data/UnitsOfMeasure/Internal.hs b/src/Data/UnitsOfMeasure/Internal.hs --- a/src/Data/UnitsOfMeasure/Internal.hs +++ b/src/Data/UnitsOfMeasure/Internal.hs @@ -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 diff --git a/src/Data/UnitsOfMeasure/Plugin.hs b/src/Data/UnitsOfMeasure/Plugin.hs --- a/src/Data/UnitsOfMeasure/Plugin.hs +++ b/src/Data/UnitsOfMeasure/Plugin.hs @@ -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 diff --git a/src/Data/UnitsOfMeasure/Plugin/Convert.hs b/src/Data/UnitsOfMeasure/Plugin/Convert.hs --- a/src/Data/UnitsOfMeasure/Plugin/Convert.hs +++ b/src/Data/UnitsOfMeasure/Plugin/Convert.hs @@ -9,7 +9,11 @@ import TyCon import Type +#if __GLASGOW_HASKELL__ > 802 +import TcType () +#else import TcType +#endif #if __GLASGOW_HASKELL__ > 710 import TyCoRep diff --git a/src/Data/UnitsOfMeasure/Plugin/NormalForm.hs b/src/Data/UnitsOfMeasure/Plugin/NormalForm.hs --- a/src/Data/UnitsOfMeasure/Plugin/NormalForm.hs +++ b/src/Data/UnitsOfMeasure/Plugin/NormalForm.hs @@ -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 diff --git a/src/Data/UnitsOfMeasure/Plugin/Unify.hs b/src/Data/UnitsOfMeasure/Plugin/Unify.hs --- a/src/Data/UnitsOfMeasure/Plugin/Unify.hs +++ b/src/Data/UnitsOfMeasure/Plugin/Unify.hs @@ -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] diff --git a/src/Data/UnitsOfMeasure/Read.hs b/src/Data/UnitsOfMeasure/Read.hs --- a/src/Data/UnitsOfMeasure/Read.hs +++ b/src/Data/UnitsOfMeasure/Read.hs @@ -4,7 +4,6 @@ {-# LANGUAGE PartialTypeSignatures #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} {-# OPTIONS_GHC -fno-warn-partial-type-signatures #-} {-# OPTIONS_GHC -fno-warn-orphans #-} diff --git a/src/Data/UnitsOfMeasure/Show.hs b/src/Data/UnitsOfMeasure/Show.hs --- a/src/Data/UnitsOfMeasure/Show.hs +++ b/src/Data/UnitsOfMeasure/Show.hs @@ -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 diff --git a/src/Data/UnitsOfMeasure/Singleton.hs b/src/Data/UnitsOfMeasure/Singleton.hs --- a/src/Data/UnitsOfMeasure/Singleton.hs +++ b/src/Data/UnitsOfMeasure/Singleton.hs @@ -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 #-} diff --git a/src/TcPluginExtras.hs b/src/TcPluginExtras.hs --- a/src/TcPluginExtras.hs +++ b/src/TcPluginExtras.hs @@ -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 diff --git a/tests/ErrorTests.hs b/tests/ErrorTests.hs --- a/tests/ErrorTests.hs +++ b/tests/ErrorTests.hs @@ -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 diff --git a/tests/Tests.hs b/tests/Tests.hs --- a/tests/Tests.hs +++ b/tests/Tests.hs @@ -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 diff --git a/uom-plugin.cabal b/uom-plugin.cabal --- a/uom-plugin.cabal +++ b/uom-plugin.cabal @@ -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 -maintainer: Adam Gundry -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 +maintainer: Adam Gundry +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