Extract.hs

{-# LANGUAGE BangPatterns         #-}
{-# LANGUAGE ConstraintKinds      #-}
{-# LANGUAGE FlexibleContexts     #-}
{-# LANGUAGE OverloadedStrings    #-}
{-# LANGUAGE TypeFamilies         #-}
{-# LANGUAGE UndecidableInstances #-}

module Arbor.File.Format.Asif.Extract
  ( formats
  , list
  , map
  , vectorBoxed
  , vectorUnboxed
  ) where

import           Arbor.File.Format.Asif.Format.Type (Format)
import           Arbor.File.Format.Asif.Whatever
import           Control.Lens
import           Data.Binary.Get
import           Data.List                          hiding (map)
import           Data.Text                          (Text)
import           Data.Text.Encoding                 (decodeUtf8')
import           Data.Text.Encoding.Error
import           Prelude                            hiding (map)

import qualified Data.Binary.Get                    as G
import qualified Data.ByteString.Lazy               as LBS
import qualified Data.Map.Strict                    as M
import qualified Data.Vector                        as V
import qualified Data.Vector.Unboxed                as VU

vectorBoxed :: Get a -> LBS.ByteString -> V.Vector a
vectorBoxed g = V.unfoldr step
  where step !s = case runGetOrFail g s of
          Left (_, _, _)     -> Nothing
          Right (!rs, _, !k) -> Just (k, rs)

vectorUnboxed :: VU.Unbox a => Get a -> LBS.ByteString -> VU.Vector a
vectorUnboxed g = VU.unfoldr step
  where step !s = case runGetOrFail g s of
          Left (_, _, _)     -> Nothing
          Right (!rs, _, !k) -> Just (k, rs)

list :: Get a -> LBS.ByteString -> [a]
list g = G.runGet go
  where go = do
          empty <- G.isEmpty
          if not empty
            then (:) <$> g <*> go
            else return []

map :: (Ord a) => LBS.ByteString -> Get a -> LBS.ByteString -> Get b -> M.Map a b
map ks kf vs vf = foldr (\(k, v) m -> M.insert k v m) M.empty $ zip keys values
  where
    keys = list kf ks
    values = list vf vs

formats :: LBS.ByteString -> [Maybe (Whatever Format)]
formats bs = LBS.split 0 bs <&> decodeUtf8' . LBS.toStrict <&> convert
  where convert :: Either UnicodeException Text -> Maybe (Whatever Format)
        convert (Left _)   = Nothing
        convert (Right "") = Nothing
        convert (Right t)  = Just (tReadWhatever t)