ace 0.3 → 0.4
raw patch · 3 files changed
+492/−5 lines, 3 files
Files
- ace.cabal +3/−3
- src/ACE/Html.hs +484/−0
- test/Main.hs +5/−2
ace.cabal view
@@ -1,5 +1,5 @@ name: ace-version: 0.3+version: 0.4 synopsis: Attempto Controlled English parser and printer description: Attempto Controlled English is a formally defined unambiguous language which is a subset of the English language. This package provides a tokenizer,@@ -29,12 +29,12 @@ ACE.Combinators ACE.Types.Pretty ACE.Pretty+ ACE.Html build-depends: attoparsec >= 0.11.1.0, parsec >= 3.1.5, data-default >= 0.5.3, text >= 0.11.2.0,- base >= 4 && <5,- bifunctors+ base >= 4 && <5 test-suite test type: exitcode-stdio-1.0
+ src/ACE/Html.hs view
@@ -0,0 +1,484 @@+{-# LANGUAGE OverloadedStrings #-}++{-# OPTIONS -fno-warn-orphans #-}++-- | Instances for pretty printing as HTML.++module ACE.Html () where++import ACE.Types.Pretty+import ACE.Types.Syntax+import Data.Monoid hiding (All)+import Data.Text (pack)+import Data.Text.Lazy.Builder+import Text.Blaze+import qualified Text.Blaze.Html5.Attributes as A+import qualified Text.Blaze.Html5 as H++-- | Maybe pretty print if anything.+mtoMarkup :: ToMarkup a => Markup -> Maybe a -> Markup+mtoMarkup x = maybe "" ((x <>) . toMarkup)++-- | Maybe pretty print if anything. Other side.+toMarkupm :: ToMarkup a => Markup -> Maybe a -> Markup+toMarkupm x = maybe "" ((<> x) . toMarkup)++-- | Maybe pretty print if anything. Other side.+toMarkupmf :: ToMarkup a => Markup -> (Markup -> Markup) -> Maybe a -> Markup+toMarkupmf x f = maybe "" (f . (<> x) . toMarkup)++wrap cls inner = H.span ! A.title cls ! A.class_ ("ace-" <> cls) $ inner++instance ToMarkup Specification where+ toMarkup (Specification c mspec) =+ wrap "specification"+ (toMarkup c <> wrap "period" "." <> mtoMarkup " " mspec)++instance ToMarkup SentenceCoord where+ toMarkup (SentenceCoord c mcoord) =+ wrap "sentence-or" (toMarkup c <> mtoMarkup (wrap "sentence-op" " or ") mcoord)++instance ToMarkup SentenceCoord_1 where+ toMarkup (SentenceCoord_1 c mcoord) =+ wrap "sentence-and" (toMarkup c <> mtoMarkup (wrap "sentence-op" " and ") mcoord)++instance ToMarkup SentenceCoord_2 where+ toMarkup (SentenceCoord_2 c mcoord) =+ wrap "sentence-or" (toMarkup c <> mtoMarkup (wrap "sentence-op" " or ") mcoord)++instance ToMarkup SentenceCoord_3 where+ toMarkup (SentenceCoord_3 c mcoord) =+ wrap "sentence-and" (toMarkup c <> mtoMarkup (wrap "sentence-op" " and ") mcoord)++instance ToMarkup TopicalizedSentence where+ toMarkup t =+ case t of+ TopicalizedSentenceExistential t' c -> toMarkup t' <> mtoMarkup " " c+ TopicalizedSentenceUniversal u s -> toMarkup u <> " " <> toMarkup s+ TopicalizedSentenceComposite c -> toMarkup c++instance ToMarkup UniversalTopic where+ toMarkup (UniversalTopic q n) =+ wrap "universal-topic"+ (wrap "universal-quantor" (toMarkup q) <> " " <> toMarkup n)++instance ToMarkup CompositeSentence where+ toMarkup c =+ case c of+ CompositeSentenceCond s -> toMarkup s+ CompositeSentenceNeg s -> toMarkup s+ CompositeSentence s -> toMarkup s++instance ToMarkup ConditionalSentence where+ toMarkup (ConditionalSentence x y) =+ wrap "conditional"+ (wrap "if-if" "if " <> toMarkup x <> wrap "if-then" " then " <> toMarkup y)++instance ToMarkup NegatedSentence where+ toMarkup (NegatedSentence s) =+ wrap "negated-sentence"+ ("it is not the case that " <> toMarkup s)++instance ToMarkup Sentence where+ toMarkup (Sentence n v) =+ wrap "sentence" (toMarkup n <> " " <> toMarkup v)++instance ToMarkup ExistentialTopic where+ toMarkup (ExistentialTopic g np) =+ wrap "existential"+ (wrap "existential-quantor" (toMarkup g) <> " " <> toMarkup np)++instance ToMarkup NPCoord where+ toMarkup n =+ wrap "npcoord"+ (case n of+ NPCoordDistributed d u -> toMarkup d <> " " <> toMarkup u+ NPCoordUnmarked u -> toMarkup u)++instance ToMarkup UnmarkedNPCoord where+ toMarkup (UnmarkedNPCoord np mu) =+ toMarkup np <> mtoMarkup (wrap "unmarked-npcoord-and" " and ") mu++instance ToMarkup N' where+ toMarkup (N' mad n mappos mnp mrel) =+ wrap "n_"+ (toMarkupm " " mad <>+ toMarkup n <>+ mtoMarkup " " mappos <>+ mtoMarkup (wrap "of-pp" " of ") mnp <>+ mtoMarkup " " mrel)++instance ToMarkup NP where+ toMarkup (NP s n') =+ wrap "np"+ (toMarkup s <> " " <> toMarkup n')++instance ToMarkup N where+ toMarkup (N t) =+ wrap "n"+ (toMarkup t)++instance ToMarkup PP where+ toMarkup (PP p np) =+ wrap "pp"+ (toMarkup p <> " " <> toMarkup np)++instance ToMarkup Preposition where+ toMarkup (Preposition t) =+ wrap "preposition" (toMarkup t)++instance ToMarkup ApposCoord where+ toMarkup (ApposCoord a ma) =+ wrap "appos-coord" (toMarkup a <> mtoMarkup " " ma)++instance ToMarkup Apposition where+ toMarkup a =+ wrap "apposition"+ (case a of+ AppositionVar v -> toMarkup v+ AppositionQuote q -> toMarkup q)++instance ToMarkup Quotation where+ toMarkup (Quotation q) =+ wrap "quotation"+ ("\"" <> toMarkup q <> "\"")++instance ToMarkup Variable where+ toMarkup (Variable t) =+ wrap "variable" (toMarkup t)++instance ToMarkup RelativeClauseCoord where+ toMarkup (RelativeClauseCoord r me) =+ wrap "relative-clause-coord"+ (toMarkup r <>+ case me of+ Nothing -> ""+ Just (c,r') -> " " <> toMarkup c <> " " <> toMarkup r')++instance ToMarkup PossessiveNPCoord where+ toMarkup p =+ wrap "possessive-np-coord"+ (case p of+ PossessiveNPCoordGen g -> toMarkup g+ PossessiveNPCoordPronoun p' -> toMarkup p')++instance ToMarkup GenitiveNPCoord where+ toMarkup g =+ case g of+ GenitiveNPCoord s n t -> toMarkup s <> " " <> toMarkup n <> toMarkup t+ GenitiveNPCoordName n t -> toMarkup n <> toMarkup t++instance ToMarkup ProperName where+ toMarkup (ProperName t) =+ wrap "proper-name" (toMarkup t)++instance ToMarkup PossessivePronounCoord where+ toMarkup (PossessivePronounCoord p mp) =+ wrap "possessive-pronoun-coord"+ (toMarkup p <> mtoMarkup (wrap "possessive-pronoun-and" " and ") mp)++instance ToMarkup GenitiveTail where+ toMarkup g =+ wrap "genitive-tail"+ (case g of+ GenitiveTailSaxonTail t -> toMarkup t+ GenitiveTailCoordtail t -> toMarkup t)++instance ToMarkup GenitiveCoordTail where+ toMarkup (GenitiveCoordTail t) =+ (wrap "genitive-and" " and " <> toMarkup t)++instance ToMarkup SaxonGenitiveTail where+ toMarkup (SaxonGenitiveTail m mg) =+ wrap "genitive-tail"+ (toMarkup m <>+ case mg of+ Nothing -> ""+ Just (c,r) -> toMarkup c <> " " <> toMarkup r)++instance ToMarkup RelativeClause where+ toMarkup r =+ wrap "relative-clause"+ (case r of+ RelativeClauseThat v -> wrap "relative-clause-that" "that " <> toMarkup v+ RelativeClauseNP a b -> toMarkup a <> " " <> toMarkup b+ RelativeClauseThatNPVP a b -> wrap "relative-clause-that" "that " <> toMarkup a <> " " <> toMarkup b+ RelativeClauseNPVP a b c -> toMarkup a <> " " <> toMarkup b <> " " <> toMarkup c+ RelativeClausePP p n v -> toMarkup p <> " " <> toMarkup n <> " " <> toMarkup v)++instance ToMarkup VPCoord where+ toMarkup v =+ wrap "vp-coord"+ (case v of+ VPCoord' vp coord vpcoord -> toMarkup vp <> " " <> toMarkup coord <> " " <> toMarkup vpcoord+ VPCoordVP vp -> toMarkup vp)++instance ToMarkup GenitiveSpecifier where+ toMarkup g =+ wrap "genitive-specifier"+ (case g of+ GenitiveSpecifierD d -> toMarkup d+ GenitiveSpecifierPPC p -> toMarkup p+ GenitiveSpecifierN i -> toMarkup (pack (show i)))++instance ToMarkup GenitiveN' where+ toMarkup (GenitiveN' ma n mac) =+ wrap "genitive-n_"+ (toMarkupm " " ma <> toMarkup n <> mtoMarkup " " mac)++instance ToMarkup VP where+ toMarkup v =+ wrap "vp"+ (case v of+ VP v' -> toMarkup v'+ VPNeg cop v' -> toMarkup cop <> wrap "vp-not" " not " <> toMarkup v')++instance ToMarkup V' where+ toMarkup (V' madverb compl mo) =+ wrap "v_"+ (toMarkupm " " madverb <>+ toMarkup compl <>+ mconcat (map ((" " <>) . toMarkup) mo))++instance ToMarkup AdverbCoord where+ toMarkup (AdverbCoord ad mad) =+ wrap "adverb-coord"+ (toMarkup ad <> mtoMarkup (wrap "adverb-and" " and ") mad)++instance ToMarkup ComplV where+ toMarkup c =+ wrap "compl-v"+ (case c of+ ComplVIV i -> toMarkup i+ ComplVPI pi' pp -> toMarkup pi' <> " " <> toMarkup pp+ ComplVTV tv compl -> toMarkup tv <> " " <> toMarkup compl+ ComplVPV pt pp compl -> toMarkup pt <> " " <> toMarkup pp <> " " <> toMarkup compl+ ComplVPV' pt compl pp -> toMarkup pt <> " " <> toMarkup compl <> " " <> toMarkup pp+ ComplVDisV dis compl compl' -> toMarkup dis <> " " <> toMarkup compl <> " " <> toMarkup compl'+ ComplVPDV pd compl pp compl' -> toMarkup pd <> " " <> toMarkup compl <> " " <> toMarkup pp <> " " <> toMarkup compl'+ ComplVCopula cop copcomp -> toMarkup cop <> " " <> toMarkup copcomp)++instance ToMarkup PhrasalTransitiveV where+ toMarkup (PhrasalTransitiveV t) =+ wrap "phrasal-transitive-v"+ (toMarkup t)++instance ToMarkup PhrasalDistransitiveV where+ toMarkup (PhrasalDistransitiveV t) =+ wrap "phrasal-distransitive-v"+ (toMarkup t)++instance ToMarkup CopulaCompl where+ toMarkup c =+ wrap "copula-compl"+ (case c of+ CopulaComplAPC apc -> toMarkup apc+ CopulaComplNPC npc -> toMarkup npc+ CopulaComplPP pp -> toMarkup pp)++instance ToMarkup APCoord where+ toMarkup a =+ case a of+ APCoordAnd x y -> toMarkup x <> " and " <> toMarkup y+ APCoord a' -> toMarkup a'++instance ToMarkup APgrad where+ toMarkup a =+ case a of+ APgradAPThan x y -> toMarkup x <> " than " <> toMarkup y+ APgradAP a' -> toMarkup a'++instance ToMarkup AP where+ toMarkup a =+ case a of+ APIntrans i -> toMarkup i+ APTrans aj pp -> toMarkup aj <> " " <> toMarkup pp++instance ToMarkup TransitiveAdjective where+ toMarkup (TransitiveAdjective t) = toMarkup t++instance ToMarkup Compl where+ toMarkup c =+ case c of+ ComplNP np -> toMarkup np+ ComplPP pp -> toMarkup pp++instance ToMarkup PhrasalIntransitiveV where+ toMarkup (PhrasalIntransitiveV t) =+ wrap "phrasal-intransitive-v"+ (toMarkup t)++instance ToMarkup PhrasalParticle where+ toMarkup (PhrasalParticle t) =+ wrap "phrasal-particle"+ (toMarkup t)++instance ToMarkup IntransitiveV where+ toMarkup (IntransitiveV v) =+ wrap "intransitive-v"+ (toMarkup v)++instance ToMarkup TransitiveV where+ toMarkup (TransitiveV t) =+ wrap "transitive-v"+ (toMarkup t)++instance ToMarkup DistransitiveV where+ toMarkup (DistransitiveV t) =+ wrap "distransitive-v" (toMarkup t)++instance ToMarkup IntransitiveAdjective where+ toMarkup (IntransitiveAdjective t) =+ wrap "intransitive-adjective"+ (toMarkup t)++instance ToMarkup VModifier where+ toMarkup v =+ wrap "v-modifier" (case v of+ VModifierVC adv -> toMarkup adv+ VModifierPP pp -> toMarkup pp+ VModifierAVPP x -> toMarkup x)++instance ToMarkup AdverbialPP where+ toMarkup (AdverbialPP pp ac) =+ toMarkup pp <> " " <> toMarkup ac++instance ToMarkup Adverb where+ toMarkup (Adverb a) =+ wrap "adverb" (toMarkup a)++instance ToMarkup Specifier where+ toMarkup s =+ wrap "specifier"+ (case s of+ SpecifyDeterminer d -> toMarkup d+ SpecifyPossessive np -> toMarkup np+ SpecifyNumberP n -> toMarkup n)++instance ToMarkup AdjectiveCoord where+ toMarkup (AdjectiveCoord i ma) =+ wrap "adjective-coord" (toMarkup i <> mtoMarkup " and " ma)++instance ToMarkup NumberP where+ toMarkup (NumberP mq i) =+ wrap "number-p"+ (toMarkupm " " mq <> toMarkup (pack (show i)))++instance ToMarkup ExistentialGlobalQuantor where+ toMarkup (ExistentialGlobalQuantor c) =+ wrap "existential-quantor"+ ("there " <> toMarkup c)++instance ToMarkup ExistentialGlobalQuestionQuantor where+ toMarkup (ExistentialGlobalQuestionQuantor c) =+ wrap "existential-question-quantor"+ (toMarkup c <> " there")++instance ToMarkup Aux where+ toMarkup d =+ wrap "aux"+ (case d of+ Do -> "do"+ Does -> "does")++instance ToMarkup Coord where+ toMarkup c =+ wrap "coord"+ (case c of+ And -> "and"+ Or -> "or")++instance ToMarkup Copula where+ toMarkup c =+ wrap "copula"+ (case c of+ Is -> "is"+ Are -> "are")++instance ToMarkup Determiner where+ toMarkup d =+ wrap "determiner"+ (case d of+ The -> "the"+ A -> "a"+ An -> "an"+ Some -> "some"+ No -> "no"+ EveryEach -> "every/each"+ All -> "all"+ NotEvery -> "not every"+ NotEach -> "not each"+ NotAll -> "not all"+ Which -> "which")++instance ToMarkup DistributiveGlobalQuantor where+ toMarkup ForEachOf =+ wrap "distributive-global-quantor" "for each of"++instance ToMarkup DistributiveMarker where+ toMarkup EachOf =+ wrap "distributive-marker" "each of"++instance ToMarkup GeneralizedQuantor where+ toMarkup g =+ wrap "generalized-quantor"+ (case g of+ AtMost -> "at most"+ AtLeast -> "at least"+ MoreThan -> "more than"+ LessThan -> "less than"+ NotMoreThan -> "not more than"+ NotLessThan -> "not less than")++instance ToMarkup PossessivePronoun where+ toMarkup p =+ wrap "possessive-pronoun"+ (case p of+ His -> "his"+ Her -> "her"+ HisHer -> "his/her"+ Its -> "its"+ Their -> "their"+ HisHerOwn -> "his own/her own"+ ItsOwn -> "its own"+ TheirOwn -> "their own"+ Whose -> "whose")++instance ToMarkup Pronoun where+ toMarkup p =+ wrap "pronoun"+ (case p of+ It -> "it"+ HeShe -> "he/she"+ Himher -> "him/her"+ They -> "they"+ Them -> "them"+ Itself -> "itself"+ HimHerSelf -> "himself/herself"+ Themselves -> "themselves"+ SomeoneSomebody -> "someone/somebody"+ Something -> "something"+ NoOneNobody -> "no-one/nobody"+ NoThing -> "nothing"+ EveryoneEverybody -> "everyone/everybody"+ Everything -> "everything"+ NotEveryoneEverybody -> "not everyone/not everybody"+ NotEverything -> "not everything"+ WhatWho -> "what/who"+ Whom -> "whom"+ WhichWho -> "which/who")++instance ToMarkup SaxonGenitiveMarker where+ toMarkup a =+ wrap "saxon-genitive-marker"+ (case a of+ Apostrophe -> "'"+ ApostropheS -> "'s")++instance ToMarkup UniversalGlobalQuantor where+ toMarkup u =+ wrap "universal-quantor"+ (case u of+ ForEvery -> "for every"+ ForEach -> "for each"+ ForAll -> "for all")
test/Main.hs view
@@ -9,10 +9,12 @@ import ACE.Combinators import ACE.Parsers import ACE.Pretty+import ACE.Html import ACE.Tokenizer (tokenize) import ACE.Types.Syntax import ACE.Types.Tokens-import Data.Text.Lazy.Builder (fromText)+import Data.Text.Lazy.Builder (fromText,toLazyText)+import Data.Text.Lazy (toStrict) import Control.Applicative import Control.Monad hiding (ap)@@ -673,7 +675,8 @@ where isomorphic name parser text = it name- (printed parser text == Right (fromText text))+ ((printed parser text >>= printed parser . toText) == Right (fromText text))+ where toText = toStrict . toLazyText -- | Is that left? isLeft :: Either a b -> Bool