{-# OPTIONS_HADDOCK not-home #-}

{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}

module Numeric.Units.Dimensional.UnitNames.Internal
where

import Control.Monad (join)
import Data.Data
#if MIN_VERSION_base(4, 8, 0)
import Data.Foldable (toList)
#else
import Data.Foldable (Foldable, toList)
#endif
import GHC.Generics
import Numeric.Units.Dimensional.Dimensions.TermLevel (Dimension', asList, HasDimension(..))
import Numeric.Units.Dimensional.UnitNames.InterchangeNames
import Numeric.Units.Dimensional.Variants (Metricality(..))
import Prelude hiding ((*), (/), (^), product)
import qualified Prelude as P

-- | The name of a unit.
data UnitName (m :: Metricality) where
  -- The name of the unit of dimensionless values.
  One :: UnitName 'NonMetric
  -- A name of an atomic unit to which metric prefixes may be applied.
  MetricAtomic :: NameAtom ('UnitAtom 'Metric) -> UnitName 'Metric
  -- A name of an atomic unit to which metric prefixes may not be applied.
  Atomic :: NameAtom ('UnitAtom 'NonMetric) -> UnitName 'NonMetric
  -- A name of a prefixed unit.
  Prefixed :: PrefixName -> UnitName 'Metric -> UnitName 'NonMetric
  -- A compound name formed from the product of two names.
  Product :: UnitName 'NonMetric -> UnitName 'NonMetric -> UnitName 'NonMetric
  -- A compound name formed from the quotient of two names.
  Quotient :: UnitName 'NonMetric -> UnitName 'NonMetric -> UnitName 'NonMetric
  -- A compound name formed by raising a unit name to an integer power.
  Power :: UnitName 'NonMetric -> Int -> UnitName 'NonMetric
  -- A compound name formed by grouping another name, which is generally compound.
  Grouped :: UnitName 'NonMetric -> UnitName 'NonMetric
  -- A weakened name formed by forgetting whether it could accept a metric prefix.
  -- Differs from 'Grouped' because it is displayed without parentheses.
  Weaken :: UnitName 'Metric -> UnitName 'NonMetric
  deriving (Typeable)

deriving instance Eq (UnitName m)

instance Show (UnitName m) where
  show One = "1"
  show (MetricAtomic a) = abbreviation_en a
  show (Atomic a) = abbreviation_en a
  show (Prefixed a n) = abbreviation_en a ++ show n
  show (Product n1 n2) = show n1 ++ " " ++ show n2
  show (Quotient n1 n2) = show n1 ++ " / " ++ show n2
  show (Power x n) = show x ++ "^" ++ show n
  show (Grouped n) = "(" ++ show n ++ ")"
  show (Weaken n) = show n

isAtomic :: UnitName m -> Bool
isAtomic (One) = True
isAtomic (MetricAtomic _) = True
isAtomic (Atomic _) = True
isAtomic (Prefixed _ _) = True
isAtomic (Grouped _) = True
isAtomic (Weaken n) = isAtomic n
isAtomic _ = False

isAtomicOrProduct :: UnitName m -> Bool
isAtomicOrProduct (Product _ _) = True
isAtomicOrProduct n = isAtomic n

-- reduce by algebraic simplifications
reduce :: UnitName m -> UnitName m
reduce (One) = One
reduce n@(MetricAtomic _) = n
reduce n@(Atomic _) = n
reduce n@(Prefixed _ _) = n
reduce (Product n1 n2) = reduce' (reduce n1 * reduce n2)
reduce (Quotient n1 n2) = reduce' (reduce n1 * reduce n2)
reduce (Power n x) = reduce' ((reduce n) ^ x)
reduce (Grouped n) = reduce' (Grouped (reduce n))
reduce (Weaken n) = reduce' (Weaken (reduce n))

-- reduce, knowing that subterms are already in reduced form
reduce' :: UnitName m -> UnitName m
reduce' (Product One n) = reduce' n
reduce' (Product n One) = reduce' n
reduce' (Power (Power n x1) x2) = reduce (n ^ (x1 P.* x2))
reduce' (Power (Grouped (Power n x1)) x2) = reduce (n ^ (x1 P.* x2))
reduce' (Power _ 0) = One
reduce' (Power n 1) = reduce' n
reduce' (Grouped n) = reduce' n
reduce' n@(Weaken (MetricAtomic _)) = n
reduce' n = n

data NameAtomType = UnitAtom Metricality
                  | PrefixAtom
  deriving (Eq, Ord, Data, Typeable, Generic)

-- | The name of a metric prefix.
type PrefixName = NameAtom 'PrefixAtom

nOne :: UnitName 'NonMetric
nOne = One

nMeter :: UnitName 'Metric
nMeter = ucumMetric "m" "m" "metre"

nGram :: UnitName 'Metric
nGram = ucumMetric "g" "g" "gram"

nKilogram :: UnitName 'NonMetric
nKilogram = applyPrefix kilo nGram

nSecond :: UnitName 'Metric
nSecond = ucumMetric "s" "s" "second"

nAmpere :: UnitName 'Metric
nAmpere = ucumMetric "A" "A" "Ampere"

nKelvin :: UnitName 'Metric
nKelvin = ucumMetric "K" "K" "Kelvin"

nMole :: UnitName 'Metric
nMole = ucumMetric "mol" "mol" "mole"

nCandela :: UnitName 'Metric
nCandela = ucumMetric "cd" "cd" "candela"

-- | The name of the base unit associated with a specified dimension.
baseUnitName :: Dimension' -> UnitName 'NonMetric
baseUnitName d = let powers = asList $ dimension d
                  in reduce . product $ zipWith (^) baseUnitNames powers

baseUnitNames :: [UnitName 'NonMetric]
baseUnitNames = [weaken nMeter, nKilogram, weaken nSecond, weaken nAmpere, weaken nKelvin, weaken nMole, weaken nCandela]

deka, hecto, kilo, mega, giga, tera, peta, exa, zetta, yotta :: PrefixName
deka  = prefix "da" "da" "deka"
hecto = prefix "h" "h" "hecto"
kilo  = prefix "k" "k" "kilo"
mega  = prefix "M" "M" "mega"
giga  = prefix "G" "G" "giga"
tera  = prefix "T" "T" "tera"
peta  = prefix "P" "P" "peta"
exa   = prefix "E" "E" "exa"
zetta = prefix "Z" "Z" "zetta"
yotta = prefix "Y" "Y" "yotta"
deci, centi, milli, micro, nano, pico, femto, atto, zepto, yocto :: PrefixName
deci  = prefix "d" "d" "deci"
centi = prefix "c" "c" "centi"
milli = prefix "m" "m" "milli"
micro = prefix "u" "μ" "micro"
nano  = prefix "n" "n" "nano"
pico  = prefix "p" "p" "pico"
femto = prefix "f" "f" "femto"
atto  = prefix "a" "a" "atto"
zepto = prefix "z" "z" "zepto"
yocto = prefix "y" "y" "yocto"

-- | Forms a 'UnitName' from a 'Metric' name by applying a metric prefix.
applyPrefix :: PrefixName -> UnitName 'Metric -> UnitName 'NonMetric
applyPrefix = Prefixed

{-
We will reuse the operators and function names from the Prelude.
To prevent unpleasant surprises we give operators the same fixity
as the Prelude.
-}

infixr 8  ^
infixl 7  *, /

-- | Form a 'UnitName' by taking the product of two others.
(*) :: UnitName m1 -> UnitName m2 -> UnitName 'NonMetric
a * b = Product (weaken a) (weaken b)

-- | Form a 'UnitName' by dividing one by another.
(/) :: UnitName m1 -> UnitName m2 -> UnitName 'NonMetric
n1 / n2 | isAtomicOrProduct n1 = Quotient (weaken n1) (weaken n2)
        | otherwise            = Quotient (grouped n1) (weaken n2)

-- | Form a 'UnitName' by raising a name to an integer power.
(^) :: UnitName m -> Int -> UnitName 'NonMetric
x ^ n | isAtomic x = Power (weaken x) n
      | otherwise  = Power (grouped x) n

-- | Convert a 'UnitName' which may or may not be 'Metric' to one
-- which is certainly 'NonMetric'.
weaken :: UnitName m -> UnitName 'NonMetric
weaken n@(MetricAtomic _) = Weaken n -- we really only need this one case and a catchall, but the typechecker can't see it
weaken n@One = n
weaken n@(Atomic _) = n
weaken n@(Prefixed _ _) = n
weaken n@(Product _ _) = n
weaken n@(Quotient _ _) = n
weaken n@(Power _ _) = n
weaken n@(Grouped _) = n
weaken n@(Weaken _) = n

-- | Attempt to convert a 'UnitName' which may or may not be 'Metric' to one
-- which is certainly 'Metric'.
strengthen :: UnitName m -> Maybe (UnitName 'Metric)
strengthen n@(MetricAtomic _) = Just n
strengthen (Weaken n) = strengthen n
strengthen _ = Nothing

-- | Convert a 'UnitName' of one 'Metricality' into a name of the other metricality by
-- strengthening or weakening if neccessary. Because it may not be possible to strengthen,
-- the result is returned in a 'Maybe' wrapper.
relax :: forall m1 m2.(Typeable m1, Typeable m2) => UnitName m1 -> Maybe (UnitName m2)
relax n = go (typeRep (Proxy :: Proxy m1)) (typeRep (Proxy :: Proxy m2)) n
  where
    metric = typeRep (Proxy :: Proxy 'Metric)
    nonMetric = typeRep (Proxy :: Proxy 'NonMetric)
    go :: TypeRep -> TypeRep -> UnitName m1 -> Maybe (UnitName m2)
    go p1 p2 | p1 == p2 = cast
             | (p1 == nonMetric) && (p2 == metric) = join . fmap gcast . strengthen
             | (p1 == metric) && (p2 == nonMetric) = cast . weaken
             | otherwise = error "Should be unreachable. TypeRep of an unexpected Metricality encountered."

-- | Constructs a 'UnitName' by applying a grouping operation to
-- another 'UnitName', which may be useful to express precedence.
grouped :: UnitName m -> UnitName 'NonMetric
grouped = Grouped . weaken

-- | Represents the name of an atomic unit or prefix.
data NameAtom (m :: NameAtomType)
  = NameAtom 
  {
    _interchangeName :: InterchangeName, -- ^ The interchange name of the unit.
    abbreviation_en :: String, -- ^ The abbreviated name of the unit in international English
    name_en :: String -- ^ The full name of the unit in international English
  }
  deriving (Eq, Ord, Data, Typeable, Generic)

instance HasInterchangeName (NameAtom m) where
  interchangeName = _interchangeName

instance HasInterchangeName (UnitName m) where
  interchangeName One = InterchangeName { name = "1", authority = UCUM }
  interchangeName (MetricAtomic a) = interchangeName a
  interchangeName (Atomic a) = interchangeName a
  interchangeName (Prefixed p n) = let n' = (name . interchangeName $ p) ++ (name . interchangeName $ n)
                                       a' = max (authority . interchangeName $ p) (authority . interchangeName $ n)
                                    in InterchangeName { name = n', authority = a' }
  interchangeName (Product n1 n2) = let n' = (name . interchangeName $ n1) ++ "." ++ (name . interchangeName $ n2)
                                        a' = max (authority . interchangeName $ n1) (authority . interchangeName $ n2)
                                     in InterchangeName { name = n', authority = a' }
  interchangeName (Quotient n1 n2) = let n' = (name . interchangeName $ n1) ++ "/" ++ (name . interchangeName $ n2)
                                         a' = max (authority . interchangeName $ n1) (authority . interchangeName $ n2)
                                      in InterchangeName { name = n', authority = a' }
  interchangeName (Power n x) = let n' = (name . interchangeName $ n) ++ (show x)
                                 in InterchangeName { name = n', authority = authority . interchangeName $ n }
  interchangeName (Grouped n) = let n' = "(" ++ (name . interchangeName $ n) ++ ")"
                                 in InterchangeName { name = n', authority = authority . interchangeName $ n }
  interchangeName (Weaken n) = interchangeName n

prefix :: String -> String -> String -> PrefixName
prefix i a f = NameAtom (InterchangeName i UCUM) a f

ucumMetric :: String -> String -> String -> UnitName 'Metric
ucumMetric i a f = MetricAtomic $ NameAtom (InterchangeName i UCUM) a f

ucum :: String -> String -> String -> UnitName 'NonMetric
ucum i a f = Atomic $ NameAtom (InterchangeName i UCUM) a f

dimensionalAtom :: String -> String -> String -> UnitName 'NonMetric
dimensionalAtom i a f = Atomic $ NameAtom (InterchangeName i DimensionalLibrary) a f

-- | Constructs an atomic name for a custom unit.
atom :: String -- ^ Interchange name
     -> String -- ^ Abbreviated name in international English
     -> String -- ^ Full name in international English
     -> UnitName 'NonMetric
atom i a f = Atomic $ NameAtom (InterchangeName i Custom) a f

-- | The type of a unit name transformation that may be associated with an operation that takes a single unit as input.
type UnitNameTransformer = (forall m.UnitName m -> UnitName 'NonMetric)

-- | The type of a unit name transformation that may be associated with an operation that takes two units as input.
type UnitNameTransformer2 = (forall m1 m2.UnitName m1 -> UnitName m2 -> UnitName 'NonMetric)

-- | Forms the product of a list of 'UnitName's.
--
-- If you wish to form a heterogenous product of 'Metric' and 'NonMetric' units
-- you should apply 'weaken' to the 'Metric' ones.
product :: Foldable f => f (UnitName 'NonMetric) -> UnitName 'NonMetric
product = go . toList
  where
    -- This is not defined using a simple fold so that it does not complicate the product with
    -- valid but meaningless occurences of nOne.
    go :: [UnitName 'NonMetric] -> UnitName 'NonMetric
    go [] = nOne
    go [n] = n
    go (n : ns) = n * go ns