Lots more of a proper Adnot repo

Data/Adnot.hs

@@ -0,0 +1,10 @@
+module Data.Adnot ( Value(..)
+                  , Array
+                  , Product
+                  , decodeValue
+                  , encodeValue
+                  ) where
+
+import Data.Adnot.Emit
+import Data.Adnot.Parse
+import Data.Adnot.Type

Data/Adnot/Class.hs

@@ -0,0 +1,209 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE OverloadedLists #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE DefaultSignatures #-}
+{-# LANGUAGE DataKinds #-}
+
+module Data.Adnot.Class where
+
+import           Data.Adnot.Type
+import           Data.Adnot.Emit
+import           Data.Int
+import           Data.Word
+import qualified Data.ByteString.Lazy as BSL
+import qualified Data.Foldable as F
+import qualified Data.List.NonEmpty as NE
+import qualified Data.Map.Lazy as ML
+import qualified Data.Map.Strict as MS
+import qualified Data.Sequence as Seq
+import qualified Data.Text as T
+import qualified Data.Text.Lazy as TL
+import qualified Data.Vector as V
+import           GHC.Generics
+import           GHC.TypeLits (KnownSymbol)
+
+encode :: ToAdnot a => a -> BSL.ByteString
+encode = encodeValue . toAdnot
+
+class GenToAdnot f where
+  genToAdnot :: f p -> Value
+
+instance (GenToAdnot l, GenToAdnot r) => GenToAdnot (l :+: r) where
+  genToAdnot (L1 x) = genToAdnot x
+  genToAdnot (R1 y) = genToAdnot y
+
+instance ToAdnot x => GenToAdnot (K1 i x) where
+  genToAdnot (K1 x) = toAdnot x
+
+instance (GatherSequence f, Constructor name) => GenToAdnot (C1 name f) where
+  genToAdnot (M1 x) = Sum (T.pack (conName c)) (V.fromList (gatherSequence x))
+    where c :: M1 c name f ()
+          c = undefined
+
+instance (GenToAdnot f) => GenToAdnot (S1 name f) where
+  genToAdnot (M1 x) = genToAdnot x
+
+instance (GenToAdnot f) => GenToAdnot (D1 name f) where
+  genToAdnot (M1 x) = genToAdnot x
+
+instance (GatherSequence l, GatherSequence r) => GenToAdnot (l :*: r) where
+  genToAdnot x = List (V.fromList (gatherSequence x))
+
+class GatherRecord f where
+  gatherRecord :: f p -> [(T.Text, Value)]
+
+instance (GatherRecord l, GatherRecord r) => GatherRecord (l :*: r) where
+  gatherRecord (x :*: y) = gatherRecord x ++ gatherRecord y
+
+instance (GenToAdnot f, Selector name) => GatherRecord (S1 name f) where
+  gatherRecord (M1 x) = [(T.pack (selName s), genToAdnot x)]
+    where s :: S1 name f ()
+          s = undefined
+
+instance GatherRecord U1 where
+  gatherRecord U1 = []
+
+class GatherSequence f where
+  gatherSequence :: f p -> [Value]
+
+instance GatherSequence U1 where
+  gatherSequence U1 = []
+
+instance (GatherSequence l, GatherSequence r) => GatherSequence (l :*: r) where
+  gatherSequence (x :*: y) = gatherSequence x ++ gatherSequence y
+
+instance ToAdnot x => GatherSequence (K1 i x) where
+  gatherSequence (K1 x) = [toAdnot x]
+
+instance GenToAdnot f => GatherSequence (S1 name f) where
+  gatherSequence (M1 x) = [genToAdnot x]
+
+instance GenToAdnot f => GatherSequence (D1 name f) where
+  gatherSequence (M1 x) = [genToAdnot x]
+
+instance GenToAdnot U1 where
+  genToAdnot U1 = List []
+
+genericToAdnot :: (GenToAdnot (Rep t), Generic t) => t -> Value
+genericToAdnot x = genToAdnot (from x)
+
+class ToAdnot a where
+  toAdnot :: a -> Value
+
+  default toAdnot :: (Generic a, GenToAdnot (Rep a)) => a -> Value
+  toAdnot = genericToAdnot
+
+-- * Integral types
+instance ToAdnot Int where
+  toAdnot n = Integer (fromIntegral n)
+
+instance ToAdnot Integer where
+  toAdnot n = Integer n
+
+instance ToAdnot Int8 where
+  toAdnot n = Integer (fromIntegral n)
+
+instance ToAdnot Int16 where
+  toAdnot n = Integer (fromIntegral n)
+
+instance ToAdnot Int32 where
+  toAdnot n = Integer (fromIntegral n)
+
+instance ToAdnot Int64 where
+  toAdnot n = Integer (fromIntegral n)
+
+instance ToAdnot Word where
+  toAdnot n = Integer (fromIntegral n)
+
+instance ToAdnot Word8 where
+  toAdnot n = Integer (fromIntegral n)
+
+instance ToAdnot Word16 where
+  toAdnot n = Integer (fromIntegral n)
+
+instance ToAdnot Word32 where
+  toAdnot n = Integer (fromIntegral n)
+
+instance ToAdnot Word64 where
+  toAdnot n = Integer (fromIntegral n)
+
+-- * Rational/Floating types
+instance ToAdnot Double where
+  toAdnot d = Double d
+
+instance ToAdnot Float where
+  toAdnot d = Double (fromRational (toRational d))
+
+-- * String types
+instance {-# INCOHERENT #-} ToAdnot String where
+  toAdnot s = String (T.pack s)
+
+instance ToAdnot T.Text where
+  toAdnot s = String s
+
+instance ToAdnot TL.Text where
+  toAdnot s = String (TL.toStrict s)
+
+instance ToAdnot Char where
+  toAdnot c = String (T.singleton c)
+
+-- * List types
+instance ToAdnot a => ToAdnot [a] where
+  toAdnot ls = List (fmap toAdnot (V.fromList ls))
+
+instance ToAdnot a => ToAdnot (V.Vector a) where
+  toAdnot ls = List (fmap toAdnot ls)
+
+instance ToAdnot a => ToAdnot (Seq.Seq a) where
+  toAdnot ls = List (V.fromList (F.toList (fmap toAdnot ls)))
+
+instance ToAdnot a => ToAdnot (NE.NonEmpty a) where
+  toAdnot ls = List (V.fromList (F.toList (fmap toAdnot ls)))
+
+-- * Mapping types
+instance ToAdnot a => ToAdnot (MS.Map T.Text a) where
+  toAdnot ls = Product (fmap toAdnot ls)
+
+-- * Tuples
+instance ToAdnot () where
+  toAdnot () = List []
+
+instance (ToAdnot a, ToAdnot b) => ToAdnot (a, b) where
+  toAdnot (a, b) = List [toAdnot a, toAdnot b]
+
+instance (ToAdnot a, ToAdnot b, ToAdnot c) => ToAdnot (a, b, c) where
+  toAdnot (a, b, c) = List [toAdnot a, toAdnot b, toAdnot c]
+
+instance (ToAdnot a, ToAdnot b, ToAdnot c, ToAdnot d)
+         => ToAdnot (a, b, c, d) where
+  toAdnot (a, b, c, d) = List [toAdnot a, toAdnot b, toAdnot c, toAdnot d]
+
+-- Some common Haskell algebraic data types
+instance ToAdnot a => ToAdnot (Maybe a) where
+  toAdnot Nothing = Sum "Nothing" []
+  toAdnot (Just x) = Sum "Just" [toAdnot x]
+
+instance (ToAdnot a, ToAdnot b) => ToAdnot (Either a b) where
+  toAdnot (Left x)  = Sum "Left" [toAdnot x]
+  toAdnot (Right y) = Sum "Right" [toAdnot y]
+
+instance ToAdnot Bool where
+  toAdnot True  = Symbol "True"
+  toAdnot False = Symbol "False"
+
+-- * Parsing
+
+type ParseError = String
+type Parser a = Either ParseError a
+
+withSum :: String -> (T.Text -> Array -> Parser a) -> Value -> Parser a
+withSum n k val = case val of
+  Sum t as -> k t as
+  _        -> Left ("Expected sum in " ++ n)
+
+class FromAdnot a where
+  parseAdnot :: Value -> Parser a

Data/Adnot/Emit.hs

@@ -0,0 +1,46 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Data.Adnot.Emit where
+
+import           Control.Monad (sequence)
+import           Data.ByteString.Lazy (ByteString)
+import           Data.ByteString.Builder
+import           Data.List (intersperse)
+import qualified Data.Map.Strict as M
+import           Data.Monoid ((<>))
+import           Data.Text (Text)
+import           Data.Text.Encoding (encodeUtf8)
+import qualified Data.Vector as V
+
+import Data.Adnot.Type
+
+encodeValue :: Value -> ByteString
+encodeValue = toLazyByteString . buildValue
+
+buildValue :: Value -> Builder
+buildValue (Sum n vs)
+  | V.null vs = char7 '(' <> ident n <> char7 ')'
+  | otherwise =
+    char7 '(' <> ident n <> char7 ' ' <> spaceSepArr vs <> char7 ')'
+buildValue (Product ps) =
+  char7 '{' <> buildPairs ps <> char7 '}'
+buildValue (List vs) =
+  char7 '[' <> spaceSepArr vs <> char7 ']'
+buildValue (Integer i) = integerDec i
+buildValue (Double d) = doubleDec d
+buildValue (Symbol t) = ident t
+buildValue (String t) =
+  char7 '"' <> byteString (encodeUtf8 t) <> char7 '"'
+
+spaceSep :: [Builder] -> Builder
+spaceSep = mconcat . intersperse (char7 ' ')
+
+spaceSepArr :: Array -> Builder
+spaceSepArr = spaceSep . map buildValue . V.toList
+
+ident :: Text -> Builder
+ident = byteString . encodeUtf8
+
+buildPairs :: Product -> Builder
+buildPairs ps = spaceSep [ go k v | (k, v) <- M.toList ps ]
+  where go k v = ident k <> char7 ' ' <> buildValue v

Data/ADTN.hs

@@ -1,49 +1,33 @@
 {-# LANGUAGE OverloadedStrings #-}
 
-module Data.ADTN where
+module Data.Adnot.Parse (decodeValue) where
 
 import           Control.Applicative((<|>))
-import           Data.Attoparsec.ByteString
 import           Data.Attoparsec.ByteString.Char8
 import           Data.ByteString (ByteString)
-import qualified Data.ByteString as BS
-import           Data.Map.Strict (Map)
 import qualified Data.Map as M
-import           Data.Text (Text)
 import qualified Data.Text as T
-import           Data.Vector (Vector)
 import qualified Data.Vector as V
 
-
-data Value
-  = Sum Text Array
-  | Product Object
-  | List Array
-  | Integer Integer
-  | Double Double
-  | Symbol Text
-  | String Text
-    deriving (Eq, Show)
-
-type Array = Vector Value
-type Object = Map Text Value
+import           Data.Adnot.Type
 
 decodeValue :: ByteString -> Either String Value
 decodeValue = parseOnly pVal
-  where pVal :: Parser Value
-        pVal = skipSpace *> (pSum <|> pProd <|> pList <|> pLit)
-        pSum = Sum <$> (char '(' *> skipSpace *> pIdent)
+  where pVal = ws *> (pSum <|> pProd <|> pList <|> pLit)
+        pSum = Sum <$> (char '(' *> ws *> pIdent)
                    <*> (pValueList <* char ')')
         pProd =  Product . M.fromList
-             <$> (char '{' *> pProdBody <* skipSpace <* char '}')
+             <$> (char '{' *> pProdBody <* ws <* char '}')
         pProdBody = many' pPair
-        pPair = (,) <$> (skipSpace *> pIdent) <*> pVal
-        pList = List <$> (char '[' *> pValueList <* skipSpace <* char ']')
+        pPair = (,) <$> (ws *> pIdent) <*> pVal
+        pList = List <$> (char '[' *> pValueList <* ws <* char ']')
         pLit  =  Symbol  <$> pIdent
              <|> String  <$> pString
              <|> Integer <$> decimal
         pValueList = V.fromList <$> many' pVal
-        pIdent = T.pack <$> many1' letter_ascii
+        pIdent = T.pack <$>
+                 ((:) <$> (letter_ascii <|> char '_')
+                      <*> many' (letter_ascii <|> digit <|> char '_'))
         pString = T.pack <$> (char '"' *> manyTill pStrChar (char '"'))
         pStrChar =  '\n' <$ string "\\n"
                 <|> '\t' <$ string "\\t"
@@ -54,3 +38,5 @@ decodeValue = parseOnly pVal
                 <|> '\"' <$ string "\\\""
                 <|> '\\' <$ string "\\\\"
                 <|> anyChar
+        ws = skipSpace *> ((comment *> ws) <|> return ())
+        comment = char '#' *> manyTill anyChar (char '\n')

Data/Adnot/Type.hs

@@ -0,0 +1,39 @@
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE BangPatterns #-}
+
+module Data.Adnot.Type (Value(..), Array, Product) where
+
+import           Control.DeepSeq (NFData(..))
+import           Data.Data (Data)
+import           Data.Typeable (Typeable)
+import           Data.Map.Strict (Map)
+import qualified Data.Map as M
+import           Data.Text (Text)
+import           Data.Vector (Vector)
+import           GHC.Exts (IsString(..))
+
+-- | An Adnot value represented as a Haskell value
+data Value
+  = Sum !Text !Array
+  | Product !Product
+  | List !Array
+  | Integer !Integer
+  | Double !Double
+  | Symbol !Text
+  | String !Text
+    deriving (Eq, Show, Read, Typeable, Data)
+
+instance NFData Value where
+  rnf (Sum t as) = rnf t `seq` rnf as
+  rnf (Product ls) = rnf ls
+  rnf (List as) = rnf as
+  rnf (Integer i) = rnf i
+  rnf (Double d) = rnf d
+  rnf (Symbol t) = rnf t
+  rnf (String t) = rnf t
+
+instance IsString Value where
+  fromString = String . fromString
+
+type Array = Vector Value
+type Product = Map Text Value

adnot-id/Main.hs

@@ -0,0 +1,22 @@
+module Main where
+
+import           Data.Adnot
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Lazy.Char8 as BSL
+import           System.Environment (getArgs)
+import           System.Exit (die)
+
+helpText :: String
+helpText = "Usage: adnot-id [file]"
+
+main = do
+  content <- do
+    args <- getArgs
+    case args of
+      []     -> BS.getContents
+      ["-"]  -> BS.getContents
+      [file] -> BS.readFile file
+      _      -> die helpText
+  case decodeValue content of
+    Right val -> BSL.putStrLn (encodeValue val)
+    Left err  -> die err

adnot.cabal

@@ -0,0 +1,36 @@
+name:                adnot
+version:             0.1.0.0
+-- synopsis:            
+-- description:         
+license:             BSD3
+license-file:        LICENSE
+author:              Getty Ritter
+maintainer:          gettyritter@gmail.com
+copyright:           ©2016 Getty Ritter
+category:            Data
+build-type:          Simple
+cabal-version:       >=1.12
+
+library
+  exposed-modules:     Data.Adnot
+  other-modules:       Data.Adnot.Parse,
+                       Data.Adnot.Class,
+                       Data.Adnot.Emit,
+                       Data.Adnot.Type
+  build-depends:       base >=4.8 && <5,
+                       attoparsec,
+                       bytestring,
+                       deepseq,
+                       hashable,
+                       containers,
+                       text,
+                       vector
+  default-language:    Haskell2010
+
+executable adnot-id
+  default-language: Haskell2010
+  hs-source-dirs:   adnot-id
+  main-is:          Main.hs
+  build-depends:    base >=4.8 && <5,
+                    bytestring,
+                    adnot

adtn.cabal

@@ -1,28 +0,0 @@
-
-name:                adtn
-version:             0.1.0.0
-license:             BSD3
-license-file:        LICENSE
-author:              Getty Ritter
-maintainer:          gettyritter@gmail.com
-category:            Data
-build-type:          Simple
-cabal-version:       >=1.10
-
-library
-  exposed-modules:     Data.ADTN
-  build-depends:       base >=4.8 && <4.9,
-                       attoparsec,
-                       bytestring,
-                       aeson,
-                       containers,
-                       text,
-                       vector
-  default-language:    Haskell2010