gdritter repos adnot / master
ormolu Getty Ritter 3 years ago
7 changed file(s) with 161 addition(s) and 141 deletion(s). Collapse all Expand all
+76
-66
Data/Adnot/Class.hs less more
1 {-# LANGUAGE DataKinds #-}
2 {-# LANGUAGE DefaultSignatures #-}
3 {-# LANGUAGE FlexibleContexts #-}
4 {-# LANGUAGE FlexibleInstances #-}
5 {-# LANGUAGE GADTs #-}
6 {-# LANGUAGE OverloadedLists #-}
17 {-# LANGUAGE OverloadedStrings #-}
2 {-# LANGUAGE OverloadedLists #-}
8 {-# LANGUAGE ScopedTypeVariables #-}
9 {-# LANGUAGE TypeOperators #-}
310 {-# LANGUAGE TypeSynonymInstances #-}
4 {-# LANGUAGE FlexibleInstances #-}
5 {-# LANGUAGE FlexibleContexts #-}
6 {-# LANGUAGE TypeOperators #-}
7 {-# LANGUAGE ScopedTypeVariables #-}
8 {-# LANGUAGE DefaultSignatures #-}
9 {-# LANGUAGE DataKinds #-}
10 {-# LANGUAGE GADTs #-}
1111
1212 module Data.Adnot.Class where
1313
14 import Control.Monad ((>=>))
15 import Data.Adnot.Parse
16 import Data.Adnot.Type
17 import Data.Adnot.Emit
18 import Data.Adnot.Parse
19 import Data.Int
20 import Data.Word
14 import Control.Monad ((>=>))
15 import Data.Adnot.Emit
16 import Data.Adnot.Parse
17 import Data.Adnot.Type
2118 import qualified Data.ByteString as BS
2219 import qualified Data.ByteString.Lazy as BSL
2320 import qualified Data.Foldable as F
21 import Data.Int
2422 import qualified Data.List.NonEmpty as NE
2523 import qualified Data.Map.Lazy as ML
2624 import qualified Data.Map.Strict as MS
2826 import qualified Data.Text as T
2927 import qualified Data.Text.Lazy as TL
3028 import qualified Data.Vector as V
31 import GHC.Generics
32 import GHC.TypeLits (KnownSymbol)
29 import Data.Word
30 import GHC.Generics
31 import GHC.TypeLits (KnownSymbol)
3332
3433 encode :: ToAdnot a => a -> BSL.ByteString
3534 encode = encodeValue . toAdnot
4645
4746 instance (GatherSequence f, Constructor name) => GenToAdnot (C1 name f) where
4847 genToAdnot (M1 x) = Sum (T.pack (conName c)) (V.fromList (gatherSequence x))
49 where c :: M1 c name f ()
50 c = undefined
48 where
49 c :: M1 c name f ()
50 c = undefined
5151
5252 instance (GenToAdnot f) => GenToAdnot (S1 name f) where
5353 genToAdnot (M1 x) = genToAdnot x
6666
6767 instance (GenToAdnot f, Selector name) => GatherRecord (S1 name f) where
6868 gatherRecord (M1 x) = [(T.pack (selName s), genToAdnot x)]
69 where s :: S1 name f ()
70 s = undefined
69 where
70 s :: S1 name f ()
71 s = undefined
7172
7273 instance GatherRecord U1 where
7374 gatherRecord U1 = []
9899
99100 class ToAdnot a where
100101 toAdnot :: a -> Value
101
102102 default toAdnot :: (Generic a, GenToAdnot (Rep a)) => a -> Value
103103 toAdnot = genericToAdnot
104104
180180 key .= val = (key, toAdnot val)
181181
182182 -- * Tuples
183
183184 instance ToAdnot () where
184185 toAdnot () = List []
185186
189190 instance (ToAdnot a, ToAdnot b, ToAdnot c) => ToAdnot (a, b, c) where
190191 toAdnot (a, b, c) = List [toAdnot a, toAdnot b, toAdnot c]
191192
192 instance (ToAdnot a, ToAdnot b, ToAdnot c, ToAdnot d)
193 => ToAdnot (a, b, c, d) where
193 instance
194 (ToAdnot a, ToAdnot b, ToAdnot c, ToAdnot d) =>
195 ToAdnot (a, b, c, d)
196 where
194197 toAdnot (a, b, c, d) = List [toAdnot a, toAdnot b, toAdnot c, toAdnot d]
195198
196199 -- Common Haskell algebraic data types
199202 toAdnot (Just x) = Sum "Just" [toAdnot x]
200203
201204 instance (ToAdnot a, ToAdnot b) => ToAdnot (Either a b) where
202 toAdnot (Left x) = Sum "Left" [toAdnot x]
205 toAdnot (Left x) = Sum "Left" [toAdnot x]
203206 toAdnot (Right y) = Sum "Right" [toAdnot y]
204207
205208 instance ToAdnot Bool where
206 toAdnot True = String "True"
209 toAdnot True = String "True"
207210 toAdnot False = String "False"
208211
209212 -- Parsing
212215 decode = decodeValue >=> parseAdnot
213216
214217 type ParseError = String
218
215219 type Parser a = Either ParseError a
216220
217221 niceType :: Value -> String
218 niceType Sum {} = "sum"
222 niceType Sum {} = "sum"
219223 niceType Product {} = "product"
220 niceType List {} = "list"
224 niceType List {} = "list"
221225 niceType Integer {} = "integer"
222 niceType Double {} = "double"
223 niceType String {} = "string"
226 niceType Double {} = "double"
227 niceType String {} = "string"
224228
225229 withSum :: String -> (T.Text -> Array -> Parser a) -> Value -> Parser a
226230 withSum n k val = case val of
227231 Sum t as -> k t as
228 _ -> Left ("Expected sum in " ++ n)
232 _ -> Left ("Expected sum in " ++ n)
229233
230234 withSumNamed :: String -> T.Text -> (Array -> Parser a) -> Value -> Parser a
231235 withSumNamed n tag k val = case val of
232236 Sum t as
233237 | tag == t -> k as
234 | otherwise -> Left $ unwords
235 [ "Expected tag", T.unpack tag, "in", n, "but found", T.unpack t ]
236 _ -> Left ("Expected sum in " ++ n)
238 | otherwise ->
239 Left $
240 unwords
241 ["Expected tag", T.unpack tag, "in", n, "but found", T.unpack t]
242 _ -> Left ("Expected sum in " ++ n)
237243
238244 withProduct :: String -> (Product -> Parser a) -> Value -> Parser a
239245 withProduct n k val = case val of
240246 Product ps -> k ps
241 _ -> Left ("Expected product in " ++ n)
247 _ -> Left ("Expected product in " ++ n)
242248
243249 withList :: String -> (Array -> Parser a) -> Value -> Parser a
244250 withList n k val = case val of
245251 List ls -> k ls
246 _ -> Left ("Expected list in " ++ n)
252 _ -> Left ("Expected list in " ++ n)
247253
248254 withInteger :: String -> (Integer -> Parser a) -> Value -> Parser a
249255 withInteger n k val = case val of
250256 Integer i -> k i
251 _ -> Left ("Expected integer in " ++ n)
257 _ -> Left ("Expected integer in " ++ n)
252258
253259 withDouble :: String -> (Double -> Parser a) -> Value -> Parser a
254260 withDouble n k val = case val of
255 Double d -> k d
261 Double d -> k d
256262 Integer i -> k (fromIntegral i)
257 _ -> Left ("Expected double in " ++ n)
263 _ -> Left ("Expected double in " ++ n)
258264
259265 withString :: String -> (T.Text -> Parser a) -> Value -> Parser a
260266 withString n k val = case val of
261267 String s -> k s
262 _ -> Left ("Expected string in " ++ n)
268 _ -> Left ("Expected string in " ++ n)
263269
264270 (.:) :: FromAdnot a => Product -> T.Text -> Parser a
265271 map .: key = case MS.lookup key map of
266 Just x -> parseAdnot x
272 Just x -> parseAdnot x
267273 Nothing -> Left ("Missing key " ++ show key)
268274
269275 (.:?) :: FromAdnot a => Product -> T.Text -> Parser (Maybe a)
270276 map .:? key = case MS.lookup key map of
271 Just x -> Just <$> parseAdnot x
277 Just x -> Just <$> parseAdnot x
272278 Nothing -> return Nothing
273279
274280 (.!=) :: Parser (Maybe a) -> a -> Parser a
332338 parseAdnot = withString "Text" return
333339
334340 instance FromAdnot TL.Text where
335 parseAdnot = withString "Text" (return . TL.fromStrict)
341 parseAdnot = withString "Text" (return . TL.fromStrict)
336342
337343 instance FromAdnot Char where
338344 parseAdnot = withString "Char" $ \s -> case T.uncons s of
339345 Just (c, "") -> return c
340 _ -> Left "Expected a single-element string"
341
346 _ -> Left "Expected a single-element string"
342347
343348 -- List types
344349 instance FromAdnot a => FromAdnot [a] where
358363 lst <- mapM parseAdnot ls
359364 case F.toList lst of
360365 [] -> Left "Expected non-empty sequence"
361 (x:xs) -> Right (x NE.:| xs)
366 (x : xs) -> Right (x NE.:| xs)
362367
363368 -- Mapping types
364369 instance FromAdnot a => FromAdnot (MS.Map T.Text a) where
371376 parseAdnot = withList "()" $ \ls ->
372377 case ls of
373378 [] -> return ()
374 _ -> Left "Expected empty list"
379 _ -> Left "Expected empty list"
375380
376381 instance (FromAdnot a, FromAdnot b) => FromAdnot (a, b) where
377382 parseAdnot = withList "(a, b)" $ \ls ->
378383 case ls of
379384 [a, b] -> (,) <$> parseAdnot a <*> parseAdnot b
380 _ -> Left "Expected two-element list"
381
385 _ -> Left "Expected two-element list"
382386
383387 instance (FromAdnot a, FromAdnot b, FromAdnot c) => FromAdnot (a, b, c) where
384388 parseAdnot = withList "(a, b, c)" $ \ls ->
385389 case ls of
386390 [a, b, c] -> (,,) <$> parseAdnot a <*> parseAdnot b <*> parseAdnot c
387 _ -> Left "Expected three-element list"
388
389
390 instance (FromAdnot a, FromAdnot b, FromAdnot c, FromAdnot d)
391 => FromAdnot (a, b, c, d) where
391 _ -> Left "Expected three-element list"
392
393 instance
394 (FromAdnot a, FromAdnot b, FromAdnot c, FromAdnot d) =>
395 FromAdnot (a, b, c, d)
396 where
392397 parseAdnot = withList "(a, b, c, d)" $ \ls ->
393398 case ls of
394 [a, b, c, d] -> (,,,) <$> parseAdnot a <*> parseAdnot b
395 <*> parseAdnot c <*> parseAdnot d
396 _ -> Left "Expected four-element list"
399 [a, b, c, d] ->
400 (,,,) <$> parseAdnot a <*> parseAdnot b
401 <*> parseAdnot c
402 <*> parseAdnot d
403 _ -> Left "Expected four-element list"
397404
398405 -- Common Haskell algebraic data types
399406 instance FromAdnot a => FromAdnot (Maybe a) where
400407 parseAdnot = withSum "Maybe" go
401 where go "Nothing" [] = return Nothing
402 go "Just" [x] = Just <$> parseAdnot x
403 go _ _ = Left "Invalid Maybe"
408 where
409 go "Nothing" [] = return Nothing
410 go "Just" [x] = Just <$> parseAdnot x
411 go _ _ = Left "Invalid Maybe"
404412
405413 instance (FromAdnot a, FromAdnot b) => FromAdnot (Either a b) where
406414 parseAdnot = withSum "Either" go
407 where go "Left" [x] = Left <$> parseAdnot x
408 go "Right" [x] = Right <$> parseAdnot x
409 go _ _ = Left "Invalid Either"
415 where
416 go "Left" [x] = Left <$> parseAdnot x
417 go "Right" [x] = Right <$> parseAdnot x
418 go _ _ = Left "Invalid Either"
410419
411420 instance FromAdnot Bool where
412421 parseAdnot = withString "Bool" go
413 where go "True" = return True
414 go "False" = return False
415 go _ = Left "Invalid Bool"
422 where
423 go "True" = return True
424 go "False" = return False
425 go _ = Left "Invalid Bool"
+17
-16
Data/Adnot/Emit.hs less more
22
33 module Data.Adnot.Emit where
44
5 import Control.Monad (sequence)
6 import Data.ByteString.Lazy (ByteString)
7 import Data.ByteString.Builder
8 import Data.List (intersperse)
5 import Control.Monad (sequence)
6 import Data.Adnot.Type
7 import Data.ByteString.Builder
8 import Data.ByteString.Lazy (ByteString)
9 import Data.List (intersperse)
910 import qualified Data.Map.Strict as M
10 import Data.Monoid ((<>))
11 import Data.Text (Text)
11 import Data.Monoid ((<>))
12 import Data.Text (Text)
1213 import qualified Data.Text as T
13 import Data.Text.Encoding (encodeUtf8Builder)
14 import Data.Text.Encoding (encodeUtf8Builder)
1415 import qualified Data.Vector as V
15
16 import Data.Adnot.Type
1716
1817 encodeValue :: Value -> ByteString
1918 encodeValue = toLazyByteString . buildValue
3332
3433 buildString t
3534 | isValidSymbol t = encodeUtf8Builder t
36 | otherwise = char7 '"' <> escape t <> char7 '"'
35 | otherwise = char7 '"' <> escape t <> char7 '"'
3736
3837 escape :: T.Text -> Builder
3938 escape = T.foldr go mempty
40 where go '"' r = byteString "\\\"" <> r
41 go '\n' r = byteString "\\n" <> r
42 go '\\' r = byteString "\\\\" <> r
43 go c r = char7 c <> r
39 where
40 go '"' r = byteString "\\\"" <> r
41 go '\n' r = byteString "\\n" <> r
42 go '\\' r = byteString "\\\\" <> r
43 go c r = char7 c <> r
4444
4545 spaceSep :: [Builder] -> Builder
4646 spaceSep = mconcat . intersperse (char7 ' ')
4949 spaceSepArr = spaceSep . map buildValue . V.toList
5050
5151 buildPairs :: Product -> Builder
52 buildPairs ps = spaceSep [ go k v | (k, v) <- M.toList ps ]
53 where go k v = buildString k <> char7 ' ' <> buildValue v
52 buildPairs ps = spaceSep [go k v | (k, v) <- M.toList ps]
53 where
54 go k v = buildString k <> char7 ' ' <> buildValue v
+40
-34
Data/Adnot/Parse.hs less more
22
33 module Data.Adnot.Parse (decodeValue) where
44
5 import Control.Applicative((<|>))
6 import Data.Attoparsec.ByteString.Char8
7 import Data.ByteString (ByteString)
5 import Control.Applicative ((<|>))
6 import Data.Adnot.Type
7 import Data.Attoparsec.ByteString.Char8
8 import Data.ByteString (ByteString)
89 import qualified Data.ByteString.Char8 as BS
910 import qualified Data.Map as M
1011 import qualified Data.Text as T
1112 import qualified Data.Text.Encoding as T
1213 import qualified Data.Vector as V
1314
14 import Data.Adnot.Type
15
1615 decodeValue :: ByteString -> Either String Value
1716 decodeValue = parseOnly pVal
18 where pVal = ws *> (pSum <|> pProd <|> pList <|> pLit)
19 pSum = Sum <$> (char '(' *> ws *> (pIdent <|> pString))
20 <*> (pValueList <* (ws *> char ')'))
21 pProd = Product . M.fromList
22 <$> (char '{' *> pProdBody <* ws <* char '}')
23 pProdBody = many' pPair
24 pPair = (,) <$> (ws *> (pIdent <|> pString)) <*> pVal
25 pList = List <$> (char '[' *> pValueList <* ws <* char ']')
26 pLit = String <$> pIdent
27 <|> String <$> pString
28 <|> Double <$> double
29 <|> Integer <$> decimal
30 pStr = String <$> (pIdent <|> pString)
31 pValueList = V.fromList <$> many' pVal
32 pIdent = T.pack <$>
33 ((:) <$> (letter_ascii <|> char '_')
34 <*> many' (letter_ascii <|> digit <|> char '_'))
35 pString = T.decodeUtf8 . BS.pack <$> (char '"' *> manyTill pStrChar (char '"'))
36 pStrChar = '\n' <$ string "\\n"
37 <|> '\t' <$ string "\\t"
38 <|> '\r' <$ string "\\r"
39 <|> '\b' <$ string "\\b"
40 <|> '\f' <$ string "\\f"
41 <|> '\'' <$ string "\\'"
42 <|> '\"' <$ string "\\\""
43 <|> '\\' <$ string "\\\\"
44 <|> anyChar
45 ws = skipSpace *> ((comment *> ws) <|> return ())
46 comment = char '#' *> manyTill anyChar (char '\n')
17 where
18 pVal = ws *> (pSum <|> pProd <|> pList <|> pLit)
19 pSum =
20 Sum <$> (char '(' *> ws *> (pIdent <|> pString))
21 <*> (pValueList <* (ws *> char ')'))
22 pProd =
23 Product . M.fromList
24 <$> (char '{' *> pProdBody <* ws <* char '}')
25 pProdBody = many' pPair
26 pPair = (,) <$> (ws *> (pIdent <|> pString)) <*> pVal
27 pList = List <$> (char '[' *> pValueList <* ws <* char ']')
28 pLit =
29 String <$> pIdent
30 <|> String <$> pString
31 <|> Double <$> double
32 <|> Integer <$> decimal
33 pStr = String <$> (pIdent <|> pString)
34 pValueList = V.fromList <$> many' pVal
35 pIdent =
36 T.pack
37 <$> ( (:) <$> (letter_ascii <|> char '_')
38 <*> many' (letter_ascii <|> digit <|> char '_')
39 )
40 pString = T.decodeUtf8 . BS.pack <$> (char '"' *> manyTill pStrChar (char '"'))
41 pStrChar =
42 '\n' <$ string "\\n"
43 <|> '\t' <$ string "\\t"
44 <|> '\r' <$ string "\\r"
45 <|> '\b' <$ string "\\b"
46 <|> '\f' <$ string "\\f"
47 <|> '\'' <$ string "\\'"
48 <|> '\"' <$ string "\\\""
49 <|> '\\' <$ string "\\\\"
50 <|> anyChar
51 ws = skipSpace *> ((comment *> ws) <|> return ())
52 comment = char '#' *> manyTill anyChar (char '\n')
+11
-10
Data/Adnot/Type.hs less more
1 {-# LANGUAGE BangPatterns #-}
12 {-# LANGUAGE DeriveDataTypeable #-}
2 {-# LANGUAGE BangPatterns #-}
33
4 module Data.Adnot.Type (Value(..), Array, Product, isValidSymbol) where
4 module Data.Adnot.Type (Value (..), Array, Product, isValidSymbol) where
55
6 import Control.DeepSeq (NFData(..))
6 import Control.DeepSeq (NFData (..))
77 import qualified Data.Char as C
8 import Data.Data (Data)
9 import Data.Typeable (Typeable)
10 import Data.Map.Strict (Map)
8 import Data.Data (Data)
119 import qualified Data.Map as M
12 import Data.Text (Text)
10 import Data.Map.Strict (Map)
11 import Data.Text (Text)
1312 import qualified Data.Text as T
14 import Data.Vector (Vector)
15 import GHC.Exts (IsString(..))
13 import Data.Typeable (Typeable)
14 import Data.Vector (Vector)
15 import GHC.Exts (IsString (..))
1616
1717 -- | An Adnot value represented as a Haskell value
1818 data Value
2222 | Integer !Integer
2323 | Double !Double
2424 | String !Text
25 deriving (Eq, Show, Read, Typeable, Data)
25 deriving (Eq, Show, Read, Typeable, Data)
2626
2727 instance NFData Value where
2828 rnf (Sum t as) = rnf t `seq` rnf as
3636 fromString = String . fromString
3737
3838 type Array = Vector Value
39
3940 type Product = Map Text Value
4041
4142 isValidSymbol :: Text -> Bool
+9
-8
Data/Adnot.hs less more
1 module Data.Adnot ( Value(..)
2 , Array
3 , Product
4 , decodeValue
5 , encodeValue
6 , module Data.Adnot.Class
7 ) where
1 module Data.Adnot
2 ( Value (..),
3 Array,
4 Product,
5 decodeValue,
6 encodeValue,
7 module Data.Adnot.Class,
8 )
9 where
810
911 import Data.Adnot.Class
1012 import Data.Adnot.Emit
1113 import Data.Adnot.Parse
1214 import Data.Adnot.Type
13 import Data.Adnot.Class
+1
-0
Setup.hs less more
11 import Distribution.Simple
2
23 main = defaultMain
+7
-7
adnot-id/Main.hs less more
11 module Main where
22
3 import Data.Adnot
3 import Data.Adnot
44 import qualified Data.ByteString as BS
55 import qualified Data.ByteString.Lazy.Char8 as BSL
6 import System.Environment (getArgs)
7 import System.Exit (die)
6 import System.Environment (getArgs)
7 import System.Exit (die)
88
99 helpText :: String
1010 helpText = "Usage: adnot-id [file]"
1313 content <- do
1414 args <- getArgs
1515 case args of
16 [] -> BS.getContents
17 ["-"] -> BS.getContents
16 [] -> BS.getContents
17 ["-"] -> BS.getContents
1818 [file] -> BS.readFile file
19 _ -> die helpText
19 _ -> die helpText
2020 case decodeValue content of
2121 Right val -> BSL.putStrLn (encodeValue val)
22 Left err -> die err
22 Left err -> die err