Cardinality-0.1: examples/HelloWorld.hs

{-
Copyright (C) 2010 Andrejs Sisojevs <andrejs.sisojevs@nextmail.ru>

All rights reserved.

For license and copyright information, see the file COPYRIGHT

-}

--------------------------------------------------------------------------
--------------------------------------------------------------------------

{-# LANGUAGE MultiParamTypeClasses  #-}


import Data.Cardinality
import Data.CardinalityRange
import Data.List
import System.IO

data MyContainer a =
              MyContainer {
                field_1 :: Maybe a
              , field_2 :: (a, a, a)
              , field_3 :: a
              , field_4 :: [a]
              }
            deriving (Show)

emptiestMyContainer :: MyContainer Int
emptiestMyContainer = MyContainer Nothing (1,1,1) 1 []

instance HasCard (MyContainer a) where
        cardOf mc = sumLCs
                        [ cardOf $ field_1 mc -- 0..1
                        , cardOf $ field_2 mc -- 3 (uses instance HasCard (a,a,a))
                        , preciseC 1
                        , cardOf $ field_4 mc -- 0..Inf
                        ] -- = 4..Inf

instance HasCardT MyContainer where
        cardOfT = cardOf

instance HasCardConstr (MyContainer a) where
        cardinalityConstraintOf mc_a = cardinalityRange (cardOf emptiestMyContainer) infiniteC

instance HasCardConstrT MyContainer where
        cardinalityConstraintOfT = cardinalityConstraintOf

instance HasCardUCT (MyContainer a) [a] where
        uContTrans mc_a =
                uContTrans (field_1 mc_a)
             ++ uContTrans (field_2 mc_a)
             ++            [field_3 mc_a]
             ++             field_4 mc_a

instance HasCardUCT_T MyContainer [] where
        uContTransT = uContTrans

-- We will use this function to instaniate both @HasCardUCT@ and @HasCardUCT_T@.
-- They must use different error throwers, that's why had to define transform
-- outside of instances - in order to avoid doublecoding the same thing.
__uContTrans :: (TransformError_Details -> MyContainer a) -> [a] -> MyContainer a
__uContTrans error_fun a_list = result
    where
       result =
          case a_list of
              (e1 : e2 : e3 : e4 : rest_a_list_1) ->
                        case rest_a_list_1 of
                            (e5 : rest_a_list_2) ->
                                MyContainer {
                                        field_1 = Just e1
                                      , field_2 = (e2,e3,e4)
                                      , field_3 = e5
                                      , field_4 = rest_a_list_2
                                    }
                            _ -> MyContainer {
                                        field_1 = Nothing
                                      , field_2 = (e1,e2,e3)
                                      , field_3 = e4
                                      , field_4 = rest_a_list_1
                                    }
              _ -> error_fun "not enough elements in list"

instance HasCardUCT [a] (MyContainer a) where
        uContTrans = __uContTrans (uContError "[a]" "MyContainer a")

instance HasCardUCT_T [] MyContainer where
        uContTransT = __uContTrans (uContErrorT "[]" "MyContainer")

main = do
      let f pr c = pr ++ (concat $ intersperse "\n" $ map show c)
      let output1 = f "Initial MyContainers:\n"             initial_containers
      let output2 = f "MyContainers trasformed to lists:\n" initial_containers2lists
      let output3 = f "Initial lists:\n"                    initial_lists
      let output4 = f "Lists trasformed to MyContainers:\n" initial_lists2containers
      putStrLn output1
      pressAnyKey
      putStrLn output2
      pressAnyKey
      putStrLn output3
      pressAnyKey
      putStrLn output4
      pressAnyKey
   where
      initial_containers       :: [MyContainer Int]
      initial_lists            :: [[Int]]
      initial_containers2lists :: [Maybe [Int]]
      initial_lists2containers :: [Maybe (MyContainer Int)]
      ---------------------------------
      initial_containers =
                [ MyContainer (Just 1) (2,3,4) 5 [6,7,8,9,10]
                , MyContainer (Just 1) (2,3,4) 5 []
                , MyContainer Nothing (2,3,4) 5 [6,7,8,9,10]
                , MyContainer Nothing (2,3,4) 5 []
                ]
      initial_lists =
                [ []
                , [1]
                , [1..3]
                , [1..4]
                , [1..10]
                , [1..5]
                , [2..10]
                ]
      initial_containers2lists = map sContTrans initial_containers
      initial_lists2containers = map sContTrans initial_lists

---------------------------------------------------------------
-- helpers

infixr 1 <<
(<<)   :: Monad m => m b -> m a -> m b
f << x = x >> f

putStrLn_paged :: Int -> String -> IO ()
putStrLn_paged page_size s = f $ lines s
        where
          f lines_list =
                let (to_print, to_next_itera) = splitAt page_size lines_list
                 in do putStrLn (concat $ intersperse "\n" to_print)
                       case null to_next_itera of
                           True  -> return ()
                           False -> f to_next_itera << pressAnyKey

pressAnyKey = hGetChar stdin << putStrLn "\n-------Press any key to continue...-------"