Skip to content

Instantly share code, notes, and snippets.

@alexbiehl

alexbiehl/HEAD-decode.dump-simpl.hs

Last active December 2, 2016 13:20
Show Gist options
  • Star 0 You must be signed in to star a gist
  • Fork 0 You must be signed in to fork a gist
  • Save alexbiehl/0a1b5016223e00ae79a1399176e14eef to your computer and use it in GitHub Desktop.
Save alexbiehl/0a1b5016223e00ae79a1399176e14eef to your computer and use it in GitHub Desktop.
Download ZIP
Extract from DSL to parse ResultSets for mysql-haskell
Raw
decode.hs
{-# LANGUAGE RankNTypes #-}
module X where
import Data.Int
import Data.Vector (Vector)
import qualified Data.Vector as V
import qualified System.IO.Streams as Streams
data ColValue = CV_Null
| CV_Text !String
| CV_Int8 !Int8
| CV_Int16 !Int16
| CV_Int32 !Int32
| CV_Int64 !Int64
deriving (Show)
data Error = Error
data Row a =
Row { _rowCols :: !Int
, _rowDecode :: forall r. (a -> Int -> r)
-> (Error -> r)
-> Vector ColValue
-> Int
-> r
}
newtype Column a =
Column { runColumn :: forall r. (a -> r)
-> (Error -> r)
-> ColValue
-> r
}
instance Functor Row where
fmap f (Row n m) = Row n $ \succ_ fail_ v i ->
m (succ_ . f) fail_ v i
{-# INLINE fmap #-}
instance Applicative Row where
pure a = Row 0 $ \succ_ _fail _v i -> succ_ a i
{-# INLINE pure #-}
Row n fm <*> Row m am = Row (n + m) $ \succ_ fail_ v i ->
fm (\f j -> am (\a k -> succ_ (f a) k) fail_ v j) fail_ v i
{-# INLINE (<*>) #-}
instance Functor Column where
fmap f (Column m) = Column $ \succ_ fail_ v ->
m (succ_ . f) fail_ v
{-# INLINE fmap #-}
newtype Result a =
Result { runResult :: Streams.InputStream (Vector ColValue)
-> IO (Either Error a)
}
runRow1 :: forall a r. Row a
-> Vector ColValue
-> (a -> r)
-> (Error -> r)
-> r
runRow1 (Row cols decode) v succ_ fail_
| cols == V.length v = decode (\a _ -> succ_ a) (\e -> fail_ e) v 0
| otherwise = fail_ Error
{-# INLINE runRow1 #-}
foldlRows :: (a -> b -> a) -> a -> Row b -> Result a
foldlRows f z row@(Row cols _) = Result $ \is -> do
let loop s = do
ma <- Streams.read is
case ma of
Just a -> runRow1 row a (\x -> loop $! f s x) (\e -> return (Left e))
Nothing -> return (Right s)
loop $! z
{-# INLINE foldlRows #-}
col :: Column a -> Row a
col val = Row 1 $ \succ_ fail_ v i ->
runColumn val (\a -> succ_ a (i + 1)) fail_ (V.unsafeIndex v i)
{-# INLINE col #-}
int32 :: Column Int32
int32 = Column $ \succ_ fail_ mv ->
case mv of
CV_Int8 i -> succ_ (fromIntegral i)
CV_Int16 i -> succ_ (fromIntegral i)
CV_Int32 i -> succ_ i
_ -> fail_ Error
{-# INLINE int32 #-}
text :: Column String
text = Column $ \succ_ fail_ mv ->
case mv of
CV_Text t -> succ_ t
_ -> fail_ Error
{-# INLINE text #-}
data Emp = Emp !Int32 !Int32 !Int32 !String
empRow :: Row Emp
empRow = Emp <$> col int32 <*> col int32 <*> col int32 <*> col text
{-# INLINE empRow #-}
empResult :: Result Int
empResult = foldlRows (\x _ -> x + 1) 0 empRow
Raw
ghc-8.0.1-decode.dump-simpl.hs
-- RHS size: {terms: 175, types: 184, coercions: 4}
$wempResult
:: IO (Maybe (Vector ColValue))
-> State# RealWorld -> (# State# RealWorld, Either Error Int #)
$wempResult =
\ (ww :: IO (Maybe (Vector ColValue))) (w :: State# RealWorld) ->
letrec {
$sloop
:: State# RealWorld
-> Int# -> (# State# RealWorld, Either Error Int #)
$sloop =
\ (sc :: State# RealWorld) (sc1 :: Int#) ->
case (ww `cast` ...) sc of _ { (# ipv, ipv1 #) ->
case ipv1 of _ {
Nothing -> (# ipv, Right (I# sc1) #);
Just a ->
case length $fVectorVectora a of _ { I# y ->
case y of _ {
__DEFAULT -> (# ipv, empResult2 #);
4# ->
case a of _ { Vector dt dt1 dt2 ->
let {
$wsucc_
:: Int#
-> State# RealWorld -> (# State# RealWorld, Either Error Int #)
$wsucc_ =
\ (ww1 :: Int#) (w1 :: State# RealWorld) ->
let {
$wsucc_1
:: Int#
-> State# RealWorld -> (# State# RealWorld, Either Error Int #)
$wsucc_1 =
\ (ww2 :: Int#) (w2 :: State# RealWorld) ->
case indexArray# dt2 (+# dt ww2) of _ { (# ipv2 #) ->
case ipv2 of _ {
__DEFAULT -> (# w2, empResult2 #);
CV_Int8 dt4 ->
case indexArray# dt2 (+# dt (+# ww2 1#)) of _ { (# ipv3 #) ->
case ipv3 of _ {
__DEFAULT -> (# w2, empResult2 #);
CV_Text t -> $sloop w2 (+# sc1 1#)
}
};
CV_Int16 dt4 ->
case indexArray# dt2 (+# dt (+# ww2 1#)) of _ { (# ipv3 #) ->
case ipv3 of _ {
__DEFAULT -> (# w2, empResult2 #);
CV_Text t -> $sloop w2 (+# sc1 1#)
}
};
CV_Int32 dt4 ->
case indexArray# dt2 (+# dt (+# ww2 1#)) of _ { (# ipv3 #) ->
case ipv3 of _ {
__DEFAULT -> (# w2, empResult2 #);
CV_Text t -> $sloop w2 (+# sc1 1#)
}
}
}
} } in
case indexArray# dt2 (+# dt ww1) of _ { (# ipv2 #) ->
case ipv2 of _ {
__DEFAULT -> (# w1, empResult2 #);
CV_Int8 dt4 -> $wsucc_1 (+# ww1 1#) w1;
CV_Int16 dt4 -> $wsucc_1 (+# ww1 1#) w1;
CV_Int32 dt4 -> $wsucc_1 (+# ww1 1#) w1
}
} } in
case indexArray# dt2 dt of _ { (# ipv2 #) ->
case ipv2 of _ {
__DEFAULT -> (# ipv, empResult2 #);
CV_Int8 dt4 -> $wsucc_ 1# ipv;
CV_Int16 dt4 -> $wsucc_ 1# ipv;
CV_Int32 dt4 -> $wsucc_ 1# ipv
}
}
}
}
}
}
}; } in
$sloop w 0#
Raw
HEAD-decode.dump-simpl.hs
-- RHS size: {terms: 193, types: 182, coercions: 3}
empResult :: Result Int
empResult =
case <$> $fFunctorRow $WEmp lvl19 of { Row dt fm ->
case + $fNumInt (I# dt) lvl17 of dt1 { I# dt2 ->
case + $fNumInt dt1 lvl17 of dt3 { I# dt4 ->
case + $fNumInt dt3 lvl17 of dt5 { I# dt6 ->
(\ (is :: InputStream (Vector ColValue)) ->
let {
lvl23 :: IO (Maybe (Vector ColValue))
lvl23 = case is of { InputStream ds1 ds2 -> ds1 } } in
$!
(letrec {
loop :: Int -> IO (Either Error Int)
loop =
\ (s :: Int) ->
let {
lvl24 :: IO (Either Error Int)
lvl24 = $! loop (+ $fNumInt s lvl17) } in
let {
lvl25 :: IO (Either Error Int)
lvl25 = return $fMonadIO (Right s) } in
>>=
$fMonadIO
lvl23
(\ (ma :: Maybe (Vector ColValue)) ->
case ma of {
Nothing -> lvl25;
Just a ->
case == $fEqInt dt5 (lvl13 a) of {
False -> lvl21;
True ->
fm
(\ _ (j :: Int) ->
case a of { Vector dt7 dt8 dt9 ->
case + $fNumInt (I# dt7) j of { I# i# ->
let {
$wsucc_ :: Int -> IO (Either Error Int)
$wsucc_ =
\ (w :: Int) ->
case + $fNumInt (I# dt7) w of { I# i#1 ->
case indexArray# dt9 i#1 of { (# ipv #) ->
case ipv of {
__DEFAULT -> lvl21;
CV_Int8 dt10 ->
case + $fNumInt (I# dt7) (+ $fNumInt w lvl17) of
{ I# i#2 ->
case indexArray# dt9 i#2 of { (# ipv1 #) ->
case ipv1 of {
__DEFAULT -> lvl21;
CV_Text t -> lvl24
}
}
};
CV_Int16 dt10 ->
case + $fNumInt (I# dt7) (+ $fNumInt w lvl17) of
{ I# i#2 ->
case indexArray# dt9 i#2 of { (# ipv1 #) ->
case ipv1 of {
__DEFAULT -> lvl21;
CV_Text t -> lvl24
}
}
};
CV_Int32 dt10 ->
case + $fNumInt (I# dt7) (+ $fNumInt w lvl17) of
{ I# i#2 ->
case indexArray# dt9 i#2 of { (# ipv1 #) ->
case ipv1 of {
__DEFAULT -> lvl21;
CV_Text t -> lvl24
}
}
}
}
}
} } in
case indexArray# dt9 i# of { (# ipv #) ->
case ipv of {
__DEFAULT -> lvl21;
CV_Int8 dt10 -> $wsucc_ (+ $fNumInt j lvl17);
CV_Int16 dt10 -> $wsucc_ (+ $fNumInt j lvl17);
CV_Int32 dt10 -> $wsucc_ (+ $fNumInt j lvl17)
}
}
}
})
lvl22
a
$fShowColValue2
}
}); } in
loop)
$fShowColValue2)
`cast` ...
}
}
}
}
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment