Haskell Style Guide

in­stance NF­Data DPOR where
  rnf dpor = rnf ( dpor­Run­nable dpor
                 , dpor­Todo     dpor
                 , dpor­Done     dpor
                 , dporSleep    dpor
                 , dpor­Taken    dpor
                 , dpor­Ac­tion   dpor
                 )

case rest of
  ((_, run­nable, _):_) -> map fst run­nable
  []                   -> []

case M.lookup tid' (dpor­Done dpor) of
  Just dpor' ->
    let done = M.in­sert tid' (grow state' tid' rest dpor') (dpor­Done dpor)
    in dpor { dpor­Done = done }
  Nothing    ->
    let taken = M.in­sert tid' a (dpor­Taken dpor)
    in dpor { dpor­Taken = if con­ser­vative then dpor­Taken dpor else taken }

can­In­ter­rupt :: Dep­State -> ThreadId -> ThreadAc­tion -> Bool
can­In­ter­rupt dep­state tid act
  | is­Masked­In­ter­rupt­ible dep­state tid = case act of
    Blocked­Put­MVar  _ -> True
    BlockedRead­MVar _ -> True
    Blocked­TakeMVar _ -> True
    BlockedSTM      _ -> True
    Blocked­ThrowTo  _ -> True
    _ -> False
  | is­MaskedUn­in­ter­rupt­ible dep­state tid = False
  | oth­er­wise = True

autocheck­WayIO :: (Eq a, Show a) => Way -> Mem­Type -> ConcIO a -> IO Bool
autocheck­WayIO way mem­type concio =
  de­jafusWayIO way mem­type concio autocheck­Cases

in­cor­por­at­eT­race
  :: Mem­Type
  -- ^ Memory model
  -> Bool
  -- ^ Whether the \"to-­do\" point which was used to create this new
  -- ex­e­cu­tion was con­ser­vative or not.
  -> Trace
  -- ^ The ex­e­cu­tion trace: the de­cision made, the run­nable threads,
  -- and the ac­tion per­formed.
  -> DPOR
  -> DPOR

runSCT :: Mon­adRef r n
  => Way
  -- ^ How to run the con­cur­rent pro­gram.
  -> Mem­Type
  -- ^ The memory model to use for non-­syn­chron­ised @CRef@ op­er­a­tions.
  -> ConcT r n a
  -- ^ The com­pu­ta­tion to run many times.
  -> n [(Either Failure a, Trace)]

data Way where
  Sys­tem­at­ic­ally :: Bounds -> Way
  Ran­domly :: Ran­domGen g => g -> Int -> Way

data Id­Source = Id
  { _nextCRId  :: Int
  , _next­MVId  :: Int
  , _nextTVId  :: Int
  , _nextTId   :: Int
  , _used­CR­Names :: [String]
  , _used­M­V­Names :: [String]
  , _usedTV­Names :: [String]
  , _usedTNames  :: [String]
  }
  de­riving (Eq, Ord, Show)

data ThreadAc­tion
  = Fork ThreadId
  | My­Th­readId
  | Get­Num­Cap­ab­il­ities Int
  | Set­Num­Cap­ab­il­ities Int
  | Yield
  de­riving (Eq, Show)

type Sched­uler state
  = [(De­cision, ThreadAc­tion)]
  -> Maybe (ThreadId, ThreadAc­tion)
  -> NonEmpty (ThreadId, Looka­head)
  -> state
  -> (Maybe ThreadId, state)

fail­ures :: [Failure]
fail­ures =
  [ In­tern­alError
  , Abort
  , Dead­lock
  , STM­Dead­lock
  , Un­caugh­tEx­cep­tion
  , Il­leg­alSub­con­cur­rency
  ]

fail­ures :: [Failure]
fail­ures = [ In­tern­alError
           , Abort
           , Dead­lock
           , STM­Dead­lock
           , Un­caugh­tEx­cep­tion
           , Il­leg­alSub­con­cur­rency
           ]

(~=) :: Thread n r -> BlockedOn -> Bool
thread ~= theb­lock = case (_b­locking thread, theb­lock) of
  (Just (On­M­Var­Full  _), On­M­Var­Full  _) -> True
  (Just (On­M­Var­Empty _), On­M­Var­Empty _) -> True
  (Just (OnTVar      _), OnTVar      _) -> True
  (Just (On­Mask      _), On­Mask      _) -> True
  _ -> False

step­Throw t ts act e =
  case propagate (to­Ex­cep­tion e) t ts of
    Just ts' -> simple ts' act
    Nothing
      | t == ini­tial­Thread -> pure (Left Un­caugh­tEx­cep­tion, Single act)
      | oth­er­wise -> simple (kill t ts) act

con­cat­Par­ti­tion :: (a -> Bool) -> [[a]] -> ([a], [a])
{-# IN­LINE con­cat­Par­ti­tion #-}
con­cat­Par­ti­tion p = foldl (foldr se­lect) ([], []) where
  se­lect a ~(ts, fs)
    | p a       = (a:ts, fs)
    | oth­er­wise = (ts, a:fs)

forkFi­nally :: Mon­ad­Conc m => m a -> (Either SomeEx­cep­tion a -> m ()) -> m (ThreadId m)
forkFi­nally ac­tion an­d_then =
  mask $ \re­store ->
    fork $ Ca.try (re­store ac­tion) >>= an­d_then

rep­res­ent­ative :: Eq a => Pre­dicate a -> Pre­dicate a
rep­res­ent­ative p xs = result { _fail­ures = choose . col­lect $ _fail­ures result } where
  result  = p xs
  col­lect = groupBy' [] ((==) `on` fst)
  choose  = map $ min­im­umBy (com­paring $ \(_, trc) -> (preEmps trc, length trc))

find­In­stance :: Expr s1 m1 h1 -> Expr s2 m2 h2 -> Maybe [(String, [String])]
find­In­stance eG eS
    | eS `isIn­stanceOf` eG = Just nameMap
    | oth­er­wise = Nothing
  where
    env = map fst . en­vir­on­ment'
    nameMap =
      map (\((s,g):sgs) -> (s, nub (g:map snd sgs))) .
      groupBy ((==) `on` fst) .
      sortOn fst $
      zip (env eS) (env eG)

grow state tid trc@((d, _, a):rest) dpor =
  let tid'   = tidOf tid d
      state' = up­dateDep­State state tid' a
  in case M.lookup tid' (dpor­Done dpor) of
       Just dpor' ->
         let done = M.in­sert tid' (grow state' tid' rest dpor') (dpor­Done dpor)
         in dpor { dpor­Done = done }
       Nothing ->
         let taken = M.in­sert tid' a (dpor­Taken dpor)
             sleep = dporSleep dpor `M.union` dpor­Taken dpor
             done  = M.in­sert tid' (sub­tree state' tid' sleep trc) (dpor­Done dpor)
         in dpor { dpor­Taken = if con­ser­vative then dpor­Taken dpor else taken
                 , dpor­Todo  = M.de­lete tid' (dpor­Todo dpor)
                 , dpor­Done  = done
                 }
grow _ _ [] _ = err "in­cor­por­at­eT­race" "trace ex­hausted without reading a to-do point!"

($$) :: Ord h => Expr s m h -> Expr s m h -> Maybe (Expr s m h)
f $$ e = case funTys (ex­pr­Ty­peRep f) of
    Just (fArgTy, fResTy) ->
      if fArgTy == ig­nore­Ty­peRep && is­Just (un­monad $ ex­pr­Ty­peRep e)
      then mkfun fResTy
      else mkfun =<< ex­pr­Ty­peRep f `fun­Res­ultTy` ex­pr­Ty­peRep e
    Nothing -> Nothing

check­File :: (Mon­adError FileError m, Mon­adIO m) => File­Config -> File­Path -> Int64 -> m ()
check­File fcfg fname bytes = do
  let max­bytes = max­SizeIn­Bytes fcfg
  if bytes > max­bytes
    then throw­Error (FileTooLarge bytes max­bytes)
    else do
      ok <- liftIO (ad­di­tion­al­Rules fcfg fname)
      case ok of
        Right _ -> pure ()
        Left  e -> throw­Error (FileDis­al­lowed e)