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 ...@@ -20,7 +20,7 @@ data-files: prelude
library library
exposed-modules: Algebra.Monad.Concatenative Data.CaPriCon CaPriCon.Run exposed-modules: Algebra.Monad.Concatenative Data.CaPriCon CaPriCon.Run
default-extensions: RebindableSyntax, ViewPatterns, TupleSections, FlexibleInstances, FlexibleContexts, MultiParamTypeClasses, FunctionalDependencies, LambdaCase, TypeOperators, RankNTypes, GeneralizedNewtypeDeriving, TypeFamilies 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) if !impl(haste)
ghc-options: -Wincomplete-patterns -Wname-shadowing -W -Werror ghc-options: -Wincomplete-patterns -Wname-shadowing -W -Werror
hs-source-dirs: src hs-source-dirs: src
...@@ -35,7 +35,7 @@ executable capricon ...@@ -35,7 +35,7 @@ executable capricon
default-extensions: RebindableSyntax, ViewPatterns, TupleSections, FlexibleInstances, FlexibleContexts, MultiParamTypeClasses, FunctionalDependencies, LambdaCase, TypeOperators, RankNTypes, GeneralizedNewtypeDeriving, TypeFamilies default-extensions: RebindableSyntax, ViewPatterns, TupleSections, FlexibleInstances, FlexibleContexts, MultiParamTypeClasses, FunctionalDependencies, LambdaCase, TypeOperators, RankNTypes, GeneralizedNewtypeDeriving, TypeFamilies
-- other-modules: -- other-modules:
-- other-extensions: -- 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 ghc-options: -Wincomplete-patterns -Wname-shadowing -W -Werror
hs-source-dirs: exe hs-source-dirs: exe
default-language: Haskell2010 default-language: Haskell2010
......
...@@ -12,13 +12,14 @@ import Data.IORef ...@@ -12,13 +12,14 @@ import Data.IORef
import System.Directory (getXdgDirectory, XdgDirectory(..)) import System.Directory (getXdgDirectory, XdgDirectory(..))
import System.FilePath ((</>)) import System.FilePath ((</>))
import CaPriCon.Run import CaPriCon.Run
import Data.CaPriCon (ListBuilder(..))
instance Serializable Word8 ([Word8] -> [Word8]) [Word8] Char where encode _ c = (fromIntegral (fromEnum c):) instance Serializable [Word8] Char where encode _ c = ListBuilder (fromIntegral (fromEnum c):)
instance Format Word8 ([Word8] -> [Word8]) [Word8] Char where datum = datum <&> \x -> toEnum (fromEnum (x::Word8)) instance Format [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] (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] (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] (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 Format [Word8] (WriteImpl IO String [Word8]) where datum = return (WriteImpl (\x -> writeBytes x . pack))
f_readString = (\x -> try (return Nothing) (Just<$>readString x)) f_readString = (\x -> try (return Nothing) (Just<$>readString x))
f_readBytes = (\x -> try (return Nothing) (Just . unpack<$>readBytes x)) f_readBytes = (\x -> try (return Nothing) (Just . unpack<$>readBytes x))
......
...@@ -45,12 +45,12 @@ instance Monad JS.CIO where join = (P.>>=id) ...@@ -45,12 +45,12 @@ instance Monad JS.CIO where join = (P.>>=id)
instance MonadIO JS.CIO where liftIO = JS.liftIO instance MonadIO JS.CIO where liftIO = JS.liftIO
instance MonadSubIO JS.CIO JS.CIO where liftSubIO = id instance MonadSubIO JS.CIO JS.CIO where liftSubIO = id
instance Serializable Word8 ([Word8] -> [Word8]) [Word8] Char where encode _ c = (fromIntegral (fromEnum c):) instance Serializable [Word8] Char where encode _ c = ListBuilder (fromIntegral (fromEnum c):)
instance Format Word8 ([Word8] -> [Word8]) [Word8] Char where datum = datum <&> \x -> toEnum (fromEnum (x::Word8)) instance Format [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] (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] (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] (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 Format [Word8] (WriteImpl JS.CIO String [Word8]) where datum = return (WriteImpl setBytes)
runComment c = unit runComment c = unit
toWordList :: JS.JSString -> [Word8] toWordList :: JS.JSString -> [Word8]
......
...@@ -71,12 +71,12 @@ data WriteImpl io str bytes = WriteImpl (str -> bytes -> io ()) ...@@ -71,12 +71,12 @@ data WriteImpl io str bytes = WriteImpl (str -> bytes -> io ())
instance Show (ReadImpl io str bytes) where show _ = "#<open>" instance Show (ReadImpl io str bytes) where show _ = "#<open>"
instance Show (WriteImpl io str bytes) where show _ = "#<write>" instance Show (WriteImpl io str bytes) where show _ = "#<write>"
type ListSerializable a = (Serializable Word8 ([Word8] -> [Word8]) [Word8] a) type ListSerializable a = (Serializable [Word8] a)
type ListFormat a = (Format Word8 ([Word8] -> [Word8]) [Word8] a) type ListFormat a = (Format [Word8] a)
type IOListFormat io str = (ListFormat (ReadImpl io str str), ListFormat (WriteImpl io str str), type IOListFormat io str = (ListFormat (ReadImpl io str str), ListFormat (WriteImpl io str str),
ListFormat (ReadImpl io str [Word8]), ListFormat (WriteImpl io str [Word8])) 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] (ReadImpl io str bytes) where encode _ _ = zero
instance Serializable Word8 ([Word8] -> [Word8]) [Word8] (WriteImpl io str bytes) where encode _ _ = id instance Serializable [Word8] (WriteImpl io str bytes) where encode _ _ = zero
instance ListSerializable str => ListSerializable (COCBuiltin io str) instance ListSerializable str => ListSerializable (COCBuiltin io str)
instance (ListFormat str,IOListFormat io str) => ListFormat (COCBuiltin io str) instance (ListFormat str,IOListFormat io str) => ListFormat (COCBuiltin io str)
......
...@@ -8,7 +8,7 @@ module Data.CaPriCon( ...@@ -8,7 +8,7 @@ module Data.CaPriCon(
StringPattern,NodeDir(..),AHDir(..),ApDir, StringPattern,NodeDir(..),AHDir(..),ApDir,
findPattern,freshContext, findPattern,freshContext,
-- * Showing nodes -- * Showing nodes
NodeDoc(..),doc2raw,doc2latex,showNode,showNode' ListBuilder(..),NodeDoc(..),doc2raw,doc2latex,showNode,showNode'
) where ) where
import Definitive import Definitive
...@@ -37,10 +37,14 @@ instance IsCapriconString String where ...@@ -37,10 +37,14 @@ instance IsCapriconString String where
toString = id toString = id
type ListStream = [Word8] type ListStream = [Word8]
type ListBuilder = ListStream -> ListStream newtype ListBuilder = ListBuilder (ListStream -> ListStream)
instance SerialStream Word8 ListBuilder ListStream where instance Semigroup ListBuilder where ListBuilder a + ListBuilder b = ListBuilder (a . b)
encodeByte _ b = (b:) instance Monoid ListBuilder where zero = ListBuilder id
toSerialStream k = k [] instance SerialStreamType ListStream where
type StreamBuilder ListStream = ListBuilder
instance SerialStream ListStream where
encodeByte _ b = ListBuilder (b:)
toSerialStream (ListBuilder k) = k []
-- | Inductive types -- | Inductive types
type UniverseSize = Int type UniverseSize = Int
...@@ -58,8 +62,8 @@ data Application str = Ap (ApHead str) [Node str] ...@@ -58,8 +62,8 @@ data Application str = Ap (ApHead str) [Node str]
deriving (Show,Generic) deriving (Show,Generic)
type Env str = [(str,NodeType str)] type Env str = [(str,NodeType str)]
type ListSerializable a = (Serializable Word8 ListBuilder ListStream a) type ListSerializable a = (Serializable ListStream a)
type ListFormat a = (Format Word8 ListBuilder ListStream a) type ListFormat a = (Format ListStream a)
instance ListSerializable BindType instance ListSerializable BindType
instance ListFormat BindType instance ListFormat BindType
instance ListSerializable str => ListSerializable (Node str) instance ListSerializable str => ListSerializable (Node str)
...@@ -173,7 +177,10 @@ instance Foldable (NodeDir str) where ...@@ -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 fold (NodeDir a b c) = (fold.map fold.map2 fold) a + (fold.map fold.map2 fold) b + fold c
instance Traversable (NodeDir str) where instance Traversable (NodeDir str) where
sequence (NodeDir a b c) = NodeDir<$>sequence3 a<*>sequence3 b<*>sequence c 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 (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) instance (ListFormat str, ListFormat a) => ListFormat (NodeDir str a)
i'NodeDir :: Iso (NodeDir str a) (NodeDir str' a') i'NodeDir :: Iso (NodeDir str a) (NodeDir str' a')
......
...@@ -48,7 +48,7 @@ library ...@@ -48,7 +48,7 @@ library
AllowAmbiguousTypes AllowAmbiguousTypes
LambdaCase LambdaCase
other-extensions: UndecidableInstances, ScopedTypeVariables, StandaloneDeriving, PatternSynonyms, ViewPatterns, TypeFamilies, CPP, RecursiveDo, GADTs, DeriveGeneric, OverloadedStrings, NoMonomorphismRestriction, DeriveDataTypeable, ExistentialQuantification, BangPatterns 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) if flag(paranoid)
ghc-options: -Wall -Werror ghc-options: -Wall -Werror
hs-source-dirs: src hs-source-dirs: src
......
...@@ -59,8 +59,10 @@ instance Foldable (ExprNode s) where ...@@ -59,8 +59,10 @@ instance Foldable (ExprNode s) where
instance Traversable (ExprNode s) where instance Traversable (ExprNode s) where
sequence (Lambda s a) = Lambda s<$>a sequence (Lambda s a) = Lambda s<$>a
sequence (Apply ff fx) = Apply<$>ff<*>fx 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 (Serializable Bytes a,Serializable Bytes s) => Serializable 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 (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 :: Constraint (Expression a b)
c'Expression = c'_ c'Expression = c'_
...@@ -203,14 +205,14 @@ curlyCommitDir = curlyDirPath (curlyUserDir + "/commits") ...@@ -203,14 +205,14 @@ curlyCommitDir = curlyDirPath (curlyUserDir + "/commits")
-- | A Curly log level -- | A Curly log level
data LogLevel = Quiet | Chatty | Verbose | Debug data LogLevel = Quiet | Chatty | Verbose | Debug
deriving (Eq,Ord,Show,Generic) deriving (Eq,Ord,Show,Generic)
instance Serializable Word8 Builder Bytes LogLevel instance Serializable Bytes LogLevel
instance Format Word8 Builder Bytes LogLevel instance Format Bytes LogLevel
data LogMessage = LogLine LogLevel String data LogMessage = LogLine LogLevel String
| LogActionStart String | LogActionStart String
| LogActionEnd String Bool | LogActionEnd String Bool
deriving (Show,Generic) deriving (Show,Generic)
instance Format Word8 Builder Bytes LogMessage instance Format Bytes LogMessage
instance Serializable Word8 Builder Bytes LogMessage instance Serializable Bytes LogMessage
-- The global log level, as set by the environment variable CURLY_LOGLEVEL -- The global log level, as set by the environment variable CURLY_LOGLEVEL
envLogLevel :: LogLevel envLogLevel :: LogLevel
...@@ -368,7 +370,7 @@ instance HasIdents s s' t t' => HasIdents s s' (Maybe t) (Maybe t') where ...@@ -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 data RelocationSize = RS_16 | RS_32 | RS_64
deriving (Eq,Ord,Show,Generic) 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 { data BinaryRelocation = BinaryRelocation {
_br_PCRelative :: Bool, _br_PCRelative :: Bool,
_br_size :: RelocationSize, _br_size :: RelocationSize,
...@@ -376,8 +378,8 @@ data BinaryRelocation = BinaryRelocation { ...@@ -376,8 +378,8 @@ data BinaryRelocation = BinaryRelocation {
_br_symoffset :: Int _br_symoffset :: Int
} }
deriving (Eq,Ord,Show,Generic) deriving (Eq,Ord,Show,Generic)
instance Serializable Word8 Builder Bytes BinaryRelocation instance Serializable Bytes BinaryRelocation
instance Format Word8 Builder Bytes BinaryRelocation instance Format Bytes BinaryRelocation
-- | The type of all Curly builtins -- | The type of all Curly builtins
data Builtin = B_Undefined data Builtin = B_Undefined
| B_Seq | B_Seq
...@@ -421,15 +423,15 @@ instance Documented Builtin where ...@@ -421,15 +423,15 @@ instance Documented Builtin where
where show' (B_Number n) = show n where show' (B_Number n) = show n
show' (B_String s) = show s show' (B_String s) = show s
show' b = show b show' b = show b
instance Serializable Word8 Builder Bytes Builtin where instance Serializable Bytes Builtin where
instance Format Word8 Builder Bytes Builtin where instance Format Bytes Builtin where
instance NFData Builtin where rnf b = b`seq`() instance NFData Builtin where rnf b = b`seq`()
newtype Compressed a = Compressed { unCompressed :: a } newtype Compressed a = Compressed { unCompressed :: a }
deriving (Show,Eq,Ord) 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)) 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) datum = (datum <&> decompress) >*> (Compressed <$> datum)
noCurlySuf :: FilePath -> Maybe FilePath noCurlySuf :: FilePath -> Maybe FilePath
...@@ -445,18 +447,18 @@ instance Show Hash where ...@@ -445,18 +447,18 @@ instance Show Hash where
show (Hash h) = show (B64Chunk h) show (Hash h) = show (B64Chunk h)
instance Read Hash where instance Read Hash where
readsPrec _ = readsParser (readable <&> \(B64Chunk h) -> Hash h) readsPrec _ = readsParser (readable <&> \(B64Chunk h) -> Hash h)
instance Serializable Word8 Builder Bytes Hash where instance Serializable Bytes Hash where
encode _ (Hash h) = h^.chunkBuilder encode _ (Hash h) = h^.chunkBuilder
instance Format Word8 Builder Bytes Hash where instance Format Bytes Hash where
datum = Hash<$>getChunk 32 datum = Hash<$>getChunk 32
newtype LibraryID = LibraryID Chunk newtype LibraryID = LibraryID Chunk
deriving (Eq,Ord,Generic) deriving (Eq,Ord,Generic)
idSize :: Int idSize :: Int
idSize = 32 idSize = 32
instance Serializable Word8 Builder Bytes LibraryID where instance Serializable Bytes LibraryID where
encode _ (LibraryID x) = x^.chunkBuilder encode _ (LibraryID x) = x^.chunkBuilder
instance Format Word8 Builder Bytes LibraryID where instance Format Bytes LibraryID where
datum = LibraryID<$>getChunk idSize datum = LibraryID<$>getChunk idSize
instance NFData LibraryID instance NFData LibraryID
instance Show LibraryID where instance Show LibraryID where
...@@ -473,8 +475,8 @@ instance Documented GlobalID where ...@@ -473,8 +475,8 @@ instance Documented GlobalID where
else \(GlobalID n _) -> Pure n else \(GlobalID n _) -> Pure n
where showL (Just (n,l)) = "["+show l+":"+n+"]" where showL (Just (n,l)) = "["+show l+":"+n+"]"
showL _ = "[]" showL _ = "[]"
instance Serializable Word8 Builder Bytes GlobalID instance Serializable Bytes GlobalID
instance Format Word8 Builder Bytes GlobalID instance Format Bytes GlobalID
instance NFData GlobalID instance NFData GlobalID
instance Identifier GlobalID where instance Identifier GlobalID where
pureIdent n = GlobalID n Nothing pureIdent n = GlobalID n Nothing
......
...@@ -55,8 +55,8 @@ instance Show (Symbol s) where ...@@ -55,8 +55,8 @@ instance Show (Symbol s) where
show (Builtin _ b) = "#"+show b show (Builtin _ b) = "#"+show b
instance Documented (Symbol s) where instance Documented (Symbol s) where
document s = Pure (show s) document s = Pure (show s)
instance (Serializable Word8 Builder Bytes s,Identifier s) => Serializable Word8 Builder Bytes (Symbol s) instance (Serializable Bytes s,Identifier s) => Serializable Bytes (Symbol s)
instance (Format Word8 Builder Bytes s,Identifier s) => Format Word8 Builder Bytes (Symbol s) instance (Format Bytes s,Identifier s) => Format Bytes (Symbol s)
instance NFData (Symbol s) where instance NFData (Symbol s) where
rnf (Argument n) = rnf n rnf (Argument n) = rnf n
rnf (Builtin _ b) = rnf b rnf (Builtin _ b) = rnf b
...@@ -80,8 +80,8 @@ instance HasIdents s s' (StrictnessHead s) (StrictnessHead s') where ...@@ -80,8 +80,8 @@ instance HasIdents s s' (StrictnessHead s) (StrictnessHead s') where
(ff'idents k sts) (ff'idents k sts)
ff'idents _ StH_Void = pure StH_Void ff'idents _ StH_Void = pure StH_Void
ff'idents _ (StH_Val n) = pure (StH_Val n) ff'idents _ (StH_Val n) = pure (StH_Val n)
instance Serializable Word8 Builder Bytes s => Serializable Word8 Builder Bytes (StrictnessHead s) instance Serializable Bytes s => Serializable Bytes (StrictnessHead s)
instance Format Word8 Builder Bytes s => Format Word8 Builder Bytes (StrictnessHead s) instance Format Bytes s => Format Bytes (StrictnessHead s)
instance NFData s => NFData (StrictnessHead s) instance NFData s => NFData (StrictnessHead s)
noStrictness :: Strictness s noStrictness :: Strictness s
...@@ -90,8 +90,8 @@ noStrictness = HNF StH_Void [] ...@@ -90,8 +90,8 @@ noStrictness = HNF StH_Void []
data Strictness s = Delayed s (ExprStrictness s) data Strictness s = Delayed s (ExprStrictness s)
| HNF (StrictnessHead s) [ExprStrictness s] | HNF (StrictnessHead s) [ExprStrictness s]
deriving (Eq,Ord,Generic) deriving (Eq,Ord,Generic)
instance Serializable Word8 Builder Bytes s => Serializable Word8 Builder Bytes (Strictness s) instance Serializable Bytes s => Serializable Bytes (Strictness s)
instance Format Word8 Builder Bytes s => Format Word8 Builder Bytes (Strictness s) instance Format Bytes s => Format Bytes (Strictness s)
instance NFData s => NFData (Strictness s) instance NFData s => NFData (Strictness s)
instance HasIdents s s' (Strictness s) (Strictness s') where 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) 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) ...@@ -26,8 +26,10 @@ import System.Environment (lookupEnv)
-- | A documentation node (similar to a HTML node, but simpler) -- | A documentation node (similar to a HTML node, but simpler)
data DocNode a = DocTag String [(String,String)] [a] data DocNode a = DocTag String [(String,String)] [a]
deriving (Eq,Ord,Show,Generic) deriving (Eq,Ord,Show,Generic)
instance Serializable Word8 Builder Bytes a => Serializable Word8 Builder Bytes (DocNode a) instance Serializable Bytes a => Serializable Bytes (DocNode a)
instance Format Word8 Builder Bytes a => Format Word8 Builder 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 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 Foldable DocNode where fold (DocTag _ _ l) = fold l
instance Traversable DocNode where sequence (DocTag t as l) = DocTag t as<$>sequence l instance Traversable DocNode where sequence (DocTag t as l) = DocTag t as<$>sequence l
...@@ -51,10 +53,10 @@ instance Documented Int where ...@@ -51,10 +53,10 @@ instance Documented Int where
document n = docTag' "int" [Pure (show n)] document n = docTag' "int" [Pure (show n)]
newtype Metadata = Metadata (Forest (Map String) String) 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' (Forest (Map String) String) Metadata
i'Metadata = iso Metadata (\(Metadata m) -> m) 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 instance DataMap Metadata String (Free (Map String) String) where
at i = from i'Metadata.at i at i = from i'Metadata.at i
instance Show Metadata where instance Show Metadata where
...@@ -155,15 +157,15 @@ mkDoc :: String -- ^ The root tag name ...@@ -155,15 +157,15 @@ mkDoc :: String -- ^ The root tag name
-> String -- ^ Documentation in textual format -> String -- ^ Documentation in textual format
-> Documentation -> Documentation
mkDoc t d = Join . DocTag t [] $ fromMaybe [] $ matches Just (between spc spc (sepBy' docAtom spc)) d 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") spc = skipMany' (oneOf " \t\n")
docAtom :: (ParseStream c s, ParseToken c, TokenPayload c ~ Char,Monad m) => ParserT s m Documentation docAtom :: (ParseStream s, StreamChar s ~ Char,Monad m) => ParserT s m Documentation
docFormat :: (ParseStream c s, ParseToken c, TokenPayload c ~ Char,Monad m) => String -> [Char] -> ParserT s m Documentation docFormat :: (ParseStream s, StreamChar s ~ Char,Monad m) => String -> [Char] -> ParserT s m Documentation
docAtom = fst docAtom' docAtom = fst docAtom'
docFormat = snd 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) (ParserT s m Documentation,String -> [Char] -> ParserT s m Documentation)
docAtom' = (tag <+? txt,strSplice) docAtom' = (tag <+? txt,strSplice)
where letter p = token >>= \case where letter p = token >>= \case
...@@ -193,7 +195,7 @@ docAtom' = (tag <+? txt,strSplice) ...@@ -193,7 +195,7 @@ docAtom' = (tag <+? txt,strSplice)
<+? single '\\' >> token <+? 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 => String -> [(String,String)] -> ParserT s m Documentation
docLine n as = Join . DocTag n as <$> many1' (skipMany' (oneOf " \t") >> docAtom) docLine n as = Join . DocTag n as <$> many1' (skipMany' (oneOf " \t") >> docAtom)
showRawDoc :: Documentation -> String showRawDoc :: Documentation -> String
......
...@@ -42,15 +42,15 @@ curlyLibVersion = 11 ...@@ -42,15 +42,15 @@ curlyLibVersion = 11
binaryEOI :: (MonadParser s m p, Monoid s, Eq s) => p () binaryEOI :: (MonadParser s m p, Monoid s, Eq s) => p ()
binaryEOI = guard . (==zero) =<< remaining binaryEOI = guard . (==zero) =<< remaining
newtype Chunked a = Chunked { getChunked :: a } 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) 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)) datum = datum <&> \x -> maybe (error "No parse for chunked data") Chunked (matches Just (datum <* binaryEOI) (x :: Bytes))
data FutureExtensionTail = FutureExtensionTail data FutureExtensionTail = FutureExtensionTail
instance Serializable Word8 Builder Bytes FutureExtensionTail where instance Serializable Bytes FutureExtensionTail where
encode = zero encode = zero
instance Format Word8 Builder Bytes FutureExtensionTail where instance Format Bytes FutureExtensionTail where
datum = runStreamState (put zero) >> return FutureExtensionTail datum = runStreamState (put zero) >> return FutureExtensionTail
type FutureExtension = Extension FutureExtensionTail type FutureExtension = Extension FutureExtensionTail
...@@ -65,8 +65,8 @@ instance ExtensionDefault a => ExtensionDefault (Extension a) where ...@@ -65,8 +65,8 @@ instance ExtensionDefault a => ExtensionDefault (Extension a) where
newtype Extension a = Extension (Chunked a) newtype Extension a = Extension (Chunked a)
deriving instance Serializable Word8 Builder Bytes a => Serializable Word8 Builder Bytes (Extension a) deriving instance Serializable Bytes a => Serializable Bytes (Extension a)
instance (ExtensionDefault a,Format Word8 Builder Bytes a) => Format Word8 Builder Bytes (Extension a) where 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)) 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)] newtype ModDir s a = ModDir [(s,a)]
...@@ -83,10 +83,12 @@ instance Documented a => Documented (Module a) where ...@@ -83,10 +83,12 @@ instance Documented a => Documented (Module a) where
,docTag' "ul" (map (docTag "li" [("class","modVal")] . pure . doc') l')] ,docTag' "ul" (map (docTag "li" [("class","modVal")] . pure . doc') l')]
document (Pure s) = document s 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) 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) 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 Functor (ModDir s) where map f (ModDir l) = ModDir (l <&> l'2 %~ f)
instance Ord s => SemiApplicative (Zip (ModDir s)) where 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)) 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 ...@@ -139,9 +141,9 @@ instance Functor (ModLeaf s) where
map = warp leafVal map = warp leafVal
instance Foldable (ModLeaf s) where fold l = l^.leafVal instance Foldable (ModLeaf s) where fold l = l^.leafVal
instance Traversable (ModLeaf s) where sequence l = leafVal id l 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) 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 = (\(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 <$>datum<*>datum<*>datum<*>datum<*>datum<*>datum<*>datum
instance (Identifier s,Identifier s') => HasIdents s s' (ModLeaf s a) (ModLeaf s' a) where instance (Identifier s,Identifier s') => HasIdents s s' (ModLeaf s a) (ModLeaf s' a) where
...@@ -155,10 +157,10 @@ instance Semigroup SourceRange where ...@@ -155,10 +157,10 @@ instance Semigroup SourceRange where
NoRange + a = a NoRange + a = a
a + NoRange = a a + NoRange = a
instance Monoid SourceRange where zero = NoRange 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)