diff --git a/LineFormat.lhs b/LineFormat.lhs new file mode 100644 index 0000000000000000000000000000000000000000..f60c35bacb07cc89ef91cf1afcc3a98203122664 --- /dev/null +++ b/LineFormat.lhs @@ -0,0 +1,48 @@ +\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} diff --git a/test2.hs b/test2.hs index 76ac05227182d0b44b396d2bacd07f96ae7c3839..aa771285494947a890621128f9ab2df879cd6477 100644 --- a/test2.hs +++ b/test2.hs @@ -1,6 +1,7 @@ {-# 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]]] - -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@(BITSTRING t)) = - let n = (mkName . typename $ name) in - [ DataD [] n [] Nothing + [{-DerivClause Nothing [ ConT ''Enum]-}]] + +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) |] + + 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