language-kort (empty) → 0.1.0.0
raw patch · 15 files changed
+1300/−0 lines, 15 filesdep +QuickCheckdep +basedep +base64-bytestringsetup-changed
Dependencies added: QuickCheck, base, base64-bytestring, bytestring, language-kort, random, razom-text-util, regex-applicative, smaoin, text, text-position, utf8-string, vocabulary-kadma
Files
- AUTHORS +1/−0
- COPYING +121/−0
- ChangeLog +17/−0
- INSTALL +13/−0
- NEWS +23/−0
- README +16/−0
- Setup.hs +2/−0
- language-kort.cabal +57/−0
- src/Language/Kort.hs +27/−0
- src/Language/Kort/Parser.hs +232/−0
- src/Language/Kort/Types.hs +73/−0
- src/Language/Kort/UidGen.hs +142/−0
- src/Language/Kort/Writer.hs +154/−0
- test/Input.hs +171/−0
- test/test.hs +251/−0
+ AUTHORS view
@@ -0,0 +1,1 @@+fr33domlover <fr33domlover@riseup.net>
+ COPYING view
@@ -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.
+ ChangeLog view
@@ -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 <http://darcs.rel4tion.org> 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
+ INSTALL view
@@ -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
+ NEWS view
@@ -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)
+ README view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ language-kort.cabal view
@@ -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
+ src/Language/Kort.hs view
@@ -0,0 +1,27 @@+{- This file is part of language-kort.+ -+ - Written in 2015 by fr33domlover <fr33domlover@rel4tion.org>.+ -+ - ♡ 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+ - <http://creativecommons.org/publicdomain/zero/1.0/>.+ -}++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
+ src/Language/Kort/Parser.hs view
@@ -0,0 +1,232 @@+{- This file is part of language-kort.+ -+ - Written in 2015 by fr33domlover <fr33domlover@rel4tion.org>.+ -+ - ♡ 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+ - <http://creativecommons.org/publicdomain/zero/1.0/>.+ -}++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)
+ src/Language/Kort/Types.hs view
@@ -0,0 +1,73 @@+{- This file is part of language-kort.+ -+ - Written in 2015 by fr33domlover <fr33domlover@rel4tion.org>.+ -+ - ♡ 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+ - <http://creativecommons.org/publicdomain/zero/1.0/>.+ -}++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])
+ src/Language/Kort/UidGen.hs view
@@ -0,0 +1,142 @@+{- This file is part of language-kort.+ -+ - Written in 2015 by fr33domlover <fr33domlover@rel4tion.org>.+ -+ - ♡ 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+ - <http://creativecommons.org/publicdomain/zero/1.0/>.+ -}++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
+ src/Language/Kort/Writer.hs view
@@ -0,0 +1,154 @@+{- This file is part of language-kort.+ -+ - Written in 2015 by fr33domlover <fr33domlover@rel4tion.org>.+ -+ - ♡ 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+ - <http://creativecommons.org/publicdomain/zero/1.0/>.+ -}++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
+ test/Input.hs view
@@ -0,0 +1,171 @@+{- This file is part of language-kort.+ -+ - Written in 2015 by fr33domlover <fr33domlover@rel4tion.org>.+ -+ - ♡ 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+ - <http://creativecommons.org/publicdomain/zero/1.0/>.+ -}++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
+ test/test.hs view
@@ -0,0 +1,251 @@+{- This file is part of language-kort.+ -+ - Written in 2015 by fr33domlover <fr33domlover@rel4tion.org>.+ -+ - ♡ 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+ - <http://creativecommons.org/publicdomain/zero/1.0/>.+ -}++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