diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,201 +1,201 @@ - Apache License - Version 2.0, January 2004 - http://www.apache.org/licenses/ - - TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION - - 1. Definitions. - - "License" shall mean the terms and conditions for use, reproduction, - and distribution as defined by Sections 1 through 9 of this document. - - "Licensor" shall mean the copyright owner or entity authorized by - the copyright owner that is granting the License. - - "Legal Entity" shall mean the union of the acting entity and all - other entities that control, are controlled by, or are under common - control with that entity. For the purposes of this definition, - "control" means (i) the power, direct or indirect, to cause the - direction or management of such entity, whether by contract or - otherwise, or (ii) ownership of fifty percent (50%) or more of the - outstanding shares, or (iii) beneficial ownership of such entity. - - "You" (or "Your") shall mean an individual or Legal Entity - exercising permissions granted by this License. - - "Source" form shall mean the preferred form for making modifications, - including but not limited to software source code, documentation - source, and configuration files. - - "Object" form shall mean any form resulting from mechanical - transformation or translation of a Source form, including but - not limited to compiled object code, generated documentation, - and conversions to other media types. - - "Work" shall mean the work of authorship, whether in Source or - Object form, made available under the License, as indicated by a - copyright notice that is included in or attached to the work - (an example is provided in the Appendix below). - - "Derivative Works" shall mean any work, whether in Source or Object - form, that is based on (or derived from) the Work and for which the - editorial revisions, annotations, elaborations, or other modifications - represent, as a whole, an original work of authorship. For the purposes - of this License, Derivative Works shall not include works that remain - separable from, or merely link (or bind by name) to the interfaces of, - the Work and Derivative Works thereof. - - "Contribution" shall mean any work of authorship, including - the original version of the Work and any modifications or additions - to that Work or Derivative Works thereof, that is intentionally - submitted to Licensor for inclusion in the Work by the copyright owner - or by an individual or Legal Entity authorized to submit on behalf of - the copyright owner. For the purposes of this definition, "submitted" - means any form of electronic, verbal, or written communication sent - to the Licensor or its representatives, including but not limited to - communication on electronic mailing lists, source code control systems, - and issue tracking systems that are managed by, or on behalf of, the - Licensor for the purpose of discussing and improving the Work, but - excluding communication that is conspicuously marked or otherwise - designated in writing by the copyright owner as "Not a Contribution." - - "Contributor" shall mean Licensor and any individual or Legal Entity - on behalf of whom a Contribution has been received by Licensor and - subsequently incorporated within the Work. - - 2. Grant of Copyright License. Subject to the terms and conditions of - this License, each Contributor hereby grants to You a perpetual, - worldwide, non-exclusive, no-charge, royalty-free, irrevocable - copyright license to reproduce, prepare Derivative Works of, - publicly display, publicly perform, sublicense, and distribute the - Work and such Derivative Works in Source or Object form. - - 3. Grant of Patent License. Subject to the terms and conditions of - this License, each Contributor hereby grants to You a perpetual, - worldwide, non-exclusive, no-charge, royalty-free, irrevocable - (except as stated in this section) patent license to make, have made, - use, offer to sell, sell, import, and otherwise transfer the Work, - where such license applies only to those patent claims licensable - by such Contributor that are necessarily infringed by their - Contribution(s) alone or by combination of their Contribution(s) - with the Work to which such Contribution(s) was submitted. If You - institute patent litigation against any entity (including a - cross-claim or counterclaim in a lawsuit) alleging that the Work - or a Contribution incorporated within the Work constitutes direct - or contributory patent infringement, then any patent licenses - granted to You under this License for that Work shall terminate - as of the date such litigation is filed. - - 4. Redistribution. You may reproduce and distribute copies of the - Work or Derivative Works thereof in any medium, with or without - modifications, and in Source or Object form, provided that You - meet the following conditions: - - (a) You must give any other recipients of the Work or - Derivative Works a copy of this License; and - - (b) You must cause any modified files to carry prominent notices - stating that You changed the files; and - - (c) You must retain, in the Source form of any Derivative Works - that You distribute, all copyright, patent, trademark, and - attribution notices from the Source form of the Work, - excluding those notices that do not pertain to any part of - the Derivative Works; and - - (d) If the Work includes a "NOTICE" text file as part of its - distribution, then any Derivative Works that You distribute must - include a readable copy of the attribution notices contained - within such NOTICE file, excluding those notices that do not - pertain to any part of the Derivative Works, in at least one - of the following places: within a NOTICE text file distributed - as part of the Derivative Works; within the Source form or - documentation, if provided along with the Derivative Works; or, - within a display generated by the Derivative Works, if and - wherever such third-party notices normally appear. The contents - of the NOTICE file are for informational purposes only and - do not modify the License. You may add Your own attribution - notices within Derivative Works that You distribute, alongside - or as an addendum to the NOTICE text from the Work, provided - that such additional attribution notices cannot be construed - as modifying the License. - - You may add Your own copyright statement to Your modifications and - may provide additional or different license terms and conditions - for use, reproduction, or distribution of Your modifications, or - for any such Derivative Works as a whole, provided Your use, - reproduction, and distribution of the Work otherwise complies with - the conditions stated in this License. - - 5. Submission of Contributions. Unless You explicitly state otherwise, - any Contribution intentionally submitted for inclusion in the Work - by You to the Licensor shall be under the terms and conditions of - this License, without any additional terms or conditions. - Notwithstanding the above, nothing herein shall supersede or modify - the terms of any separate license agreement you may have executed - with Licensor regarding such Contributions. - - 6. Trademarks. This License does not grant permission to use the trade - names, trademarks, service marks, or product names of the Licensor, - except as required for reasonable and customary use in describing the - origin of the Work and reproducing the content of the NOTICE file. - - 7. Disclaimer of Warranty. Unless required by applicable law or - agreed to in writing, Licensor provides the Work (and each - Contributor provides its Contributions) on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or - implied, including, without limitation, any warranties or conditions - of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A - PARTICULAR PURPOSE. You are solely responsible for determining the - appropriateness of using or redistributing the Work and assume any - risks associated with Your exercise of permissions under this License. - - 8. Limitation of Liability. In no event and under no legal theory, - whether in tort (including negligence), contract, or otherwise, - unless required by applicable law (such as deliberate and grossly - negligent acts) or agreed to in writing, shall any Contributor be - liable to You for damages, including any direct, indirect, special, - incidental, or consequential damages of any character arising as a - result of this License or out of the use or inability to use the - Work (including but not limited to damages for loss of goodwill, - work stoppage, computer failure or malfunction, or any and all - other commercial damages or losses), even if such Contributor - has been advised of the possibility of such damages. - - 9. Accepting Warranty or Additional Liability. While redistributing - the Work or Derivative Works thereof, You may choose to offer, - and charge a fee for, acceptance of support, warranty, indemnity, - or other liability obligations and/or rights consistent with this - License. However, in accepting such obligations, You may act only - on Your own behalf and on Your sole responsibility, not on behalf - of any other Contributor, and only if You agree to indemnify, - defend, and hold each Contributor harmless for any liability - incurred by, or claims asserted against, such Contributor by reason - of your accepting any such warranty or additional liability. - - END OF TERMS AND CONDITIONS - - APPENDIX: How to apply the Apache License to your work. - - To apply the Apache License to your work, attach the following - boilerplate notice, with the fields enclosed by brackets "[]" - replaced with your own identifying information. (Don't include - the brackets!) The text should be enclosed in the appropriate - comment syntax for the file format. We also recommend that a - file or class name and description of purpose be included on the - same "printed page" as the copyright notice for easier - identification within third-party archives. - - Copyright 2022 Alexander Lucas - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. + Apache License + Version 2.0, January 2004 + http://www.apache.org/licenses/ + + TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION + + 1. Definitions. + + "License" shall mean the terms and conditions for use, reproduction, + and distribution as defined by Sections 1 through 9 of this document. + + "Licensor" shall mean the copyright owner or entity authorized by + the copyright owner that is granting the License. + + "Legal Entity" shall mean the union of the acting entity and all + other entities that control, are controlled by, or are under common + control with that entity. For the purposes of this definition, + "control" means (i) the power, direct or indirect, to cause the + direction or management of such entity, whether by contract or + otherwise, or (ii) ownership of fifty percent (50%) or more of the + outstanding shares, or (iii) beneficial ownership of such entity. + + "You" (or "Your") shall mean an individual or Legal Entity + exercising permissions granted by this License. + + "Source" form shall mean the preferred form for making modifications, + including but not limited to software source code, documentation + source, and configuration files. + + "Object" form shall mean any form resulting from mechanical + transformation or translation of a Source form, including but + not limited to compiled object code, generated documentation, + and conversions to other media types. + + "Work" shall mean the work of authorship, whether in Source or + Object form, made available under the License, as indicated by a + copyright notice that is included in or attached to the work + (an example is provided in the Appendix below). + + "Derivative Works" shall mean any work, whether in Source or Object + form, that is based on (or derived from) the Work and for which the + editorial revisions, annotations, elaborations, or other modifications + represent, as a whole, an original work of authorship. For the purposes + of this License, Derivative Works shall not include works that remain + separable from, or merely link (or bind by name) to the interfaces of, + the Work and Derivative Works thereof. + + "Contribution" shall mean any work of authorship, including + the original version of the Work and any modifications or additions + to that Work or Derivative Works thereof, that is intentionally + submitted to Licensor for inclusion in the Work by the copyright owner + or by an individual or Legal Entity authorized to submit on behalf of + the copyright owner. For the purposes of this definition, "submitted" + means any form of electronic, verbal, or written communication sent + to the Licensor or its representatives, including but not limited to + communication on electronic mailing lists, source code control systems, + and issue tracking systems that are managed by, or on behalf of, the + Licensor for the purpose of discussing and improving the Work, but + excluding communication that is conspicuously marked or otherwise + designated in writing by the copyright owner as "Not a Contribution." + + "Contributor" shall mean Licensor and any individual or Legal Entity + on behalf of whom a Contribution has been received by Licensor and + subsequently incorporated within the Work. + + 2. Grant of Copyright License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + copyright license to reproduce, prepare Derivative Works of, + publicly display, publicly perform, sublicense, and distribute the + Work and such Derivative Works in Source or Object form. + + 3. Grant of Patent License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + (except as stated in this section) patent license to make, have made, + use, offer to sell, sell, import, and otherwise transfer the Work, + where such license applies only to those patent claims licensable + by such Contributor that are necessarily infringed by their + Contribution(s) alone or by combination of their Contribution(s) + with the Work to which such Contribution(s) was submitted. If You + institute patent litigation against any entity (including a + cross-claim or counterclaim in a lawsuit) alleging that the Work + or a Contribution incorporated within the Work constitutes direct + or contributory patent infringement, then any patent licenses + granted to You under this License for that Work shall terminate + as of the date such litigation is filed. + + 4. Redistribution. You may reproduce and distribute copies of the + Work or Derivative Works thereof in any medium, with or without + modifications, and in Source or Object form, provided that You + meet the following conditions: + + (a) You must give any other recipients of the Work or + Derivative Works a copy of this License; and + + (b) You must cause any modified files to carry prominent notices + stating that You changed the files; and + + (c) You must retain, in the Source form of any Derivative Works + that You distribute, all copyright, patent, trademark, and + attribution notices from the Source form of the Work, + excluding those notices that do not pertain to any part of + the Derivative Works; and + + (d) If the Work includes a "NOTICE" text file as part of its + distribution, then any Derivative Works that You distribute must + include a readable copy of the attribution notices contained + within such NOTICE file, excluding those notices that do not + pertain to any part of the Derivative Works, in at least one + of the following places: within a NOTICE text file distributed + as part of the Derivative Works; within the Source form or + documentation, if provided along with the Derivative Works; or, + within a display generated by the Derivative Works, if and + wherever such third-party notices normally appear. The contents + of the NOTICE file are for informational purposes only and + do not modify the License. You may add Your own attribution + notices within Derivative Works that You distribute, alongside + or as an addendum to the NOTICE text from the Work, provided + that such additional attribution notices cannot be construed + as modifying the License. + + You may add Your own copyright statement to Your modifications and + may provide additional or different license terms and conditions + for use, reproduction, or distribution of Your modifications, or + for any such Derivative Works as a whole, provided Your use, + reproduction, and distribution of the Work otherwise complies with + the conditions stated in this License. + + 5. Submission of Contributions. Unless You explicitly state otherwise, + any Contribution intentionally submitted for inclusion in the Work + by You to the Licensor shall be under the terms and conditions of + this License, without any additional terms or conditions. + Notwithstanding the above, nothing herein shall supersede or modify + the terms of any separate license agreement you may have executed + with Licensor regarding such Contributions. + + 6. Trademarks. This License does not grant permission to use the trade + names, trademarks, service marks, or product names of the Licensor, + except as required for reasonable and customary use in describing the + origin of the Work and reproducing the content of the NOTICE file. + + 7. Disclaimer of Warranty. Unless required by applicable law or + agreed to in writing, Licensor provides the Work (and each + Contributor provides its Contributions) on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or + implied, including, without limitation, any warranties or conditions + of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A + PARTICULAR PURPOSE. You are solely responsible for determining the + appropriateness of using or redistributing the Work and assume any + risks associated with Your exercise of permissions under this License. + + 8. Limitation of Liability. In no event and under no legal theory, + whether in tort (including negligence), contract, or otherwise, + unless required by applicable law (such as deliberate and grossly + negligent acts) or agreed to in writing, shall any Contributor be + liable to You for damages, including any direct, indirect, special, + incidental, or consequential damages of any character arising as a + result of this License or out of the use or inability to use the + Work (including but not limited to damages for loss of goodwill, + work stoppage, computer failure or malfunction, or any and all + other commercial damages or losses), even if such Contributor + has been advised of the possibility of such damages. + + 9. Accepting Warranty or Additional Liability. While redistributing + the Work or Derivative Works thereof, You may choose to offer, + and charge a fee for, acceptance of support, warranty, indemnity, + or other liability obligations and/or rights consistent with this + License. However, in accepting such obligations, You may act only + on Your own behalf and on Your sole responsibility, not on behalf + of any other Contributor, and only if You agree to indemnify, + defend, and hold each Contributor harmless for any liability + incurred by, or claims asserted against, such Contributor by reason + of your accepting any such warranty or additional liability. + + END OF TERMS AND CONDITIONS + + APPENDIX: How to apply the Apache License to your work. + + To apply the Apache License to your work, attach the following + boilerplate notice, with the fields enclosed by brackets "[]" + replaced with your own identifying information. (Don't include + the brackets!) The text should be enclosed in the appropriate + comment syntax for the file format. We also recommend that a + file or class name and description of purpose be included on the + same "printed page" as the copyright notice for easier + identification within third-party archives. + + Copyright 2022 Alexander Lucas + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,3 +1,3 @@ -# aasam - -This project is a fully-extended implementation of the algorithm ℳ from Annika Aasa's "Precedences in specifications and implementations of programming languages". It provides an interface for converting distfix (mixfix) precedence grammars into unambiguous context-free grammars. +# aasam + +This project is a fully-extended implementation of the algorithm ℳ from Annika Aasa's "Precedences in specifications and implementations of programming languages". It provides an interface for converting distfix (mixfix) precedence grammars into unambiguous context-free grammars. diff --git a/aasam.cabal b/aasam.cabal --- a/aasam.cabal +++ b/aasam.cabal @@ -1,41 +1,43 @@ -cabal-version: 2.4 -name: aasam -version: 0.1.0.0 -license: Apache-2.0 -license-file: LICENSE -maintainer: mobotsar@protonmail.com -author: Alexander Lucas -bug-reports: https://gitlab.com/mobotsar/aasam -synopsis: - Convert distfix precedence grammars to unambiguous context-free grammars. - -description: - This project is a fully-extended implementation of the algorithm ℳ from Annika Aasa's "Precedences in specifications and implementations of programming languages". It provides an interface for converting distfix (mixfix) precedence grammars into unambiguous context-free grammars. - -category: parsing -extra-source-files: README.md - -library - exposed-modules: Aasam - hs-source-dirs: lib - other-modules: - Util - Grammars - - default-language: Haskell2010 - build-depends: - base ^>=4.15.1.0, - containers >=0.6.4 && <0.7 - -test-suite aasam-test - type: exitcode-stdio-1.0 - main-is: AasamTest.hs - hs-source-dirs: test - default-language: Haskell2010 - build-depends: - base ^>=4.15.1.0, - HUnit ==1.6.2.0, - test-framework ==0.8.2.0, - test-framework-hunit ==0.3.0.2, - containers >=0.6.4 && <0.7, - aasam +cabal-version: 2.4 +name: aasam +version: 0.2.0.0 +license: Apache-2.0 +license-file: LICENSE +maintainer: mobotsar@protonmail.com +author: Alexander Lucas +bug-reports: https://gitlab.com/mobotsar/aasam +synopsis: + Convert distfix precedence grammars to unambiguous context-free grammars. + +description: + This project is a fully-extended implementation of the algorithm ℳ from Annika Aasa's "Precedences in specifications and implementations of programming languages". It provides an interface for converting distfix (mixfix) precedence grammars into unambiguous context-free grammars. + +category: parsing +extra-source-files: README.md + +library + exposed-modules: Aasam + hs-source-dirs: lib + other-modules: + Util + Grammars + + default-language: Haskell2010 + build-depends: + base ^>=4.15.1.0, + containers >=0.6.4 && <0.7, + text >= 1.2.5 && < 1.3 + +test-suite aasam-test + type: exitcode-stdio-1.0 + main-is: AasamTest.hs + hs-source-dirs: test + default-language: Haskell2010 + build-depends: + base ^>=4.15.1.0, + HUnit ==1.6.2.0, + test-framework ==0.8.2.0, + test-framework-hunit ==0.3.0.2, + containers >=0.6.4 && <0.7, + aasam, + text >= 1.2.5 && < 1.3 diff --git a/lib/Aasam.hs b/lib/Aasam.hs --- a/lib/Aasam.hs +++ b/lib/Aasam.hs @@ -1,291 +1,303 @@ -module Aasam - ( m - , module Grammars - , AasamError(..) - ) where - -import Data.Function (on) -import Data.List (groupBy) -import qualified Data.List.NonEmpty as DLNe -import Data.List.NonEmpty (NonEmpty((:|))) -import Data.Set (Set, insert, union) -import qualified Data.Set as Set -import Grammars - ( CfgProduction - , CfgString - , ContextFree - , NonTerminal(..) - , Precedence - , PrecedenceProduction(..) - , Terminal(..) - ) -import Util ((>.), (|>), unwrapOr) - -import Data.Bifunctor (Bifunctor(bimap, second)) -import Data.Data (toConstr) -import qualified Data.Foldable -import qualified Data.List as List - -doGeneric :: PrecedenceProduction -> (Int -> NonEmpty String -> a) -> a -doGeneric (Prefix prec words) f = f prec words -doGeneric (Postfix prec words) f = f prec words -doGeneric (Infixl prec words) f = f prec words -doGeneric (Infixr prec words) f = f prec words -doGeneric (Closed words) f = f 0 words - -getWords :: PrecedenceProduction -> [String] -getWords = flip doGeneric (const DLNe.toList) - -prec :: PrecedenceProduction -> Int -prec = flip doGeneric const - -nt :: Int -> Int -> Int -> NonTerminal -nt prec p q = NonTerminal (show prec ++ show p ++ show q) - --- TODO: write a proper implementation of this that doesn't depend on List -groupSetBy :: Ord a => (a -> a -> Bool) -> Set a -> Set (Set a) -groupSetBy projection = Set.toList >. groupBy projection >. map Set.fromList >. Set.fromList - -makeClasses :: Precedence -> Set Precedence -makeClasses = groupSetBy fixeq - where - fixeq = on (==) toConstr - -- equivalence relation of fixity on precedence productions - -type UniquenessPair = (PrecedenceProduction, Precedence) - --- This function returns a set of upairs. A upair contains a production of a single precedence on the left, --- and the set of all productions of that precedence on the right (including the one on the left). -classToPairSet :: Precedence -> Set UniquenessPair -classToPairSet = groupSetBy preceq >. Set.map pair - where - pair :: Precedence -> UniquenessPair - pair prec = (Set.elemAt 0 prec, prec) - preceq :: PrecedenceProduction -> PrecedenceProduction -> Bool - preceq a b = prec a == prec b - -pairifyClasses :: Set Precedence -> Set (Set UniquenessPair) -pairifyClasses = Set.map classToPairSet - -type PqQuad = (Int, Int, PrecedenceProduction, Precedence) - -pqboundUPair :: Set UniquenessPair -> Set UniquenessPair -> UniquenessPair -> PqQuad -pqboundUPair pre post (r, s) = (greater pre $ prec r, greater post $ prec r, r, s) - where - greater :: Set UniquenessPair -> Int -> Int - greater upairs n = Set.size $ Set.filter ((n <) . prec . fst) upairs - -pqboundClasses :: Set UniquenessPair -> Set UniquenessPair -> Set (Set UniquenessPair) -> Set (Set PqQuad) -pqboundClasses pre post = Set.map (Set.map (pqboundUPair pre post)) - -intersperseStart :: NonEmpty String -> CfgString -intersperseStart = DLNe.map (Left . Terminal) >. DLNe.intersperse (Right (NonTerminal "!start")) >. DLNe.toList - -fill :: Precedence -> Set CfgProduction -> Set CfgProduction -fill s cfgprods = Set.union withTerminals withoutTerminals - where - (left, withoutTerminals) = Set.partition hasTerminal cfgprods - where - hasTerminal :: CfgProduction -> Bool - hasTerminal (_, words) = List.any isTerminal words - isTerminal :: Either Terminal NonTerminal -> Bool - isTerminal (Right (NonTerminal _)) = False - isTerminal (Left (Terminal _)) = True - withTerminals = fill' s left - -- TODO: write a proper implementation of this composition that doesn't depend on List - where - fill' :: Precedence -> Set CfgProduction -> Set CfgProduction - fill' s = Set.toList >. repeat >. zipWith reset (Set.toList s) >. concat >. Set.fromList - where - reset :: PrecedenceProduction -> [CfgProduction] -> [CfgProduction] - reset pp = map (second re) - where - re :: CfgString -> CfgString - re str = - case pp of - Infixl prec words -> kansas str words - Infixr prec words -> kansas str words - _ -> - error - "This is a bug in Aasam. Somehow, I got a CfgProduction that hasn't any terminals, or a Closed production." - where - kansas :: CfgString -> NonEmpty String -> CfgString - kansas str words = List.head str : intersperseStart words ++ [List.last str] - --- The CE production on `closedrule` must go to a non-terminal. --- Relevant terminals in these rules are all added by `fill`. Those added immediately in the rule bodies are just to signal to fill. --- If an "evil" non-terminal appears anywhere in the output of a *rule fuctions, that's a bug. -prerule :: Int -> Int -> PqQuad -> Set CfgProduction -prerule p q (_, _, r, s) = fill s $ Set.singleton (nt (prec r) p q, [Right (nt (prec r - 1) (p + 1) q)]) - -postrule :: Int -> Int -> PqQuad -> Set CfgProduction -postrule p q (_, _, r, s) = fill s $ Set.singleton (nt (prec r) p q, [Right (nt (prec r - 1) p (q + 1))]) - -inlrule :: Int -> Int -> PqQuad -> Set CfgProduction -inlrule p q (_, _, r, s) = fill s $ Set.fromList [a, b] - where - a = (nt (prec r) p q, [Right (nt (prec r) 0 q), Left (Terminal "evil"), Right (nt (prec r - 1) p 0)]) - b = (nt (prec r) p q, [Right (nt (prec r - 1) p q)]) - -inrrule :: Int -> Int -> PqQuad -> Set CfgProduction -inrrule p q (_, _, r, s) = fill s $ Set.fromList [a, b] - where - a = (nt (prec r) p q, [Right (nt (prec r - 1) 0 q), Left (Terminal "evil"), Right (nt (prec r) p 0)]) - b = (nt (prec r) p q, [Right (nt (prec r - 1) p q)]) - -closedrule :: Set UniquenessPair -> Set UniquenessPair -> Int -> Int -> PqQuad -> Set CfgProduction -closedrule pres posts p q (_, _, r, s) = insert ae isets `union` jsets - where - ae :: CfgProduction - ae = (nt 0 p q, [Right (NonTerminal "CE")]) - isets :: Set CfgProduction - isets = foldl (flip (union . ido)) Set.empty (zip (Set.toList pres) [1 .. p]) - where - ido :: (UniquenessPair, Int) -> Set CfgProduction - ido ((r, s), i) = - Set.singleton - (nt 0 p q, intersperseStart (getWords r |> DLNe.fromList) ++ [Right (nt (prec r) (p - i) 0)]) - jsets :: Set CfgProduction - jsets = foldl (flip (union . jdo)) Set.empty (zip (Set.toList posts) [1 .. q]) - where - jdo :: (UniquenessPair, Int) -> Set CfgProduction - jdo ((r, s), j) = - Set.singleton - (nt 0 p q, Right (nt (prec r) 0 (q - j)) : intersperseStart (getWords r |> DLNe.fromList)) - -convertClass :: (Int -> Int -> PqQuad -> Set CfgProduction) -> Set PqQuad -> Set CfgProduction -convertClass rule = foldl (flip (union . psets)) Set.empty - where - psets (pbound, qbound, r, s) = foldl (flip (union . qsets)) Set.empty [0 .. pbound] - where - qsets p = foldl ((. flip (rule p) (pbound, qbound, r, s)) . union) Set.empty [0 .. qbound] - -convertClasses :: Set UniquenessPair -> Set UniquenessPair -> Set (Set PqQuad) -> Set CfgProduction -convertClasses pres posts = Set.map convertClassBranching >. foldl union Set.empty - where - convertClassBranching :: Set PqQuad -> Set CfgProduction - convertClassBranching quads = convertClass rule quads - where - rule = - case Set.elemAt 0 quads of - (_, _, Infixl _ _, _) -> inlrule - (_, _, Infixr _ _, _) -> inrrule - (_, _, Prefix _ _, _) -> prerule - (_, _, Postfix _ _, _) -> postrule - (_, _, Closed _, _) -> closedrule pres posts --- |The type of errors. Contains a list of strings, each of which describes an error of the input grammar. -newtype AasamError = - AasamError [String] - deriving (Show, Eq, Ord) - --- |Takes a distfix precedence grammar. If there is an error, produces an 'AasamError', else produces a corresponding unambiguous context-free grammar. --- --- All possible errors are enumerated in the documentation for 'Precedence'. -m :: Precedence -> Either ContextFree AasamError -m precg = - if null errors - then Left (nt highestPrecedence 0 0, addCes (assignStart prods)) - else Right (AasamError errors) - where - errors :: [String] - errors = foldl fn [] [positive, noInitSubseq, noInitWhole, classesPrecDisjoint, precContinue] - where - fn :: [String] -> Maybe String -> [String] - fn a e = - case e of - Nothing -> a - Just err -> err : a - positive = - if all fn precg - then Nothing - else Just errstr - where - fn (Closed _) = True - fn x = prec x > 0 - errstr = "All precedences must be positive integers." - noInitSubseq = - if Set.disjoint initials subsequents - then Nothing - else Just errstr - where - (initials, subsequents) = foldl fn (Set.empty, Set.empty) precg - where - fn (i, s) e = (insert (head words) i, (tail words |> Set.fromList) `union` s) - where - words = getWords e - errstr = "No initial word may also be a subsequent word of another production." - noInitWhole = - if all fx precg - then Nothing - else Just errstr - where - fx x = all fy precg - where - fy y = getWords x `notPrefixedBy` getWords y || x == y - where - notPrefixedBy :: Eq a => [a] -> [a] -> Bool - notPrefixedBy [] [] = False - notPrefixedBy (_:_) [] = False - notPrefixedBy [] (_:_) = True - notPrefixedBy (x:xs) (y:ys) = x /= y || notPrefixedBy xs ys - errstr = "No initial sequence of words may also be the whole sequence of another production." - classesPrecDisjoint = - if allDisjoint precGroups - then Nothing - else Just errstr - where - allDisjoint :: Ord a => [Set a] -> Bool - allDisjoint (x:xs) = all (Set.disjoint x) xs && allDisjoint xs - allDisjoint [] = True - precGroups :: [Set Int] - precGroups = List.map (foldl (flip (insert . prec)) Set.empty) (Set.toList classes) - errstr = "No precedence of a production of one fixity may also be the precedence of a production of another fixity." - precContinue = - if precedences == Set.fromList [lowestPrecedence .. highestPrecedence] - then Nothing - else Just errstr - where - errstr = "The set of precedences must be either empty or the set of integers between 1 and greatest precedence, inclusive." - classes = makeClasses precg - upairClasses = pairifyClasses classes - (pre, post) = (findBy isPre, findBy isPost) - where - isPre clas = - case Set.elemAt 0 clas of - (Prefix _ _, _) -> True - _ -> False - isPost clas = - case Set.elemAt 0 clas of - (Postfix _ _, _) -> True - _ -> False - findBy f = unwrapOr Set.empty $ Data.Foldable.find f upairClasses - prods = pqboundClasses pre post upairClasses |> convertClasses pre post - addCes :: Set CfgProduction -> Set CfgProduction - addCes = union ces - where - ces :: Set CfgProduction - ces = - Set.filter isClosed precg |> - Set.map (\(Closed words) -> (NonTerminal "CE", intersperseStart words)) - where - isClosed :: PrecedenceProduction -> Bool - isClosed (Closed _) = True - isClosed _ = False - assignStart :: Set CfgProduction -> Set CfgProduction - assignStart = Set.map $ bimap lhsMap rhsMap - where - lhsMap :: NonTerminal -> NonTerminal - lhsMap lhs = - if lhs == NonTerminal "!start" - then nt highestPrecedence 0 0 - else lhs - rhsMap = map submap - where - submap :: Either Terminal NonTerminal -> Either Terminal NonTerminal - submap (Right x) = Right $ lhsMap x - submap y = y - (highestPrecedence, lowestPrecedence, precedences) = - foldl - (\(ha, la, pa) e -> (max (prec e) ha, min (prec e) la, prec e `insert` pa)) - (0, 0, Set.singleton 0) - precg +module Aasam + ( m + , module Grammars + , AasamError(..) + ) where + +import Data.Function (on) +import Data.List (groupBy) +import qualified Data.List.NonEmpty as DLNe +import Data.List.NonEmpty (NonEmpty((:|))) +import Data.Set (Set, insert, union) +import qualified Data.Set as Set +import Grammars + ( CfgProduction + , CfgString + , ContextFree + , NonTerminal(..) + , Precedence + , PrecedenceProduction(..) + , Terminal(..) + ) +import Util ((>.), (|>), unwrapOr) + +import Data.Bifunctor (Bifunctor(bimap, second)) +import Data.Data (toConstr) +import qualified Data.Foldable +import qualified Data.List as List + +import qualified Data.Text as Text +import Data.Text (Text) + +doGeneric :: PrecedenceProduction -> (Int -> NonEmpty Text -> a) -> a +doGeneric (Prefix prec words) f = f prec words +doGeneric (Postfix prec words) f = f prec words +doGeneric (Infixl prec words) f = f prec words +doGeneric (Infixr prec words) f = f prec words +doGeneric (Closed words) f = f 0 words + +getWords :: PrecedenceProduction -> [Text] +getWords = flip doGeneric (const DLNe.toList) + +prec :: PrecedenceProduction -> Int +prec = flip doGeneric const + +nt :: Int -> Int -> Int -> NonTerminal +nt prec p q = (NonTerminal . Text.pack) (show prec ++ show p ++ show q) + +-- TODO: write a proper implementation of this that doesn't depend on List +groupSetBy :: Ord a => (a -> a -> Bool) -> Set a -> Set (Set a) +groupSetBy projection = Set.toList >. groupBy projection >. map Set.fromList >. Set.fromList + +makeClasses :: Precedence -> Set Precedence +makeClasses = groupSetBy fixeq + where + fixeq = on (==) toConstr + -- equivalence relation of fixity on precedence productions + +type UniquenessPair = (PrecedenceProduction, Precedence) + +-- This function returns a set of upairs. A upair contains a production of a single precedence on the left, +-- and the set of all productions of that precedence on the right (including the one on the left). +classToPairSet :: Precedence -> Set UniquenessPair +classToPairSet = groupSetBy preceq >. Set.map pair + where + pair :: Precedence -> UniquenessPair + pair prec = (Set.elemAt 0 prec, prec) + preceq :: PrecedenceProduction -> PrecedenceProduction -> Bool + preceq a b = prec a == prec b + +pairifyClasses :: Set Precedence -> Set (Set UniquenessPair) +pairifyClasses = Set.map classToPairSet + +type PqQuad = (Int, Int, PrecedenceProduction, Precedence) + +pqboundUPair :: Set UniquenessPair -> Set UniquenessPair -> UniquenessPair -> PqQuad +pqboundUPair pre post (r, s) = (greater pre $ prec r, greater post $ prec r, r, s) + where + greater :: Set UniquenessPair -> Int -> Int + greater upairs n = Set.size $ Set.filter ((n <) . prec . fst) upairs + +pqboundClasses :: Set UniquenessPair -> Set UniquenessPair -> Set (Set UniquenessPair) -> Set (Set PqQuad) +pqboundClasses pre post = Set.map (Set.map (pqboundUPair pre post)) + +intersperseStart :: NonEmpty Text -> CfgString +intersperseStart = + DLNe.map (Left . Terminal) >. DLNe.intersperse (Right ((NonTerminal . Text.pack) "!start")) >. DLNe.toList + +fill :: Precedence -> Set CfgProduction -> Set CfgProduction +fill s cfgprods = Set.union withTerminals withoutTerminals + where + (left, withoutTerminals) = Set.partition hasTerminal cfgprods + where + hasTerminal :: CfgProduction -> Bool + hasTerminal (_, words) = List.any isTerminal words + isTerminal :: Either Terminal NonTerminal -> Bool + isTerminal (Right (NonTerminal _)) = False + isTerminal (Left (Terminal _)) = True + withTerminals = fill' s left + -- TODO: write a proper implementation of this composition that doesn't depend on List + where + fill' :: Precedence -> Set CfgProduction -> Set CfgProduction + fill' s = Set.toList >. repeat >. zipWith reset (Set.toList s) >. concat >. Set.fromList + where + reset :: PrecedenceProduction -> [CfgProduction] -> [CfgProduction] + reset pp = map (second re) + where + re :: CfgString -> CfgString + re str = + case pp of + Infixl prec words -> kansas str words + Infixr prec words -> kansas str words + _ -> + error + "This is a bug in Aasam. Somehow, I got a CfgProduction that hasn't any terminals, or a Closed production." + where + kansas :: CfgString -> NonEmpty Text -> CfgString + kansas str words = List.head str : intersperseStart words ++ [List.last str] + +-- The CE production on `closedrule` must go to a non-terminal. +-- Relevant terminals in these rules are all added by `fill`. Those added immediately in the rule bodies are just to signal to fill. +-- If an "evil" non-terminal appears anywhere in the output of a *rule fuctions, that's a bug. +prerule :: Int -> Int -> PqQuad -> Set CfgProduction +prerule p q (_, _, r, s) = fill s $ Set.singleton (nt (prec r) p q, [Right (nt (prec r - 1) (p + 1) q)]) + +postrule :: Int -> Int -> PqQuad -> Set CfgProduction +postrule p q (_, _, r, s) = fill s $ Set.singleton (nt (prec r) p q, [Right (nt (prec r - 1) p (q + 1))]) + +inlrule :: Int -> Int -> PqQuad -> Set CfgProduction +inlrule p q (_, _, r, s) = fill s $ Set.fromList [a, b] + where + a = + ( nt (prec r) p q + , [Right (nt (prec r) 0 q), Left ((Terminal . Text.pack) "evil"), Right (nt (prec r - 1) p 0)]) + b = (nt (prec r) p q, [Right (nt (prec r - 1) p q)]) + +inrrule :: Int -> Int -> PqQuad -> Set CfgProduction +inrrule p q (_, _, r, s) = fill s $ Set.fromList [a, b] + where + a = + ( nt (prec r) p q + , [Right (nt (prec r - 1) 0 q), Left ((Terminal . Text.pack) "evil"), Right (nt (prec r) p 0)]) + b = (nt (prec r) p q, [Right (nt (prec r - 1) p q)]) + +closedrule :: Set UniquenessPair -> Set UniquenessPair -> Int -> Int -> PqQuad -> Set CfgProduction +closedrule pres posts p q (_, _, r, s) = insert ae isets `union` jsets + where + ae = (nt 0 p q, [Right ((NonTerminal . Text.pack) "CE")]) + isets :: Set CfgProduction + isets = foldl (flip (union . ido)) Set.empty (zip (Set.toList pres) [1 .. p]) + where + ido :: (UniquenessPair, Int) -> Set CfgProduction + ido ((r, s), i) = + Set.singleton + (nt 0 p q, intersperseStart (getWords r |> DLNe.fromList) ++ [Right (nt (prec r) (p - i) 0)]) + jsets :: Set CfgProduction + jsets = foldl (flip (union . jdo)) Set.empty (zip (Set.toList posts) [1 .. q]) + where + jdo :: (UniquenessPair, Int) -> Set CfgProduction + jdo ((r, s), j) = + Set.singleton + (nt 0 p q, Right (nt (prec r) 0 (q - j)) : intersperseStart (getWords r |> DLNe.fromList)) + +convertClass :: (Int -> Int -> PqQuad -> Set CfgProduction) -> Set PqQuad -> Set CfgProduction +convertClass rule = foldl (flip (union . psets)) Set.empty + where + psets (pbound, qbound, r, s) = foldl (flip (union . qsets)) Set.empty [0 .. pbound] + where + qsets p = foldl ((. flip (rule p) (pbound, qbound, r, s)) . union) Set.empty [0 .. qbound] + +convertClasses :: Set UniquenessPair -> Set UniquenessPair -> Set (Set PqQuad) -> Set CfgProduction +convertClasses pres posts = Set.map convertClassBranching >. foldl union Set.empty + where + convertClassBranching :: Set PqQuad -> Set CfgProduction + convertClassBranching quads = convertClass rule quads + where + rule = + case Set.elemAt 0 quads of + (_, _, Infixl _ _, _) -> inlrule + (_, _, Infixr _ _, _) -> inrrule + (_, _, Prefix _ _, _) -> prerule + (_, _, Postfix _ _, _) -> postrule + (_, _, Closed _, _) -> closedrule pres posts + +-- |The type of errors. Contains a list of strings, each of which describes an error of the input grammar. +newtype AasamError = + AasamError [Text] + deriving (Show, Eq, Ord) + +-- |Takes a distfix precedence grammar. If there is an error, produces an 'AasamError', else produces a corresponding unambiguous context-free grammar. +-- +-- All possible errors are enumerated in the documentation for 'Precedence'. +m :: Precedence -> Either AasamError ContextFree +m precg = + if null errors + then Right (nt highestPrecedence 0 0, assignStart (addCes prods)) + else Left (AasamError errors) + where + errors = foldl fn [] [positive, noInitSubseq, noInitWhole, classesPrecDisjoint, precContinue] + where + fn :: [Text] -> Maybe Text -> [Text] + fn a e = + case e of + Nothing -> a + Just err -> err : a + positive = + if all fn precg + then Nothing + else Just errstr + where + fn (Closed _) = True + fn x = prec x > 0 + errstr = Text.pack "All precedences must be positive integers." + noInitSubseq = + if Set.disjoint initials subsequents + then Nothing + else Just errstr + where + (initials, subsequents) = foldl fn (Set.empty, Set.empty) precg + where + fn (i, s) e = (insert (head words) i, (tail words |> Set.fromList) `union` s) + where + words = getWords e + errstr = Text.pack "No initial word may also be a subsequent word of another production." + noInitWhole = + if all fx precg + then Nothing + else Just errstr + where + fx x = all fy precg + where + fy y = getWords x `notPrefixedBy` getWords y || x == y + where + notPrefixedBy :: Eq a => [a] -> [a] -> Bool + notPrefixedBy [] [] = False + notPrefixedBy (_:_) [] = False + notPrefixedBy [] (_:_) = True + notPrefixedBy (x:xs) (y:ys) = x /= y || notPrefixedBy xs ys + errstr = + Text.pack "No initial sequence of words may also be the whole sequence of another production." + classesPrecDisjoint = + if allDisjoint precGroups + then Nothing + else Just errstr + where + allDisjoint :: Ord a => [Set a] -> Bool + allDisjoint (x:xs) = all (Set.disjoint x) xs && allDisjoint xs + allDisjoint [] = True + precGroups :: [Set Int] + precGroups = List.map (foldl (flip (insert . prec)) Set.empty) (Set.toList classes) + errstr = + Text.pack + "No precedence of a production of one fixity may also be the precedence of a production of another fixity." + precContinue = + if precedences == Set.fromList [lowestPrecedence .. highestPrecedence] + then Nothing + else Just errstr + where + errstr = + Text.pack + "The set of precedences must be either empty or the set of integers between 1 and greatest precedence, inclusive." + classes = makeClasses precg + upairClasses = pairifyClasses classes + (pre, post) = (findBy isPre, findBy isPost) + where + isPre clas = + case Set.elemAt 0 clas of + (Prefix _ _, _) -> True + _ -> False + isPost clas = + case Set.elemAt 0 clas of + (Postfix _ _, _) -> True + _ -> False + findBy f = unwrapOr Set.empty $ Data.Foldable.find f upairClasses + prods = pqboundClasses pre post upairClasses |> convertClasses pre post + addCes :: Set CfgProduction -> Set CfgProduction + addCes = union ces + where + ces :: Set CfgProduction + ces = + Set.filter isClosed precg |> + Set.map (\(Closed words) -> ((NonTerminal . Text.pack) "CE", intersperseStart words)) + where + isClosed :: PrecedenceProduction -> Bool + isClosed (Closed _) = True + isClosed _ = False + assignStart :: Set CfgProduction -> Set CfgProduction + assignStart = Set.map $ bimap lhsMap rhsMap + where + lhsMap :: NonTerminal -> NonTerminal + lhsMap lhs = + if lhs == (NonTerminal . Text.pack) "!start" + then nt highestPrecedence 0 0 + else lhs + rhsMap = map submap + where + submap :: Either Terminal NonTerminal -> Either Terminal NonTerminal + submap (Right x) = Right $ lhsMap x + submap y = y + (highestPrecedence, lowestPrecedence, precedences) = + foldl + (\(ha, la, pa) e -> (max (prec e) ha, min (prec e) la, prec e `insert` pa)) + (0, 0, Set.singleton 0) + precg diff --git a/lib/Grammars.hs b/lib/Grammars.hs --- a/lib/Grammars.hs +++ b/lib/Grammars.hs @@ -1,51 +1,54 @@ -{-# LANGUAGE DeriveDataTypeable #-} - -module Grammars where - -import Data.Data (Data, Typeable) -import Data.List.NonEmpty (NonEmpty) -import Data.Set (Set) -import qualified Data.Set as Set - -newtype NonTerminal = - NonTerminal String - deriving (Eq, Ord, Show) - -newtype Terminal = - Terminal String - deriving (Eq, Ord, Show) - -type CfgString = [Either Terminal NonTerminal] - --- |The type of a context-free production. The left and right items correspond respectively to the left and right hand sides of a production rule. -type CfgProduction = (NonTerminal, CfgString) - --- |The type of a context-free gramar. On the left the starting non-terminal, and on the right is the set of productions in the grammar. -type ContextFree = (NonTerminal, Set CfgProduction) - --- |The type of a distfix precedence production. --- --- Int parameters are precedences. --- --- NonEmpty String parameters are lists of non-terminal symbols expressed as strings. --- The particular data constructor used implies the interspersal pattern of non-terminals in the terminal list when the production is interpreted. --- For example, --- --- > Infixl 1 (fromList ["?", ":"]) --- corresponds to the left-associative production, E -> E ? E : E. -data PrecedenceProduction - = Prefix Int (NonEmpty String) - | Postfix Int (NonEmpty String) - | Infixl Int (NonEmpty String) - | Infixr Int (NonEmpty String) - | Closed (NonEmpty String) - deriving (Eq, Ord, Show, Typeable, Data) - --- |The type of a distfix precedence grammar. The following must be true of any parameter to `Aasam.m`. --- --- * All precedences must be positive integers. --- * No initial word may also be a subsequent word of another production. --- * No initial sequence of words may also be the whole sequence of another production. --- * No precedence of a production of one fixity may also be the precedence of a production of another fixity. --- * The set of precedences must be either empty or the set of integers between 1 and greatest precedence, inclusive. -type Precedence = Set PrecedenceProduction +{-# LANGUAGE DeriveDataTypeable #-} + +module Grammars where + +import Data.Data (Data, Typeable) +import Data.List.NonEmpty (NonEmpty) +import Data.Set (Set) +import qualified Data.Set as Set + +import qualified Data.Text as Text +import Data.Text (Text) + +newtype NonTerminal = + NonTerminal Text + deriving (Eq, Ord, Show) + +newtype Terminal = + Terminal Text + deriving (Eq, Ord, Show) + +type CfgString = [Either Terminal NonTerminal] + +-- |The type of a context-free production. The left and right items correspond respectively to the left and right hand sides of a production rule. +type CfgProduction = (NonTerminal, CfgString) + +-- |The type of a context-free grammar. On the left the starting non-terminal, and on the right is the set of productions in the grammar. +type ContextFree = (NonTerminal, Set CfgProduction) + +-- |The type of a distfix precedence production. +-- +-- Int parameters are precedences. +-- +-- NonEmpty Text parameters are lists of terminal symbols expressed as strings. +-- A particular data constructor implies a corresponding interspersal pattern of non-terminals in the terminal list when the production is interpreted. +-- For example, +-- +-- > Infixl 1 (fromList ["?", ":"]) +-- corresponds to the left-associative production, E -> E ? E : E. +data PrecedenceProduction + = Prefix Int (NonEmpty Text) + | Postfix Int (NonEmpty Text) + | Infixl Int (NonEmpty Text) + | Infixr Int (NonEmpty Text) + | Closed (NonEmpty Text) + deriving (Eq, Ord, Show, Typeable, Data) + +-- |The type of a distfix precedence grammar. The following must be true of any parameter to `Aasam.m`. +-- +-- * All precedences must be positive integers. +-- * No initial word may also be a subsequent word of another production. +-- * No initial sequence of words may also be the whole sequence of another production. +-- * No precedence of a production of one fixity may also be the precedence of a production of another fixity. +-- * The set of precedences must be either empty or the set of integers between 1 and greatest precedence, inclusive. +type Precedence = Set PrecedenceProduction diff --git a/lib/Util.hs b/lib/Util.hs --- a/lib/Util.hs +++ b/lib/Util.hs @@ -1,18 +1,18 @@ -module Util where - -infixl 5 >. - -(>.) :: (a -> b) -> (b -> c) -> a -> c -(>.) = flip (.) - -infixl 4 |> - -(|>) :: a -> (a -> b) -> b -(|>) x f = f x - -unwrapOr :: a -> Maybe a -> a -unwrapOr _ (Just x) = x -unwrapOr y _ = y - -tup :: a -> b -> (a, b) -tup a b = (a, b) +module Util where + +infixl 5 >. + +(>.) :: (a -> b) -> (b -> c) -> a -> c +(>.) = flip (.) + +infixl 4 |> + +(|>) :: a -> (a -> b) -> b +(|>) x f = f x + +unwrapOr :: a -> Maybe a -> a +unwrapOr _ (Just x) = x +unwrapOr y _ = y + +tup :: a -> b -> (a, b) +tup a b = (a, b) diff --git a/test/AasamTest.hs b/test/AasamTest.hs --- a/test/AasamTest.hs +++ b/test/AasamTest.hs @@ -1,64 +1,70 @@ -{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} - -{-# HLINT ignore "Evaluate" #-} -module Main - ( main - ) where - -import Aasam -import qualified Data.List as List -import Data.List.NonEmpty (fromList, xor) -import qualified Data.Set as Set -import Test.Framework (defaultMain) -import Test.Framework.Providers.API (Test(Test)) -import Test.Framework.Providers.HUnit (hUnitTestToTests) -import Test.HUnit (Assertable(assert), Assertion, Test(..), assertEqual) - -testMap :: (Eq a, Show a) => [(String, a, a)] -> [Test.HUnit.Test] -testMap = List.map (\(label, x, y) -> TestLabel label (TestCase (assertEqual "" x y))) - -tests :: [Test.Framework.Providers.API.Test] -tests = hUnitTestToTests $ TestList labeledTests - -main :: IO () -main = defaultMain tests - -empt :: [a] -empt = [] - -labeledTests :: [Test.HUnit.Test] -labeledTests = - [] - -- ++ testMap [("okay", Just 20, Just (Set.size (snd (un (m pg0)))))] - ++ - testMap [("under", Nothing, Just (m pg2))] - -pg0 :: Precedence -pg0 = - Set.fromList - [ Postfix 4 (fromList ["?"]) - , Infixl 4 (fromList ["+"]) - , Infixl 0 (fromList ["+"]) - , Postfix 2 (fromList ["!", "?"]) - , Closed (fromList ["int"]) - ] - -un :: Either a b -> a -un (Left x) = x -un _ = error "fail" - -pg1 :: Set.Set PrecedenceProduction -pg1 = - Set.fromList - [ Infixr 2 (fromList ["="]) - , Prefix 1 (fromList ["λ", "."]) - , Closed (fromList ["x"]) - , Closed (fromList ["(", "$", ")"]) - ] - -pg2 :: Set.Set PrecedenceProduction -pg2 = Set.empty - -d :: Maybe ContextFree -> ContextFree -d (Just x) = x -d Nothing = (NonTerminal "String", Set.empty) +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +{-# HLINT ignore "Evaluate" #-} +module Main (main) where + +import Aasam +import qualified Data.List as List +import Data.List.NonEmpty (fromList, NonEmpty) +import qualified Data.Set as Set +import Test.Framework (defaultMain) +import Test.Framework.Providers.API (Test(Test)) +import Test.Framework.Providers.HUnit (hUnitTestToTests) +import Test.HUnit (Assertable(assert), Assertion, Test(..), assertEqual) + +import qualified Data.Text as Text +import Data.Text (Text) + +testMap :: (Eq a, Show a) => [(String, a, a)] -> [Test.HUnit.Test] +testMap = List.map (\(label, x, y) -> TestLabel label (TestCase (assertEqual "" x y))) + +tests :: [Test.Framework.Providers.API.Test] +tests = hUnitTestToTests $ TestList labeledTests + +fromList' :: [String] -> NonEmpty Text +fromList' = fromList . map Text.pack + +main :: IO () +main = defaultMain tests + +empt :: [a] +empt = [] + +labeledTests :: [Test.HUnit.Test] +labeledTests = + [] + -- ++ testMap [("okay", Just 20, Just (Set.size (snd (un (m pg0)))))] + ++ + testMap [("under", Nothing, Just (m pg2))] + +pg0 :: Precedence +pg0 = + Set.fromList + [ Postfix 4 (fromList' ["?"]) + , Infixl 4 (fromList' ["+"]) + , Infixl 0 (fromList' ["+"]) + , Postfix 2 (fromList' ["!", "?"]) + , Closed (fromList' ["int"]) + ] + +un :: Either a b -> a +un (Left x) = x +un _ = error "fail" + +pg1 :: Set.Set PrecedenceProduction +pg1 = + Set.fromList + [ Infixr 2 (fromList' ["="]) + , Prefix 1 (fromList' ["λ", "."]) + , Closed (fromList' ["x"]) + , Closed (fromList' ["(", "$", ")"]) + ] + +pg2 :: Set.Set PrecedenceProduction +pg2 = Set.fromList [Prefix 2 (fromList' ["if", " ", "then"]), + Prefix 1 (fromList' ["if", "then", "else"]), + Closed (fromList' ["x"])] + +d :: Maybe ContextFree -> ContextFree +d (Just x) = x +d Nothing = ((NonTerminal . Text.pack) "", Set.empty)