{-# LANGUAGE TypeFamilies, GeneralizedNewtypeDeriving, TemplateHaskell, ScopedTypeVariables,
MultiParamTypeClasses, DeriveDataTypeable, TypeSynonymInstances,
FlexibleInstances, UndecidableInstances, DeriveLift #-}
{-# OPTIONS_HADDOCK prune #-}
module Language.Pads.CoreBaseTypes where
import Language.Pads.Generic
import Language.Pads.MetaData
import Language.Pads.PadsParser
import Language.Pads.RegExp
import Data.Maybe
import qualified Language.Pads.Source as S
import qualified Language.Pads.Errors as E
import qualified Data.ByteString as B
import Data.ByteString.Internal
import qualified Data.ByteString.Char8 as C
import Language.Pads.PadsPrinter
import Language.Pads.Generation
import Language.Haskell.TH as TH
import Language.Haskell.TH.Syntax
import Data.Data
import qualified Data.Map as M
import qualified Data.List as List
import Data.Word
import Data.Char as Char
import Data.Int
import Data.Bits
import Text.PrettyPrint.Mainland as PP
import Text.PrettyPrint.Mainland.Class
import Control.Monad
import Control.Monad.Reader
import System.IO.Unsafe (unsafePerformIO)
type Char_md = Base_md
char_parseM :: PadsParser (Char, Base_md)
char_parseM =
handleEOF def "Char" $
handleEOR def "Char" $ do
c <- takeHeadP
returnClean c
char_def :: Char
char_def = 'X'
type instance PadsArg Char = ()
type instance Meta Char = Base_md
instance Pads1 () Char Base_md where
parsePP1 () = char_parseM
printFL1 () = char_printFL
def1 () = char_def
char_printFL :: PadsPrinter (Char, md)
char_printFL (c,bmd) = addString [c]
char_genM :: PadsGen st Char
char_genM = randLetter
char_serialize :: Char -> CList
char_serialize c = toCL [CharChunk c]
type BitBool = Bool
type BitBool_md = Base_md
bitBool_parseM :: PadsParser (BitBool, Base_md)
bitBool_parseM =
handleEOF False "BitBool" $
handleEOR False "BitBool" $ do
b <- takeBits8P 1
returnClean (b == 1)
bitBool_def = False
bitBool_printFL :: PadsPrinter (BitBool, md)
bitBool_printFL (bb,bbmd) = fshow bb
bitBool_genM :: PadsGen st BitBool
bitBool_genM = randElem [False,True]
bitBool_serialize :: BitBool -> CList
bitBool_serialize b = toCL [BinaryChunk ((fromIntegral . fromEnum) b) 1]
type BitField = Integer
type BitField_md = Base_md
bitField_parseM :: Integral a => a -> PadsParser (BitField, Base_md)
bitField_parseM x =
if x < 0
then returnError def (E.BitWidthError 0 (fromIntegral x))
else handleEOF 0 "BitField" $
handleEOR 0 "BitField" $ do
b <- takeBitsP x
returnClean b
bitField_def :: a -> BitField
bitField_def _ = 0
bitField_printFL :: Integral a => a -> PadsPrinter (BitField, md)
bitField_printFL _ (x, xmd) = fshow x
bitField_genM :: Integral a => a -> PadsGen st BitField
bitField_genM x = randIntegerBound (2^x - 1)
bitField_serialize :: Integral a => a -> BitField -> CList
bitField_serialize b v = toCL [BinaryChunk v (fromIntegral b)]
type Bits8 = Word8
type Bits8_md = Base_md
bits8_parseM :: Integral a => a -> PadsParser (Bits8, Base_md)
bits8_parseM x =
if x < 1 || x > 8
then returnError 0 (E.BitWidthError 8 (fromIntegral x))
else handleEOF 0 "Bits8" $
handleEOR 0 "Bits8" $ do
b <- takeBits8P x
returnClean b
bits8_def :: a -> Bits8
bits8_def _ = 0
bits8_printFL :: Integral a => a -> PadsPrinter (Bits8, md)
bits8_printFL _ (x, xmd) = fshow x
bits8_genM :: Integral a => a -> PadsGen st Bits8
bits8_genM x = randNumBound (2^x - 1)
bits8_serialize :: Int -> Bits8 -> CList
bits8_serialize b v = toCL [BinaryChunk (fromIntegral v) b]
type Bits16 = Word16
type Bits16_md = Base_md
bits16_parseM :: Integral a => a -> PadsParser (Bits16, Base_md)
bits16_parseM x =
if x < 1 || x > 16
then returnError 0 (E.BitWidthError 16 (fromIntegral x))
else handleEOF 0 "Bits16" $
handleEOR 0 "Bits16" $ do
b <- takeBits16P x
returnClean b
bits16_def :: a -> Bits16
bits16_def _ = 0
bits16_printFL :: Integral a => a -> PadsPrinter (Bits16, md)
bits16_printFL _ (x, xmd) = fshow x
bits16_genM :: Integral a => a -> PadsGen st Bits16
bits16_genM x = randNumBound (2^x - 1)
bits16_serialize :: Int -> Bits16 -> CList
bits16_serialize b v = toCL [BinaryChunk (fromIntegral v) b]
type Bits32 = Word32
type Bits32_md = Base_md
bits32_parseM :: Integral a => a -> PadsParser (Bits32, Base_md)
bits32_parseM x =
if x < 1 || x > 32
then returnError 0 (E.BitWidthError 32 (fromIntegral x))
else handleEOF 0 "Bits32" $
handleEOR 0 "Bits32" $ do
b <- takeBits32P x
returnClean b
bits32_def :: a -> Bits32
bits32_def _ = 0
bits32_printFL :: Integral a => a -> PadsPrinter (Bits32, md)
bits32_printFL _ (x, xmd) = fshow x
bits32_genM :: Integral a => a -> PadsGen st Bits32
bits32_genM x = randNumBound (2^x - 1)
bits32_serialize :: Int -> Bits32 -> CList
bits32_serialize b v = toCL [BinaryChunk (fromIntegral v) b]
type Bits64 = Word64
type Bits64_md = Base_md
bits64_parseM :: Integral a => a -> PadsParser (Bits64, Base_md)
bits64_parseM x =
if x < 1 || x > 64
then returnError 0 (E.BitWidthError 64 (fromIntegral x))
else handleEOF 0 "Bits64" $
handleEOR 0 "Bits64" $ do
b <- takeBits64P x
returnClean b
bits64_def :: a -> Bits64
bits64_def _ = 0
bits64_printFL :: Integral a => a -> PadsPrinter (Bits64, md)
bits64_printFL _ (x, xmd) = fshow x
bits64_genM :: Integral a => a -> PadsGen st Bits64
bits64_genM x = randNumBound (2^x - 1)
bits64_serialize :: Int -> Bits64 -> CList
bits64_serialize b v = toCL [BinaryChunk (fromIntegral v) b]
type Int_md = Base_md
int_parseM :: PadsParser (Int,Base_md)
int_parseM =
handleEOF def "Int" $
handleEOR def "Int" $ do
c <- peekHeadP
let isNeg = (c == '-')
when isNeg (takeHeadP >> return ())
digits <- satisfy Char.isDigit
if not (null digits)
then returnClean (digitListToInt isNeg digits)
else returnError def (E.FoundWhenExpecting (mkStr c) "Int")
int_def :: Int
int_def = 0
type instance PadsArg Int = ()
type instance Meta Int = Base_md
instance Pads1 () Int Base_md where
parsePP1 () = int_parseM
printFL1 () = int_printFL
def1 () = int_def
int_printFL :: PadsPrinter (Int, Base_md)
int_printFL (i, bmd) = fshow i
int_genM :: PadsGen st Int
int_genM = randNum
int_serialize :: Int -> CList
int_serialize i = toCL $ map CharChunk $ show i
type Integer_md = Base_md
integer_parseM :: PadsParser (Integer,Base_md)
integer_parseM =
handleEOF def "Integer" $
handleEOR def "Integer" $ do
c <- peekHeadP
let isNeg = (c == '-')
when isNeg (takeHeadP >> return ())
digits <- satisfy Char.isDigit
if not (null digits)
then returnClean (toEnum $ digitListToInt isNeg digits)
else returnError def (E.FoundWhenExpecting (mkStr c) "Integer")
integer_def :: Integer
integer_def = 0
type instance PadsArg Integer = ()
type instance Meta Integer = Base_md
instance Pads1 () Integer Base_md where
parsePP1 () = integer_parseM
printFL1 () = integer_printFL
def1 () = integer_def
integer_printFL :: PadsPrinter (Integer, Base_md)
integer_printFL (i, bmd) = fshow i
integer_genM :: PadsGen st Integer
integer_genM = randInteger
integer_serialize :: Integer -> CList
integer_serialize i = toCL $ map CharChunk $ show i
type Float_md = Base_md
float_parseM :: PadsParser (Float,Base_md)
float_parseM =
handleEOF def "Float" $
handleEOR def "Float" $ do
c <- peekHeadP
let isNeg = (c == '-')
when isNeg (takeHeadP >> return ())
let sign = if isNeg then "-" else ""
digits1 <- satisfy Char.isDigit
d <- peekHeadP
let hasDot = (d == '.')
when hasDot (takeHeadP >> return ())
let dec = if hasDot then "." else ""
digits2 <- satisfy Char.isDigit
e <- peekHeadP
let hasExp = (e == 'e')
when hasExp (takeHeadP >> return ())
let exp = if hasExp then "e" else ""
es <- peekHeadP
let hasESign = (es == '-')
when hasESign (takeHeadP >> return ())
let expSign = if hasESign then "-" else ""
digits3 <- satisfy Char.isDigit
if not (null digits1)
then returnClean (read (sign ++digits1++dec++digits2++exp++expSign++digits3))
else returnError def (E.FoundWhenExpecting (mkStr c) "Float")
float_def :: Float
float_def = 0
type instance PadsArg Float = ()
type instance Meta Float = Base_md
instance Pads1 () Float Base_md where
parsePP1 () = float_parseM
printFL1 () = float_printFL
def1 () = float_def
float_printFL :: PadsPrinter (Float, Base_md)
float_printFL (d, bmd) = fshow d
float_genM :: PadsGen st Float
float_genM = randNum
float_serialize :: Float -> CList
float_serialize f = toCL $ map CharChunk $ show f
type Double_md = Base_md
double_parseM :: PadsParser (Double,Base_md)
double_parseM =
handleEOF def "Double" $
handleEOR def "Double" $ do
c <- peekHeadP
let isNeg = (c == '-')
when isNeg (takeHeadP >> return ())
let sign = if isNeg then "-" else ""
digits1 <- satisfy Char.isDigit
d <- peekHeadP
let hasDot = (d == '.')
when hasDot (takeHeadP >> return ())
let dec = if hasDot then "." else ""
digits2 <- satisfy Char.isDigit
e <- peekHeadP
let hasExp = (e == 'e')
when hasExp (takeHeadP >> return ())
let exp = if hasExp then "e" else ""
es <- peekHeadP
let hasESign = (es == '-')
when hasESign (takeHeadP >> return ())
let expSign = if hasESign then "-" else ""
digits3 <- satisfy Char.isDigit
if not (null digits1)
then returnClean (read (sign ++digits1++dec++digits2++exp++expSign++digits3))
else returnError def (E.FoundWhenExpecting (mkStr c) "Double")
double_def :: Double
double_def = 0
type instance PadsArg Double = ()
type instance Meta Double = Base_md
instance Pads1 () Double Base_md where
parsePP1 () = double_parseM
printFL1 () = double_printFL
def1 () = 0
double_printFL :: PadsPrinter (Double, Base_md)
double_printFL (d, bmd) = fshow d
double_genM :: PadsGen st Double
double_genM = randNum
double_serialize :: Double -> CList
double_serialize d = toCL $ map CharChunk $ show d
type Try a = a
type Try_md a_md = (Base_md, a_md)
try_parseM :: PadsMD md => PadsParser (rep,md) -> PadsParser (Try rep, Try_md md)
try_parseM p = do
(rep,md) <- parseTry p
return (rep, (cleanBasePD, md))
try_printFL :: PadsPrinter (a,a_md) -> PadsPrinter (Try a,Try_md a_md)
try_printFL p _ = printNothing
try_def :: a -> Try a
try_def d = d
try_genM :: PadsGen st a -> PadsGen st (Try a)
try_genM g = g >>= return
try_serialize = id
type Digit = Int
type Digit_md = Base_md
digit_parseM :: PadsParser (Digit, Base_md)
digit_parseM =
handleEOF def "Pdigit" $
handleEOR def "Pdigit" $ do
c <- takeHeadP
if isDigit c
then returnClean (digitToInt c)
else returnError def (E.FoundWhenExpecting [c] "Digit")
digit_def :: Digit
digit_def = 0
digit_printFL :: PadsPrinter (Digit, Base_md)
digit_printFL (i, bmd) = fshow i
digit_genM :: PadsGen st Digit
digit_genM = randNumBound 9
digit_serialize :: Digit -> CList
digit_serialize d = toCL $ map CharChunk $ show d
type String_md = Base_md
string_parseM :: PadsParser (String, Base_md)
string_parseM = do
document <- getAllBinP
returnClean $ C.unpack document
string_def = ""
type instance PadsArg String = ()
type instance Meta String = Base_md
instance Pads1 () String Base_md where
parsePP1 () = string_parseM
printFL1 () = string_printFL
def1 () = string_def
string_printFL :: PadsPrinter (String, Base_md)
string_printFL (str, bmd) = addString str
string_genM :: PadsGen st String
string_genM = stringVW_genM 100
string_serialize :: String -> CList
string_serialize s = toCL $ map CharChunk s
newtype Text = Text S.RawStream
deriving (Eq, Show, Data, Typeable, Ord)
type Text_md = Base_md
text_parseM :: PadsParser (Text, Base_md)
text_parseM = do
document <- getAllBinP
returnClean (Text document)
instance Pretty Text where
ppr (Text str) = text "ASCII"
text_def :: Text
text_def = Text $ B.pack []
type instance PadsArg Text = ()
type instance Meta Text = Base_md
instance Pads1 () Text Base_md where
parsePP1 () = text_parseM
printFL1 () = text_printFL
def1 () = text_def
text_printFL :: PadsPrinter (Text, Base_md)
text_printFL (Text str, bmd) = addBString str
text_genM :: PadsGen st Text
text_genM = Text <$> B.pack <$> (map S.chrToWord8) <$> stringVW_genM 500
text_serialize :: Text -> CList
text_serialize (Text b) = toCL $ ((map (CharChunk . S.word8ToChr)) . B.unpack) b
newtype Binary = Binary S.RawStream
deriving (Eq, Show, Data, Typeable, Ord)
type Binary_md = Base_md
binary_parseM :: PadsParser (Binary, Base_md)
binary_parseM = do
document <- getAllBinP
returnClean (Binary document)
instance Pretty Binary where
ppr (Binary str) = text "Binary"
binary_def :: Binary
binary_def = Binary $ B.pack []
type instance PadsArg Binary = ()
type instance Meta Binary = Base_md
instance Pads1 () Binary Base_md where
parsePP1 () = binary_parseM
printFL1 () = binary_printFL
def1 () = binary_def
binary_printFL :: PadsPrinter (Binary, Base_md)
binary_printFL (Binary bstr, bmd) = addBString bstr
type StringC = String
type StringC_md = Base_md
stringC_parseM :: Char -> PadsParser (StringC, Base_md)
stringC_parseM c =
handleEOF (stringC_def c) "StringC" $
handleEOR (stringC_def c) "StringC" $ do
str <- satisfy (\c'-> c /= c')
returnClean str
stringC_def c = ""
stringC_printFL :: Char -> PadsPrinter (StringC, Base_md)
stringC_printFL c (str, bmd) = addString str
stringC_genM :: Char -> PadsGen st StringC
stringC_genM c = do
i <- randNumBound 500
replicateM i (randLetterExcluding c)
stringC_serialize :: Char -> StringC -> CList
stringC_serialize c s = (string_serialize s) `cAppend` (toCL [CharChunk c])
type StringFW = String
type StringFW_md = Base_md
stringFW_parseM :: Int -> PadsParser (StringFW, Base_md)
stringFW_parseM 0 = returnClean ""
stringFW_parseM n =
handleEOF (stringFW_def n) "StringFW" $
handleEOR (stringFW_def n) "StringFW" $ do
str <- takeP n
if (length str) == n
then returnClean str
else returnError (stringFW_def n) (E.Insufficient (length str) n)
stringFW_def :: Int -> StringFW
stringFW_def n = replicate n 'X'
stringFW_printFL :: Int -> PadsPrinter (StringFW, Base_md)
stringFW_printFL n (str, bmd) = addString (take n str)
stringFW_genM :: Int -> PadsGen st StringFW
stringFW_genM i = replicateM i randLetter
stringFW_serialize :: Int -> StringFW -> CList
stringFW_serialize _ = string_serialize
type StringVW = String
type StringVW_md = Base_md
stringVW_parseM :: Int -> PadsParser (StringVW, Base_md)
stringVW_parseM 0 = returnClean ""
stringVW_parseM n =
handleEOF (stringVW_def n) "StringVW" $
handleEOR (stringVW_def n) "StringVW" $ do
str <- takeP n
returnClean str
stringVW_def :: Int -> StringVW
stringVW_def n = replicate n 'X'
stringVW_printFL :: Int -> PadsPrinter (StringVW, Base_md)
stringVW_printFL n (str, bmd) = addString (take n str)
stringVW_genM :: Int -> PadsGen st StringVW
stringVW_genM x = do
i <- randNumBound x
replicateM i randLetter
stringVW_serialize :: Int -> StringVW -> CList
stringVW_serialize i s = string_serialize s
type StringME = String
type StringME_md = Base_md
stringME_parseM :: RE -> PadsParser (StringME, Base_md)
stringME_parseM re =
handleEOF (stringME_def re) "StringME" $ do
match <- regexMatchP re
case match of
Just str -> returnClean str
Nothing -> returnError (stringME_def re) (E.RegexMatchFail (show re))
stringME_def (RE re) = ""
stringME_def (REd re d) = d
stringME_printFL :: RE -> PadsPrinter (StringME, Base_md)
stringME_printFL re (str, bmd) = addString str
stringME_genM :: RE -> PadsGen st StringME
stringME_genM _
= error $ "stringME_genM unimplemented: consider using the workaround \"type "
++ "XYZ = obtain StringME (RE) from StringME (RE) using <| "
++ "(const id, id) |> generator (gen)\" in your description to "
++ "provide your own regex-specific generator."
stringME_serialize :: RE -> StringME -> CList
stringME_serialize _ s = string_serialize s
type StringSE = String
type StringSE_md = Base_md
stringSE_parseM :: RE -> PadsParser (StringSE, Base_md)
stringSE_parseM re =
checkEOF (stringSE_def re) "StringSE" $
checkEOR (stringSE_def re) "StringSE" $ do
match <- regexStopP re
case match of
Just str -> returnClean str
Nothing -> returnError (stringSE_def re) (E.RegexMatchFail (show re))
stringSE_def (RE re) = ""
stringSE_def (REd re d) = d
stringSE_printFL :: RE -> PadsPrinter (StringSE, Base_md)
stringSE_printFL re (str, bmd) = addString str
stringSE_genM :: RE -> PadsGen st StringSE
stringSE_genM r
= error $ "stringSE_genM unimplemented: consider using the workaround \"type "
++ "XYZ = obtain StringSE (" ++ show r ++ ") from StringSE ("
++ show r ++ ") using <| (const id, id) |> generator (gen)\" in your "
++ "description to provide your own regex-specific generator."
stringSE_serialize :: RE -> StringSE -> CList
stringSE_serialize _ s = string_serialize s
type StringP = String
type StringP_md = Base_md
stringP_parseM :: (Char -> Bool) -> PadsParser (StringP, Base_md)
stringP_parseM p =
handleEOF (stringP_def p) "StringP" $
handleEOR (stringP_def p) "StringP" $ do
str <- satisfy p
returnClean str
stringP_def _ = ""
stringP_printFL :: (Char -> Bool) -> PadsPrinter (StringP, Base_md)
stringP_printFL p (str, bmd) = addString str
stringP_genM :: (Char -> Bool) -> PadsGen st StringP
stringP_genM _
= error $ "stringP_genM unimplemented: consider using the workaround \"type "
++ "XYZ = obtain StringP (pred) from StringP (pred) using <| "
++ "(const id, id) |> generator (gen)\" in your description to "
++ "provide your own predicate-specific generator."
stringP_serialize :: (Char -> Bool) -> StringP -> CList
stringP_serialize _ s = string_serialize s
type StringPESC = String
type StringPESC_md = Base_md
stringPESC_parseM :: (Bool, (Char, [Char])) -> PadsParser(StringPESC, Base_md)
stringPESC_parseM arg @ (endIfEOR, (escape, stops)) =
let (doEOF, doEOR) = if endIfEOR then (checkEOF, checkEOR) else (handleEOF, handleEOR)
in
doEOF "" "StringPESC" $
doEOR "" "StringPESC" $ do
{ c1 <- peekHeadP
; if c1 `elem` stops then
returnClean ""
else if c1 == escape then do
{ takeHeadP
; doEOF [c1] "StringPESC" $
doEOR [c1] "StringPESC" $ do
{ c2 <- takeHeadP
; if (c2 == escape) || (c2 `elem` stops) then do
{ (rest, rest_md) <- stringPESC_parseM arg
; return (c2:rest, rest_md)
}
else do
{ (rest, rest_md) <- stringPESC_parseM arg
; return (c1:c2:rest, rest_md)
}
}
} else do
{ c1 <- takeHeadP
; (rest, rest_md) <- stringPESC_parseM arg
; return (c1:rest, rest_md)
}
}
stringPESC_def :: (Bool, (Char, [Char])) -> String
stringPESC_def arg@(endIfEOR, (escape, stops)) = ""
stringPESC_printFL :: (Bool, (Char, [Char])) -> PadsPrinter (StringPESC, Base_md)
stringPESC_printFL (_, (escape, stops)) (str, bmd) =
let replace c = if c `elem` stops then escape : [c] else [c]
newStr = concat (map replace str)
in addString newStr
stringPESC_genM :: (Bool, (Char, [Char])) -> PadsGen st StringPESC
stringPESC_genM _ = error "stringPESC_genM: unimplemented"
stringPESC_serialize :: (Bool, (Char, [Char])) -> StringPESC -> CList
stringPESC_serialize _ s = string_serialize s
type CharNB = Char
type CharNB_md = Base_md
charNB_parseM :: PadsParser (CharNB, Base_md)
charNB_parseM =
handleEOF def "CharNB" $
handleEOR def "CharNB" $ do
c <- takeBitsP 8
returnClean (S.word8ToChr (fromIntegral c :: Word8))
charNB_def :: Char
charNB_def = char_def
charNB_printFL :: PadsPrinter (CharNB, md)
charNB_printFL (c, bmd) = addString [c]
charNB_genM :: PadsGen st CharNB
charNB_genM = char_genM
charNB_serialize :: CharNB -> CList
charNB_serialize = char_serialize
type StringNB = String
type StringNB_md = Base_md
stringNB_parseM :: PadsParser (String, Base_md)
stringNB_parseM = do
str <- drainSourceNBP
returnClean str
stringNB_def = string_def
stringNB_printFL :: PadsPrinter (String, Base_md)
stringNB_printFL = string_printFL
stringNB_genM :: PadsGen st StringNB
stringNB_genM = string_genM
type StringCNB = String
type StringCNB_md = Base_md
stringCNB_parseM :: Char -> PadsParser (StringCNB, Base_md)
stringCNB_parseM c =
handleEOF (stringCNB_def c) "StringCNB" $
handleEOR (stringCNB_def c) "StringCNB" $ do
str <- satisfyNBP (\c' -> c /= c')
returnClean str
stringCNB_def :: Char -> StringCNB
stringCNB_def = stringC_def
stringCNB_printFL :: Char -> PadsPrinter (StringCNB, Base_md)
stringCNB_printFL = stringC_printFL
stringCNB_genM :: Char -> PadsGen st StringCNB
stringCNB_genM = stringC_genM
stringCNB_serialize :: Char -> StringC -> CList
stringCNB_serialize = stringC_serialize
type StringFWNB = String
type StringFWNB_md = Base_md
stringFWNB_parseM :: Int -> PadsParser (StringFW, Base_md)
stringFWNB_parseM 0 = returnClean ""
stringFWNB_parseM n =
handleEOF (stringFWNB_def n) "StringFWNB" $
handleEOR (stringFWNB_def n) "StringFWNB" $ do
str <- takeBytesNBP n
let str' = map S.word8ToChr (B.unpack str)
if (length str') == n
then returnClean str'
else returnError (stringFWNB_def n) (E.Insufficient (length str') n)
stringFWNB_def :: Int -> StringFW
stringFWNB_def n = replicate n 'X'
stringFWNB_printFL :: Int -> PadsPrinter (StringFW, Base_md)
stringFWNB_printFL = stringFW_printFL
stringFWNB_genM :: Int -> PadsGen st StringFWNB
stringFWNB_genM = stringFW_genM
stringFWNB_serialize :: Int -> StringFWNB -> CList
stringFWNB_serialize _ = string_serialize
type BytesNB = S.RawStream
type BytesNB_md = Base_md
bytesNB_parseM :: Int -> PadsParser (BytesNB, BytesNB_md)
bytesNB_parseM n =
handleEOF (def1 n) "BytesNB" $
handleEOR (def1 n) "BytesNB" $ do
bytes <- takeBytesNBP n
if B.length bytes == n
then returnClean bytes
else returnError (def1 n) (E.Insufficient (B.length bytes) n)
bytesNB_printFL :: Int -> PadsPrinter (BytesNB, BytesNB_md)
bytesNB_printFL = bytes_printFL
bytesNB_def :: Int -> BytesNB
bytesNB_def = bytes_def
bytesNB_genM :: Int -> PadsGen st BytesNB
bytesNB_genM = bytes_genM
bytesNB_serialize :: Int -> BytesNB -> CList
bytesNB_serialize = bytes_serialize
data Chunk = CharChunk Char
| BinaryChunk { val :: Integer, bits :: Int }
deriving (Eq, Show, Lift)
fromChunks :: [Chunk] -> B.ByteString
fromChunks cs = let
bits = concat $ chunksToBits cs
toPad = case (8 - ((length bits) `mod` 8)) of 8 -> 0; x -> x
padding = replicate toPad 0
bytes = asBytes $ bits ++ padding
in if (length (bits ++ padding) `mod` 8) /= 0
then error "fromChunks: bug in binary conversion"
else B.pack $ map fromBytes bytes
where
chunksToBits :: [Chunk] -> [[Word8]]
chunksToBits [] = []
chunksToBits ((CharChunk c):cs) =
(toPaddedBits (fromEnum c) 8) : chunksToBits cs
chunksToBits ((BinaryChunk v b):cs) =
(toPaddedBits v b) : chunksToBits cs
toPaddedBits :: Integral a => a -> Int -> [Word8]
toPaddedBits x padTo = let
x' = toBits x []
padding = replicate (padTo - length x') 0
in if (padTo - length x') < 0
then drop (abs $ padTo - length x') x'
else padding ++ x'
toBits :: Integral a => a -> [Word8] -> [Word8]
toBits 0 [] = [0]
toBits 0 bs = bs
toBits x bs = toBits (x `div` 2) (fromIntegral x `mod` 2 : bs)
asBytes :: [Word8] -> [[Word8]]
asBytes [] = []
asBytes xs = (take 8 xs) : (asBytes $ drop 8 xs)
fromBytes :: [Word8] -> Word8
fromBytes bs = let
withPowers = zip bs (reverse [0..7])
in foldr1 (+) (map (\(b,p) -> b * 2^p) withPowers)
type CList = [Chunk] -> [Chunk]
instance Show CList where
show cl = show $ fromCL cl
cAppend :: CList -> CList -> CList
cs1 `cAppend` cs2 = cs1 . cs2
cConcat :: [CList] -> CList
cConcat cl = foldr cAppend id cl
toCL :: [Chunk] -> CList
toCL cs = (cs ++)
fromCL :: CList -> [Chunk]
fromCL cl = cl []
class ExpSerialize a where
exp_serialize :: a -> CList
instance ExpSerialize Char where
exp_serialize = char_serialize
instance ExpSerialize [Char] where
exp_serialize = string_serialize
instance ExpSerialize RE where
exp_serialize _ = string_serialize "RegEx Literal"
instance {-# INCOHERENT #-} (Num a, Show a) => ExpSerialize a where
exp_serialize x = toCL $ map CharChunk $ show x
class LitParse a where
litParse :: a -> PadsParser ((), Base_md)
litPrint :: a -> FList
strLit_parseM :: String -> PadsParser ((), Base_md)
strLit_parseM s =
handleEOF () s $
handleEOR () s $ do
match <- scanStrP s
case match of
Just [] -> returnClean ()
Just junk -> returnError () (E.ExtraBeforeLiteral s)
Nothing -> returnError () (E.MissingLiteral s)
strLit_printFL :: String -> FList
strLit_printFL str = addString str
instance LitParse Char where
litParse = charLit_parseM
litPrint = charLit_printFL
charLit_parseM :: Char -> PadsParser ((),Base_md)
charLit_parseM c =
handleEOF () (mkStr c) $
handleEOR () (mkStr c) $ do
c' <- takeHeadP
if c == c' then returnClean () else do
foundIt <- scanP c
returnError () (if foundIt
then E.ExtraBeforeLiteral (mkStr c)
else E.MissingLiteral (mkStr c))
charLit_printFL :: Char -> FList
charLit_printFL c = addString [c]
instance LitParse String where
litParse = strLit_parseM
litPrint = strLit_printFL
instance LitParse RE where
litParse = reLit_parseM
litPrint = reLit_printFL
reLit_parseM :: RE -> PadsParser ((), Base_md)
reLit_parseM re = do
(match, md) <- stringME_parseM re
if numErrors md == 0
then return ((), md)
else badReturn ((), md)
reLit_printFL :: RE -> FList
reLit_printFL (RE re) = addString "--REGEXP LITERAL-- "
reLit_printFL (REd re def) = addString def
type EOF = ()
type EOF_md = Base_md
eof_parseM :: PadsParser (EOF, Base_md)
eof_parseM = do
isEof <- isEOFP
if isEof then returnClean ()
else returnError () (E.ExtraBeforeLiteral "Eof")
type EOR = ()
type EOR_md = Base_md
eor_parseM :: PadsParser (EOR, Base_md)
eor_parseM =
handleEOF () "EOR" $ do
isEor <- isEORP
if isEor then doLineEnd
else returnError () (E.LineError "Expecting EOR")
eor_printFL :: (EOR,Base_md) -> FList
eor_printFL = const eorLit_printFL
eOR_printFL = eor_printFL
eOR_def :: EOR
eOR_def = ()
eof_printFL :: (EOF,Base_md) -> FList
eof_printFL = const eofLit_printFL
eOR_genM :: PadsGen st EOR
eOR_genM = return eOR_def
eOR_serialize :: CList
eOR_serialize = toCL [CharChunk '\n']
eOF_printFL = eof_printFL
eOF_def :: EOF
eOF_def = ()
eOF_genM :: PadsGen st EOF
eOF_genM = return eOF_def
eOF_serialize :: CList
eOF_serialize = toCL []
eorLit_printFL :: FList
eorLit_printFL = printEOR
eofLit_printFL :: FList
eofLit_printFL = printEOF
newtype Void = Void ()
deriving (Eq, Show, Data, Typeable, Ord)
type Void_md = Base_md
void_parseM :: PadsParser (Void, Base_md)
void_parseM = returnClean (Void ())
void_def :: Void
void_def = Void ()
type instance Meta Void = Base_md
instance Pads1 () Void Base_md where
parsePP1 () = void_parseM
printFL1 () = void_printFL
def1 () = void_def
void_printFL :: PadsPrinter (Void,Base_md)
void_printFL v = nil
void_genM :: PadsGen st Void
void_genM = return void_def
void_serialize :: CList
void_serialize = toCL []
pstrLit_printQ :: String -> FList
pstrLit_printQ str = addString str
tuple_printQ :: (String, String, String) -> FList
tuple_printQ (s1,s2,s3) = pstrLit_printQ s1 +++ pstrLit_printQ s2 +++ pstrLit_printQ s3
rtuple_printQ :: (String, String, String) -> FList
rtuple_printQ ss = tuple_printQ ss +++ (addString ['\n'])
list_printQ :: [(String,String,String)] -> FList
list_printQ [] = nil
list_printQ (item:items) = rtuple_printQ item +++ list_printQ items
handleEOF val str p
= do { isEof <- isEOFP
; if isEof then
returnError val (E.FoundWhenExpecting "EOF" str)
else p}
handleEOR val str p
= do { isEor <- isEORP
; if isEor then
returnError val (E.FoundWhenExpecting "EOR" str)
else p}
checkEOF val str p
= do { isEof <- isEOFP
; if isEof then
returnClean val
else p}
checkEOR val str p
= do { isEor <- isEORP
; if isEor then
returnClean val
else p}
type Bytes = S.RawStream
type Bytes_md = Base_md
bytes_parseM :: Int -> PadsParser (Bytes,Bytes_md)
bytes_parseM n =
handleEOF (def1 n) "Bytes" $
handleEOR (def1 n) "Bytes" $ do
bytes <- takeBytesP n
if B.length bytes == n
then returnClean bytes
else returnError (def1 n) (E.Insufficient (B.length bytes) n)
bytes_printFL :: Int -> PadsPrinter (Bytes, Bytes_md)
bytes_printFL n (bs, bmd) =
addBString bs
bytes_def :: Int -> Bytes
bytes_def i = B.pack $ replicate i (0::Word8)
bytes_genM :: Int -> PadsGen st Bytes
bytes_genM i = do
w8s <- replicateM i $ randNumBound (255 :: Word8)
return $ B.pack w8s
bytes_serialize :: Int -> Bytes -> CList
bytes_serialize _ bs = toCL $ map (CharChunk . S.word8ToChr) $ B.unpack bs
type instance PadsArg Bytes = Int
type instance Meta Bytes = Bytes_md
instance Pads1 Int Bytes Bytes_md where
parsePP1 = bytes_parseM
printFL1 = bytes_printFL
def1 i = bytes_def i
mkStr c = "'" ++ [c] ++ "'"
md = Base_md 0 Nothing