1

I am new to Haskell, so maybe I am missing some fundamental concepts here (or maybe failed to find the appropriate extension). I was wondering if there was a way to optimize or further abstract the following scenario. This code seems very redundant.

Let's say I have the following data classes:

data Person = Person
              { personName :: !String
              , personAge  :: !Int
              } deriving Show

data Dog = Dog
           { dogName :: !String
           , dogAge  :: !Int
           } deriving Show

Let's say I have a service and I'm only concerned with outputing records as strings. In reality, the strings will probably be JSON and the records fetched from the DB, but let's take a simpler case. I basically need a URL token to fetch an appropriate object (say, the string "dog" will get me a Dog, or even just the Haskell "show" string, without expressly declaring it as (value)::Dog).

I have attempted to implement this in several ways...the only thing that seems to work is the following:

data Creature =  DogC    Dog
               | PersonC Person  
               deriving Show

fromString :: String -> Maybe Creature
fromString "dog" =    Just $ DogC    $ Dog "muffin" 8
fromString "person" = Just $ PersonC $ Person "John" 22
fromString   _    = Nothing

main :: IO ()
main = do
       putStrLn $ show $ fromString "dog"

I'm not entirely fond of the new type, nor the list of fromString declarations. And to benefit from the original data declarations, I would probably need to write a similarly tedious expression (eg, "fromCreature") to revert Creature back into my original types. This information might change, so I would probably need TH for a few of the declarations...

Is there a way around some of this? I fiddled with GADTs and classes, but both seemed to be dependent on type- rather than value- based polymorphism (A string identifier tends to cause issues with ambiguous instances). It would be nice to map the constructor to a string (Say, with Data.Map), but constructors often have different kinds.

Update

So, I went with an approach that isn't exactly relevant to the question I had asked, but it may be useful to someone. I did want to maintain some record types, but most didn't add much value and were getting in my way. The steps I had followed went something like:

  • Use a different/lower-level DB driver, that returns workable types (eg, [ColumnDef] and [[SQLValue]] instead of tuples and records...).
  • Create ToJSON instances for SQLValue -- most of the types were covered, except a few ByteString types, and I had to handle the conversion of SQLNull to Null. To maintain compatibility with some record types, my default handler looked like: toJSON = genericToJSON defaultOptions { sumEncoding = UnTaggedValue} The untagged value should allow one to read the JSON into defined data types (eg, Dog / Person ) if desired....
  • Given that column name is accessible from ColumnDef, I wrote an expression that zips [ColumnDef] and [SqlValue] to a list of Aeson-compatible key-value pairs, eg: toJsPairs :: [ColumnDef] -> [SqlValue] -> [(Text,Value)]
  • Then, I wrote an expression to fetch the JSON from a table name, which more or less serves as my "universal dispatcher." It references a list of authorized tables, so it's less crazy than it might sound.

The code looked a bit like this (using mysql-haskell).

{-# LANGUAGE OverloadedStrings #-}

import qualified Control.Applicative as App
import Database.MySQL.Base
import qualified System.IO.Streams as Streams
import Data.Aeson (FromJSON, ToJSON)
import Data.Aeson.Encode.Pretty (encodePretty)
import Data.Aeson.Types
import Data.Text.Encoding
import Data.String (fromString)
import Data.ByteString.Internal
import qualified Data.ByteString.Lazy.Internal as BLI
import Data.HashMap.Strict (fromList)

appConnectInfo = defaultConnectInfo {
                   ciUser = "some_user"
                 , ciPassword = "some_password"
                 , ciDatabase = "some_db"
             }

instance FromJSON ByteString where
  parseJSON (String s) = pure $ encodeUtf8 s
  parseJSON _ = App.empty

instance ToJSON ByteString where
    toJSON  = String . decodeUtf8 

instance ToJSON MySQLValue where
    toJSON (MySQLNull) = Null
    toJSON x = genericToJSON defaultOptions
                       { sumEncoding = UntaggedValue } x 

-- This expression should fail on dimensional mismatch.
-- It's stupidly lenient, but really dimensional mismatch should
-- never occur...

toJsPairs :: [ColumnDef] -> [MySQLValue] -> [(Text,Value)]
toJsPairs [] _ = []
toJsPairs _ [] = []
toJsPairs (x:xs) (y:ys) = (txt x, toJSON y):toJsPairs xs ys
                    where
                         -- Implement any modifications to the key names here
                         txt = decodeUtf8.columnName

listRecords :: String -> IO BLI.ByteString 
listRecords tbl = do
    conn <- connect appConnectInfo

    -- This is clearly an injection vulnerability.
    -- Implemented, however, the values for 'tbl' are intensely
    -- vetted.  This is just an example.

    (defs, is) <- query_ conn $ fromString ( "SELECT * FROM `" ++ tbl ++ "` LIMIT 100")
    rcrds <- Streams.toList is
    return $ encodePretty $ map (jsnobj defs) rcrds
        where
            jsnobj :: [ColumnDef] -> [MySQLValue] -> Value
            jsnobj defs x = Object $ fromList $ toJsPairs defs x
2
  • 2
    In the real case, can you change the first two types? If so, what about something like data CreatureType = Dog | Person ; data Creature = { cName :: !String, cAge :: !Int, cType :: CreatureType }? Commented Jul 2, 2017 at 4:48
  • I suppose that's the problem with contrived examples -- there are multiple data types and they are not as congruent as the ones listed. Commented Jul 2, 2017 at 19:39

1 Answer 1

1

If what you want to consume at the end is json value - it might make sense to represent result as json value using aeson library:

{-# LANGUAGE DeriveGeneric #-}

import Data.Aeson
import GHC.Generics

data Dog = Dog Int String deriving (Show, Generic)
data Cat = Cat Int String deriving (Show, Generic)

-- here I'm using instance derived with generics, but you can write one by
-- hands
instance ToJSON Dog
instance ToJSON Cat

-- actions to get stuff from db
getDog :: Monad m => Int -> m Dog
getDog i = return (Dog i (show i))

getCat :: Monad m => Int -> m Cat
getCat i = return (Cat i (show i))

-- dispatcher - picks which action to use
getAnimal :: Monad m => String -> Int -> m (Maybe Value)
getAnimal "dog" i = Just . toJSON <$> getDog i
getAnimal "cat" i = Just . toJSON <$> getCat i
getAnimal _ _ = return Nothing


main :: IO ()
main = do
    getAnimal "dog" 2 >>= print
    getAnimal "cat" 3 >>= print
    getAnimal "chupakabra" 12 >>= print

High energy magic version

class Monad m => MonadAnimal m where
    -- basically you want something that fetches extra argumets from HTTP or
    -- whatevere, perform DB query and so on.

class Animal a where
    animalName :: Proxy a -> String
    animalGetter :: MonadAnimal m => m a

locateAnimals :: MonadAnimal m => Q [(String, m Value)]
locateAnimals -- implement using TH (reify function is your friend). It should look for
-- all the animal instances in scope and make a list from them with serialized
-- fetcher.

-- with that in place dispatcher should be easy to implement
Sign up to request clarification or add additional context in comments.

4 Comments

So, this does away with the "Creature" type, which is an improvement. I'm wondering if there is a way to make the dispatcher more general.
Maybe so that I could do something like [ instance Animal Dog where animalName="dog" ] and getAnimal would resolve (perhaps with a few other functions dependant on 'name'). Then again, I'm not sure if this is any better or more concise than just declaring getAnimal by hand....especially in an example with finite and clearly defined data types....
instance Animal Dog where animalName="dog" will only get youAnimal a => a -> String which won't give you directly what you want. If you prefer to have universal dispatcher that works on arbitrary instance... Let's try some high energy magic....
I did something else (see the update). With the information that was given, however, this is a good answer.

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

Start asking to get answers

Find the answer to your question by asking.

Ask question

Explore related questions

See similar questions with these tags.