Prettier output

haskell-distributed · Jul 30, 2012 · e06c6bf · e06c6bf
1 parent 4b5f192
commit e06c6bf
Show file tree

Hide file tree

Showing 3 changed files with 63 additions and 9 deletions.
diff --git a/azure-service-api/azure-service-api.cabal b/azure-service-api/azure-service-api.cabal
@@ -25,6 +25,7 @@ Library
                        certificate >= 1.2 && < 1.3,
                        case-insensitive >= 0.4 && < 0.5,
                        hxt >= 9.2 && < 9.3,
+                       pretty >= 1.1 && < 1.2,
                        resourcet,
                        transformers,
                        hxt-xpath

diff --git a/azure-service-api/src/Network/Azure/ServiceManagement.hs b/azure-service-api/src/Network/Azure/ServiceManagement.hs
@@ -28,6 +28,15 @@ import Data.Certificate.X509 (X509)
 import Control.Monad.Trans.Resource (ResourceT)
 import Control.Monad.IO.Class (liftIO)
 import Control.Arrow.ArrowList (listA)
+import Text.PrettyPrint 
+  ( Doc
+  , text
+  , (<+>)
+  , ($$)
+  , vcat
+  , hang
+  , doubleQuotes
+  )
 import Network.HTTP.Conduit 
   ( parseUrl
   , clientCertificates
@@ -57,26 +66,70 @@ import Text.XML.HXT.XPath (getXPathTrees)
 data HostedService = HostedService { 
     hostedServiceName :: String 
   }
-  deriving Show
 
 data CloudService = CloudService {
     cloudServiceName :: String 
   , cloudServiceVMs  :: [VirtualMachine]
   }
-  deriving Show
 
 data VirtualMachine = VirtualMachine { 
     vmName           :: String
   , vmInputEndpoints :: [Endpoint]
   }
-  deriving Show
 
 data Endpoint = Endpoint {
-   endpointName :: String
- , endpointPort :: String 
- , endpointVip  :: String
- }
- deriving Show
+    endpointName :: String
+  , endpointPort :: String 
+  , endpointVip  :: String
+  }
+
+--------------------------------------------------------------------------------
+-- Pretty-printing                                                            --
+--------------------------------------------------------------------------------
+
+instance Show HostedService where 
+  show = show . ppHostedService
+
+instance Show CloudService where
+  show = show . ppCloudService
+
+instance Show VirtualMachine where
+  show = show . ppVirtualMachine
+
+instance Show Endpoint where
+  show = show . ppEndpoint
+
+ppHostedService :: HostedService -> Doc
+ppHostedService = text . hostedServiceName
+
+ppCloudService :: CloudService -> Doc
+ppCloudService cs =
+    (text "Cloud Service" <+> (doubleQuotes . text . cloudServiceName $ cs)) 
+  `hang2`
+    (   text "VIRTUAL MACHINES"
+      `hang2`
+        (vcat . map ppVirtualMachine . cloudServiceVMs $ cs)
+    )
+
+ppVirtualMachine :: VirtualMachine -> Doc
+ppVirtualMachine vm = 
+    (text "Virtual Machine" <+> (doubleQuotes . text . vmName $ vm))
+  `hang2`
+    (   text "INPUT ENDPOINTS"
+      `hang2`
+        (vcat . map ppEndpoint . vmInputEndpoints $ vm)
+    )
+
+ppEndpoint :: Endpoint -> Doc
+ppEndpoint ep = 
+    (text "Input endpoint" <+> (doubleQuotes . text . endpointName $ ep))
+  `hang2`
+    (    text "Port" <+> text (endpointPort ep)
+      $$ text "IP"   <+> text (endpointVip ep)
+    )
+
+hang2 :: Doc -> Doc -> Doc
+hang2 d1 d2 = hang d1 2 d2
 
 --------------------------------------------------------------------------------
 -- Pure operations                                                            --

diff --git a/distributed-process-azure/src/Control/Distributed/Process/Backend/Azure/CommandLine.hs b/distributed-process-azure/src/Control/Distributed/Process/Backend/Azure/CommandLine.hs
@@ -104,7 +104,7 @@ main = do
         params <- azureParameters azureOpts Nothing
         backend <- initializeBackend params 
         css <- cloudServices backend
-        print css
+        mapM_ print css
       Start azureOpts sshOpts name -> do
         params <- azureParameters azureOpts (Just sshOpts)
         backend <- initializeBackend params