{-# LANGUAGE TemplateHaskellQuotes, TupleSections #-}

-- | Generate the unit types and function to work with them

module Math.Haskellator.Internal.TH.DerivedUnitGeneration (
      DQuantity (..)
    , generateDerivedUnits
    ) where

import Language.Haskell.TH

import Math.Haskellator.Internal.TH.UnitGeneration
import Math.Haskellator.Internal.Units

-- | A derived quantity. Works in the same way as 'Quantity', but with an additional
-- 'Dimension' representing it.
data DQuantity = DQuantity UnitDef Dimension [UnitDef]

dunitFromStringFun :: Name
dunitFromStringFun :: Name
dunitFromStringFun = String -> Name
mkName String
"derivedUnitFromString"

-- | Since derived units are instantly converted to the 'Dimension' representing them,
-- this function will only generate one additional function 'derivedUnitFromString'.
-- Imagine the call @generateDerivedUnits [DQuantity (UnitDef "Herz" "Hz" 1) [UnitExp Second (-1)] [] []@.
--
-- > derivedUnitFromString :: String -> Either String Dimension
-- > derivedUnitFromString "Hz" = Right [UnitExp Second (-1)]
-- > derivedUnitFromString x = Left x
generateDerivedUnits :: [DQuantity] -> Q [Dec]
generateDerivedUnits :: [DQuantity] -> Q [Dec]
generateDerivedUnits [DQuantity]
dunitGroups = do
    let allUnits :: [(Dimension, UnitDef)]
allUnits = (DQuantity -> [(Dimension, UnitDef)])
-> [DQuantity] -> [(Dimension, UnitDef)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\(DQuantity UnitDef
base Dimension
units [UnitDef]
derived) -> (Dimension
units,) (UnitDef -> (Dimension, UnitDef))
-> [UnitDef] -> [(Dimension, UnitDef)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UnitDef
baseUnitDef -> [UnitDef] -> [UnitDef]
forall a. a -> [a] -> [a]
:[UnitDef]
derived) [DQuantity]
dunitGroups
        fromStringClauses :: [Q Clause]
fromStringClauses = ((Dimension, UnitDef) -> Q Clause
mkFromStringClause ((Dimension, UnitDef) -> Q Clause)
-> [(Dimension, UnitDef)] -> [Q Clause]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Dimension, UnitDef)]
allUnits) [Q Clause] -> [Q Clause] -> [Q Clause]
forall a. [a] -> [a] -> [a]
++ [Clause -> Q Clause
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Clause -> Q Clause) -> Clause -> Q Clause
forall a b. (a -> b) -> a -> b
$ [Pat] -> Body -> [Dec] -> Clause
Clause [Name -> Pat
VarP (Name -> Pat) -> Name -> Pat
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"x"] (Exp -> Body
NormalB (Exp -> Body) -> Exp -> Body
forall a b. (a -> b) -> a -> b
$ Exp -> Exp -> Exp
AppE (Name -> Exp
ConE 'Left) (Name -> Exp
VarE (Name -> Exp) -> Name -> Exp
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"x")) []]
    Dec
fromStringSig     <- Name -> Q Type -> Q Dec
forall (m :: * -> *). Quote m => Name -> m Type -> m Dec
sigD Name
dunitFromStringFun [t|String -> Either String Dimension|]
    Dec
fromStringFun     <- Name -> [Q Clause] -> Q Dec
forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD Name
dunitFromStringFun [Q Clause]
fromStringClauses
    [Dec] -> Q [Dec]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return [Dec
fromStringSig, Dec
fromStringFun]


mkFromStringClause :: (Dimension, UnitDef) -> Q Clause
mkFromStringClause :: (Dimension, UnitDef) -> Q Clause
mkFromStringClause (Dimension
d, UnitDef String
_ String
a Double
_) = do
  let pattern :: Pat
pattern = Lit -> Pat
LitP (Lit -> Pat) -> Lit -> Pat
forall a b. (a -> b) -> a -> b
$ String -> Lit
StringL String
a
  Body
body <- Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (Q Exp -> Q Body) -> Q Exp -> Q Body
forall a b. (a -> b) -> a -> b
$ Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE 'Right) [|d|]
  Clause -> Q Clause
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Clause -> Q Clause) -> Clause -> Q Clause
forall a b. (a -> b) -> a -> b
$ [Pat] -> Body -> [Dec] -> Clause
Clause [Pat
pattern] Body
body []