Skip to content
Snippets Groups Projects
Commit 6bb0a3ec authored by Hugo Hörnquist's avatar Hugo Hörnquist
Browse files

Line Format encoding.

parent 3b2e309a
No related branches found
No related tags found
No related merge requests found
\begin{code}
-- allow instances on lists.
-- used both for the String instance, but also to generalize array intances
{-# LANGUAGE FlexibleInstances #-}
module LineFormat where
import Data.ByteString.Builder
import qualified Data.ByteString.Lazy as BS
import Data.Int
class LineFormat a where
encode :: a -> Builder
-- decode :: ByteString -> a
instance LineFormat Bool where
encode True = char7 '1'
encode False = char7 '0'
instance LineFormat Int8 where
encode = int8Dec
instance LineFormat Int16 where
encode = int16Dec
instance LineFormat Int32 where
encode = int32Dec
instance LineFormat Float where
-- TODO ensure this is equivalent to printf("%g", val)
encode = floatDec
-- Strings are NOT character lists in LysKom, intoduce overlapping instance
instance {-# OVERLAPPING #-} LineFormat [Char] where
encode s = let bs = toLazyByteString $ string8 s
in int64Dec (BS.length bs)
<> char7 'H'
<> lazyByteString bs
instance LineFormat a => LineFormat [a] where
encode t = intDec (length t)
<> string7 " { "
<> mconcat ((<> char8 ' ') . encode <$> t)
<> char7 '}'
\end{code}
{-# LANGUAGE TemplateHaskell #-}
import Language.Haskell.TH
import Language.Haskell.TH.Syntax
import Text.Parsers.ProtocolA (documentParser)
import Text.Parsers.ProtocolA.Data (ProtocolAItem (..))
import Text.Parsers.ProtocolA.Types
......@@ -8,6 +9,10 @@ import Text.ParserCombinators.Parsec (parseFromFile)
import Data.Either (rights)
import Data.Char (toUpper)
import Data.Maybe (maybe)
import LineFormat
import Data.Int
-- typename "sparse-block" ⇒ "SparseBlock"
typename (s:xs) = toUpper s : f xs
......@@ -17,80 +22,121 @@ typename (s:xs) = toUpper s : f xs
-- varname "last-time-read" ⇒ "lastTimeRead"
varname [] = []
varname "data" = "data_"
varname "type" = "type_"
varname ('-':c:xs) = toUpper c : varname xs
varname (c:xs) = c : varname xs
b = Bang NoSourceUnpackedness NoSourceStrictness
lystype :: LysType -> Type
lystype INT32 = ConT ''Int
lystype INT16 = ConT ''Int
lystype INT8 = ConT ''Int
lystype INT32 = ConT ''Int32
lystype INT16 = ConT ''Int16
lystype INT8 = ConT ''Int8
lystype BOOL = ConT ''Bool
lystype FLOAT = ConT ''Double
lystype FLOAT = ConT ''Float
lystype HOLLERITH = ConT ''String
lystype (ARRAY n) = AppT ListT $ lystype n
lystype (Reference n) = ConT . mkName . typename $ n
-- `lystype _' is intentionally missing. since they should never be
-- able to appear.
f :: ProtocolAItem -> [Dec]
f (Comment s) = []
f :: ProtocolAItem -> Q [Dec]
f (Comment s) = return []
f (DerivedType name (Reference other_name)) = [
f (DerivedType name (Reference other_name)) = return [
TySynD (mkName . typename $ name) [] $
ConT (mkName . typename $ other_name) ]
-- TODO union
f (DerivedType name (Union t)) = []
f (DerivedType name (Union t)) = return []
-- TODO Enumerations and selections should both have custom to-from
-- enum, to map up the numbers
f (DerivedType name (ENUMERATION t)) = [
f (DerivedType name (ENUMERATION t)) = return [
DataD [] (mkName . typename $ name) [] Nothing
[NormalC (mkName . typename $ n) [] | (n, _) <- t]
[DerivClause Nothing [ ConT ''Enum]]]
[{-DerivClause Nothing [ ConT ''Enum]-}]]
f (DerivedType name (ENUMERATION_OF t)) = [] -- TODO
f (DerivedType name (ENUMERATION_OF t)) = return [] -- TODO
f (DerivedType name (SELECTION opts)) = [
f (DerivedType name (SELECTION opts)) = return [
DataD [] (mkName . typename $ name) [] Nothing
[ NormalC (mkName . typename $ n)
[( b, lystype t)]
| (_,_,(n,t)) <- opts ]
[DerivClause Nothing [ ConT ''Enum]]]
[{-DerivClause Nothing [ ConT ''Enum]-}]]
f (DerivedType name typ@(STRUCTURE t)) =
let n = (mkName . typename $ name) in
[ DataD [] n [] Nothing
[RecC n [(mkName . varname $ n, b, lystype t) | (n, t) <- t]]
[] ]
f (DerivedType name typ@(STRUCTURE t)) = do
let n = mkName . typename $ name
gens <- mapM newName $ varname . fst <$> t
encode <- [| encode |]
body <- [| mconcat . fmap (<> char7 ' ') $
$(return . ListE $ (AppE encode) . VarE <$> gens) |]
f (DerivedType name typ@(BITSTRING t)) =
let n = (mkName . typename $ name) in
[ DataD [] n [] Nothing
return [ DataD [] n [] Nothing
[RecC n [(mkName . varname $ n, b, lystype t) | (n, t) <- t]]
[]
, InstanceD Nothing [] (AppT (ConT ''LineFormat) (ConT n))
[FunD (mkName "encode")
[ Clause [ ConP n $ map VarP gens ]
(NormalB body)
[] ]]
]
f (DerivedType name typ@(BITSTRING t)) = do
let n = mkName . typename $ name
gens <- mapM newName $ varname <$> t
encode <- [| encode |]
body <- [| mconcat $
$(return . ListE $ (AppE encode) . VarE <$> gens) |]
return [ DataD [] n [] Nothing
[RecC n [(mkName . varname $ n, b, ConT ''Bool) | n <- t]]
[] ]
[]
, InstanceD Nothing [] (AppT (ConT ''LineFormat) (ConT n))
[FunD (mkName "encode")
[ Clause [ ConP n $ map VarP gens ]
(NormalB body)
[] ]]
]
-- Primitive types + array
f (DerivedType name t) = [TySynD (mkName . typename $ name) [] $ lystype t]
f (DerivedType name t) = return [TySynD (mkName . typename $ name) [] $ lystype t]
-- TODO all these types
f (Request _ _ _ _) = []
f (Async _ _ _) = []
f (ProtoEdition _) = []
f (ProtoVer _) = []
f (LysKomDVersion _) = []
f (TypeAlias _ _) = []
f (RequestAlias _ _) = []
f (AsyncAlias _ _) = []
f (Other _) = []
f (Request name n args ret) = return []
{-
return [
SigD (mkName . varname $ name) $
arrow $ [ lystype t | (_,t) <- args ]
++ [ AppT (ConT . mkName $ "LysKom")
$ maybe (TupleT 0) lystype ret ] ]
-}
f (Async _ _ _) = return []
f (ProtoEdition _) = return []
f (ProtoVer _) = return []
f (LysKomDVersion _) = return []
f (TypeAlias _ _) = return []
f (RequestAlias _ _) = return []
f (AsyncAlias _ _) = return []
f (Other _) = return []
-- tup [ListT, ListT, ListT] ⇒ ([], [], [])
tup :: [Type] -> Type
tup xs = foldl (\done t -> AppT done t) (TupleT (length xs)) xs
-- arrow [a, b, c] ⇒ a -> b -> c
arrow :: [Type] -> Type
arrow (x:[]) = x
arrow (x:xs) = AppT (AppT ArrowT x) $ arrow xs
main :: IO ()
main = do
d <- parseFromFile documentParser "/usr/share/doc/lyskom/protocol-a-full.txt"
let dat = head $ rights [d]
-- runQ (return $ concat $ map f dat) >>= putStrLn.pprint
mapM_ (putStrLn.pprint) (concat $ map f dat)
return ()
((mconcat <$>) $ mapM runQ $ map f dat) >>= putStrLn.pprint
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Please register or to comment