diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +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. diff --git a/aasam.cabal b/aasam.cabal new file mode 100644 --- /dev/null +++ b/aasam.cabal @@ -0,0 +1,41 @@ +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 diff --git a/lib/Aasam.hs b/lib/Aasam.hs new file mode 100644 --- /dev/null +++ b/lib/Aasam.hs @@ -0,0 +1,291 @@ +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 diff --git a/lib/Grammars.hs b/lib/Grammars.hs new file mode 100644 --- /dev/null +++ b/lib/Grammars.hs @@ -0,0 +1,51 @@ +{-# 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 diff --git a/lib/Util.hs b/lib/Util.hs new file mode 100644 --- /dev/null +++ b/lib/Util.hs @@ -0,0 +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) diff --git a/test/AasamTest.hs b/test/AasamTest.hs new file mode 100644 --- /dev/null +++ b/test/AasamTest.hs @@ -0,0 +1,64 @@ +{-# 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)