diff --git a/AUTHORS b/AUTHORS new file mode 100644 --- /dev/null +++ b/AUTHORS @@ -0,0 +1,1 @@ +fr33domlover diff --git a/COPYING b/COPYING new file mode 100644 --- /dev/null +++ b/COPYING @@ -0,0 +1,121 @@ +Creative Commons Legal Code + +CC0 1.0 Universal + + CREATIVE COMMONS CORPORATION IS NOT A LAW FIRM AND DOES NOT PROVIDE + LEGAL SERVICES. DISTRIBUTION OF THIS DOCUMENT DOES NOT CREATE AN + ATTORNEY-CLIENT RELATIONSHIP. CREATIVE COMMONS PROVIDES THIS + INFORMATION ON AN "AS-IS" BASIS. CREATIVE COMMONS MAKES NO WARRANTIES + REGARDING THE USE OF THIS DOCUMENT OR THE INFORMATION OR WORKS + PROVIDED HEREUNDER, AND DISCLAIMS LIABILITY FOR DAMAGES RESULTING FROM + THE USE OF THIS DOCUMENT OR THE INFORMATION OR WORKS PROVIDED + HEREUNDER. + +Statement of Purpose + +The laws of most jurisdictions throughout the world automatically confer +exclusive Copyright and Related Rights (defined below) upon the creator +and subsequent owner(s) (each and all, an "owner") of an original work of +authorship and/or a database (each, a "Work"). + +Certain owners wish to permanently relinquish those rights to a Work for +the purpose of contributing to a commons of creative, cultural and +scientific works ("Commons") that the public can reliably and without fear +of later claims of infringement build upon, modify, incorporate in other +works, reuse and redistribute as freely as possible in any form whatsoever +and for any purposes, including without limitation commercial purposes. +These owners may contribute to the Commons to promote the ideal of a free +culture and the further production of creative, cultural and scientific +works, or to gain reputation or greater distribution for their Work in +part through the use and efforts of others. + +For these and/or other purposes and motivations, and without any +expectation of additional consideration or compensation, the person +associating CC0 with a Work (the "Affirmer"), to the extent that he or she +is an owner of Copyright and Related Rights in the Work, voluntarily +elects to apply CC0 to the Work and publicly distribute the Work under its +terms, with knowledge of his or her Copyright and Related Rights in the +Work and the meaning and intended legal effect of CC0 on those rights. + +1. Copyright and Related Rights. A Work made available under CC0 may be +protected by copyright and related or neighboring rights ("Copyright and +Related Rights"). Copyright and Related Rights include, but are not +limited to, the following: + + i. the right to reproduce, adapt, distribute, perform, display, + communicate, and translate a Work; + ii. moral rights retained by the original author(s) and/or performer(s); +iii. publicity and privacy rights pertaining to a person's image or + likeness depicted in a Work; + iv. rights protecting against unfair competition in regards to a Work, + subject to the limitations in paragraph 4(a), below; + v. rights protecting the extraction, dissemination, use and reuse of data + in a Work; + vi. database rights (such as those arising under Directive 96/9/EC of the + European Parliament and of the Council of 11 March 1996 on the legal + protection of databases, and under any national implementation + thereof, including any amended or successor version of such + directive); and +vii. other similar, equivalent or corresponding rights throughout the + world based on applicable law or treaty, and any national + implementations thereof. + +2. Waiver. To the greatest extent permitted by, but not in contravention +of, applicable law, Affirmer hereby overtly, fully, permanently, +irrevocably and unconditionally waives, abandons, and surrenders all of +Affirmer's Copyright and Related Rights and associated claims and causes +of action, whether now known or unknown (including existing as well as +future claims and causes of action), in the Work (i) in all territories +worldwide, (ii) for the maximum duration provided by applicable law or +treaty (including future time extensions), (iii) in any current or future +medium and for any number of copies, and (iv) for any purpose whatsoever, +including without limitation commercial, advertising or promotional +purposes (the "Waiver"). Affirmer makes the Waiver for the benefit of each +member of the public at large and to the detriment of Affirmer's heirs and +successors, fully intending that such Waiver shall not be subject to +revocation, rescission, cancellation, termination, or any other legal or +equitable action to disrupt the quiet enjoyment of the Work by the public +as contemplated by Affirmer's express Statement of Purpose. + +3. Public License Fallback. Should any part of the Waiver for any reason +be judged legally invalid or ineffective under applicable law, then the +Waiver shall be preserved to the maximum extent permitted taking into +account Affirmer's express Statement of Purpose. In addition, to the +extent the Waiver is so judged Affirmer hereby grants to each affected +person a royalty-free, non transferable, non sublicensable, non exclusive, +irrevocable and unconditional license to exercise Affirmer's Copyright and +Related Rights in the Work (i) in all territories worldwide, (ii) for the +maximum duration provided by applicable law or treaty (including future +time extensions), (iii) in any current or future medium and for any number +of copies, and (iv) for any purpose whatsoever, including without +limitation commercial, advertising or promotional purposes (the +"License"). The License shall be deemed effective as of the date CC0 was +applied by Affirmer to the Work. Should any part of the License for any +reason be judged legally invalid or ineffective under applicable law, such +partial invalidity or ineffectiveness shall not invalidate the remainder +of the License, and in such case Affirmer hereby affirms that he or she +will not (i) exercise any of his or her remaining Copyright and Related +Rights in the Work or (ii) assert any associated claims and causes of +action with respect to the Work, in either case contrary to Affirmer's +express Statement of Purpose. + +4. Limitations and Disclaimers. + + a. No trademark or patent rights held by Affirmer are waived, abandoned, + surrendered, licensed or otherwise affected by this document. + b. Affirmer offers the Work as-is and makes no representations or + warranties of any kind concerning the Work, express, implied, + statutory or otherwise, including without limitation warranties of + title, merchantability, fitness for a particular purpose, non + infringement, or the absence of latent or other defects, accuracy, or + the present or absence of errors, whether or not discoverable, all to + the greatest extent permissible under applicable law. + c. Affirmer disclaims responsibility for clearing rights of other persons + that may apply to the Work or any use thereof, including without + limitation any person's Copyright and Related Rights in the Work. + Further, Affirmer disclaims responsibility for obtaining any necessary + consents, permissions or other rights required for any use of the + Work. + d. Affirmer understands and acknowledges that Creative Commons is not a + party to this document and has no duty or obligation with respect to + this CC0 or use of the Work. diff --git a/ChangeLog b/ChangeLog new file mode 100644 --- /dev/null +++ b/ChangeLog @@ -0,0 +1,17 @@ +The changes are recorded by the version control system, Darcs. To see a log +quickly from the terminal, run: + + $ darcs changes --repo http://darcs.rel4tion.org/repos/language-kort + +There is also a web interface at which, among other +things, can display the history log. + +To see the log in a local clone, first get a copy of the repository if you +haven't yet: + + $ darcs get http://darcs.rel4tion.org/repos/language-kort + +Then move into the newly created directory and run darcs: + + $ cd language-kort + $ darcs changes diff --git a/INSTALL b/INSTALL new file mode 100644 --- /dev/null +++ b/INSTALL @@ -0,0 +1,13 @@ +Install from Hackage: + + $ cabal install language-kort + +Install from unpacked release tarball or source repo: + + $ cd language-kort + $ cabal install + +Just play with it without installing: + + $ cabal build + $ cabal repl diff --git a/NEWS b/NEWS new file mode 100644 --- /dev/null +++ b/NEWS @@ -0,0 +1,23 @@ +This file lists the user-visible interesting changes between releases. For a +full list of changes to the source, see the ChangeLog. + + + +language-kort 0.1.0.0 -- 2015-06-18 +=================================== + +General, build and documentation changes: + +* (This is the first release, so everything is new) + +New APIs, features and enhancements: + +* (This is the first release, so everything is a new feature) + +Bug fixes: + +* (This is just the first release, many bugs haven't been discovered yet) + +Dependency changes: + +* (This is the first release) diff --git a/README b/README new file mode 100644 --- /dev/null +++ b/README @@ -0,0 +1,16 @@ +See the .cabal file for more info and link to project website the version +control. + +The official download locations are: + +- Hackage +- The project website +- Torrents + +This library is free software, and is committed to software freedom. It is +released to the public domain using the CC0 Public Domain Dedication. For the +boring "legal" details see the file 'COPYING'. + +See the file 'INSTALL' for hints on installation. The file 'ChangeLog' explains +how to see the history log of the changes done in the code. 'NEWS' provides a +friendly overview of the changes for each release. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/language-kort.cabal b/language-kort.cabal new file mode 100644 --- /dev/null +++ b/language-kort.cabal @@ -0,0 +1,57 @@ +name: language-kort +version: 0.1.0.0 +synopsis: Parser and serializer for the Kort information language. +description: This package provides a library containing all the + necessary tools for working with Kort files, allowing + programs to load and save semantic data. +homepage: http://rel4tion.org/projects/language-kort/ +bug-reports: http://rel4tion.org/projects/language-kort/tickets/ +license: PublicDomain +license-file: COPYING +author: fr33domlover +maintainer: fr33domlover@riseup.net +copyright: ♡ Copying is an act of love. Please copy, reuse and share. +category: Language +build-type: Simple +extra-source-files: AUTHORS ChangeLog COPYING INSTALL NEWS README +cabal-version: >=1.10 + +source-repository head + type: darcs + location: http://darcs.rel4tion.org/repos/language-kort/ + +library + exposed-modules: Language.Kort + , Language.Kort.Parser + , Language.Kort.Types + , Language.Kort.UidGen + , Language.Kort.Writer + -- other-modules: + -- other-extensions: + build-depends: base >=4.7 && <5 + , base64-bytestring >=1.0 + , bytestring >=0.10 + , random >=1.1 + , razom-text-util >=0.1.2 + , regex-applicative >=0.3.1 + , smaoin >=0.3 + , text >=1.2 + , text-position >=0.1 + , vocabulary-kadma >=0.1 + , utf8-string >=1 + hs-source-dirs: src + default-language: Haskell2010 + +test-suite test + default-language: Haskell2010 + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: test.hs + other-modules: Input + build-depends: base + , bytestring + , QuickCheck >=2.8 + , language-kort + , smaoin + , text + , vocabulary-kadma diff --git a/src/Language/Kort.hs b/src/Language/Kort.hs new file mode 100644 --- /dev/null +++ b/src/Language/Kort.hs @@ -0,0 +1,27 @@ +{- This file is part of language-kort. + - + - Written in 2015 by fr33domlover . + - + - ♡ Copying is an act of love. Please copy, reuse and share. + - + - The author(s) have dedicated all copyright and related and neighboring + - rights to this software to the public domain worldwide. This software is + - distributed without any warranty. + - + - You should have received a copy of the CC0 Public Domain Dedication along + - with this software. If not, see + - . + -} + +module Language.Kort + ( module Language.Kort.Parser + , module Language.Kort.Types + , module Language.Kort.UidGen + , module Language.Kort.Writer + ) +where + +import Language.Kort.Parser +import Language.Kort.Types +import Language.Kort.UidGen +import Language.Kort.Writer diff --git a/src/Language/Kort/Parser.hs b/src/Language/Kort/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Language/Kort/Parser.hs @@ -0,0 +1,232 @@ +{- This file is part of language-kort. + - + - Written in 2015 by fr33domlover . + - + - ♡ Copying is an act of love. Please copy, reuse and share. + - + - The author(s) have dedicated all copyright and related and neighboring + - rights to this software to the public domain worldwide. This software is + - distributed without any warranty. + - + - You should have received a copy of the CC0 Public Domain Dedication along + - with this software. If not, see + - . + -} + +module Language.Kort.Parser + ( parseString + , parseText + , parseFile + , toSmaoinValue + , toSmaoinModel + ) +where + +import Control.Exception (assert) +import qualified Data.ByteString.Base64.Lazy as B64 +import qualified Data.ByteString.Lazy as BL +import qualified Data.ByteString.Lazy.Char8 as BLC +import Data.Char +import Data.Either (rights) +import Data.Maybe (catMaybes) +import Data.Position (Advance, commonAdvance) +import qualified Data.Smaoin as S +import qualified Data.Smaoin.Vocabulary.Smaoin as V.Smaoin +import Data.Ratio ((%)) +import qualified Data.Text.Lazy as T +import Language.Kort.Types +import Language.Kort.UidGen +import Text.Razom.Char +import Text.Razom.Lexer +import Text.Razom.Number +import Text.Razom.Uid +import Text.Razom.Value +import Text.Razom.Types +import Text.Regex.Applicative + +value :: Regex Element +value = Value <$> literal <* string "::" <*> resource + +resource :: Regex Resource +resource = Uid <$> uid <|> f <$> generator + where + f s = if null s then UGenerator else LGenerator s + +element :: Regex Element +element = Resource <$> resource <|> value + +statement :: Regex Statement +statement = Statement <$> resource <* sep <*> resource <*> elements + where + sep = some $ sym '\t' + elements = some $ sep *> element + +comment :: Regex Comment +comment = string "--" *> many (sym '-') *> many cspace *> many cchar + where + cspace = psym $ \ c -> isSpace c && c /= '\n' + cchar = psym $ \ c -> isGraphical c || c == '\t' + +line :: Regex Line +line = (Left <$> comment <|> Right <$> statement) <* sym '\n' + +adv :: Advance Char +adv = commonAdvance 8 False True False False + +-- | Parse Kort source text from a 'String'. +parseString :: String -> ParseResult +parseString = tokenizeString adv line + +-- | Parse Kort source text from 'T.Text'. +parseText :: T.Text -> ParseResult +parseText = tokenizeText adv line + +-- | Parse Kort source text read from a file. +parseFile :: FilePath -> IO ParseResult +parseFile = tokenizeFile adv line + +-- | Matches a boolean Smaoin literal body and returns the value. +boolean :: Regex Bool +boolean = True <$ string "[x]" <|> False <$ string "[_]" + +-- | Matches a Smaoin hex number literal body and returns the value. +hex :: Regex Integer +hex = string "0x" *> hexadecimal + +-- | Matches a Smaoin real number literal body and returns the value. +real :: Regex S.RealNum +real = signed $ (\ b e -> b * S.realnum 1 e) <$> realbase <*> realexp + where + realbase = f <$> some digit <*> optional (sym '.' *> some digit) + f ns Nothing = fromDigits ns [] + f ns (Just fs) = fromDigits ns fs + realexp = g <$> optional (sym '$' *> signed decimal) + g Nothing = 0 + g (Just n) = n + +-- | Matches a Smaoin rational number literal body and returns 'Just' the +-- value. If the matched denominator is 0, it returns 'Nothing'. +ratio :: Regex (Maybe S.Rational) +ratio = f <$> signed decimal <*> (sym '/' *> decimal) + where + f _ 0 = Nothing + f n d = Just $ n % d + +-- | Matches a Smaoin character literal body and returns the value. +character :: Regex Char +character = chardirect <|> sym '\\' *> (charesc <|> numesc) + where + chardirect = psym $ \ c -> isGraphical c && c `notElem` "{}\\" + charesc = psym (`elem` "{}\\") + numesc = sym 'x' *> (chr <$> hexadecimal) + +-- | Matches a Smaoin string literal body and returns the value. +stringl :: Regex String +stringl = catMaybes <$> many (chardirect <|> sym '\\' *> (charesc <|> numesc)) + where + chardirect = Just <$> psym (\ c -> isGraphical c && c `notElem` "{}\\") + charesc = Just <$> psym (`elem` "{}\\") <|> Nothing <$ sym '&' + numesc = sym 'x' *> (Just . chr <$> hexadecimal) + +-- | Matches a Smaoin data base64 encoded literal body, and returns the decoded +-- value. +chunk :: Regex BL.ByteString +chunk = (\ c p -> f $ c ++ p) <$> many chunkchar <*> padding + where + chunkchar = psym $ \ c -> isAsciiUpper c || isAsciiLower c || isDigit c + || c == '+' || c == '/' + padc = sym '=' + padding = snd <$> withMatched (optional (padc *> optional padc)) + -- The regex is supposed to ensure we got a valid base64 string, so + -- decoding must succeed. If it ever doesn't, there's an implementation + -- error here. Therefore, use an assertion to signal a failure. + f s = + case B64.decode $ BLC.pack s of + Right b -> b + Left e -> assert False BL.empty + +-- | Parse a Kort literal into a typed value. Return an error message if the +-- literal body format doesn't match the type. +toSmaoinValue :: String -> S.Resource -> Either String S.Value +toSmaoinValue s r + | r == V.Smaoin._Boolean = + case match boolean s of + Just b -> Right $ S.Boolean b + Nothing -> Left "Invalid boolean literal" + | r == V.Smaoin._Number = + case (match hex s, match real s, match ratio s) of + (Just n, _, _) -> + Right $ S.Number $ S.RealNumber $ fromInteger n + (Nothing, Just n, _) -> + Right $ S.Number $ S.RealNumber n + (Nothing, Nothing, Just x) -> + case x of + Just n -> + Right $ S.Number $ S.RatioNumber n + Nothing -> + Left "Rational number literal with denominator 0" + (Nothing, Nothing, Nothing) -> + Left "Number literal doesn't match any of the formats" + | r == V.Smaoin._Character = + case match character s of + Just c -> Right $ S.Character c + Nothing -> Left "Invalid character literal" + | r == V.Smaoin._String = + case match stringl s of + Just s' -> Right $ S.String $ T.pack s' + Nothing -> Left "Invalid string literal" + | r == V.Smaoin._Data = + case match chunk s of + Just d -> Right $ S.Chunk d + Nothing -> Left "Invalid data literal" + | otherwise = Right $ S.Generic (T.pack s) r + +data Problem = NotTwo | HasGen | NotRes | InvVal + +-- | Convert from the Kort document model to a list of Smaoin statements. +-- +-- This function doesn't handle Uid generation or other shortcuts. It just +-- collects statements invalid for Smaoin and statements with generators into +-- separate lists. If you want Uids to be generated, use the functions in +-- "Language.Kort.UidGen". +-- +-- 5 lists are returned: +-- +-- (1) Kort statements which don't have exactly 2 elements +-- (2) Kort statements with 2 elements, but containing generators +-- (3) Kort statements with 2 elements, but the 1st is a value, not a resource +-- (4) Kort statement with 2 elements, but invalid object value +-- (5) Successfully converted Smaoin statements +-- +-- Kort comments are ignored and dropped. +toSmaoinModel + :: Document + -> ([Statement], [Statement], [Statement], [Statement], [S.Statement]) +toSmaoinModel doc = g (rights doc) ([], [], [], [], []) + where + isVal (Resource _) = False + isVal (Value _ _) = True + f (Statement (Uid i) (Uid p) [Resource (Uid s), e]) = + case e of + Resource (Uid o) -> Right $ mk $ S.ResourceE $ S.res o + Resource _ -> Left HasGen + Value l (Uid t) -> + case toSmaoinValue l (S.res t) of + Right v -> Right $ mk $ S.ValueE v + Left _ -> Left InvVal + Value l _ -> Left HasGen + where + mk = S.Statement (S.res i) (S.res s) (S.res p) + f s@(Statement i r e) + | length e /= 2 = Left NotTwo + | stmtHasGens s = Left HasGen + | isVal $ head e = Left NotRes + | otherwise = error "Implementation error" + g [] t = t + g (s:ss) (nottwo, hasgen, notres, invval, l) = + case f s of + Right stmt -> g ss (nottwo, hasgen, notres, invval, stmt:l) + Left NotTwo -> g ss (s:nottwo, hasgen, notres, invval, l) + Left HasGen -> g ss (nottwo, s:hasgen, notres, invval, l) + Left NotRes -> g ss (nottwo, hasgen, s:notres, invval, l) + Left InvVal -> g ss (nottwo, hasgen, notres, s:invval, l) diff --git a/src/Language/Kort/Types.hs b/src/Language/Kort/Types.hs new file mode 100644 --- /dev/null +++ b/src/Language/Kort/Types.hs @@ -0,0 +1,73 @@ +{- This file is part of language-kort. + - + - Written in 2015 by fr33domlover . + - + - ♡ Copying is an act of love. Please copy, reuse and share. + - + - The author(s) have dedicated all copyright and related and neighboring + - rights to this software to the public domain worldwide. This software is + - distributed without any warranty. + - + - You should have received a copy of the CC0 Public Domain Dedication along + - with this software. If not, see + - . + -} + +module Language.Kort.Types + ( Resource (..) + , Element (..) + , Comment + , Statement (..) + , Line (..) + , Document + , ParseError (..) + , ParseResult (..) + , UidMap + ) +where + +import Text.Razom.Types + +-- | A resource, either an actual Uid or a placeholder. +data Resource + -- | A resource Uid. + = Uid String + -- | A generator with a label. When generating Uids to fill the + -- placeholders, generators with the same label get assigned the same Uid. + | LGenerator String + -- | A unique generator. When generating Uids, it will get assigned its own + -- unique Uid. + | UGenerator + deriving (Eq, Show) + +-- | A statement element, i.e. a relation tuple member. Either a resource or a +-- value with a literal and a type resource. +data Element = Resource Resource | Value String Resource deriving (Eq, Show) + +-- | Kort comment line. +type Comment = String + +-- | A tuple of arbitrary arity, which is a member of a given relation. +-- Parameters: +-- +-- (1) Identifier +-- (2) Relation +-- (3) Elements: subject, object, etc. +data Statement = Statement Resource Resource [Element] deriving (Eq, Show) + +-- | A Kort line. Either a comment or an arbitrary-arity statement. +type Line = Either Comment Statement + +-- | A Kort document, represented as a list of lines. Note that in Kort the +-- order of lines is semantically insignificant. +type Document = [Line] + +-- | Returned when the parser fails. +type ParseError = LexError Line + +-- | Returned from the parser. Provides either the parsed line, or error +-- information. +type ParseResult = LexResult Line + +-- | A structure storing generated Uids for insertion to placeholders. +type UidMap = ([(String, String)], [String]) diff --git a/src/Language/Kort/UidGen.hs b/src/Language/Kort/UidGen.hs new file mode 100644 --- /dev/null +++ b/src/Language/Kort/UidGen.hs @@ -0,0 +1,142 @@ +{- This file is part of language-kort. + - + - Written in 2015 by fr33domlover . + - + - ♡ Copying is an act of love. Please copy, reuse and share. + - + - The author(s) have dedicated all copyright and related and neighboring + - rights to this software to the public domain worldwide. This software is + - distributed without any warranty. + - + - You should have received a copy of the CC0 Public Domain Dedication along + - with this software. If not, see + - . + -} + +module Language.Kort.UidGen + ( stmtHasGens + , docHasGens + , generateResources + , generateResourcesIO + , sweepGenerators + ) +where + +import Control.Monad (liftM) +import Data.ByteString.Char8 (unpack) +import Data.List (mapAccumL, nub) +import Data.Monoid +import qualified Data.Smaoin as S +import Language.Kort.Types +import System.Random + +-- | Check if a statement has generators. +stmtHasGens :: Statement -> Bool +stmtHasGens (Statement i r e) = isGen i || isGen r || any hasGen e + where + isGen (Uid _) = False + isGen _ = True + hasGen (Resource r) = isGen r + hasGen (Value s r) = isGen r + +-- | Check if a document has generators. +docHasGens :: Document -> Bool +docHasGens = any p + where + p (Right s) = stmtHasGens s + p (Left _) = False + +-- Make a list of unique generator labels and the number of unlabeled +-- generators in the document. +collectGens :: Document -> ([String], Int) +collectGens ls = k $ mconcat [h i r e | Right (Statement i r e) <- ls] + where + p UGenerator = True + p _ = False + m (Resource r) = r + m (Value s r) = r + f rs = ([s | LGenerator s <- rs], Sum $ length $ filter p rs) + g els = f $ map m els + h i r e = g $ Resource i : Resource r : e + k (l, n) = (nub l, getSum n) + +-- Generate a list of a given length containing fresh new unique Uids. +genUids :: RandomGen g => Int -> g -> ([String], g) +genUids n = f n [] + where + f 0 ss g = (ss, g) + f n ss g = + let (s, g') = (\ (S.Resource r, g) -> (unpack r, g)) $ random g + in f (n - 1) (s:ss) g' + +-- Return a Uid for a resource - either the existing one or a newly generated +-- one if a generator is given +genResOne :: UidMap -> Resource -> (UidMap, String) +genResOne um (Uid s) = (um, s) +genResOne (lu, uu) (LGenerator s) = + case lookup s lu of + Just u -> ((lu, uu), u) + Nothing -> error "genResOne impl error" +genResOne (lu, uu:uus) UGenerator = ((lu, uus), uu) +genResOne _ _ = error "genResOne impl error" + +-- Apply function to first element of pair +applyFst :: (a -> c) -> (a, b) -> (c, b) +applyFst f (x, y) = (f x, y) + +-- Apply function to second element of pair +applySnd :: (b -> c) -> (a, b) -> (a, c) +applySnd f (x, y) = (x, f y) + +-- Replace generators with Uids in a single statement +genResStmt :: UidMap -> Statement -> (UidMap, Statement) +genResStmt um (Statement i r e) = (um', Statement i' r' e') + where + (umi, i') = applySnd Uid $ genResOne um i + (umr, r') = applySnd Uid $ genResOne umi r + f um (Resource r) = applySnd (Resource . Uid) $ genResOne um r + f um (Value s r) = applySnd (Value s . Uid) $ genResOne um r + (um', e') = mapAccumL f umr e + +-- Create Uid map with generated Uids for given document +makeMap :: RandomGen g => Document -> g -> (UidMap, g) +makeMap doc g = + let (ls, n) = collectGens doc + (lu, g') = genUids (length ls) g + (uu, g'') = genUids n g' + in ((zip ls lu, uu), g'') + +-- | Replace generators with newly generated unique resources. +generateResources :: RandomGen g => Document -> g -> (Document, g) +generateResources doc g = + let f m l@(Left _) = (m, l) + f m (Right stmt) = applySnd Right $ genResStmt m stmt + (m, g') = makeMap doc g + in (snd $ mapAccumL f m doc, g') + +-- | Like 'generateResources', but uses specifically the global system random +-- generator. +generateResourcesIO :: Document -> IO Document +generateResourcesIO doc = liftM (fst . generateResources doc) getStdGen + +-- Return a Uid for a resource - either the existing one or a blank one if a +-- generator is given +cleanGensOne :: Resource -> Resource +cleanGensOne r@(Uid _) = r +cleanGensOne (LGenerator s) = Uid "?" +cleanGensOne UGenerator = Uid "?" + +-- Replace generators with dummy Uids in a single statement +cleanGensStmt :: Statement -> Statement +cleanGensStmt (Statement i r e) = + Statement (cleanGensOne i) (cleanGensOne r) (map f e) + where + f (Resource r) = Resource $ cleanGensOne r + f (Value s r) = Value s $ cleanGensOne r + +-- | Replace generators with dummy resource Uids (ASCII question marks). +sweepGenerators :: Document -> Document +sweepGenerators = map f + where + f l@(Left _) = l + f (Right s) = Right $ cleanGensStmt s diff --git a/src/Language/Kort/Writer.hs b/src/Language/Kort/Writer.hs new file mode 100644 --- /dev/null +++ b/src/Language/Kort/Writer.hs @@ -0,0 +1,154 @@ +{- This file is part of language-kort. + - + - Written in 2015 by fr33domlover . + - + - ♡ Copying is an act of love. Please copy, reuse and share. + - + - The author(s) have dedicated all copyright and related and neighboring + - rights to this software to the public domain worldwide. This software is + - distributed without any warranty. + - + - You should have received a copy of the CC0 Public Domain Dedication along + - with this software. If not, see + - . + -} + +module Language.Kort.Writer + ( writeString + , writeText + , writeFile + , fromSmaoinValue + , fromSmaoinModel + ) +where + +import Prelude hiding (writeFile) +import qualified Data.ByteString.Base64.Lazy as B64 +import qualified Data.ByteString.Lazy as BL +import qualified Data.ByteString.Lazy.Char8 as BLC +import qualified Data.ByteString as BS +import qualified Data.ByteString.UTF8 as BU +import Data.Char (ord) +import Data.Either (either) +import Data.List (intersperse, lines) +import Data.Monoid +import Data.Ratio (numerator, denominator) +import qualified Data.Smaoin as S +import qualified Data.Smaoin.Vocabulary.Smaoin as V.Smaoin +import qualified Data.Text.Lazy as T +import qualified Data.Text.Lazy.Builder as TB +import qualified Data.Text.Lazy.Encoding as TE +import Language.Kort.Types +import Numeric (showHex) +import Text.Razom.Char (isGraphical) +import Text.Razom.Uid (escapeUid) + +wrapRes = (TB.singleton '<' <>) . (<> TB.singleton '>') + +writeResource :: Resource -> TB.Builder +writeResource (Uid s) = wrapRes $ TB.fromString $ escapeUid s +writeResource (LGenerator l) = wrapRes $ TB.singleton '%' <> TB.fromString l +writeResource UGenerator = wrapRes $ TB.singleton '%' + +writeElement :: Element -> TB.Builder +writeElement (Resource r) = writeResource r +writeElement (Value s r) = + TB.fromString "{{" <> + TB.fromString s <> + TB.fromString "}}::" <> + writeResource r + +writeStatement (Statement i r e) = + mconcat $ intersperse (TB.singleton '\t') $ + writeResource i : writeResource r : map writeElement e + +-- Split in newlines and replace other comment-invalid characters +writeComment :: String -> TB.Builder +writeComment s = mconcat $ (TB.fromString "-- " :) $ + map TB.fromString . + intersperse "\n-- " . + lines . + map (\ c -> if isGraphical c || c == '\t' || c == '\n' + then c else '\xfffd') $ + s + +writeLine :: Line -> TB.Builder +writeLine = either writeComment writeStatement + +-- | Write Kort model into a 'String'. +writeString :: Document -> String +writeString = T.unpack . writeText + +-- | Write Kort model into 'T.Text'. +writeText :: Document -> T.Text +writeText = TB.toLazyText . mconcat . map ((<> TB.singleton '\n') . writeLine) + +-- | Write Kort model into a file. +writeFile :: FilePath -> Document -> IO () +writeFile fp = BL.writeFile fp . TE.encodeUtf8 . writeText + +-- Get a Kort boolean literal. +writeBoolean :: Bool -> String +writeBoolean True = "[x]" +writeBoolean False = "[_]" + +-- Get a Kort real number literal. +writeRealNum :: S.RealNum -> String +writeRealNum n = show (S.sig n) ++ '$' : show (S.expo n) + +-- Get a Kort rational number literal. +writeRatio :: S.Rational -> String +writeRatio r = show (numerator r) ++ '/' : show (denominator r) + +-- Get a Kort character literal. +writeCharacter :: Char -> String +writeCharacter c + | c `elem` "{}\\" = ['\\', c] + | not $ isGraphical c = '\\' : 'x' : showHex (ord c) "" + | otherwise = [c] + +-- Get a Kort string literal. +writeStringL :: T.Text -> String +writeStringL = concatMap f . T.unpack + where + f c | c `elem` "{}\\" = ['\\', c] + | not $ isGraphical c = '\\' : 'x' : showHex (ord c) "\&" + | otherwise = [c] + +-- Get a Kort data literal. +writeChunk :: BL.ByteString -> String +writeChunk = BLC.unpack . B64.encode + +-- | Write a Smaoin value as a Kort literal. +fromSmaoinValue :: S.Value -> (String, S.Resource) +fromSmaoinValue (S.Boolean b) = (writeBoolean b, V.Smaoin._Boolean) +fromSmaoinValue (S.Number x) = + case x of + S.RealNumber n -> (writeRealNum n, V.Smaoin._Number) + S.RatioNumber n -> (writeRatio n, V.Smaoin._Number) +fromSmaoinValue (S.Character c) = (writeCharacter c, V.Smaoin._Character) +fromSmaoinValue (S.String s) = (writeStringL s, V.Smaoin._String) +fromSmaoinValue (S.Chunk d) = (writeChunk d, V.Smaoin._Data) +fromSmaoinValue (S.Generic t r) = (T.unpack t, r) + +fromSmaoinResource :: S.Resource -> Resource +fromSmaoinResource (S.Resource r) = Uid $ BU.toString r + +fromSmaoinEntity :: S.Entity -> Element +fromSmaoinEntity (S.ResourceE r) = Resource $ fromSmaoinResource r +fromSmaoinEntity (S.ValueE v) = + let (s, r) = fromSmaoinValue v + in Value s (fromSmaoinResource r) + +fromSmaoinStatement :: S.Statement -> Statement +fromSmaoinStatement (S.Statement i s p o) = + Statement + (fromSmaoinResource i) + (fromSmaoinResource p) + [ Resource $ fromSmaoinResource s + , fromSmaoinEntity o + ] + +-- | Write a Smaoin model as a Kort document. +fromSmaoinModel :: [S.Statement] -> Document +fromSmaoinModel = map $ Right . fromSmaoinStatement diff --git a/test/Input.hs b/test/Input.hs new file mode 100644 --- /dev/null +++ b/test/Input.hs @@ -0,0 +1,171 @@ +{- This file is part of language-kort. + - + - Written in 2015 by fr33domlover . + - + - ♡ Copying is an act of love. Please copy, reuse and share. + - + - The author(s) have dedicated all copyright and related and neighboring + - rights to this software to the public domain worldwide. This software is + - distributed without any warranty. + - + - You should have received a copy of the CC0 Public Domain Dedication along + - with this software. If not, see + - . + -} + +module Input where + +import qualified Data.ByteString.Char8 as BSC +import qualified Data.Smaoin as S +import qualified Data.Smaoin.Vocabulary.Smaoin as VS +import Language.Kort + +-- Possible judgements of parser about a Kort line +data Status = Clean | NotTwo | HasGen | NotRes | InvVal | Drop + deriving (Eq, Show) + +-- Kort lines, expected parser judgements and whether they have no generators +type Record = (Line, Status, Bool) + +input :: [Record] +input = + [ (cmnt "Top comment", Drop, True) + +{- -- 0 elements - invalid in Kort, must have at least 1 + -- clean + , (stmt (u "i0.1") (u "r0.1") [], NotTwo, True) + -- hasgen + , (stmt (lg "l1") (u "r0.2") [], NotTwo, False) + , (stmt (u "i0.3") ug [], NotTwo, False) + , (stmt ug (lg "l2") [], NotTwo, False) +-} + -- 1 element + -- clean + , (stmt (u "i1.1") (u "r1.1") [ru "a1.1"], NotTwo, True) + -- hasgen + , (stmt (u "i1.2") (lg "l2") [rug], NotTwo, False) + , (stmt ug (u "r1.3") [rlg "l1"], NotTwo, False) + , (stmt (lg "l3") ug [rug], NotTwo, False) + , (stmt ug (lg "l4") [ru "a1.5"], NotTwo, False) + -- notres + , (stmt (u "i1.6") (u "r1.6") [vu "v" "t1.6"], NotTwo, True) + -- hasgen, notres + , (stmt (u "i1.7") (lg "l2") [vu "v" "t1.7"], NotTwo, False) + , (stmt ug (u "r1.8") [vlg "v" "l1"], NotTwo, False) + , (stmt (lg "l3") ug [vug "v"], NotTwo, False) + , (stmt ug (lg "l4") [vu "v" "t1.A"], NotTwo, False) + -- notres, invval + , (stmt (u "i1.B") (u "r1.B") [vbool "c"], NotTwo, True) + , (stmt (u "i1.C") (u "r1.C") [vchar "xy"], NotTwo, True) + , (stmt (u "i1.D") (u "r1.D") [vstr "\\x"], NotTwo, True) + , (stmt (u "i1.E") (u "r1.E") [vnum "A/+"], NotTwo, True) + , (stmt (u "i1.F") (u "r1.F") [vdata "[x]"], NotTwo, True) + -- hasgen, notres, invval + , (stmt (u "i1.G") (lg "l2") [vbool "A/+"], NotTwo, False) + , (stmt ug (u "r1.H") [vchar "[+]"], NotTwo, False) + , (stmt (lg "l3") ug [vstr "\\x"], NotTwo, False) + , (stmt ug (lg "l4") [vnum "xyz"], NotTwo, False) + , (stmt ug ug [vdata "-5/7"], NotTwo, False) + + , (cmnt "Middle\ncomment", Drop, True) + + -- 2 elements + -- clean + , (stmt (u "i2.1") (u "r2.1") [ru "a2.1", ru "b2.1"], Clean, True) + , (stmt (u "i2.2") (u "r2.2") [ru "a2.2", vbool "[_]"], Clean, True) + , (stmt (u "i2.3") (u "r2.3") [ru "a2.3", vchar "\\xa"], Clean, True) + , (stmt (u "i2.4") (u "r2.4") [ru "a2.4", vstr "x\\xaz"], Clean, True) + , (stmt (u "i2.5") (u "r2.5") [ru "a2.5", vnum "4$-6"], Clean, True) + , (stmt (u "i2.6") (u "r2.6") [ru "a2.6", vdata "Ab+5"], Clean, True) + , (stmt (u "i2.7") (u "r2.7") [ru "a2.7", vu "v" "s2.2"], Clean, True) + -- hasgen + , (stmt (u "i2.8") (lg "l4") [ru "a2.8", ru "b2.8"], HasGen, False) + , (stmt ug (u "r2.9") [ru "a2.9", vbool "[_]"], HasGen, False) + , (stmt (u "i2.A") ug [ru "a2.A", vchar "\\xA"], HasGen, False) + , (stmt ug (lg "l2") [ru "a2.B", vstr "x\\xAz"], HasGen, False) + , (stmt (lg "l3") ug [ru "a2.C", vnum "4$-6"], HasGen, False) + , (stmt ug (u "r2.D") [ru "a2.D", vdata "Ab+5"], HasGen, False) + , (stmt (u "i2.E") (u "r2.E") [rug, vu "v" "s2.E"], HasGen, False) + , (stmt (u "i2.F") (lg "l2") [rug, vu "v" "s2.F"], HasGen, False) + , (stmt ug (u "r2.G") [rlg "l1", ru "b2.G"], HasGen, False) + , (stmt (lg "l3") ug [ru "a2.H", rug], HasGen, False) + , (stmt ug (lg "l4") [rlg "l5", ru "a2.I"], HasGen, False) + , (stmt (u "i2.J") (lg "l2") [ru "a2.J", rug], HasGen, False) + , (stmt ug (u "r2.K") [ru "a2.J", rlg "l1"], HasGen, False) + , (stmt (lg "l3") ug [rlg "a2.L", rug], HasGen, False) + , (stmt ug (lg "l4") [ru "a2.M", rlg "l4"], HasGen, False) + , (stmt (u "i2.N") (lg "l2") [ru "a2.N", vug "l5"], HasGen, False) + , (stmt ug (u "r2.O") [ru "a2.O", vlg "v" "l1"], HasGen, False) + , (stmt (lg "l3") ug [rlg "a2.P", vug "l2"], HasGen, False) + , (stmt ug (lg "l4") [ru "a2.Q", vlg "v" "l4"], HasGen, False) + -- notres + , (stmt (u "i2.R") (u "r2.R") [vu "v" "t2.R", ru "b2.R"], NotRes, True) + , (stmt (u "i2.S") (u "r2.S") [vu "v" "t2.S", vbool "?"], NotRes, True) + , (stmt (u "i2.T") (u "r2.T") [vnum "x", vdata "A"], NotRes, True) + , (stmt (u "i2.U") (u "r2.U") [vchar "v", ru "b2.U"], NotRes, True) + -- invval + , (stmt (u "i2.V") (u "r2.V") [ru "a2.V", vbool "x\\xAz"], InvVal, True) + , (stmt (u "i2.W") (u "r2.W") [ru "a2.W", vchar "4$-6"], InvVal, True) + , (stmt (u "i2.X") (u "r2.X") [ru "a2.X", vstr "x\\x"], InvVal, True) + , (stmt (u "i2.Y") (u "r2.Y") [ru "a2.Y", vnum "[_]"], InvVal, True) + , (stmt (u "i2.Z") (u "r2.Z") [ru "a2.Z", vdata "%"], InvVal, True) + -- hasgen, notres + , (stmt (u "i2.a") (lg "l2") [vu "v" "t2.a", rug], HasGen, False) + , (stmt ug (u "r2.b") [vlg "v" "l1", ru "b2.b"], HasGen, False) + , (stmt (lg "l3") ug [vug "v", vchar "a"], HasGen, False) + , (stmt ug (lg "l4") [vu "v" "t2.d", rlg "l1"], HasGen, False) + -- notres, invval + , (stmt (u "i2.e") (u "r2.e") [vbool "c", ru "a2.e"], NotRes, True) + , (stmt (u "i2.f") (u "r2.f") [vchar "xy", vu "v" "s2.e"], NotRes, True) + , (stmt (u "i2.g") (u "r2.g") [vstr "\\x", vu "v" "s2.g"], NotRes, True) + , (stmt (u "i2.h") (u "r2.h") [vnum "A/+", ru "a2.h"], NotRes, True) + , (stmt (u "i2.i") (u "r2.i") [vdata "[x]", vu "v" "s2.i"], NotRes, True) + , (stmt (u "i2.j") (u "r2.j") [vbool "[x]", vchar "xy"], NotRes, True) + , (stmt (u "i2.k") (u "r2.k") [vchar "x", vstr "\\x"], NotRes, True) + , (stmt (u "i2.l") (u "r2.l") [vstr "xy", vnum "A/+"], NotRes, True) + , (stmt (u "i2.m") (u "r2.m") [vnum "0xA", vdata "[x]"], NotRes, True) + , (stmt (u "i2.n") (u "r2.n") [vdata "/4z", vbool "c"], NotRes, True) + -- hasgen, notres, invval + , (stmt (u "i2.o") (lg "l2") [vbool "A/+", rug], HasGen, False) + , (stmt ug (u "r.p") [vchar "[+]", vlg "v" "l6"], HasGen, False) + , (stmt (lg "l3") ug [vstr "\\x", vu "v" "s2.q"], HasGen, False) + , (stmt ug (lg "l4") [vnum "xyz", vug "v"], HasGen, False) + , (stmt ug ug [vdata "-5/7", rlg "l6"], HasGen, False) + , (stmt (u "i2.t") (u "r2.t") [vbool "A/+", rug], HasGen, False) + , (stmt (u "i2.u") (u "r2.u") [vchar "[+]", vlg "v" "l6"], HasGen, False) + , (stmt (lg "l3") ug [vstr "\\x", vu "v" "s2.v"], HasGen, False) + , (stmt (u "i2.w") (u "r2.w") [vnum "xyz", vug "v"], HasGen, False) + , (stmt (u "i2.x") (u "r2.x") [vdata "-5/7", rlg "l6"], HasGen, False) + + -- 3+ elements + , (stmt (u "i3.1") (u "r3.1") [ru"a3.1",ru"b3.1",ru"c3.1"], NotTwo, True) + , (stmt (u "i3.2") (u "r3.2") [ru"a3.2",ru"b3.2",rlg"l4"], NotTwo, False) + , (stmt (u "i3.3") (lg "l6") [ru"a3.3",ru"b3.3",ru"c3.3"], NotTwo, False) + , (stmt (u "i3.4") (u "r3.4") [vbool"5",ru"b3.4",ru"c3.4"], NotTwo, True) + , (stmt (u "i3.5") (u "r3.5") [ru"a3.5",vnum"a",ru"c3.5"], NotTwo, True) + , (stmt (u "i3.6") (u "r3.6") [vdata"$",ru"b3.6",vchar"xy"], NotTwo, True) + , (stmt (u "i3.7") (u "r3.7") (replicate 10 (ru "x3.7")), NotTwo, True) + , (stmt (u "i3.8") (u "r3.8") (replicate 10 (vug "v")), NotTwo, False) + , (stmt (u "i3.9") (u "r3.9") (replicate 10 (vchar "v")), NotTwo, True) + , (stmt (u "i3.A") ug (replicate 10 (vchar "vw")), NotTwo, False) + + , (cmnt "Bottom\rcomment", Drop, True) + ] + where + cmnt = Left + stmt i r e = Right $ Statement i r e + ru = Resource . Uid + lg = LGenerator + ug = UGenerator + u = Uid + rlg = Resource . LGenerator + rug = Resource UGenerator + vu v t = Value v (Uid t) + vlg v l = Value v (LGenerator l) + vug v = Value v UGenerator + from (S.Resource r) = Uid $ BSC.unpack r + vbool v = Value v $ from VS._Boolean + vchar v = Value v $ from VS._Character + vstr v = Value v $ from VS._String + vnum v = Value v $ from VS._Number + vdata v = Value v $ from VS._Data diff --git a/test/test.hs b/test/test.hs new file mode 100644 --- /dev/null +++ b/test/test.hs @@ -0,0 +1,251 @@ +{- This file is part of language-kort. + - + - Written in 2015 by fr33domlover . + - + - ♡ Copying is an act of love. Please copy, reuse and share. + - + - The author(s) have dedicated all copyright and related and neighboring + - rights to this software to the public domain worldwide. This software is + - distributed without any warranty. + - + - You should have received a copy of the CC0 Public Domain Dedication along + - with this software. If not, see + - . + -} + +import Control.Monad (unless) +import Data.Either (either, rights) +import qualified Data.Smaoin as S +import qualified Data.Text.Lazy as T +import Language.Kort +import System.Exit +import Test.QuickCheck +import Test.QuickCheck.Test +import Text.Printf + +import Input + +------------------------------------------------------------------------------- +-- Run all tests: > cabal test +-- Debug and play with tests and utilities: > cabal repl test +------------------------------------------------------------------------------- + +type Lists = + ([Statement], [Statement], [Statement], [Statement], [S.Statement]) + +notTwo (l, _, _, _, _) = l +hasGen (_, l, _, _, _) = l +notRes (_, _, l, _, _) = l +invVal (_, _, _, l, _) = l +stmts (_, _, _, _, l) = l + +reverseLists :: Lists -> Lists +reverseLists (nt, hg, nr, iv, s) = + ( reverse nt + , reverse hg + , reverse nr + , reverse iv + , reverse s + ) + +printLists :: Lists -> IO () +printLists (nt, hg, nr, iv, s) = + mapM_ (mapM_ print) [nt, hg, nr, iv] >> mapM_ print s + +inputDoc, inputDocNoGens, inputDocClean :: Document +inputDoc = map (\ (x, _, _) -> x) input +inputDocNoGens = [s | (s, _, True) <- input] +inputDocClean = [s | (s, Clean, _) <- input] + +writtenText, writtenTextNoGens, writtenTextClean :: T.Text +writtenText = writeText inputDoc +writtenTextNoGens = writeText inputDocNoGens +writtenTextClean = writeText inputDocClean + +parsedResult, parsedResultNoGens, parsedResultClean :: ParseResult +parsedResult = parseText writtenText +parsedResultNoGens = parseText writtenTextNoGens +parsedResultClean = parseText writtenTextClean + +emptyLists :: Lists +emptyLists = ([], [], [], [], []) + +parsedLists, parsedListsNoGens, parsedListsClean :: Lists +parsedLists = either (const emptyLists) toSmaoinModel parsedResult +parsedListsNoGens = either (const emptyLists) toSmaoinModel parsedResultNoGens +parsedListsClean = either (const emptyLists) toSmaoinModel parsedResultClean + +writtenDoc, writtenDocNoGens, writtenDocClean :: Document +writtenDoc = fromSmaoinModel $ stmts parsedLists +writtenDocNoGens = fromSmaoinModel $ stmts parsedListsNoGens +writtenDocClean = fromSmaoinModel $ stmts parsedListsClean + +againLists, againListsNoGens, againListsClean :: Lists +againLists = toSmaoinModel writtenDoc +againListsNoGens = toSmaoinModel writtenDocNoGens +againListsClean = toSmaoinModel writtenDocClean + +------------------------------------------------------------------ UidGen ----- + +-- Determine using the API whether a given Kort line is clean of generators +lineClean :: Line -> Bool +lineClean = either (const True) (not . stmtHasGens) + +-- Check if an input record's has-gens status matches the gens-clean column +recordHasGensCorrect :: Record -> Bool +recordHasGensCorrect (Left _, _, c) = c +recordHasGensCorrect (Right s, _, c) = stmtHasGens s == not c + +prop_stmtHasGens :: Bool +prop_stmtHasGens = and [stmtHasGens s == not c | (Right s, _, c) <- input] + +prop_docHasGens :: Bool +prop_docHasGens = docHasGens inputDoc == not (and inputClean) + where + inputClean = map (\ (_, _, x) -> x) input + +prop_generateResourcesIO1 :: IO Bool +prop_generateResourcesIO1 = do + doc <- generateResourcesIO inputDoc + return $ length doc == length inputDoc + +prop_generateResourcesIO2 :: IO Bool +prop_generateResourcesIO2 = do + doc <- generateResourcesIO inputDoc + return $ not $ docHasGens doc + +prop_generateResourcesIO3 :: IO Bool +prop_generateResourcesIO3 = do + doc <- generateResourcesIO inputDocNoGens + return $ doc == inputDocNoGens + +prop_sweepGenerators1 :: Bool +prop_sweepGenerators1 = length (sweepGenerators inputDoc) == length inputDoc + +prop_sweepGenerators2 :: Bool +prop_sweepGenerators2 = not $ docHasGens $ sweepGenerators inputDoc + +prop_sweepGenerators3 :: Bool +prop_sweepGenerators3 = sweepGenerators inputDocNoGens == inputDocNoGens + +------------------------------------------------------------------ Writer ----- + +prop_writeText1 :: Bool +prop_writeText1 = T.null $ writeText [] + +prop_writeText2 :: Bool +prop_writeText2 = + (length . T.lines) writtenTextClean == length inputDocClean + +-- The +1 accounts for the middle comment, which has a '\n' inside it +prop_writeText3 :: Bool +prop_writeText3 = + (length . T.lines) writtenTextNoGens == length inputDocNoGens + 1 + +-- The +1 accounts for the middle comment, which has a '\n' inside it +prop_writeText4 :: Bool +prop_writeText4 = + (length . T.lines) writtenText == length inputDoc + 1 + +prop_fromSmaoinModel1 :: Bool +prop_fromSmaoinModel1 = null $ fromSmaoinModel [] + +prop_fromSmaoinModel2 :: Bool +prop_fromSmaoinModel2 = writtenDocClean == reverse inputDocClean + +prop_fromSmaoinModel3 :: Bool +prop_fromSmaoinModel3 = + stmts parsedListsClean == reverse (stmts againListsClean) + +prop_fromSmaoinModel4 :: Bool +prop_fromSmaoinModel4 = + stmts parsedListsNoGens == reverse (stmts againListsNoGens) + +prop_fromSmaoinModel5 :: Bool +prop_fromSmaoinModel5 = stmts parsedLists == reverse (stmts againLists) + +------------------------------------------------------------------ Parser ----- + +prop_parseText1 :: Bool +prop_parseText1 = either (const False) null $ parseText T.empty + +prop_parseText2 :: Bool +prop_parseText2 = + either (const False) ((== rights inputDocClean) . rights) parsedResultClean + +prop_parseText3 :: Bool +prop_parseText3 = + either + (const False) ((== rights inputDocNoGens) . rights) parsedResultNoGens + +prop_parseText4 :: Bool +prop_parseText4 = + either (const False) ((== rights inputDoc) . rights) parsedResult + +prop_toSmaoinModel1 :: Bool +prop_toSmaoinModel1 = f $ toSmaoinModel [] + where + f ([], [], [], [], []) = True + f _ = False + +prop_toSmaoinModel2 :: Bool +prop_toSmaoinModel2 = f parsedListsClean + where + f ([], [], [], [], s) = length s == length inputDocClean + f _ = False + +prop_toSmaoinModel3 :: Bool +prop_toSmaoinModel3 = f parsedListsNoGens + where + f (nottwo, [], notres, invval, s) = + nottwo == reverse [t | (Right t, NotTwo, True) <- input] && + notres == reverse [t | (Right t, NotRes, True) <- input] && + invval == reverse [t | (Right t, InvVal, True) <- input] && + length s == length [() | (_, Clean, True) <- input] + f _ = False + +prop_toSmaoinModel4 :: Bool +prop_toSmaoinModel4 = f parsedLists + where + f (nottwo, hasgen, notres, invval, s) = + nottwo == reverse [t | (Right t, NotTwo, _) <- input] && + hasgen == reverse [t | (Right t, HasGen, False) <- input] && + notres == reverse [t | (Right t, NotRes, True) <- input] && + invval == reverse [t | (Right t, InvVal, True) <- input] && + length s == length [() | (_, Clean, True) <- input] + +------------------------------------------------------------ tests & main ----- + +tests :: [(String, IO Result)] +tests = + [ ("stmtHasGens", quickCheckResult prop_stmtHasGens) + , ("docHasGens", quickCheckResult prop_docHasGens) + , ("generateResourcesIO1", quickCheckResult =<< prop_generateResourcesIO1) + , ("generateResourcesIO2", quickCheckResult =<< prop_generateResourcesIO2) + , ("generateResourcesIO3", quickCheckResult =<< prop_generateResourcesIO3) + , ("sweepGenerators1", quickCheckResult prop_sweepGenerators1) + , ("sweepGenerators2", quickCheckResult prop_sweepGenerators2) + , ("sweepGenerators3", quickCheckResult prop_sweepGenerators3) + , ("writeText1", quickCheckResult prop_writeText1) + , ("writeText2", quickCheckResult prop_writeText2) + , ("writeText3", quickCheckResult prop_writeText3) + , ("writeText4", quickCheckResult prop_writeText4) + , ("parseText1", quickCheckResult prop_parseText1) + , ("parseText2", quickCheckResult prop_parseText2) + , ("parseText3", quickCheckResult prop_parseText3) + , ("parseText4", quickCheckResult prop_parseText4) + , ("toSmaoinModel1", quickCheckResult prop_toSmaoinModel1) + , ("toSmaoinModel2", quickCheckResult prop_toSmaoinModel2) + , ("toSmaoinModel3", quickCheckResult prop_toSmaoinModel3) + , ("toSmaoinModel4", quickCheckResult prop_toSmaoinModel4) + , ("fromSmaoinModel1", quickCheckResult prop_fromSmaoinModel1) + , ("fromSmaoinModel2", quickCheckResult prop_fromSmaoinModel2) + , ("fromSmaoinModel3", quickCheckResult prop_fromSmaoinModel3) + , ("fromSmaoinModel4", quickCheckResult prop_fromSmaoinModel4) + , ("fromSmaoinModel5", quickCheckResult prop_fromSmaoinModel5) + ] + +main :: IO () +main = do + results <- mapM (\ (name ,action) -> printf "%-25s: " name >> action) tests + unless (all isSuccess results) exitFailure