currency_with_newtype_indexed_by_sum_type

-- This example is slightly changed from a gist I can't locate anymore. Sorry, original author.
--
-- A newtype indexed by a sum type lifted with DataKinds.                                                                                                                                                          
-- Inspired by https://www.reddit.com/r/haskell/comments/elh8hl/newtype_or_tagged_type/                                                                                                                            
-- See also                                                                                                                                                                                                        
-- http://oleg.fi/gists/posts/2019-03-21-flag.html                                                                                                                                                                 
-- https://hackage.haskell.org/package/safe-money                                                                                                                                                                  
                                                                                                                                                                                                                   
{-# LANGUAGE DataKinds #-}                                                                                                                                                                                         
{-# LANGUAGE ScopedTypeVariables #-}                                                                                                                                                                               
{-# LANGUAGE TypeApplications #-}                                                                                                                                                                                  
{-# LANGUAGE AllowAmbiguousTypes #-}                                                                                                                                                                               
{-# LANGUAGE KindSignatures #-}                                                                                                                                                                                    
{-# LANGUAGE GeneralizedNewtypeDeriving #-}                                                                                                                                                                        
                                                                                                                                                                                                                   
module Main (main) where                                                                                                                                                                                           
                                                                                                                                                                                                                   
-- To be used as a kind                                                                                                                                                                                            
data Currency = EUR | USD                                                                                                                                                                                          
                                                                                                                                                                                                                   
--                                                                                                                                                                                                                 
-- Annoying boilerplate, I want dependent Haskell to be able to demote                                                                                                                                             
-- without boilerplate or TH                                                                                                                                                                                       
class DemoteCurrency (s :: Currency) where                                                                                                                                                                         
       demoteCurrency :: Currency                                                                                                                                                                                  
                                                                                                                                                                                                                   
instance DemoteCurrency EUR where                                                                                                                                                                                  
       demoteCurrency = EUR                                                                                                                                                                                        
                                                                                                                                                                                                                   
instance DemoteCurrency USD where                                                                                                                                                                                  
       demoteCurrency = USD                                                                                                                                                                                        
--                                                                                                                                                                                                                 
                                                                                                                                                                                                                   
-- constructor likely not exported                                                                                                                                                                                 
newtype Money (s :: Currency) = Money Int deriving (Show,Eq,Num,Ord)                                                                                                                                               
                                                                                                                                                                                                                   
makeMoney :: forall (s :: Currency) . Int -> Money s                                                                                                                                                               
makeMoney = Money                                                                                                                                                                                                  
                                                                                                                                                                                                                   
getAmount :: Money s -> Int                                                                                                                                                                                        
getAmount (Money i) = i                                                                                                                                                                                            
                                                                                                                                                                                                                   
--                                                                                                                                                                                                                 
prettyPrintMoney :: forall s. DemoteCurrency s => Money s -> String                                                                                                                                                
prettyPrintMoney t =                                                                                                                                                                                               
    let unit = case demoteCurrency @s of                                                                                                                                                                           
             EUR -> "EUR"                                                                                                                                                                                          
             USD -> "USD"                                                                                                                                                                                          
     in unit ++ " " ++ (show (getAmount t))                                                                                                                                                                        
                                                                                                                                                                                                                   
main :: IO ()                                                                                                                                                                                                      
main = do                                                                                                                                                                                                          
       putStrLn $ prettyPrintMoney $ makeMoney @USD 3                                                                                                                                                              
       putStrLn $ prettyPrintMoney $ makeMoney @EUR 3                                                                                                                                                              
       -- next line will not compile                                                                                                                                                                               
       -- putStrLn $ prettyPrintMoney $ (makeMoney @EUR 3) + (makeMoney @USD 3)