gdritter repos adnot / 362df1f
Lots more of a proper Adnot repo Getty Ritter 7 years ago
9 changed file(s) with 404 addition(s) and 84 deletion(s). Collapse all Expand all
+0
-56
Data/ADTN.hs less more
1 {-# LANGUAGE OverloadedStrings #-}
2
3 module Data.ADTN where
4
5 import Control.Applicative((<|>))
6 import Data.Attoparsec.ByteString
7 import Data.Attoparsec.ByteString.Char8
8 import Data.ByteString (ByteString)
9 import qualified Data.ByteString as BS
10 import Data.Map.Strict (Map)
11 import qualified Data.Map as M
12 import Data.Text (Text)
13 import qualified Data.Text as T
14 import Data.Vector (Vector)
15 import qualified Data.Vector as V
16
17
18 data Value
19 = Sum Text Array
20 | Product Object
21 | List Array
22 | Integer Integer
23 | Double Double
24 | Symbol Text
25 | String Text
26 deriving (Eq, Show)
27
28 type Array = Vector Value
29 type Object = Map Text Value
30
31 decodeValue :: ByteString -> Either String Value
32 decodeValue = parseOnly pVal
33 where pVal :: Parser Value
34 pVal = skipSpace *> (pSum <|> pProd <|> pList <|> pLit)
35 pSum = Sum <$> (char '(' *> skipSpace *> pIdent)
36 <*> (pValueList <* char ')')
37 pProd = Product . M.fromList
38 <$> (char '{' *> pProdBody <* skipSpace <* char '}')
39 pProdBody = many' pPair
40 pPair = (,) <$> (skipSpace *> pIdent) <*> pVal
41 pList = List <$> (char '[' *> pValueList <* skipSpace <* char ']')
42 pLit = Symbol <$> pIdent
43 <|> String <$> pString
44 <|> Integer <$> decimal
45 pValueList = V.fromList <$> many' pVal
46 pIdent = T.pack <$> many1' letter_ascii
47 pString = T.pack <$> (char '"' *> manyTill pStrChar (char '"'))
48 pStrChar = '\n' <$ string "\\n"
49 <|> '\t' <$ string "\\t"
50 <|> '\r' <$ string "\\r"
51 <|> '\b' <$ string "\\b"
52 <|> '\f' <$ string "\\f"
53 <|> '\'' <$ string "\\'"
54 <|> '\"' <$ string "\\\""
55 <|> '\\' <$ string "\\\\"
56 <|> anyChar
+209
-0
Data/Adnot/Class.hs less more
1 {-# LANGUAGE OverloadedStrings #-}
2 {-# LANGUAGE OverloadedLists #-}
3 {-# LANGUAGE TypeSynonymInstances #-}
4 {-# LANGUAGE FlexibleInstances #-}
5 {-# LANGUAGE FlexibleContexts #-}
6 {-# LANGUAGE TypeOperators #-}
7 {-# LANGUAGE ScopedTypeVariables #-}
8 {-# LANGUAGE DefaultSignatures #-}
9 {-# LANGUAGE DataKinds #-}
10
11 module Data.Adnot.Class where
12
13 import Data.Adnot.Type
14 import Data.Adnot.Emit
15 import Data.Int
16 import Data.Word
17 import qualified Data.ByteString.Lazy as BSL
18 import qualified Data.Foldable as F
19 import qualified Data.List.NonEmpty as NE
20 import qualified Data.Map.Lazy as ML
21 import qualified Data.Map.Strict as MS
22 import qualified Data.Sequence as Seq
23 import qualified Data.Text as T
24 import qualified Data.Text.Lazy as TL
25 import qualified Data.Vector as V
26 import GHC.Generics
27 import GHC.TypeLits (KnownSymbol)
28
29 encode :: ToAdnot a => a -> BSL.ByteString
30 encode = encodeValue . toAdnot
31
32 class GenToAdnot f where
33 genToAdnot :: f p -> Value
34
35 instance (GenToAdnot l, GenToAdnot r) => GenToAdnot (l :+: r) where
36 genToAdnot (L1 x) = genToAdnot x
37 genToAdnot (R1 y) = genToAdnot y
38
39 instance ToAdnot x => GenToAdnot (K1 i x) where
40 genToAdnot (K1 x) = toAdnot x
41
42 instance (GatherSequence f, Constructor name) => GenToAdnot (C1 name f) where
43 genToAdnot (M1 x) = Sum (T.pack (conName c)) (V.fromList (gatherSequence x))
44 where c :: M1 c name f ()
45 c = undefined
46
47 instance (GenToAdnot f) => GenToAdnot (S1 name f) where
48 genToAdnot (M1 x) = genToAdnot x
49
50 instance (GenToAdnot f) => GenToAdnot (D1 name f) where
51 genToAdnot (M1 x) = genToAdnot x
52
53 instance (GatherSequence l, GatherSequence r) => GenToAdnot (l :*: r) where
54 genToAdnot x = List (V.fromList (gatherSequence x))
55
56 class GatherRecord f where
57 gatherRecord :: f p -> [(T.Text, Value)]
58
59 instance (GatherRecord l, GatherRecord r) => GatherRecord (l :*: r) where
60 gatherRecord (x :*: y) = gatherRecord x ++ gatherRecord y
61
62 instance (GenToAdnot f, Selector name) => GatherRecord (S1 name f) where
63 gatherRecord (M1 x) = [(T.pack (selName s), genToAdnot x)]
64 where s :: S1 name f ()
65 s = undefined
66
67 instance GatherRecord U1 where
68 gatherRecord U1 = []
69
70 class GatherSequence f where
71 gatherSequence :: f p -> [Value]
72
73 instance GatherSequence U1 where
74 gatherSequence U1 = []
75
76 instance (GatherSequence l, GatherSequence r) => GatherSequence (l :*: r) where
77 gatherSequence (x :*: y) = gatherSequence x ++ gatherSequence y
78
79 instance ToAdnot x => GatherSequence (K1 i x) where
80 gatherSequence (K1 x) = [toAdnot x]
81
82 instance GenToAdnot f => GatherSequence (S1 name f) where
83 gatherSequence (M1 x) = [genToAdnot x]
84
85 instance GenToAdnot f => GatherSequence (D1 name f) where
86 gatherSequence (M1 x) = [genToAdnot x]
87
88 instance GenToAdnot U1 where
89 genToAdnot U1 = List []
90
91 genericToAdnot :: (GenToAdnot (Rep t), Generic t) => t -> Value
92 genericToAdnot x = genToAdnot (from x)
93
94 class ToAdnot a where
95 toAdnot :: a -> Value
96
97 default toAdnot :: (Generic a, GenToAdnot (Rep a)) => a -> Value
98 toAdnot = genericToAdnot
99
100 -- * Integral types
101 instance ToAdnot Int where
102 toAdnot n = Integer (fromIntegral n)
103
104 instance ToAdnot Integer where
105 toAdnot n = Integer n
106
107 instance ToAdnot Int8 where
108 toAdnot n = Integer (fromIntegral n)
109
110 instance ToAdnot Int16 where
111 toAdnot n = Integer (fromIntegral n)
112
113 instance ToAdnot Int32 where
114 toAdnot n = Integer (fromIntegral n)
115
116 instance ToAdnot Int64 where
117 toAdnot n = Integer (fromIntegral n)
118
119 instance ToAdnot Word where
120 toAdnot n = Integer (fromIntegral n)
121
122 instance ToAdnot Word8 where
123 toAdnot n = Integer (fromIntegral n)
124
125 instance ToAdnot Word16 where
126 toAdnot n = Integer (fromIntegral n)
127
128 instance ToAdnot Word32 where
129 toAdnot n = Integer (fromIntegral n)
130
131 instance ToAdnot Word64 where
132 toAdnot n = Integer (fromIntegral n)
133
134 -- * Rational/Floating types
135 instance ToAdnot Double where
136 toAdnot d = Double d
137
138 instance ToAdnot Float where
139 toAdnot d = Double (fromRational (toRational d))
140
141 -- * String types
142 instance {-# INCOHERENT #-} ToAdnot String where
143 toAdnot s = String (T.pack s)
144
145 instance ToAdnot T.Text where
146 toAdnot s = String s
147
148 instance ToAdnot TL.Text where
149 toAdnot s = String (TL.toStrict s)
150
151 instance ToAdnot Char where
152 toAdnot c = String (T.singleton c)
153
154 -- * List types
155 instance ToAdnot a => ToAdnot [a] where
156 toAdnot ls = List (fmap toAdnot (V.fromList ls))
157
158 instance ToAdnot a => ToAdnot (V.Vector a) where
159 toAdnot ls = List (fmap toAdnot ls)
160
161 instance ToAdnot a => ToAdnot (Seq.Seq a) where
162 toAdnot ls = List (V.fromList (F.toList (fmap toAdnot ls)))
163
164 instance ToAdnot a => ToAdnot (NE.NonEmpty a) where
165 toAdnot ls = List (V.fromList (F.toList (fmap toAdnot ls)))
166
167 -- * Mapping types
168 instance ToAdnot a => ToAdnot (MS.Map T.Text a) where
169 toAdnot ls = Product (fmap toAdnot ls)
170
171 -- * Tuples
172 instance ToAdnot () where
173 toAdnot () = List []
174
175 instance (ToAdnot a, ToAdnot b) => ToAdnot (a, b) where
176 toAdnot (a, b) = List [toAdnot a, toAdnot b]
177
178 instance (ToAdnot a, ToAdnot b, ToAdnot c) => ToAdnot (a, b, c) where
179 toAdnot (a, b, c) = List [toAdnot a, toAdnot b, toAdnot c]
180
181 instance (ToAdnot a, ToAdnot b, ToAdnot c, ToAdnot d)
182 => ToAdnot (a, b, c, d) where
183 toAdnot (a, b, c, d) = List [toAdnot a, toAdnot b, toAdnot c, toAdnot d]
184
185 -- Some common Haskell algebraic data types
186 instance ToAdnot a => ToAdnot (Maybe a) where
187 toAdnot Nothing = Sum "Nothing" []
188 toAdnot (Just x) = Sum "Just" [toAdnot x]
189
190 instance (ToAdnot a, ToAdnot b) => ToAdnot (Either a b) where
191 toAdnot (Left x) = Sum "Left" [toAdnot x]
192 toAdnot (Right y) = Sum "Right" [toAdnot y]
193
194 instance ToAdnot Bool where
195 toAdnot True = Symbol "True"
196 toAdnot False = Symbol "False"
197
198 -- * Parsing
199
200 type ParseError = String
201 type Parser a = Either ParseError a
202
203 withSum :: String -> (T.Text -> Array -> Parser a) -> Value -> Parser a
204 withSum n k val = case val of
205 Sum t as -> k t as
206 _ -> Left ("Expected sum in " ++ n)
207
208 class FromAdnot a where
209 parseAdnot :: Value -> Parser a
+46
-0
Data/Adnot/Emit.hs less more
1 {-# LANGUAGE OverloadedStrings #-}
2
3 module Data.Adnot.Emit where
4
5 import Control.Monad (sequence)
6 import Data.ByteString.Lazy (ByteString)
7 import Data.ByteString.Builder
8 import Data.List (intersperse)
9 import qualified Data.Map.Strict as M
10 import Data.Monoid ((<>))
11 import Data.Text (Text)
12 import Data.Text.Encoding (encodeUtf8)
13 import qualified Data.Vector as V
14
15 import Data.Adnot.Type
16
17 encodeValue :: Value -> ByteString
18 encodeValue = toLazyByteString . buildValue
19
20 buildValue :: Value -> Builder
21 buildValue (Sum n vs)
22 | V.null vs = char7 '(' <> ident n <> char7 ')'
23 | otherwise =
24 char7 '(' <> ident n <> char7 ' ' <> spaceSepArr vs <> char7 ')'
25 buildValue (Product ps) =
26 char7 '{' <> buildPairs ps <> char7 '}'
27 buildValue (List vs) =
28 char7 '[' <> spaceSepArr vs <> char7 ']'
29 buildValue (Integer i) = integerDec i
30 buildValue (Double d) = doubleDec d
31 buildValue (Symbol t) = ident t
32 buildValue (String t) =
33 char7 '"' <> byteString (encodeUtf8 t) <> char7 '"'
34
35 spaceSep :: [Builder] -> Builder
36 spaceSep = mconcat . intersperse (char7 ' ')
37
38 spaceSepArr :: Array -> Builder
39 spaceSepArr = spaceSep . map buildValue . V.toList
40
41 ident :: Text -> Builder
42 ident = byteString . encodeUtf8
43
44 buildPairs :: Product -> Builder
45 buildPairs ps = spaceSep [ go k v | (k, v) <- M.toList ps ]
46 where go k v = ident k <> char7 ' ' <> buildValue v
+42
-0
Data/Adnot/Parse.hs less more
1 {-# LANGUAGE OverloadedStrings #-}
2
3 module Data.Adnot.Parse (decodeValue) where
4
5 import Control.Applicative((<|>))
6 import Data.Attoparsec.ByteString.Char8
7 import Data.ByteString (ByteString)
8 import qualified Data.Map as M
9 import qualified Data.Text as T
10 import qualified Data.Vector as V
11
12 import Data.Adnot.Type
13
14 decodeValue :: ByteString -> Either String Value
15 decodeValue = parseOnly pVal
16 where pVal = ws *> (pSum <|> pProd <|> pList <|> pLit)
17 pSum = Sum <$> (char '(' *> ws *> pIdent)
18 <*> (pValueList <* char ')')
19 pProd = Product . M.fromList
20 <$> (char '{' *> pProdBody <* ws <* char '}')
21 pProdBody = many' pPair
22 pPair = (,) <$> (ws *> pIdent) <*> pVal
23 pList = List <$> (char '[' *> pValueList <* ws <* char ']')
24 pLit = Symbol <$> pIdent
25 <|> String <$> pString
26 <|> Integer <$> decimal
27 pValueList = V.fromList <$> many' pVal
28 pIdent = T.pack <$>
29 ((:) <$> (letter_ascii <|> char '_')
30 <*> many' (letter_ascii <|> digit <|> char '_'))
31 pString = T.pack <$> (char '"' *> manyTill pStrChar (char '"'))
32 pStrChar = '\n' <$ string "\\n"
33 <|> '\t' <$ string "\\t"
34 <|> '\r' <$ string "\\r"
35 <|> '\b' <$ string "\\b"
36 <|> '\f' <$ string "\\f"
37 <|> '\'' <$ string "\\'"
38 <|> '\"' <$ string "\\\""
39 <|> '\\' <$ string "\\\\"
40 <|> anyChar
41 ws = skipSpace *> ((comment *> ws) <|> return ())
42 comment = char '#' *> manyTill anyChar (char '\n')
+39
-0
Data/Adnot/Type.hs less more
1 {-# LANGUAGE DeriveDataTypeable #-}
2 {-# LANGUAGE BangPatterns #-}
3
4 module Data.Adnot.Type (Value(..), Array, Product) where
5
6 import Control.DeepSeq (NFData(..))
7 import Data.Data (Data)
8 import Data.Typeable (Typeable)
9 import Data.Map.Strict (Map)
10 import qualified Data.Map as M
11 import Data.Text (Text)
12 import Data.Vector (Vector)
13 import GHC.Exts (IsString(..))
14
15 -- | An Adnot value represented as a Haskell value
16 data Value
17 = Sum !Text !Array
18 | Product !Product
19 | List !Array
20 | Integer !Integer
21 | Double !Double
22 | Symbol !Text
23 | String !Text
24 deriving (Eq, Show, Read, Typeable, Data)
25
26 instance NFData Value where
27 rnf (Sum t as) = rnf t `seq` rnf as
28 rnf (Product ls) = rnf ls
29 rnf (List as) = rnf as
30 rnf (Integer i) = rnf i
31 rnf (Double d) = rnf d
32 rnf (Symbol t) = rnf t
33 rnf (String t) = rnf t
34
35 instance IsString Value where
36 fromString = String . fromString
37
38 type Array = Vector Value
39 type Product = Map Text Value
+10
-0
Data/Adnot.hs less more
1 module Data.Adnot ( Value(..)
2 , Array
3 , Product
4 , decodeValue
5 , encodeValue
6 ) where
7
8 import Data.Adnot.Emit
9 import Data.Adnot.Parse
10 import Data.Adnot.Type
+22
-0
adnot-id/Main.hs less more
1 module Main where
2
3 import Data.Adnot
4 import qualified Data.ByteString as BS
5 import qualified Data.ByteString.Lazy.Char8 as BSL
6 import System.Environment (getArgs)
7 import System.Exit (die)
8
9 helpText :: String
10 helpText = "Usage: adnot-id [file]"
11
12 main = do
13 content <- do
14 args <- getArgs
15 case args of
16 [] -> BS.getContents
17 ["-"] -> BS.getContents
18 [file] -> BS.readFile file
19 _ -> die helpText
20 case decodeValue content of
21 Right val -> BSL.putStrLn (encodeValue val)
22 Left err -> die err
+36
-0
adnot.cabal less more
1 name: adnot
2 version: 0.1.0.0
3 -- synopsis:
4 -- description:
5 license: BSD3
6 license-file: LICENSE
7 author: Getty Ritter
8 maintainer: gettyritter@gmail.com
9 copyright: ©2016 Getty Ritter
10 category: Data
11 build-type: Simple
12 cabal-version: >=1.12
13
14 library
15 exposed-modules: Data.Adnot
16 other-modules: Data.Adnot.Parse,
17 Data.Adnot.Class,
18 Data.Adnot.Emit,
19 Data.Adnot.Type
20 build-depends: base >=4.8 && <5,
21 attoparsec,
22 bytestring,
23 deepseq,
24 hashable,
25 containers,
26 text,
27 vector
28 default-language: Haskell2010
29
30 executable adnot-id
31 default-language: Haskell2010
32 hs-source-dirs: adnot-id
33 main-is: Main.hs
34 build-depends: base >=4.8 && <5,
35 bytestring,
36 adnot
+0
-28
adtn.cabal less more
1 -- Initial adtn.cabal generated by cabal init. For further documentation,
2 -- see http://haskell.org/cabal/users-guide/
3
4 name: adtn
5 version: 0.1.0.0
6 -- synopsis:
7 -- description:
8 license: BSD3
9 license-file: LICENSE
10 author: Getty Ritter
11 maintainer: gettyritter@gmail.com
12 -- copyright:
13 category: Data
14 build-type: Simple
15 -- extra-source-files:
16 cabal-version: >=1.10
17
18 library
19 exposed-modules: Data.ADTN
20 -- other-modules:
21 build-depends: base >=4.8 && <4.9,
22 attoparsec,
23 bytestring,
24 aeson,
25 containers,
26 text,
27 vector
28 default-language: Haskell2010⏎