blah

document.hs

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE ScopedTypeVariables #-}

import Data.Proxy

-- could probably use 'reflection' instead of my
-- hacky KnownXXX classes

data DocType = A | B | C | D
  deriving (Eq, Show, Read)

class KnownDocType (dt :: DocType) where
  docTypeOf :: Proxy dt -> DocType

instance KnownDocType A where docTypeOf _ = A
instance KnownDocType B where docTypeOf _ = B
instance KnownDocType C where docTypeOf _ = C
instance KnownDocType D where docTypeOf _ = D

class KnownDocTypes (dts :: [DocType]) where
  docTypes :: Proxy dts -> [DocType]

instance KnownDocTypes '[] where
  docTypes _ = []

instance (KnownDocType dt, KnownDocTypes dts) => KnownDocTypes (dt ': dts) where
  docTypes _ = docTypeOf (Proxy :: Proxy dt) : docTypes (Proxy :: Proxy dts)

docTypeMatches :: forall dts. KnownDocTypes dts =>  DocType -> Proxy dts -> Bool
docTypeMatches dt dts = dt `elem` docTypes dts

-- a document carries the doc types it allows at the typelevel,
-- in a list where each element has kind DocType
data Document (dts :: [DocType]) = Document
  { docType    :: DocType
  , docTitle   :: String
  , docContent :: String
  } deriving (Eq, Show)

toDocument :: forall dts. KnownDocTypes dts
           => (DocType, String, String)
           -> Either String (Document dts)
toDocument (dt, title, content) = case docTypes dts of
  [] -> Left "empty document type list"
  xs -> if docTypeMatches dt dts
        then Right (Document dt title content)
        else Left $ show dt ++ " is not one of the allowed document types: "
                 ++ show xs

  where dts = Proxy :: Proxy dts

ex1 :: Either String (Document '[])
ex1 = toDocument (A, "confidential", "boo")

ex2good, ex2bad :: Either String (Document '[A, B, C])
ex2good = toDocument (A, "confidential", "boo")
ex2bad = toDocument (D, "confidential", "boo")