mirror of
https://github.com/zap-proto/haskell.git
synced 2026-10-30 15:05:00 +00:00
106 lines
3.1 KiB
Haskell
106 lines
3.1 KiB
Haskell
{-# LANGUAGE RecordWildCards #-}
|
|
-- | Script that generates 'Internal.Gen.Instances', which is mostly a
|
|
-- bunch of tedious instances for basic types for our various type classes.
|
|
module Main where
|
|
|
|
header = unlines
|
|
[ "{-# LANGUAGE TypeFamilies #-}"
|
|
, "{-# LANGUAGE FlexibleInstances #-}"
|
|
, "{-# LANGUAGE MultiParamTypeClasses #-}"
|
|
, "module Internal.Gen.Instances where"
|
|
, "-- This module is auto-generated by gen-builtintypes-lists.hs; DO NOT EDIT."
|
|
, ""
|
|
, "import Data.Int"
|
|
, "import Data.Word"
|
|
, ""
|
|
, "import Capnp.Classes"
|
|
, " ( ListElem(..)"
|
|
, " , MutListElem(..)"
|
|
, " , FromPtr(..)"
|
|
, " , Decerialize(..)"
|
|
, " , Cerialize(..)"
|
|
, " , cerializeBasicVec"
|
|
, " )"
|
|
, ""
|
|
, "import qualified Capnp.Untyped as U"
|
|
, "import qualified Data.Vector as V"
|
|
, "import qualified GHC.Float as F"
|
|
, ""
|
|
]
|
|
|
|
data InstanceParams = P
|
|
{ to :: String
|
|
, from :: String
|
|
, typed :: String
|
|
, untyped :: String
|
|
, listSuffix :: String
|
|
}
|
|
|
|
genInstance P{..} = concat $
|
|
[ "instance ListElem msg ", typed, " where\n"
|
|
, " newtype List msg ", typed, " = List", typed, " (U.ListOf msg ", untyped, ")\n"
|
|
, " listFromPtr msg ptr = List", typed, " <$> fromPtr msg ptr\n"
|
|
, " toUntypedList (List", typed, " l) = U.List", listSuffix, " l\n"
|
|
, " length (List", typed, " l) = U.length l\n"
|
|
, " index i (List", typed, " l) = ", from, " <$> U.index i l\n"
|
|
, "instance MutListElem s ", typed, " where\n"
|
|
, " setIndex elt i (", dataCon, " l) = U.setIndex (", to, " elt) i l\n"
|
|
, " newList msg size = List", typed, " <$> U.allocList", listSuffix, " msg size\n"
|
|
, "instance Decerialize ", typed, " where\n"
|
|
, " type Cerial msg ", typed, " = ", typed, "\n"
|
|
, " decerialize val = pure val\n"
|
|
, "instance Cerialize s ", typed, " where\n"
|
|
, " cerialize _ val = pure val\n"
|
|
]
|
|
++
|
|
[ "instance Cerialize s (V.Vector " ++ t ++ ") where\n" ++
|
|
" cerialize = cerializeBasicVec\n"
|
|
| t <- take 6 $ iterate (\t -> "(V.Vector " ++ t ++ ")") typed
|
|
]
|
|
where
|
|
dataCon = "List" ++ typed
|
|
|
|
sizes = [8, 16, 32, 64]
|
|
|
|
intInstance size = P
|
|
{ to = "fromIntegral"
|
|
, from = "fromIntegral"
|
|
, typed = "Int" ++ show size
|
|
, untyped = "Word" ++ show size
|
|
, listSuffix = show size
|
|
}
|
|
|
|
wordInstance size = P
|
|
{ to = "id"
|
|
, from = "id"
|
|
, typed = "Word" ++ show size
|
|
, untyped = "Word" ++ show size
|
|
, listSuffix = show size
|
|
}
|
|
|
|
instances =
|
|
map intInstance sizes ++
|
|
map wordInstance sizes ++
|
|
[ P { to = "F.castFloatToWord32"
|
|
, from = "F.castWord32ToFloat"
|
|
, typed = "Float"
|
|
, untyped = "Word32"
|
|
, listSuffix = "32"
|
|
}
|
|
, P { to = "F.castDoubleToWord64"
|
|
, from = "F.castWord64ToDouble"
|
|
, typed = "Double"
|
|
, untyped = "Word64"
|
|
, listSuffix = "64"
|
|
}
|
|
, P { to = "id"
|
|
, from = "id"
|
|
, typed = "Bool"
|
|
, untyped = "Bool"
|
|
, listSuffix = "1"
|
|
}
|
|
]
|
|
|
|
main = writeFile "gen/lib/Internal/Gen/Instances.hs" $
|
|
header ++ concatMap genInstance instances
|