capnp-0.4.0.0: scripts/gen-basic-instances.hs

{-# 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.ReinterpretCast"
    , "import Data.Word"
    , ""
    , "import Capnp.Classes"
    , "    ( ListElem(..)"
    , "    , MutListElem(..)"
    , "    , FromPtr(..)"
    , "    , Decerialize(..)"
    , "    , Cerialize(..)"
    , "    , cerializeBasicVec"
    , "    )"
    , ""
    , "import qualified Capnp.Untyped as U"
    , "import qualified Data.Vector as V"
    , ""
    ]

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 ", typed, " where\n"
    , "    cerialize _ val = pure val\n"
    ]
    ++
    [ "instance Cerialize (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 = "floatToWord"
        , from = "wordToFloat"
        , typed = "Float"
        , untyped = "Word32"
        , listSuffix = "32"
        }
    , P { to = "doubleToWord"
        , from = "wordToDouble"
        , 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