Skip to content
GitLab
Explore
Sign in
Register
Primary navigation
Search or go to…
Project
hskom
Manage
Activity
Members
Labels
Plan
Issues
Issue boards
Milestones
Wiki
Code
Merge requests
Repository
Branches
Commits
Tags
Repository graph
Compare revisions
Snippets
Build
Pipelines
Jobs
Pipeline schedules
Artifacts
Deploy
Releases
Container registry
Model registry
Operate
Environments
Monitor
Incidents
Analyze
Value stream analytics
Contributor analytics
CI/CD analytics
Repository analytics
Model experiments
Help
Help
Support
GitLab documentation
Compare GitLab plans
GitLab community forum
Contribute to GitLab
Provide feedback
Keyboard shortcuts
?
Snippets
Groups
Projects
Show more breadcrumbs
Hugo Hörnquist
hskom
Commits
6bb0a3ec
Commit
6bb0a3ec
authored
4 years ago
by
Hugo Hörnquist
Browse files
Options
Downloads
Patches
Plain Diff
Line Format encoding.
parent
3b2e309a
No related branches found
No related tags found
No related merge requests found
Changes
2
Show whitespace changes
Inline
Side-by-side
Showing
2 changed files
LineFormat.lhs
+48
-0
48 additions, 0 deletions
LineFormat.lhs
test2.hs
+82
-36
82 additions, 36 deletions
test2.hs
with
130 additions
and
36 deletions
LineFormat.lhs
0 → 100644
+
48
−
0
View file @
6bb0a3ec
\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}
This diff is collapsed.
Click to expand it.
test2.hs
+
82
−
36
View file @
6bb0a3ec
{-# 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
''Int
32
lystype
INT16
=
ConT
''Int
16
lystype
INT8
=
ConT
''Int
8
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
This diff is collapsed.
Click to expand it.
Preview
0%
Loading
Try again
or
attach a new file
.
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Save comment
Cancel
Please
register
or
sign in
to comment