{-# LANGUAGE DataKinds #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeOperators #-}
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
module Data.UnitsOfMeasure.TH
( u
, declareBaseUnit
, declareDerivedUnit
, declareConvertibleUnit
) where
import Data.Char
import Numeric
import Text.Parse.Units
import Language.Haskell.TH
import Language.Haskell.TH.Quote
import Data.UnitsOfMeasure.Internal
import Data.UnitsOfMeasure.Convert
u :: QuasiQuoter
u :: QuasiQuoter
u = QuasiQuoter
{ quoteExp :: String -> Q Exp
quoteExp = String -> Q Exp
uExp
, quotePat :: String -> Q Pat
quotePat = String -> Q Pat
uPat
, quoteType :: String -> Q Type
quoteType = String -> Q Type
uType
, quoteDec :: String -> Q [Dec]
quoteDec = String -> Q [Dec]
uDec
}
uExp :: String -> Q Exp
uExp :: String -> Q Exp
uExp String
s
| Just (Either Integer Rational
ei, String
s') <- String -> Maybe (Either Integer Rational, String)
readNumber String
s = Either Integer Rational -> UnitExp () String -> Q Exp
mkLiteral Either Integer Rational
ei (UnitExp () String -> Q Exp) -> Q (UnitExp () String) -> Q Exp
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> Q (UnitExp () String)
parseUnitQ String
s'
| Bool
otherwise = UnitExp () String -> Q Exp
mkConversion (UnitExp () String -> Q Exp) -> Q (UnitExp () String) -> Q Exp
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> Q (UnitExp () String)
parseUnitQ String
s
where
mkLiteral :: Either Integer Rational -> UnitExp () String -> Q Exp
mkLiteral (Left Integer
0) UnitExp () String
Unity = [| zero |]
mkLiteral (Right Rational
0) UnitExp () String
Unity = [| MkQuantity 0.0 |]
mkLiteral Either Integer Rational
ei UnitExp () String
expr = [| (MkQuantity :: a -> Quantity a $(reifyUnit expr))
$(litE (either integerL rationalL ei)) |]
mkConversion :: UnitExp () String -> Q Exp
mkConversion UnitExp () String
expr = [| MkQuantity :: a -> Quantity a $(reifyUnit expr) |]
uPat :: String -> Q Pat
uPat :: String -> Q Pat
uPat String
s
| Just (Left Integer
i, String
s') <- String -> Maybe (Either Integer Rational, String)
readNumber String
s = Lit -> Q Type -> String -> Q Pat
mkPat (Integer -> Lit
integerL Integer
i) [t|Integer |] String
s'
| Just (Right Rational
r, String
s') <- String -> Maybe (Either Integer Rational, String)
readNumber String
s = Lit -> Q Type -> String -> Q Pat
mkPat (Rational -> Lit
rationalL Rational
r) [t|Rational|] String
s'
| Bool
otherwise = String -> Q Pat
forall a. HasCallStack => String -> a
error String
"unable to parse literal"
where
mkPat :: Lit -> Q Type -> String -> Q Pat
mkPat Lit
l Q Type
t String
s' = [p| MkQuantity $(litP l) |] Q Pat -> Q Type -> Q Pat
forall (m :: * -> *). Quote m => m Pat -> m Type -> m Pat
`sigP` [t| Quantity $t $(uType s') |]
uType :: String -> Q Type
uType :: String -> Q Type
uType String
s = UnitExp () String -> Q Type
reifyUnit (UnitExp () String -> Q Type) -> Q (UnitExp () String) -> Q Type
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> Q (UnitExp () String)
parseUnitQ String
s
parseUnitQ :: String -> Q (UnitExp () String)
parseUnitQ :: String -> Q (UnitExp () String)
parseUnitQ String
s = case SymbolTable () String
-> String -> Either String (UnitExp () String)
forall pre u.
(Show pre, Show u) =>
SymbolTable pre u -> String -> Either String (UnitExp pre u)
parseUnit SymbolTable () String
forall a. SymbolTable a String
universalSymbolTable String
s of
Right UnitExp () String
expr -> UnitExp () String -> Q (UnitExp () String)
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return UnitExp () String
expr
Left String
err -> String -> Q (UnitExp () String)
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"unable to parse unit expression \"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\": " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
err)
reifyUnit :: UnitExp () String -> Q Type
reifyUnit :: UnitExp () String -> Q Type
reifyUnit UnitExp () String
Unity = [t| One |]
reifyUnit (Unit Maybe ()
_ String
s) = [t| MkUnit $(litT (strTyLit s)) |]
reifyUnit (UnitExp () String
u `Mult` UnitExp () String
v) = [t| $(reifyUnit u) *: $(reifyUnit v) |]
reifyUnit (UnitExp () String
u `Div` UnitExp () String
v) = [t| $(reifyUnit u) /: $(reifyUnit v) |]
reifyUnit (UnitExp () String
u `Pow` Integer
n) | Integer
n Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Integer
0 = [t| $(reifyUnit u) ^: $(litT (numTyLit n)) |]
| Bool
otherwise = [t| One /: $(reifyUnit u) ^: $(litT (numTyLit (- n))) |]
uDec :: String -> Q [Dec]
uDec :: String -> Q [Dec]
uDec String
s = case String -> Maybe [(String, UnitDecl)]
parseUnitDecs String
s of
Just [(String, UnitDecl)]
xs -> [[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Dec]] -> [Dec]) -> Q [[Dec]] -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((String, UnitDecl) -> Q [Dec])
-> [(String, UnitDecl)] -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ((String -> UnitDecl -> Q [Dec]) -> (String, UnitDecl) -> Q [Dec]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry String -> UnitDecl -> Q [Dec]
declareUnit) [(String, UnitDecl)]
xs
Maybe [(String, UnitDecl)]
Nothing -> String -> Q ()
reportError (String
"unable to parse unit declarations: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s) Q () -> Q [Dec] -> Q [Dec]
forall a b. Q a -> Q b -> Q b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [Dec] -> Q [Dec]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return []
data UnitDecl = BaseUnit
| DefinedUnit (UnitExp () String)
| ConversionUnit Rational (UnitExp () String)
parseUnitDecs :: String -> Maybe [(String, UnitDecl)]
parseUnitDecs :: String -> Maybe [(String, UnitDecl)]
parseUnitDecs = String -> Maybe [(String, UnitDecl)]
go
where
go :: String -> Maybe [(String, UnitDecl)]
go [] = [(String, UnitDecl)] -> Maybe [(String, UnitDecl)]
forall a. a -> Maybe a
Just []
go (Char
c:String
xs) | Char -> Bool
isSpace Char
c Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
',' = String -> Maybe [(String, UnitDecl)]
go String
xs
go String
xs = case (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span Char -> Bool
isAlpha String
xs of
([], String
_) -> Maybe [(String, UnitDecl)]
forall a. Maybe a
Nothing
(String
u, String
ys) -> String -> String -> Maybe [(String, UnitDecl)]
go' String
u String
ys
go' :: String -> String -> Maybe [(String, UnitDecl)]
go' String
u [] = [(String, UnitDecl)] -> Maybe [(String, UnitDecl)]
forall a. a -> Maybe a
Just [(String
u, UnitDecl
BaseUnit)]
go' String
u (Char
c:String
xs) | Char -> Bool
isSpace Char
c = String -> String -> Maybe [(String, UnitDecl)]
go' String
u String
xs
go' String
u (Char
',':String
xs) = ((String
u, UnitDecl
BaseUnit) (String, UnitDecl) -> [(String, UnitDecl)] -> [(String, UnitDecl)]
forall a. a -> [a] -> [a]
:) ([(String, UnitDecl)] -> [(String, UnitDecl)])
-> Maybe [(String, UnitDecl)] -> Maybe [(String, UnitDecl)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Maybe [(String, UnitDecl)]
go String
xs
go' String
u (Char
'=':String
xs) = let (String
d, String
ys) = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
',') String
xs
in case String -> Maybe (Either Integer Rational, String)
readNumber String
d of
Just (Either Integer Rational
ei, String
s)
| Bool -> Bool
not ((Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isSpace String
s)
-> case SymbolTable () String
-> String -> Either String (UnitExp () String)
forall pre u.
(Show pre, Show u) =>
SymbolTable pre u -> String -> Either String (UnitExp pre u)
parseUnit SymbolTable () String
forall a. SymbolTable a String
universalSymbolTable String
s of
Right UnitExp () String
e -> ((String
u, Rational -> UnitExp () String -> UnitDecl
ConversionUnit ((Integer -> Rational)
-> (Rational -> Rational) -> Either Integer Rational -> Rational
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Integer -> Rational
forall a. Num a => Integer -> a
fromInteger Rational -> Rational
forall a. a -> a
id Either Integer Rational
ei) UnitExp () String
e) (String, UnitDecl) -> [(String, UnitDecl)] -> [(String, UnitDecl)]
forall a. a -> [a] -> [a]
:) ([(String, UnitDecl)] -> [(String, UnitDecl)])
-> Maybe [(String, UnitDecl)] -> Maybe [(String, UnitDecl)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Maybe [(String, UnitDecl)]
go String
ys
Either String (UnitExp () String)
_ -> Maybe [(String, UnitDecl)]
forall a. Maybe a
Nothing
Maybe (Either Integer Rational, String)
_ -> case SymbolTable () String
-> String -> Either String (UnitExp () String)
forall pre u.
(Show pre, Show u) =>
SymbolTable pre u -> String -> Either String (UnitExp pre u)
parseUnit SymbolTable () String
forall a. SymbolTable a String
universalSymbolTable String
d of
Right UnitExp () String
e -> ((String
u, UnitExp () String -> UnitDecl
DefinedUnit UnitExp () String
e) (String, UnitDecl) -> [(String, UnitDecl)] -> [(String, UnitDecl)]
forall a. a -> [a] -> [a]
:) ([(String, UnitDecl)] -> [(String, UnitDecl)])
-> Maybe [(String, UnitDecl)] -> Maybe [(String, UnitDecl)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Maybe [(String, UnitDecl)]
go String
ys
Left String
_ -> Maybe [(String, UnitDecl)]
forall a. Maybe a
Nothing
go' String
_ String
_ = Maybe [(String, UnitDecl)]
forall a. Maybe a
Nothing
declareUnit :: String -> UnitDecl -> Q [Dec]
declareUnit :: String -> UnitDecl -> Q [Dec]
declareUnit String
s UnitDecl
ud = case UnitDecl
ud of
UnitDecl
BaseUnit -> [d| type instance MkUnit $(litT (strTyLit s)) = Base $(litT (strTyLit s))
instance HasCanonicalBaseUnit $(litT (strTyLit s))
|]
DefinedUnit UnitExp () String
u -> [d| type instance MkUnit $(litT (strTyLit s)) = $(reifyUnit u) |]
ConversionUnit Rational
_ (Unit Maybe ()
Nothing String
s') | String
s String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
s'
-> String -> Q ()
reportError (String
"cannot define cyclic convertible unit: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s) Q () -> Q [Dec] -> Q [Dec]
forall a b. Q a -> Q b -> Q b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [Dec] -> Q [Dec]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return []
ConversionUnit Rational
r UnitExp () String
u -> [d| type instance MkUnit $(litT (strTyLit s)) = Base $(litT (strTyLit s))
instance HasCanonicalBaseUnit $(litT (strTyLit s)) where
type CanonicalBaseUnit $(litT (strTyLit s)) = $(reifyUnit u)
conversionBase _ = MkQuantity $(litE (rationalL (recip r)))
|]
declareBaseUnit :: String -> Q [Dec]
declareBaseUnit :: String -> Q [Dec]
declareBaseUnit String
s = String -> UnitDecl -> Q [Dec]
declareUnit String
s UnitDecl
BaseUnit
declareDerivedUnit :: String -> String -> Q [Dec]
declareDerivedUnit :: String -> String -> Q [Dec]
declareDerivedUnit String
s String
d = case SymbolTable () String
-> String -> Either String (UnitExp () String)
forall pre u.
(Show pre, Show u) =>
SymbolTable pre u -> String -> Either String (UnitExp pre u)
parseUnit SymbolTable () String
forall a. SymbolTable a String
universalSymbolTable String
d of
Right UnitExp () String
e -> String -> UnitDecl -> Q [Dec]
declareUnit String
s (UnitExp () String -> UnitDecl
DefinedUnit UnitExp () String
e)
Left String
_ -> String -> Q ()
reportError (String
"unable to parse derived unit: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
d) Q () -> Q [Dec] -> Q [Dec]
forall a b. Q a -> Q b -> Q b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [Dec] -> Q [Dec]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return []
declareConvertibleUnit :: String -> Rational -> String -> Q [Dec]
declareConvertibleUnit :: String -> Rational -> String -> Q [Dec]
declareConvertibleUnit String
derived Rational
r String
base = case SymbolTable () String
-> String -> Either String (UnitExp () String)
forall pre u.
(Show pre, Show u) =>
SymbolTable pre u -> String -> Either String (UnitExp pre u)
parseUnit SymbolTable () String
forall a. SymbolTable a String
universalSymbolTable String
base of
Right UnitExp () String
e -> String -> UnitDecl -> Q [Dec]
declareUnit String
derived (Rational -> UnitExp () String -> UnitDecl
ConversionUnit Rational
r UnitExp () String
e)
Left String
_ -> String -> Q ()
reportError (String
"unable to parse convertible unit: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
base) Q () -> Q [Dec] -> Q [Dec]
forall a b. Q a -> Q b -> Q b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [Dec] -> Q [Dec]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return []
readNumber :: String -> Maybe (Either Integer Rational, String)
readNumber :: String -> Maybe (Either Integer Rational, String)
readNumber String
s
| [(Rational
r, String
s')] <- ReadS Rational
forall a. Read a => ReadS a
reads String
s = (Either Integer Rational, String)
-> Maybe (Either Integer Rational, String)
forall a. a -> Maybe a
Just (Rational -> Either Integer Rational
forall a b. b -> Either a b
Right Rational
r, String
s')
| [(Integer
i, String
s')] <- ReadS Integer
forall a. Read a => ReadS a
reads String
s = (Either Integer Rational, String)
-> Maybe (Either Integer Rational, String)
forall a. a -> Maybe a
Just (Integer -> Either Integer Rational
forall a b. a -> Either a b
Left Integer
i , String
s')
| [(Rational
r, String
s')] <- ReadS Rational -> ReadS Rational
forall a. Real a => ReadS a -> ReadS a
readSigned ReadS Rational
forall a. RealFrac a => ReadS a
readFloat String
s = (Either Integer Rational, String)
-> Maybe (Either Integer Rational, String)
forall a. a -> Maybe a
Just (Rational -> Either Integer Rational
forall a b. b -> Either a b
Right Rational
r, String
s')
| Bool
otherwise = Maybe (Either Integer Rational, String)
forall a. Maybe a
Nothing