--
-- Copyright © 2013-2015 Anchor Systems, Pty Ltd and Others
--
-- The code in this file, and the program it is a part of, is
-- made available to you by its authors as open source software:
-- you can redistribute it and/or modify it under the terms of
-- the 3-clause BSD licence.
--
-- /Description/
-- This module defines TH to define Ceilometer types internally.
-- DO NOT EXPORT.
--

module Ceilometer.Types.TH
  ( declarePF
  ) where

import           Control.Applicative
import           Data.Char
import           Data.Maybe
import           Language.Haskell.TH

-- | Declare a Payload Field data type and create a prism for it
--   with the mapping provided.
--
--   The type must be non-parametrised.
--
--   /e.g./
--
--   @
--   declarePF    "Volume"
--               ("Verb", ''Word8)
--             [ ("Create", 1)
--             , ("Resize", 2) ]
--             [ ''Show, ''Eq, ''Bounded, ''Enum ]
--   @
--
--   will create:
--
--   @
--   data PFVolumeVerb = VolumeCreate | VolumeResize
--        deriving (Show, Eq, Enum, Bounded)
--
--   pfVolumeVerb :: Prism' Word8 PFVolumeVerb
--   pfVolumeVerb = prism' pretty parse
--     where pretty VolumeCreate = 1
--           pretty VolumeResize = 2
--           parse  1 = Just VolumeCreate
--           parse  2 = Just VolumeResize
--           parse  _ = Nothing
--   @
--
--   This is useful if you want parsing/print prisms for a non-parametric type.
--
declarePF :: String              -- ^ Field prefix, e.g. Volume
          -> (String,  Name)     -- ^ Type constructors to be declared and parsed from,
                                 --   the type from which we parse must have literal values.
          -> [(String, Integer)] -- ^ Data constructors and their mapping
          -> [Name]              -- ^ Derived classes
          -> Q [Dec]
declarePF = declareWith "pf"

declareWith :: String -> String -> (String,  Name) -> [(String, Integer)] -> [Name] -> Q [Dec]
declareWith prefix field (tyconStr, mappedType) ds derives = do
  pfunc      <- lookupPrismFunc
  pty        <- lookupPrismTyCon
  just       <- lookupJust
  nothing    <- lookupNothing
  let tycon    = mkName $ map toUpper prefix ++ field ++ tyconStr
      dacons   = map (mkName . (field ++) . fst) ds
      dec      = DataD [] tycon [] (map (flip NormalC []) dacons) derives

      p        = mkName (prefix ++ field ++ tyconStr)
      vals     = map (IntegerL . snd) ds
      -- make pattern: pretty VolumeCreate = 1
      pretties = zipWith mkClause
                         (map ((:[]) . flip ConP []) dacons)
                         (map (NormalB . LitE) vals)
      pretty   = mkName "pretty"
      -- make pattern: parse 1 = Just VolumeCreate
      parses   = zipWith mkClause
                         (map ((:[]) . LitP) vals)
                         (map (NormalB . AppE (ConE just) . ConE) dacons)
               ++ [Clause [WildP] (NormalB (ConE nothing)) []]
      parse    = mkName "parse"
      -- make clause: prism' pretty parse where ...
      cases    = Clause []
                        (NormalB $ AppE (AppE (VarE pfunc) (VarE pretty)) (VarE parse))
                        [FunD pretty pretties, FunD parse parses]
      -- declare the prism
      sig      = SigD p (AppT (AppT (ConT pty) (ConT mappedType)) (ConT tycon))
      def      = FunD p [cases]
  return [dec, sig, def]

mkClause :: [Pat] -> Body -> Clause
mkClause x y = Clause x y []

-- | These Will throw a first-stage compile-time error if not in scope.
--
lookupPrismFunc, lookupPrismTyCon :: Q Name
lookupJust, lookupNothing         :: Q Name
lookupPrismFunc  = lookupV "prism'"
lookupPrismTyCon = lookupT "Prism'"
lookupJust       = lookupV "Just"
lookupNothing    = lookupV "Nothing"

lookupT :: String -> Q Name
lookupT x = fromMaybe (error $ "TH: not in scope " ++ x) <$> lookupTypeName x

lookupV :: String -> Q Name
lookupV x = fromMaybe (error $ "TH: not in scope " ++ x) <$> lookupValueName x