The natural DSL's of haskell code.

Programming Simulations is Obnoxious

When writing tests for different programming structures it is often necessary to feed the tests data in some sort of systematic way. There are libraries designed to do this but the heavy lifting required is often more than I am willing to attempt.
One thing I have noticed about designing these structures is they very quickly turn into mini-DSL's which make you think "apply parser here" however, I think almost all the situations where my configurations could have been DSL are just as well suited to JSON with a few built in tokens.
Attached below is the code I use to feed historical events into a local mongoDB for testing our website out. One of my favorite things about writing this little guy was seeing the natural way that a project that was supposed to just spit a random value, became one that was configurable, timeable, and programmable.
A few of my favorite things you can do...

Set the code to run at real time relative to the stepped data

Set the offsets of the start and stop by Date or Integer

Program any of the created datasources to emit a constant that changes after some fixed amount of time. Transforming this from non-threaded to threaded haskell took place over 1 line of code.  Just a parMapM. (Not shown)

---

{-# LANGUAGE BangPatterns,TupleSections, OverloadedStrings, QuasiQuotes, TemplateHaskell, TypeFamilies, RecordWildCards, MultiParamTypeClasses, FlexibleInstances ,DeriveGeneric #-}

module MongoDataSeeder where 

import Data.String

import Data.Text

import System.IO

import GHC.Generics

import Data.Typeable

import Data.Data 

import Control.Parallel.Strategies

import Data.Time

import Text.Show

import Data.Yaml

import System.Random

import Data.Bool

import Data.Maybe

import qualified Debug.Trace as Bug

import Prelude --(Ord,($),Show,Eq,(>),(<),(/=),(==), (.),Double,Int,undefined)

import Control.Monad

import Control.Monad.State.Strict 

import Control.Applicative

import Control.Concurrent (threadDelay)

import qualified Data.ByteString as B

import qualified Data.Aeson.Bson as A2B

import qualified Data.Aeson.Generic as A

import Database.MongoDB

-- | Configure MongoDB

data MongoDBConfig = MongoDBConfig { 

     mHost ::   Text 

    ,mDatabase ::   Text 

    ,mCollection ::  Text

    ,mDelay      :: Int

    ,mPrint      :: Bool

    ,mInsertProto :: B.ByteString

    }

  deriving (Generic,Show,Eq)

instance FromJSON MongoDBConfig

instance ToJSON MongoDBConfig

{-| The Mongo Data Seeder inserts records based on a very simple query language 

    at set intervals (in milliseconds) using the first argument on the command LINE

    to set up the database connection and the second argument to set up the query

    The value given at the command line is the initial value you want to put in the query 

    You can also choose whether this should be a "constant" never changing value or 

    change according to some very simple rules right now just (Constant).  

    the after each insertion the query is changed to show that it will insert a different value 

    in the query on the next pass according to your predefined rule.   

    input your command line string as "{\"insert\":{\"iName\":<valueName>

                                                   , \"iType\":<valueType> }

                                        ,\"step\":<stepSize>

                                        ,\"start\":<startTime>}

                                        ,\"stop\" :<stopTime>}"

    valueName is just the name given to the value 

    valueType can be {\"constant\":<Double> } or "Random" 

              where <Double> is a constant that will be repeated over and over

    stepSize is in milliseconds

    startTime and StopTime can be "{sType:now}

                                   {sType:{\"date\", sVal:<UTCDateTime>} }

                                   {sType:{\"offset\":<Integer>}}"

EX: 

"{\"step\":23.0

,\"stop\":{\"sType\":{\"Offset\":22000}}

,\"start\":{\"sType\":{\"Now\":[]}}

,\"insert\":{\"iType\":{\"Random\":[]},\"iName\":\"Test\"}}"

example inserts a record

|-}

-- |Fully defined insert Data contains a Mongo DB config 

-- | and an insertDocument 

data FDInsert = FDInsert {getInsert::InsertDoc ,getMcfg::MongoDBConfig}

                deriving (Show, Eq)

type InitialDoc = FDInsert 

type DocState   = FDInsert

type InsertState = (InitialDoc , DocState)

type IOState = IO InsertState

newStateGen :: IOState -> (IOState -> IOState)

newStateGen !m = (\x -> m)

runInserter :: StateT IOState IO DocState

runInserter = do 

  iDocState <- get 

  insertDocs@(iDoc,cDoc) <- liftIO $ iDocState 

  case done insertDocs of 

    True -> return.snd $ insertDocs

    False -> do 

      rslt <- liftIO $ (threadDelay (mDelay.getMcfg $ iDoc))>>maybePrint cDoc>>insertData (snd insertDocs) -- Run the Insert function and return an updated state

      withStateT (newStateGen $ return (iDoc,rslt)) runInserter 

maybePrint d 

    |(mPrint.getMcfg $ d) = print (getInsert d) >> putStr "\n"

    | otherwise = return () 

done :: InsertState -> Bool

done ( _ ,FDInsert cDoc _) = let isDate (Date l) = Just l

                                 isDate _ = Nothing

                             in  (isDate.sType.start $ cDoc) >= (isDate.sType.stop $ cDoc) -- Nice oneline check because of mutation of state

insertData :: DocState -> IO DocState

insertData d@(FDInsert iDoc mdbCFG) = do 

  pipe <-runIOE $ connect (host.unpack.mHost $ mdbCFG)

  rnd <- randomRIO (0,100) 

  fI     <- mkInsert d --returns a function that can pass a random number generated from IO 

  e    <- access pipe UnconfirmedWrites (mDatabase mdbCFG) (fI rnd)

  strt  <- asDate.start $ iDoc

  close pipe

  return $ FDInsert (InsertDoc (iId iDoc) (step iDoc) (SeedTime (Date (addUTCTime (realToFrac.step $ iDoc) strt ))) (stop iDoc) ) mdbCFG  

mkInsert (FDInsert iDoc mdbCFG) =  let 

                                       isDate (Date l) = l

                                       commonInsert v =  insert (mCollection mdbCFG) ["pid" =: (pid.iId $ iDoc) , "val" =: v, "time" =: (isDate.sType.start $ iDoc)] 

                                       mkValue :: ValueType -> (Double -> Double)

                                       mkValue  (Constant x) = (\_ -> x) 

                                       mkValue  Random = (\x -> x) 

                                   in  return $ commonInsert.(mkValue.iType.iId $ iDoc) 

asDate (SeedTime (Date n)) = return n 

asDate _ = guard (False) >> getCurrentTime 

formatIDoc ( InsertDoc { 

               iId = a

             , step = b 

             , start = c

             , stop = d

             } ) = do 

  newC <- (formatSeedType.sType $ c)

  newD <- (formatSeedType.sType $ d)

  return $ InsertDoc a b (SeedTime newC) (SeedTime newD)

-- | formatSeedTime changes the Seed Time into appropriate UTC Dates

formatSeedType :: SeedType -> IO SeedType

formatSeedType Now = getCurrentTime >>= (\t-> return $ Date t) 

formatSeedType (Offset a) = do 

  time <- getCurrentTime

  return $ Date $ addUTCTime (realToFrac a) time 

formatSeedType x = return x

returnValidData :: InsertDoc -> IO InsertDoc

returnValidData doc = (guard (step doc >= 15.0)) >> validateStartStop (start doc) (stop doc) >> return doc

validateStartStop :: SeedTime -> SeedTime -> IO ()

validateStartStop strt stp = guard (stp /= strt) >> guard ( sType stp /= Now ) >> 

                          invalidStartStop (sType strt) (sType stp) 

invalidStartStop :: SeedType -> SeedType -> IO ()

invalidStartStop (Date strtDate) (Date stpDate) = do 

  guard (strtDate < stpDate)

invalidStartStop (Now) (Date stpDate) = do 

  time <- getCurrentTime 

  guard (time < stpDate)

invalidStartStop (Offset strt ) (Offset stp) = guard (strt < stp) 

invalidStartStop _ _ = return ()

makeValidInsert doc = undefined

data InsertId = InsertId { 

       pid :: Int

      ,iType :: ValueType

}

 deriving (Generic,Show,Eq)

instance ToJSON InsertId

instance FromJSON InsertId

data ValueType = Constant !Double | Random

  deriving (Generic,Show,Eq)

instance ToJSON ValueType

instance FromJSON ValueType

type Seconds = Double

data SeedTime = SeedTime { 

      sType :: SeedType 

}

 deriving (Generic,Show,Ord,Eq)

instance ToJSON SeedTime

instance FromJSON SeedTime

data SeedType = Now | Date !UTCTime| Offset !Double

 deriving (Generic,Show,Eq,Ord)

instance ToJSON SeedType 

instance FromJSON SeedType

data InsertDoc =InsertDoc { 

      iId    :: InsertId

     ,step   :: Seconds

     ,start  :: SeedTime

     ,stop   :: SeedTime

    }

 deriving (Generic,Show,Eq)

instance ToJSON InsertDoc

instance FromJSON InsertDoc

Pattern Matching on unordered lists

So when working in functional programming, most of the time problems feel easier to solve. But there are certain kinds of in-place algorithms that seem really difficult in functional languages.

As a test case, consider this problem.

Given a list of mutants:
M: ["Wolverine","Cyclops","Storm",...,"Sinister","Spiderman"]
P: ["Wolverine","Storm","Sinister",...,"Storm","Rogue"]


Now, P represents a set that M mutants belongs to.
Rules on M: Length(M) <= Length(P) .
Every Element m in M is unique .
Every Element p in P is unique.
p may not be an orderable element.


(or more likely not an efficiently orderable one)


Examples of unorderable elements:

• A complex image processing routine
• A complex relational database partial join

So for an unorderable set that you are matching against, there is no choice but to check each element one at a time. But since one of our requirements is that each piece of data is unique. Time shouldn't be wasted checking the same piece of data twice.


In an imperative language this is handled with nested for loops and probably some sort of mutable array structure that can have data mapped to it by an index key.





Something like this:

indexList = makeAListOfIndexes P
ansArray = makeAnArrayOfSize P
for m in M {
   for p in P(filteredByIndexList){

       if p == m -> remove indexOf(p) from indexList
       store m at indexOf(p) ansArray
   }

}


This is a very elegant solution and does a good job of solving the problem.
However, it relies heavily on mutable state. To do this functionally is easy but required some thinking.

Basically I used a type to organize the data into checked and unchecked patterns.

-----------------------------------------------------------------------------------------------------------------
-- | A datastructure to help us out



data PElement a b = EmptyPElement | Check a | Found b




-- | check if the element under test is matched with this pattern

testPatternElement :: a -> PElement (a -> Bool) a -> PElement (a -> Bool) a

testPatternElement elmUT r@(Check f)
                                                           |f elmUT == True = Found elmUT
                                                           | otherwise = r

testPatternElement elmUT k = k

-- |Mark empties makes the assumptio that any element still in check is Empty

markEmpties :: PElement a b -> PElement a b
markEmpties (Check a) = EmptyPElement
markEmpties other = other


-- | Replace the Empty elements with an Empty default
-- While replacing the Found elements with their function applied found

-- values (kind of like fromMaybe
replaceEmpties ::(b-> c)-> c -> PElement a b -> c
replaceEmpties _ dflt (EmptyPElement) = dflt
replaceEmpties f _ (Found rslt) = f rslt


-- | And a nice compact runner
runSort :: [a] -> [PElement (a -> Bool) a] -> [PElement (a -> Bool ) a]
runSort testList patternList = foldl (\pl t -> ((testPatternElement t) <gt; pl) ) patternList     testList


-- | Some tests

lst :: [Int]
lst = [1,3,4,6,2,5]


ptrns :: [Int]
ptrns = [1,2,3,4,5,6]

testPatterns :: [PElement (Int -> Bool ) b]
testPatterns = (\i -> Check (\x -> x == i) ) <gt; ptrn

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






This solves the problem well, even for complicated cases. I have written code like this for filter banks, and database checking several times. Having it available in Haskell is nice. It is very close to the feel of the Either functor and That could be used. Also, you could functorize or monadize this code. Plus, because this is still immutable... It is very thread safe and can be split up in any way you like.