uom-plugin 0.2.0.0 → 0.2.0.1
raw patch · 7 files changed
+83/−11 lines, 7 filesdep ~ghcdep ~ghc-tcplugins-extra
Dependency ranges changed: ghc, ghc-tcplugins-extra
Files
- changelog +3/−0
- src/Data/UnitsOfMeasure/Convert.hs +5/−0
- src/Data/UnitsOfMeasure/Plugin.hs +35/−5
- src/Data/UnitsOfMeasure/Plugin/Convert.hs +14/−2
- src/Data/UnitsOfMeasure/Plugin/NormalForm.hs +10/−0
- tests/ErrorTests.hs +12/−0
- uom-plugin.cabal +4/−4
changelog view
@@ -1,5 +1,8 @@ -*-change-log-*- +0.2.0.1 Adam Gundry <adam@well-typed.com> May 2016+ * Support building on GHC 8.0+ 0.2.0.0 Adam Gundry <adam@well-typed.com> December 2015 * Add Data.UnitsOfMeasure.Read module and a Read instance for Quantity * Make it possible to declare derived compound units
src/Data/UnitsOfMeasure/Convert.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE FlexibleContexts #-}@@ -9,6 +10,10 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-}++#if __GLASGOW_HASKELL__ > 710+{-# LANGUAGE UndecidableSuperClasses #-}+#endif {-# OPTIONS_GHC -fplugin Data.UnitsOfMeasure.Plugin #-}
src/Data/UnitsOfMeasure/Plugin.hs view
@@ -1,4 +1,7 @@ {-# LANGUAGE CPP #-}+#if __GLASGOW_HASKELL__ > 710+{-# LANGUAGE PatternSynonyms #-}+#endif -- | This module defines a typechecker plugin that solves equations -- involving units of measure. To use it, add@@ -23,7 +26,6 @@ import DataCon import Type import TyCon-import TypeRep import TysWiredIn import FastString@@ -40,6 +42,12 @@ import Data.UnitsOfMeasure.Plugin.Unify import TcPluginExtras +#if __GLASGOW_HASKELL__ > 710+import TyCoRep+#else+import TypeRep+#endif+ import GHC.TcPluginM.Extra ( evByFiat, tracePlugin, lookupModule, lookupName ) -- | The plugin that GHC will load when this module is used with the@@ -116,7 +124,6 @@ collectCt ct = collectType ct $ ctEvPred $ ctEvidence ct - collectType _ (TyVarTy _) = [] collectType ct (AppTy f s) = collectType ct f ++ collectType ct s collectType ct (TyConApp tc [a]) | tc == unpackTyCon uds = case maybeConstant =<< normaliseUnit uds a of@@ -125,7 +132,7 @@ collectType ct (TyConApp _ as) = concatMap (collectType ct) as collectType ct (FunTy t v) = collectType ct t ++ collectType ct v collectType ct (ForAllTy _ t) = collectType ct t- collectType _ (LitTy _) = []+ collectType _ _ = [] -- TyVarTy, LitTy from 7.10, plus CastTy and CoercionTy in 8.0 unpackCt (ct,a,xs) = newGivenCt loc (mkEqPred ty1 ty2) (evByFiat "units" ty1 ty2) where@@ -193,6 +200,29 @@ EqPred NomEq t1 t2 -> evByFiat "units" t1 t2 IrredPred t | Just (tc, [t1,t2]) <- splitTyConApp_maybe t- , tc == equivTyCon uds -> evByFiat "units" t1 t2 `EvCast`- TcCoercion (mkUnivCo (fsLit "units") Representational (mkTyConApp eqTyCon [typeKind t1, t1, t2]) t)+ , tc == equivTyCon uds -> mkFunnyEqEvidence t t1 t2 _ -> error "evMagic"++-- | Make up evidence for a fake equality constraint @t1 ~~ t2@ by+-- coercing bogus evidence of type @t1 ~ t2@ (or its heterogeneous+-- variant, in GHC 8.0).+mkFunnyEqEvidence :: Type -> Type -> Type -> EvTerm+#if __GLASGOW_HASKELL__ >= 800+mkFunnyEqEvidence t t1 t2 = EvDFunApp (dataConWrapId heqDataCon) [typeKind t1, typeKind t2, t1, t2] [evByFiat "units" t1 t2]+ `EvCast` mkUnivCo (PluginProv "units") Representational (mkHEqPred t1 t2) t+#else+mkFunnyEqEvidence t t1 t2 = evByFiat "units" t1 t2+ `EvCast` TcCoercion (mkUnivCo (fsLit "units") Representational (mkTyConApp eqTyCon [typeKind t1, t1, t2]) t)+#endif+++#if __GLASGOW_HASKELL__ >= 800+pattern FunTy :: Type -> Type -> Type+pattern FunTy t v = ForAllTy (Anon t) v++mkEqPred :: Type -> Type -> Type+mkEqPred = mkPrimEqPred++mkHEqPred :: Type -> Type -> Type+mkHEqPred t1 t2 = TyConApp heqTyCon [typeKind t1, typeKind t2, t1, t2]+#endif
src/Data/UnitsOfMeasure/Plugin/Convert.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} module Data.UnitsOfMeasure.Plugin.Convert ( UnitDefs(..) , unitKind@@ -8,9 +9,14 @@ import TyCon import Type-import TypeRep import TcType +#if __GLASGOW_HASKELL__ > 710+import TyCoRep+#else+import TypeRep+#endif+ import Data.List import Data.UnitsOfMeasure.Plugin.NormalForm@@ -43,7 +49,7 @@ -- | Try to convert a type to a unit normal form; this does not check -- the type has kind 'Unit', and may fail even if it does. normaliseUnit :: UnitDefs -> Type -> Maybe NormUnit-normaliseUnit uds ty | Just ty1 <- tcView ty = normaliseUnit uds ty1+normaliseUnit uds ty | Just ty1 <- coreView ty = normaliseUnit uds ty1 normaliseUnit _ (TyVarTy v) = pure $ varUnit v normaliseUnit uds (TyConApp tc tys) | tc == unitOneTyCon uds = pure one@@ -77,3 +83,9 @@ reifyAtom (BaseAtom s) = mkTyConApp (unitBaseTyCon uds) [s] reifyAtom (VarAtom v) = mkTyVarTy v reifyAtom (FamAtom f tys) = mkTyConApp f tys+++#if __GLASGOW_HASKELL__ > 710+promoteTyCon :: TyCon -> TyCon+promoteTyCon = id+#endif
src/Data/UnitsOfMeasure/Plugin/NormalForm.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} module Data.UnitsOfMeasure.Plugin.NormalForm ( Atom(..) , BaseUnit@@ -189,3 +190,12 @@ substUnit a v u = case Map.lookup (VarAtom a) $ _NormUnit u of Nothing -> u Just i -> (v ^: i) *: leftover a u+++#if __GLASGOW_HASKELL__ > 710+tyVarsOfType :: Type -> TyCoVarSet+tyVarsOfType = tyCoVarsOfType++tyVarsOfTypes :: [Type] -> TyCoVarSet+tyVarsOfTypes = tyCoVarsOfTypes+#endif
tests/ErrorTests.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE QuasiQuotes #-} @@ -7,6 +8,11 @@ {-# OPTIONS_GHC -fdefer-type-errors #-} {-# OPTIONS_GHC -fplugin Data.UnitsOfMeasure.Plugin #-}++#if __GLASGOW_HASKELL__ > 710+{-# OPTIONS_GHC -fno-warn-deferred-type-errors #-}+#endif+ module ErrorTests where import Data.UnitsOfMeasure@@ -36,6 +42,8 @@ , "from the context ((One *: a) ~ (a *: One))" ] , [ "Could not deduce: a ~ Base \"kg\"" , "from the context: (One *: a) ~ (a *: One)" ]+ , [ "Could not deduce: Base \"kg\" ~ a"+ , "from the context: (One *: a) ~ (a *: One)" ] ] @@ -46,6 +54,8 @@ , "from the context ((One *: a) ~ (b *: One))" ] , [ "Could not deduce: a ~ Base \"kg\"" , "from the context: (One *: a) ~ (b *: One)" ]+ , [ "Could not deduce: Base \"kg\" ~ a"+ , "from the context: (One *: a) ~ (b *: One)" ] ] @@ -55,5 +65,7 @@ given3_errors = [ [ "Could not deduce (a ~ Base \"s\")" , "from the context ((a ^: 2) ~ (b ^: 3))" ] , [ "Could not deduce: a ~ Base \"s\""+ , "from the context: (a ^: 2) ~ (b ^: 3)" ]+ , [ "Could not deduce: Base \"s\" ~ a" , "from the context: (a ^: 2) ~ (b ^: 3)" ] ]
uom-plugin.cabal view
@@ -1,5 +1,5 @@ name: uom-plugin-version: 0.2.0.0+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@@ -10,7 +10,7 @@ homepage: https://github.com/adamgundry/uom-plugin bug-reports: https://github.com/adamgundry/uom-plugin/issues stability: experimental-copyright: Copyright (c) 2014-2015, Adam Gundry+copyright: Copyright (c) 2014-2016, Adam Gundry build-type: Simple cabal-version: >=1.10 description:@@ -44,8 +44,8 @@ other-extensions: TemplateHaskell build-depends: base >=4.7 && <5, deepseq >=1.3 && <1.5,- ghc >= 7.9 && <7.12,- ghc-tcplugins-extra >=0.1 && <0.2,+ 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