Commit 24e3ee38 authored by Marc Coiffier's avatar Marc Coiffier
Browse files

Second definitive-parser overhaul, this time reducing the number of extra...

Second definitive-parser overhaul, this time reducing the number of extra parameters from 3 to just 1 in the Serializable and Format classes
parent 5aacb188
......@@ -20,7 +20,7 @@ data-files: prelude
library
exposed-modules: Algebra.Monad.Concatenative Data.CaPriCon CaPriCon.Run
default-extensions: RebindableSyntax, ViewPatterns, TupleSections, FlexibleInstances, FlexibleContexts, MultiParamTypeClasses, FunctionalDependencies, LambdaCase, TypeOperators, RankNTypes, GeneralizedNewtypeDeriving, TypeFamilies
build-depends: base >=4.8 && <4.10,definitive-base >=2.6 && <2.7,definitive-parser >=3.0 && <3.1
build-depends: base >=4.8 && <4.10,definitive-base >=2.6 && <2.7,definitive-parser >=3.1 && <3.2
if !impl(haste)
ghc-options: -Wincomplete-patterns -Wname-shadowing -W -Werror
hs-source-dirs: src
......@@ -35,7 +35,7 @@ executable capricon
default-extensions: RebindableSyntax, ViewPatterns, TupleSections, FlexibleInstances, FlexibleContexts, MultiParamTypeClasses, FunctionalDependencies, LambdaCase, TypeOperators, RankNTypes, GeneralizedNewtypeDeriving, TypeFamilies
-- other-modules:
-- other-extensions:
build-depends: base >=4.8 && <4.10,capricon >=0.8 && <0.9,definitive-base >=2.6 && <2.7,definitive-parser >=3.0 && <3.1
build-depends: base >=4.8 && <4.10,capricon >=0.8 && <0.9,definitive-base >=2.6 && <2.7,definitive-parser >=3.1 && <3.2
ghc-options: -Wincomplete-patterns -Wname-shadowing -W -Werror
hs-source-dirs: exe
default-language: Haskell2010
......
......@@ -12,13 +12,14 @@ import Data.IORef
import System.Directory (getXdgDirectory, XdgDirectory(..))
import System.FilePath ((</>))
import CaPriCon.Run
import Data.CaPriCon (ListBuilder(..))
instance Serializable Word8 ([Word8] -> [Word8]) [Word8] Char where encode _ c = (fromIntegral (fromEnum c):)
instance Format Word8 ([Word8] -> [Word8]) [Word8] Char where datum = datum <&> \x -> toEnum (fromEnum (x::Word8))
instance Format Word8 ([Word8] -> [Word8]) [Word8] (ReadImpl IO String String) where datum = return (ReadImpl f_readString)
instance Format Word8 ([Word8] -> [Word8]) [Word8] (ReadImpl IO String [Word8]) where datum = return (ReadImpl f_readBytes)
instance Format Word8 ([Word8] -> [Word8]) [Word8] (WriteImpl IO String String) where datum = return (WriteImpl writeString)
instance Format Word8 ([Word8] -> [Word8]) [Word8] (WriteImpl IO String [Word8]) where datum = return (WriteImpl (\x -> writeBytes x . pack))
instance Serializable [Word8] Char where encode _ c = ListBuilder (fromIntegral (fromEnum c):)
instance Format [Word8] Char where datum = datum <&> \x -> toEnum (fromEnum (x::Word8))
instance Format [Word8] (ReadImpl IO String String) where datum = return (ReadImpl f_readString)
instance Format [Word8] (ReadImpl IO String [Word8]) where datum = return (ReadImpl f_readBytes)
instance Format [Word8] (WriteImpl IO String String) where datum = return (WriteImpl writeString)
instance Format [Word8] (WriteImpl IO String [Word8]) where datum = return (WriteImpl (\x -> writeBytes x . pack))
f_readString = (\x -> try (return Nothing) (Just<$>readString x))
f_readBytes = (\x -> try (return Nothing) (Just . unpack<$>readBytes x))
......
......@@ -45,12 +45,12 @@ instance Monad JS.CIO where join = (P.>>=id)
instance MonadIO JS.CIO where liftIO = JS.liftIO
instance MonadSubIO JS.CIO JS.CIO where liftSubIO = id
instance Serializable Word8 ([Word8] -> [Word8]) [Word8] Char where encode _ c = (fromIntegral (fromEnum c):)
instance Format Word8 ([Word8] -> [Word8]) [Word8] Char where datum = datum <&> \x -> toEnum (fromEnum (x::Word8))
instance Format Word8 ([Word8] -> [Word8]) [Word8] (ReadImpl JS.CIO String String) where datum = return (ReadImpl getString)
instance Format Word8 ([Word8] -> [Word8]) [Word8] (ReadImpl JS.CIO String [Word8]) where datum = return (ReadImpl getBytes)
instance Format Word8 ([Word8] -> [Word8]) [Word8] (WriteImpl JS.CIO String String) where datum = return (WriteImpl setString)
instance Format Word8 ([Word8] -> [Word8]) [Word8] (WriteImpl JS.CIO String [Word8]) where datum = return (WriteImpl setBytes)
instance Serializable [Word8] Char where encode _ c = ListBuilder (fromIntegral (fromEnum c):)
instance Format [Word8] Char where datum = datum <&> \x -> toEnum (fromEnum (x::Word8))
instance Format [Word8] (ReadImpl JS.CIO String String) where datum = return (ReadImpl getString)
instance Format [Word8] (ReadImpl JS.CIO String [Word8]) where datum = return (ReadImpl getBytes)
instance Format [Word8] (WriteImpl JS.CIO String String) where datum = return (WriteImpl setString)
instance Format [Word8] (WriteImpl JS.CIO String [Word8]) where datum = return (WriteImpl setBytes)
runComment c = unit
toWordList :: JS.JSString -> [Word8]
......
......@@ -71,12 +71,12 @@ data WriteImpl io str bytes = WriteImpl (str -> bytes -> io ())
instance Show (ReadImpl io str bytes) where show _ = "#<open>"
instance Show (WriteImpl io str bytes) where show _ = "#<write>"
type ListSerializable a = (Serializable Word8 ([Word8] -> [Word8]) [Word8] a)
type ListFormat a = (Format Word8 ([Word8] -> [Word8]) [Word8] a)
type ListSerializable a = (Serializable [Word8] a)
type ListFormat a = (Format [Word8] a)
type IOListFormat io str = (ListFormat (ReadImpl io str str), ListFormat (WriteImpl io str str),
ListFormat (ReadImpl io str [Word8]), ListFormat (WriteImpl io str [Word8]))
instance Serializable Word8 ([Word8] -> [Word8]) [Word8] (ReadImpl io str bytes) where encode _ _ = id
instance Serializable Word8 ([Word8] -> [Word8]) [Word8] (WriteImpl io str bytes) where encode _ _ = id
instance Serializable [Word8] (ReadImpl io str bytes) where encode _ _ = zero
instance Serializable [Word8] (WriteImpl io str bytes) where encode _ _ = zero
instance ListSerializable str => ListSerializable (COCBuiltin io str)
instance (ListFormat str,IOListFormat io str) => ListFormat (COCBuiltin io str)
......
......@@ -8,7 +8,7 @@ module Data.CaPriCon(
StringPattern,NodeDir(..),AHDir(..),ApDir,
findPattern,freshContext,
-- * Showing nodes
NodeDoc(..),doc2raw,doc2latex,showNode,showNode'
ListBuilder(..),NodeDoc(..),doc2raw,doc2latex,showNode,showNode'
) where
import Definitive
......@@ -37,10 +37,14 @@ instance IsCapriconString String where
toString = id
type ListStream = [Word8]
type ListBuilder = ListStream -> ListStream
instance SerialStream Word8 ListBuilder ListStream where
encodeByte _ b = (b:)
toSerialStream k = k []
newtype ListBuilder = ListBuilder (ListStream -> ListStream)
instance Semigroup ListBuilder where ListBuilder a + ListBuilder b = ListBuilder (a . b)
instance Monoid ListBuilder where zero = ListBuilder id
instance SerialStreamType ListStream where
type StreamBuilder ListStream = ListBuilder
instance SerialStream ListStream where
encodeByte _ b = ListBuilder (b:)
toSerialStream (ListBuilder k) = k []
-- | Inductive types
type UniverseSize = Int
......@@ -58,8 +62,8 @@ data Application str = Ap (ApHead str) [Node str]
deriving (Show,Generic)
type Env str = [(str,NodeType str)]
type ListSerializable a = (Serializable Word8 ListBuilder ListStream a)
type ListFormat a = (Format Word8 ListBuilder ListStream a)
type ListSerializable a = (Serializable ListStream a)
type ListFormat a = (Format ListStream a)
instance ListSerializable BindType
instance ListFormat BindType
instance ListSerializable str => ListSerializable (Node str)
......@@ -173,7 +177,10 @@ instance Foldable (NodeDir str) where
fold (NodeDir a b c) = (fold.map fold.map2 fold) a + (fold.map fold.map2 fold) b + fold c
instance Traversable (NodeDir str) where
sequence (NodeDir a b c) = NodeDir<$>sequence3 a<*>sequence3 b<*>sequence c
instance (Serializable ListStream str,Serializable ListStream a) => Serializable ListStream (Cofree (NodeDir str) a) where encode = encodeCofree
instance (ListSerializable str, ListSerializable a) => ListSerializable (NodeDir str a)
instance (Format ListStream str,Format ListStream a) => Format ListStream (Cofree (NodeDir str) a) where datum = datumCofree
instance (ListFormat str, ListFormat a) => ListFormat (NodeDir str a)
i'NodeDir :: Iso (NodeDir str a) (NodeDir str' a')
......
......@@ -48,7 +48,7 @@ library
AllowAmbiguousTypes
LambdaCase
other-extensions: UndecidableInstances, ScopedTypeVariables, StandaloneDeriving, PatternSynonyms, ViewPatterns, TypeFamilies, CPP, RecursiveDo, GADTs, DeriveGeneric, OverloadedStrings, NoMonomorphismRestriction, DeriveDataTypeable, ExistentialQuantification, BangPatterns
build-depends: AES >=0.2 && <0.3,base >=4.9 && <4.10,base64-bytestring >=1.0 && <1.1,bytestring >=0.10 && <0.11,containers >=0.5 && <0.6,deepseq >=1.4 && <1.5,definitive-base >=2.6 && <2.7,definitive-filesystem >=2.1 && <2.2,definitive-network >=1.4 && <1.5,definitive-parser >=3.0 && <3.1,directory >=1.3 && <1.4,entropy >=0.3 && <0.4,fsnotify >=0.2 && <0.3,network >=2.6 && <2.7,process >=1.4 && <1.5,zlib >=0.6 && <0.7
build-depends: AES >=0.2 && <0.3,base >=4.9 && <4.10,base64-bytestring >=1.0 && <1.1,bytestring >=0.10 && <0.11,containers >=0.5 && <0.6,deepseq >=1.4 && <1.5,definitive-base >=2.6 && <2.7,definitive-filesystem >=2.1 && <2.2,definitive-network >=1.4 && <1.5,definitive-parser >=3.1 && <3.2,directory >=1.3 && <1.4,entropy >=0.3 && <0.4,fsnotify >=0.2 && <0.3,network >=2.6 && <2.7,process >=1.4 && <1.5,zlib >=0.6 && <0.7
if flag(paranoid)
ghc-options: -Wall -Werror
hs-source-dirs: src
......
......@@ -59,8 +59,10 @@ instance Foldable (ExprNode s) where
instance Traversable (ExprNode s) where
sequence (Lambda s a) = Lambda s<$>a
sequence (Apply ff fx) = Apply<$>ff<*>fx
instance (Serializable Word8 Builder Bytes a,Serializable Word8 Builder Bytes s) => Serializable Word8 Builder Bytes (ExprNode s a)
instance (Format Word8 Builder Bytes a,Format Word8 Builder Bytes s) => Format Word8 Builder Bytes (ExprNode s a)
instance (Serializable Bytes a,Serializable Bytes s) => Serializable Bytes (ExprNode s a)
instance (Serializable Bytes a,Serializable Bytes s) => Serializable Bytes (Free (ExprNode s) a) where encode = encodeFree
instance (Format Bytes a,Format Bytes s) => Format Bytes (ExprNode s a)
instance (Format Bytes a,Format Bytes s) => Format Bytes (Free (ExprNode s) a) where datum = datumFree
c'Expression :: Constraint (Expression a b)
c'Expression = c'_
......@@ -203,14 +205,14 @@ curlyCommitDir = curlyDirPath (curlyUserDir + "/commits")
-- | A Curly log level
data LogLevel = Quiet | Chatty | Verbose | Debug
deriving (Eq,Ord,Show,Generic)
instance Serializable Word8 Builder Bytes LogLevel
instance Format Word8 Builder Bytes LogLevel
instance Serializable Bytes LogLevel
instance Format Bytes LogLevel
data LogMessage = LogLine LogLevel String
| LogActionStart String
| LogActionEnd String Bool
deriving (Show,Generic)
instance Format Word8 Builder Bytes LogMessage
instance Serializable Word8 Builder Bytes LogMessage
instance Format Bytes LogMessage
instance Serializable Bytes LogMessage
-- The global log level, as set by the environment variable CURLY_LOGLEVEL
envLogLevel :: LogLevel
......@@ -368,7 +370,7 @@ instance HasIdents s s' t t' => HasIdents s s' (Maybe t) (Maybe t') where
data RelocationSize = RS_16 | RS_32 | RS_64
deriving (Eq,Ord,Show,Generic)
instance Serializable Word8 Builder Bytes RelocationSize ; instance Format Word8 Builder Bytes RelocationSize
instance Serializable Bytes RelocationSize ; instance Format Bytes RelocationSize
data BinaryRelocation = BinaryRelocation {
_br_PCRelative :: Bool,
_br_size :: RelocationSize,
......@@ -376,8 +378,8 @@ data BinaryRelocation = BinaryRelocation {
_br_symoffset :: Int
}
deriving (Eq,Ord,Show,Generic)
instance Serializable Word8 Builder Bytes BinaryRelocation
instance Format Word8 Builder Bytes BinaryRelocation
instance Serializable Bytes BinaryRelocation
instance Format Bytes BinaryRelocation
-- | The type of all Curly builtins
data Builtin = B_Undefined
| B_Seq
......@@ -421,15 +423,15 @@ instance Documented Builtin where
where show' (B_Number n) = show n
show' (B_String s) = show s
show' b = show b
instance Serializable Word8 Builder Bytes Builtin where
instance Format Word8 Builder Bytes Builtin where
instance Serializable Bytes Builtin where
instance Format Bytes Builtin where
instance NFData Builtin where rnf b = b`seq`()
newtype Compressed a = Compressed { unCompressed :: a }
deriving (Show,Eq,Ord)
instance Serializable Word8 Builder Bytes a => Serializable Word8 Builder Bytes (Compressed a) where
instance Serializable Bytes a => Serializable Bytes (Compressed a) where
encode p (Compressed a) = encode p (compress (serialize a))
instance Format Word8 Builder Bytes a => Format Word8 Builder Bytes (Compressed a) where
instance Format Bytes a => Format Bytes (Compressed a) where
datum = (datum <&> decompress) >*> (Compressed <$> datum)
noCurlySuf :: FilePath -> Maybe FilePath
......@@ -445,18 +447,18 @@ instance Show Hash where
show (Hash h) = show (B64Chunk h)
instance Read Hash where
readsPrec _ = readsParser (readable <&> \(B64Chunk h) -> Hash h)
instance Serializable Word8 Builder Bytes Hash where
instance Serializable Bytes Hash where
encode _ (Hash h) = h^.chunkBuilder
instance Format Word8 Builder Bytes Hash where
instance Format Bytes Hash where
datum = Hash<$>getChunk 32
newtype LibraryID = LibraryID Chunk
deriving (Eq,Ord,Generic)
idSize :: Int
idSize = 32
instance Serializable Word8 Builder Bytes LibraryID where
instance Serializable Bytes LibraryID where
encode _ (LibraryID x) = x^.chunkBuilder
instance Format Word8 Builder Bytes LibraryID where
instance Format Bytes LibraryID where
datum = LibraryID<$>getChunk idSize
instance NFData LibraryID
instance Show LibraryID where
......@@ -473,8 +475,8 @@ instance Documented GlobalID where
else \(GlobalID n _) -> Pure n
where showL (Just (n,l)) = "["+show l+":"+n+"]"
showL _ = "[]"
instance Serializable Word8 Builder Bytes GlobalID
instance Format Word8 Builder Bytes GlobalID
instance Serializable Bytes GlobalID
instance Format Bytes GlobalID
instance NFData GlobalID
instance Identifier GlobalID where
pureIdent n = GlobalID n Nothing
......
......@@ -55,8 +55,8 @@ instance Show (Symbol s) where
show (Builtin _ b) = "#"+show b
instance Documented (Symbol s) where
document s = Pure (show s)
instance (Serializable Word8 Builder Bytes s,Identifier s) => Serializable Word8 Builder Bytes (Symbol s)
instance (Format Word8 Builder Bytes s,Identifier s) => Format Word8 Builder Bytes (Symbol s)
instance (Serializable Bytes s,Identifier s) => Serializable Bytes (Symbol s)
instance (Format Bytes s,Identifier s) => Format Bytes (Symbol s)
instance NFData (Symbol s) where
rnf (Argument n) = rnf n
rnf (Builtin _ b) = rnf b
......@@ -80,8 +80,8 @@ instance HasIdents s s' (StrictnessHead s) (StrictnessHead s') where
(ff'idents k sts)
ff'idents _ StH_Void = pure StH_Void
ff'idents _ (StH_Val n) = pure (StH_Val n)
instance Serializable Word8 Builder Bytes s => Serializable Word8 Builder Bytes (StrictnessHead s)
instance Format Word8 Builder Bytes s => Format Word8 Builder Bytes (StrictnessHead s)
instance Serializable Bytes s => Serializable Bytes (StrictnessHead s)
instance Format Bytes s => Format Bytes (StrictnessHead s)
instance NFData s => NFData (StrictnessHead s)
noStrictness :: Strictness s
......@@ -90,8 +90,8 @@ noStrictness = HNF StH_Void []
data Strictness s = Delayed s (ExprStrictness s)
| HNF (StrictnessHead s) [ExprStrictness s]
deriving (Eq,Ord,Generic)
instance Serializable Word8 Builder Bytes s => Serializable Word8 Builder Bytes (Strictness s)
instance Format Word8 Builder Bytes s => Format Word8 Builder Bytes (Strictness s)
instance Serializable Bytes s => Serializable Bytes (Strictness s)
instance Format Bytes s => Format Bytes (Strictness s)
instance NFData s => NFData (Strictness s)
instance HasIdents s s' (Strictness s) (Strictness s') where
ff'idents k (Delayed s es) = liftA2 Delayed (k s) ((l'1.each.ff'idents .+ l'2.ff'idents) k es)
......
......@@ -26,8 +26,10 @@ import System.Environment (lookupEnv)
-- | A documentation node (similar to a HTML node, but simpler)
data DocNode a = DocTag String [(String,String)] [a]
deriving (Eq,Ord,Show,Generic)
instance Serializable Word8 Builder Bytes a => Serializable Word8 Builder Bytes (DocNode a)
instance Format Word8 Builder Bytes a => Format Word8 Builder Bytes (DocNode a)
instance Serializable Bytes a => Serializable Bytes (DocNode a)
instance Serializable Bytes a => Serializable Bytes (Free DocNode a) where encode = encodeFree
instance Format Bytes a => Format Bytes (DocNode a)
instance Format Bytes a => Format Bytes (Free DocNode a) where datum = datumFree
instance Functor DocNode where map f (DocTag t a xs) = DocTag t a (map f xs)
instance Foldable DocNode where fold (DocTag _ _ l) = fold l
instance Traversable DocNode where sequence (DocTag t as l) = DocTag t as<$>sequence l
......@@ -51,10 +53,10 @@ instance Documented Int where
document n = docTag' "int" [Pure (show n)]
newtype Metadata = Metadata (Forest (Map String) String)
deriving (Semigroup,Monoid,Serializable Word8 Builder Bytes)
deriving (Semigroup,Monoid,Serializable Bytes)
i'Metadata :: Iso' (Forest (Map String) String) Metadata
i'Metadata = iso Metadata (\(Metadata m) -> m)
instance Format Word8 Builder Bytes Metadata where datum = coerceDatum Metadata
instance Format Bytes Metadata where datum = coerceDatum Metadata
instance DataMap Metadata String (Free (Map String) String) where
at i = from i'Metadata.at i
instance Show Metadata where
......@@ -155,15 +157,15 @@ mkDoc :: String -- ^ The root tag name
-> String -- ^ Documentation in textual format
-> Documentation
mkDoc t d = Join . DocTag t [] $ fromMaybe [] $ matches Just (between spc spc (sepBy' docAtom spc)) d
spc :: (ParseStream c s, ParseToken c, TokenPayload c ~ Char,Monad m) => ParserT s m ()
spc :: (ParseStream s, StreamChar s ~ Char,Monad m) => ParserT s m ()
spc = skipMany' (oneOf " \t\n")
docAtom :: (ParseStream c s, ParseToken c, TokenPayload c ~ Char,Monad m) => ParserT s m Documentation
docFormat :: (ParseStream c s, ParseToken c, TokenPayload c ~ Char,Monad m) => String -> [Char] -> ParserT s m Documentation
docAtom :: (ParseStream s, StreamChar s ~ Char,Monad m) => ParserT s m Documentation
docFormat :: (ParseStream s, StreamChar s ~ Char,Monad m) => String -> [Char] -> ParserT s m Documentation
docAtom = fst docAtom'
docFormat = snd docAtom'
docAtom' :: (ParseStream c s, ParseToken c, TokenPayload c ~ Char,Monad m) =>
docAtom' :: (ParseStream s, StreamChar s ~ Char,Monad m) =>
(ParserT s m Documentation,String -> [Char] -> ParserT s m Documentation)
docAtom' = (tag <+? txt,strSplice)
where letter p = token >>= \case
......@@ -193,7 +195,7 @@ docAtom' = (tag <+? txt,strSplice)
<+? single '\\' >> token
docLine :: (ParseToken c, ParseStream c s, TokenPayload c ~ Char, Monad m)
docLine :: (ParseStream s, StreamChar s ~ Char, Monad m)
=> String -> [(String,String)] -> ParserT s m Documentation
docLine n as = Join . DocTag n as <$> many1' (skipMany' (oneOf " \t") >> docAtom)
showRawDoc :: Documentation -> String
......
......@@ -42,15 +42,15 @@ curlyLibVersion = 11
binaryEOI :: (MonadParser s m p, Monoid s, Eq s) => p ()
binaryEOI = guard . (==zero) =<< remaining
newtype Chunked a = Chunked { getChunked :: a }
instance Serializable Word8 Builder Bytes a => Serializable Word8 Builder Bytes (Chunked a) where
instance Serializable Bytes a => Serializable Bytes (Chunked a) where
encode p (Chunked a) = encode p (serialize a :: Bytes)
instance Format Word8 Builder Bytes a => Format Word8 Builder Bytes (Chunked a) where
instance Format Bytes a => Format Bytes (Chunked a) where
datum = datum <&> \x -> maybe (error "No parse for chunked data") Chunked (matches Just (datum <* binaryEOI) (x :: Bytes))
data FutureExtensionTail = FutureExtensionTail
instance Serializable Word8 Builder Bytes FutureExtensionTail where
instance Serializable Bytes FutureExtensionTail where
encode = zero
instance Format Word8 Builder Bytes FutureExtensionTail where
instance Format Bytes FutureExtensionTail where
datum = runStreamState (put zero) >> return FutureExtensionTail
type FutureExtension = Extension FutureExtensionTail
......@@ -65,8 +65,8 @@ instance ExtensionDefault a => ExtensionDefault (Extension a) where
newtype Extension a = Extension (Chunked a)
deriving instance Serializable Word8 Builder Bytes a => Serializable Word8 Builder Bytes (Extension a)
instance (ExtensionDefault a,Format Word8 Builder Bytes a) => Format Word8 Builder Bytes (Extension a) where
deriving instance Serializable Bytes a => Serializable Bytes (Extension a)
instance (ExtensionDefault a,Format Bytes a) => Format Bytes (Extension a) where
datum = datum <&> \x -> maybe (error "No parse for extension") (Extension . Chunked) (matches Just (datum <+? fill extensionDefault binaryEOI) (x :: Bytes))
newtype ModDir s a = ModDir [(s,a)]
......@@ -83,10 +83,12 @@ instance Documented a => Documented (Module a) where
,docTag' "ul" (map (docTag "li" [("class","modVal")] . pure . doc') l')]
document (Pure s) = document s
instance (Serializable Word8 Builder Bytes s,Serializable Word8 Builder Bytes a) => Serializable Word8 Builder Bytes (ModDir s a) where
instance (Serializable Bytes s,Serializable Bytes a) => Serializable Bytes (ModDir s a) where
encode = coerceEncode (ModDir . getChunked)
instance (Format Word8 Builder Bytes s,Format Word8 Builder Bytes a) => Format Word8 Builder Bytes (ModDir s a) where
instance (Serializable Bytes s,Serializable Bytes a) => Serializable Bytes (Free (ModDir s) a) where encode = encodeFree
instance (Format Bytes s,Format Bytes a) => Format Bytes (ModDir s a) where
datum = coerceDatum (ModDir . getChunked)
instance (Format Bytes s,Format Bytes a) => Format Bytes (Free (ModDir s) a) where datum = datumFree
instance Functor (ModDir s) where map f (ModDir l) = ModDir (l <&> l'2 %~ f)
instance Ord s => SemiApplicative (Zip (ModDir s)) where
Zip (ModDir fs) <*> Zip (ModDir xs) = Zip (ModDir (fs >>= \(s,f) -> fold (xm^.at s) <&> (s,) . f))
......@@ -139,9 +141,9 @@ instance Functor (ModLeaf s) where
map = warp leafVal
instance Foldable (ModLeaf s) where fold l = l^.leafVal
instance Traversable (ModLeaf s) where sequence l = leafVal id l
instance (Identifier s,Serializable Word8 Builder Bytes s,Serializable Word8 Builder Bytes a) => Serializable Word8 Builder Bytes (ModLeaf s a) where
instance (Identifier s,Serializable Bytes s,Serializable Bytes a) => Serializable Bytes (ModLeaf s a) where
encode p (ModLeaf a b c d e f g) = encode p (Chunked a,b,Chunked c,d,e,f,Chunked g)
instance (Identifier s,Format Word8 Builder Bytes s,Format Word8 Builder Bytes a) => Format Word8 Builder Bytes (ModLeaf s a) where
instance (Identifier s,Format Bytes s,Format Bytes a) => Format Bytes (ModLeaf s a) where
datum = (\(Chunked a) b (Chunked c) d e f (Chunked g) -> ModLeaf a b c d e f g)
<$>datum<*>datum<*>datum<*>datum<*>datum<*>datum<*>datum
instance (Identifier s,Identifier s') => HasIdents s s' (ModLeaf s a) (ModLeaf s' a) where
......@@ -155,10 +157,10 @@ instance Semigroup SourceRange where
NoRange + a = a
a + NoRange = a
instance Monoid SourceRange where zero = NoRange
instance Serializable Word8 Builder Bytes SourceRange where
instance Serializable Bytes SourceRange where
encode p (SourceRange _ b c) = encodeAlt p 0 (b,c)
encode p NoRange = encodeAlt p 1 ()
instance Format Word8 Builder Bytes SourceRange where
instance Format Bytes SourceRange where
datum = datumOf [FormatAlt (uncurry $ SourceRange Nothing),FormatAlt (uncurry0 NoRange)]
leafDoc :: Lens' (ModLeaf s a) Documentation
......@@ -210,12 +212,12 @@ instance Monoid Library where
cylMagic :: String
cylMagic = "#!/lib/cyl!# "
newtype ParEncode t = ParEncode t
instance (Ord k,Serializable Word8 Builder Bytes k, Serializable Word8 Builder Bytes a) => Serializable Word8 Builder Bytes (ParEncode (Map k a)) where
instance (Ord k,Serializable Bytes k, Serializable Bytes a) => Serializable Bytes (ParEncode (Map k a)) where
encode p (ParEncode m) = let l = foldr (\x y -> yb chunkBuilder x`par`x:y) [] [encode p x | x <- m^.ascList]
in encode p (length l) + fold l
instance (Ord k,Format Word8 Builder Bytes k,Format Word8 Builder Bytes a) => Format Word8 Builder Bytes (ParEncode (Map k a)) where
instance (Ord k,Format Bytes k,Format Bytes a) => Format Bytes (ParEncode (Map k a)) where
datum = ParEncode . yb ascList<$>datum
instance Serializable Word8 Builder Bytes Library where
instance Serializable Bytes Library where
encode p l = foldMap (encode p) cylMagic
+ let (m,(a,b,c,d,e,f,g,h)) = l^.scoped.withStrMap
syn = fromMaybe "" (a^?at "synopsis".t'Just.t'Pure)
......@@ -227,7 +229,7 @@ instance Serializable Word8 Builder Bytes Library where
d,
Chunked e,
f,g,h))
instance Format Word8 Builder Bytes Library where
instance Format Bytes Library where
datum = do
traverse_ (\c -> datum >>= guard . (c==)) cylMagic
syn <- many' (datum <*= guard . (/='\n')) <* (datum >>= guard . (=='\n'))
......
......@@ -76,19 +76,20 @@ instance Stream OpChar OpStream where
(case c of OC_Char cc -> cc ; _ -> '\0')))
uncons (OpStream _ []) = Nothing
uncons (OpStream h ((c,_):l)) = Just (c,OpStream (case c of OC_Char c' -> c':h ; _ -> h) l)
instance ParseToken OpChar where
type TokenPayload OpChar = Char
completeBefore (OC_CompleteChar _) = True
completeBefore _ = False
tokenPayload (OC_Char c) = c
tokenPayload (OC_CompleteChar c) = c
instance ParseStream OpChar OpStream where
instance ParseStreamType OpStream where
type StreamToken OpStream = OpChar
type StreamChar OpStream = Char
instance ParseStream OpStream where
completeBefore _ (OC_CompleteChar _) = True
completeBefore _ _ = False
tokenPayload _ (OC_Char c) = c
tokenPayload _ (OC_CompleteChar c) = c
acceptToken c (OpStream h t) = OpStream (c:h) t
mkStream :: (ParseToken c, Stream c s, TokenPayload c ~ Char) => s -> OpStream
mkStream :: forall s. (ParseStream s, StreamChar s ~ Char) => s -> OpStream
mkStream = OpStream "" . mk ('\0',0,0,0)
where mk (p,n,ln,cl) s = case uncons s of
Just (c,s') -> nextChar (tokenPayload c) s'
Just (c,s') -> nextChar (tokenPayload (Proxy :: Proxy s) c) s'
Nothing -> []
where nextChar '\n' s' = (OC_Char '\n',(p,n,ln,cl)):mk ('\n',n+1,ln+1,0) s'
nextChar c s' = (OC_Char c,(p,n,ln,cl)):mk (c,n+1,ln,cl+1) s'
......@@ -100,14 +101,14 @@ i'OpMap = iso OpMap getOpMap
type OpParser m = ParserT OpStream (RWST Void [Warning] (Int,OpMap,(Map String (NameExpr GlobalID),Library)) m)
data Spaces = HorizSpaces | AnySpaces
class (MonadParser s m p, ParseStream c s, TokenPayload c ~ Char) => MonadCharParser c s m p
class (MonadParser s m p, ParseStream s, StreamChar s ~ Char) => MonadCharParser s m p
instance (Monad m, ParseStream c s, TokenPayload c ~ Char) => MonadCharParser c s (StateT s m) (ParserT s m)
instance (Monad m,ParseStream s, StreamChar s ~ Char) => MonadCharParser s (StateT s m) (ParserT s m)
parseSpaces :: MonadCharParser c s m p => Spaces -> p ()
parseSpaces :: MonadCharParser s m p => Spaces -> p ()
parseSpaces HorizSpaces = hspc
parseSpaces AnySpaces = spc
parseNBSpaces :: MonadCharParser c s m p => Spaces -> p ()
parseNBSpaces :: MonadCharParser s m p => Spaces -> p ()
parseNBSpaces HorizSpaces = nbhsp
parseNBSpaces AnySpaces = nbsp
......@@ -161,7 +162,7 @@ l'library = l'3.l'2
l'typeMap :: Lens a b (x,y,(a,z)) (x,y,(b,z))
l'typeMap = l'3.l'1
parseCurly :: (ParseStream c s, TokenPayload c ~ Char,Monad m) => s -> OpParser m a -> m ([Warning]:+:a)
parseCurly :: (ParseStream s, StreamChar s ~ Char,Monad m) => s -> OpParser m a -> m ([Warning]:+:a)
parseCurly s p = (deduce p^..mapping i'RWST.stateT) (mkStream s) zero <&> \((_,ma),_,ws) -> case ma of
Just (a,_) -> Right a
Nothing -> Left ws
......@@ -175,7 +176,7 @@ mkLet (Right t) = \e -> foldl1' mkApply (t+[e])
space, spc, hspc, nbsp, nbhsp, hspace
:: MonadCharParser c s m p => p ()
:: MonadCharParser s m p => p ()
space = hspace + (eol >> skipMany' (single '#' >> skipMany' (satisfy (/='\n')) >> eol))
hspace = void $ oneOf [' ', '\t']
spc = skipMany' space
......@@ -384,7 +385,7 @@ curlyFile = do
defSymbol "value" (mkRange pre post) Nothing False e,
setExports (Pure "value")]
raw :: (ParseStream c s, TokenPayload c ~ Char,MonadParser s m p) => String -> p ()
raw :: (ParseStream s, StreamChar s ~ Char,MonadParser s m p) => String -> p ()
raw = several
curlyLine :: (Monad m, ?mountain :: Mountain) => OpParser m ()
......
......@@ -17,12 +17,12 @@ data PeerPacket = DeclareInstance InstanceName (Proxy (Either PeerErrorMessage P
deriving Generic
newtype PeerPort = PeerPort { getPeerPortNumber :: PortNumber }
instance Serializable Word8 Builder Bytes PeerPort where
instance Serializable Bytes PeerPort where
encode p = encode p . c'int . fromIntegral . getPeerPortNumber
instance Format Word8 Builder Bytes PeerPort where
instance Format Bytes PeerPort where
datum = PeerPort . fromIntegral . c'int <$> datum
instance Serializable Word8 Builder Bytes PeerPacket
instance Format Word8 Builder Bytes PeerPacket
instance Serializable Bytes PeerPacket
instance Format Bytes PeerPacket
processInstances :: IORef (Set InstanceName)
processInstances = newIORef zero^.thunk
......
......@@ -32,7 +32,7 @@ newtype PublicKey = PublicKey (Integer,Integer)
deriving (Show,Eq)
data Signature = Signature Integer Integer
deriving (Eq,Ord,Generic,Show)
instance Serializable Word8 Builder Bytes Signature ; instance Format Word8 Builder Bytes Signature
instance Serializable Bytes Signature ; instance Format Bytes Signature
newtype KeyFingerprint = KeyFingerprint Chunk
deriving (Eq,Ord)
......@@ -50,8 +50,8 @@ instance Read Access where
,("admin",Admin),("almighty",Almighty)]]
instance Semigroup Access where (+) = max
instance Monoid Access where zero = minBound
instance Serializable Word8 Builder Bytes Access where encode p a = encode p (fromEnum a)
instance Format Word8 Builder Bytes Access where datum = toEnum <$> datum
instance Serializable Bytes Access where encode p a = encode p (fromEnum a)
instance Format Bytes Access where datum = toEnum <$> datum
-- | This function is useless, but it makes textual representations of data look more
-- "random".
......@@ -77,9 +77,9 @@ zest bs = pack $ zipWith xor (unpack bs) zestBytes
]
newtype Zesty a = Zesty a
instance Serializable Word8 Builder Bytes a => Show (Zesty a) where
instance Serializable Bytes a => Show (Zesty a) where
show (Zesty a) = show (B64Chunk (zest (serialize a)^.chunk))
instance Format Word8 Builder Bytes a => Read (Zesty a) where
instance Format Bytes a => Read (Zesty a) where
readsPrec _ = readsParser ((readable <&> \(B64Chunk c) -> zest (c^..chunk)) >*> (Zesty<$>datum))
fpSize :: Int
......@@ -90,12 +90,12 @@ instance Bounded KeyFingerprint where
minBound = KeyFingerprint (pack [0 :: Word8 | _ <- [1..fpSize]])
maxBound = KeyFingerprint (pack [0xff :: Word8 | _ <- [1..fpSize]])